Permalink
Browse files

definition for GHC.Classes./=

  • Loading branch information...
1 parent a23ab18 commit 0c4b43b88ab480833fc2c36fb52ab9d25bef57f2 @kmels committed Nov 2, 2013
Showing with 20 additions and 1 deletion.
  1. +1 −1 src/DART/MkRandom.hs
  2. +19 −0 src/Language/Core/Interpreter/Libraries/GHC/Classes.hs
View
@@ -106,7 +106,7 @@ fetchDataCons :: Id -> Env -> IM [DataCon]
fetchDataCons id env = do
-- look for the data type
msumtype <- lookupId id env
- io $ putStrLn $ "fetchDataCons " ++ show msumtype
+ --io $ putStrLn $ "fetchDataCons " ++ show msumtype
return $ case msumtype of
(Right (SumType datacons)) -> datacons
(Right (TypeConstructor datacons _)) -> [datacons]
@@ -11,6 +11,7 @@ import qualified Data.List as Data.List
all :: [(Id, Either Thunk Value)]
all = [ equals
+ , notEquals
-- Bools
, conjunction -- (&&) :: Bool -> Bool -> Bool
, lt, leq
@@ -40,6 +41,24 @@ equals = (id, Right $ Fun (monomophy_2 "(==)" valEq) "polymorphic(==)") where
| otherwise = return . Boolean $ False
valEq v w = return . Boolean $ (==) v w
+-- | (/=) defined in terms of (==)
+notEquals :: (Id, Either Thunk Value)
+notEquals = (id, Right $ Fun (monomophy_2 "(/=)" notEQ) "polymorphic(/=)") where
+ id = "ghc-prim:GHC.Classes./="
+ notEQ :: Value -> Value -> IM Value
+ notEQ v@(Wrong _) _ = return v
+ notEQ _ w@(Wrong _) = return w
+ notEQ (TypeConstructor datacon id) (TypeConstructor datacon2 id2) = do return $ Boolean $ datacon /= datacon2 || id /= id2
+ notEQ(TyConApp dc1 ps) (TyConApp dc2 ps2) | dc1 == dc2 && length ps == length ps2 = do
+ -- get the value of every pointer
+ ps_vals <- mapM (flip eval []) ps
+ ps2_vals <- mapM (flip eval []) ps2
+
+ -- compare every corresponding pointer value, they must be all equal
+ mapM (uncurry notEQ) (ps_vals `zip` ps2_vals) >>= return . Boolean . Data.List.any ((/=) $ Boolean $ True)
+ | otherwise = return . Boolean $ False
+ notEQ v w = return . Boolean $ (/=) v w
+
-- | (&&)
conjunction :: (Id, Either Thunk Value)
conjunction = (id, Right $ applyFun_2 "&&" valConjunction)

0 comments on commit 0c4b43b

Please sign in to comment.