creates Value = TypeConstructor

examples/interpreter/Lists.hs

@@ -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]

src/DART/MkRandom.hs

@@ -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

src/Language/Core/Interpreter.hs

@@ -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
+

src/Language/Core/Interpreter/Acknowledge.hs

@@ -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)

src/Language/Core/Interpreter/Evaluable.hs

@@ -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
 

src/Language/Core/Interpreter/Libraries/GHC/Types.hs

@@ -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

src/Language/Core/Interpreter/Structures.hs

@@ -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

src/Language/Core/Interpreter/Util.hs

@@ -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 ++ ")"