Permalink
Browse files

creates Value = TypeConstructor

  • Loading branch information...
1 parent ec4c610 commit 0135b76f718bff842cce27b7d8195360d44b0dc3 @kmels committed Jul 27, 2013
@@ -69,7 +69,7 @@ takeTest4 = take (5-5) [1,2,3]
takeTest5 = take 1 [1]
takeTest6 = take 2 [1,2,3]
-sumFirstFifty = sum [1..50]
+sumFirstFifty = sum [1..2]
false1 :: Bool
false1 = (takeTest2 :: [Int]) == (takeTest1 :: [Int])
@@ -91,7 +91,7 @@ false1 = (takeTest2 :: [Int]) == (takeTest1 :: [Int])
-- | otherwise = MIN
first2 = take 2 [1,2,3,4]
-first0 = take 0 [1,2]
+first0 = [1,2]
first1 = intListLength [1..4] -- $ mytake 5 [5..10]
six = intListLength [1..6]
View
@@ -36,20 +36,29 @@ import Data.List((!!))
-- as there are Ty's in DataCons and they're not pattern match friendly (we have indeed an extractor)
mkRandomVal :: Env -> Ty -> IM Value
mkRandomVal env (Tcon qual_tcon) = case zDecodeQualified qual_tcon of
+ -- Make a random integer
"ghc-prim:GHC.Types.Int" -> rndInt >>= return . Num . toInteger
+ -- Make a random "id" type
id -> do
type_constructors <- fetchDataCons id env
sumTypeMkRandom type_constructors env
- where
- fetchDataCons :: Id -> Env -> IM [DataCon]
- fetchDataCons id env = do
- -- look for the data type
- msumtype <- lookupId id env
- return $ case msumtype of
- (Right (SumType datacons)) -> datacons
- _ -> []
-mkRandomVal env ty = return . Wrong $ " mkRandomVal: I don't know how to make a random val for the type " ++ showExtCoreTypeVerbose ty
+mkRandomVal env (Tapp (Tcon qual_tcon1) (Tcon qual_tcon2)) = do
+ type_constructors <- fetchDataCons (zDecodeQualified qual_tcon1) env
+ io $ putStrLn $ "Type constructors of " ++ (zDecodeQualified qual_tcon1) ++ " are: " ++ show type_constructors
+ return $ Wrong "TODO"
+
+mkRandomVal env ty = return . Wrong $ " mkRandomVal: I don't know how to make a random val for the type " ++ showExtCoreTypeVerbose ty
+
+-- | Looks up a definition of a sum type by a qualified identifier and returns a list of its constructors.
+fetchDataCons :: Id -> Env -> IM [DataCon]
+fetchDataCons id env = do
+ -- look for the data type
+ msumtype <- lookupId id env
+ return $ case msumtype of
+ (Right (SumType datacons)) -> datacons
+ _ -> []
+
-- | Given a list of data constructors (that form a sum type), make a random
-- value of type of the sum type
sumTypeMkRandom :: [DataCon] -> Env -> IM Value
@@ -91,5 +91,10 @@ isAcon _ = False
-- | Loads nothing ATM, but it'll be useful
loadLibrary :: [(Id, Either Thunk Value)] -> IM Env
-loadLibrary funs = mapM (uncurry $ flip memorize) funs
-
+loadLibrary funs = mapM (uncurry load) funs
+ where
+ load :: Id -> Either Thunk Value -> IM HeapReference
+ load id thnk_or_val = do
+ beVerboseM $ "Acknowledging defined value for " ++ id
+ memorize thnk_or_val id
+
@@ -94,7 +94,7 @@ acknowledgeVdefg (Nonrec vdef) env =
--sequence [(flip acknowledgeVdef env) vdef]
acknowledgeVdefg v@(Rec vdefs) env = do
beVerboseM $ "Acknowledging recursive definitions: " ++ (show . vdefgNames $ v)
- beVerboseM $ "with env: " ++ show (map fst env)
+ --beVerboseM $ "with env: " ++ show (map fst env)
addresses <- allocate $ length vdefs
let ids = map vdefId vdefs
@@ -109,6 +109,6 @@ acknowledgeVdefg v@(Rec vdefs) env = do
storeVdef :: Vdef -> Env -> HeapAddress -> IM HeapReference
storeVdef (Vdef (qid, ty, exp)) env address= do
beVerboseM $ "Acknowledging value definition " ++ zDecodeQualified qid
- beVerboseM $ "\twith env = " ++ show (map fst env)
- beVerboseM $ "\tin address = " ++ show address
+ --beVerboseM $ "\twith env = " ++ show (map fst env)
+ --beVerboseM $ "\tin address = " ++ show address
store address (Left $ Thunk exp env) (zDecodeQualified qid)
@@ -346,6 +346,7 @@ matches :: Value -> Alt -> IM Bool
-- data
matches (TyConApp (MkDataCon n _) _) (Acon qual_dcon _ _ _) = return $ zDecodeQualified qual_dcon == n
+matches (TypeConstructor (MkDataCon n _) _) (Acon qual_dcon _ _ _) = return $ zDecodeQualified qual_dcon == n
--matches val (Alit lit exp) = return False --TODO
matches val (Adefault _) = return True -- this is the default case, i.e. "_ -> exp "
@@ -424,6 +425,12 @@ apply (TyConApp tycon addresses) id env = do
Pointer p -> return $ TyConApp tycon (addresses ++ [p])
e@(Wrong s) -> return e
+apply (TypeConstructor tycon _) id env = do
+ addr <- getPointer id env
+ case addr of
+ Pointer p -> return $ TyConApp tycon ([p])
+ e@(Wrong s) -> return e
+
apply w@(Wrong _) _ _ = return w
apply f x _ = return . Wrong $ "Applying " ++ show f ++ " with argument " ++ show x
@@ -7,6 +7,13 @@ import Language.Core.Interpreter(evalId)
-- | Evaluates definitions found in ghc-prim:GHC.Types
+-- cons :: (Id,Either Thunk Value) -- (:) :: a -> [a] -> [a]
+-- cons = (cons_name, Right $ TypeConstructor tycon ty_name) where
+-- cons_name = "ghc-prim:GHC.Types.:"
+-- ty_name = "ghc-prim:GHC.Types.[]"
+-- tycon_args = [Tvar "a", Tvar "[a]"]
+-- tycon = MkDataCon cons_name tycon_args
+
cons :: (Id,Either Thunk Value) -- (:) :: a -> [a] -> [a]
cons = (id,Right val) where
id = "ghc-prim:GHC.Types.:"
@@ -16,6 +23,13 @@ cons = (id,Right val) where
typeConstructor :: DataCon
typeConstructor = MkDataCon id typeArgs
val = TyConApp typeConstructor []
+
+-- listConstructor :: (Id,Either Thunk Value) -- ([]) :: [a], kind * -> *
+-- listConstructor = (cons_name, Right $ TypeConstructor tycon ty_name) where
+-- cons_name = "ghc-prim:GHC.Types.[]"
+-- ty_name = "ghc-prim:GHC.Types.[]"
+-- tycon_args = [Tvar "a"]
+-- tycon = MkDataCon cons_name tycon_args
listConstructor :: (Id,Either Thunk Value) -- ([]) :: [a], kind * -> *
listConstructor = (id,Right $ TyConApp typeConstructor []) where
@@ -120,11 +120,12 @@ data Value = Wrong String
| Fun (Id -> Env -> IM Value) Description
-- | List [Value]
| Pair Pointer Pointer --HERE, heap addresses
- | TyConApp DataCon [Pointer] -- heap addresses, a type constructor application to some values
+ | TyConApp DataCon [Pointer] -- a data constructor applicated to some values
| Pointer Pointer
| FreeTypeVariable String -- useful when converting a to SomeClass a (we ignore parameters, and it's useful to save them)
| MkListOfValues [(String,Value)] -- When a value definition is recursive, depends on other values
| SumType [DataCon] -- A data type with reference to its constructors, created only from type constructors when reading modules (see Interpreter/Acknowledge).
+ | TypeConstructor DataCon Id -- A single data constructor that withholds, apart of its data constructor value, the qualified name of the type it builds. For example (:) is a type constructor for the list type, "[a]".
newtype Pointer = MkPointer { ptr_address :: HeapAddress } deriving Show
@@ -258,8 +259,12 @@ instance Show Value where
where
myIntersperse sep = foldr ((++) . (++) sep) []
constructor_names = map (\(MkDataCon id _) -> id) cons
+ show (TypeConstructor tycon ty_name) | show tycon == "[]" = "[]"
+ | otherwise = "TypeConstructor " ++ show tycon ++ " of " ++ ty_name
instance Show DataCon where
+ show (MkDataCon "ghc-prim:GHC.Types.[]" _) = "[]"
+ show (MkDataCon id []) = idName id
show (MkDataCon id []) = idName id
show (MkDataCon id types) = idName id ++ " :: " ++ types' where
types' :: String
@@ -43,7 +43,7 @@ showValue val = return $ show val
-- Special cases include the List and the Tuple constructors.
-- As we know from the semantics, the showing forces the evaluation of the arguments of the data constructor
showTyConApp :: DataCon-> [Pointer] -> IM String
-showTyConApp (MkDataCon "ghc-prim:GHC.Types.[]" []) [] = return "[]" -- empty list
+showTyConApp (MkDataCon "ghc-prim:GHC.Types.[]" _) [] = return "[]" -- empty list
showTyConApp (MkDataCon "ghc-prim:GHC.Types.:" _) ptrs = showList ptrs -- lists
showTyConApp (MkDataCon "ghc-prim:GHC.Tuple.Z2T" _) [x,y] = do
x_str <- evalPtr x >>= showValue
@@ -81,7 +81,9 @@ showList ptrs = do
-- If we find another list, don't show the []
showValue' :: Value -> IM String
showValue' t@(TyConApp (MkDataCon "ghc-prim:GHC.Types.[]" _) []) = return ""
+ showValue' t@(TyConApp (MkDataCon "ghc-prim:GHC.Types.[]" _) ty) = return $ "[] to " ++ show ty
showValue' t@(TyConApp (MkDataCon "ghc-prim:GHC.Types.:" _) ptrs) = mapM showPtr ptrs >>= return . separateWithSpaces
+ showValue' t@(TypeConstructor (MkDataCon "ghc-prim:GHC.Types.[]" [_]) "ghc-prim:GHC.Types.[]")= return ""
showValue' v = showValue v
wrapInParenthesis s = "(" ++ s ++ ")"

0 comments on commit 0135b76

Please sign in to comment.