Permalink
Browse files

curries tyconapps

  • Loading branch information...
1 parent 88045b5 commit 90d5a9dd7966b7631ea974aa63d9bcf9aae62e5a @kmels committed Jul 29, 2013
@@ -92,7 +92,7 @@ false1 = (takeTest2 :: [Int]) == (takeTest1 :: [Int])
-- | otherwise = MIN
first2 = take 2 [1,2,3,4]
-first0 = intListLength [1,2,3]
+first0 = [10,15]
first1 = intListLength [1..1] -- $ mytake 5 [5..10]
xs1 = [1..5]
@@ -68,7 +68,7 @@ fetchDataCons id env = do
io $ putStrLn $ "fetchDataCons " ++ show msumtype
return $ case msumtype of
(Right (SumType datacons)) -> datacons
- (Right (TypeConstructor datacons)) -> [datacons]
+ (Right (TypeConstructor datacons _)) -> [datacons]
_ -> []
-- | Given a list of data constructors (that form a sum type), make a random
@@ -26,6 +26,8 @@ intercalateWith :: [String] -> String -> String
intercalateWith = flip intercalate
separateWithSpaces :: [String] -> String
-separateWithSpaces = intercalate space
+separateWithSpaces = intercalate space . filter (not . (==) empty_str)
+ where
+ empty_str = ""
separateWithNewLines = intercalate newLine
@@ -181,13 +181,18 @@ instance Evaluable Exp where
res <- apply f id (heap_reference:env) -- Note1: the address is paassed
return res
- -- | A function application which has the type annotation which we will essentially ignore.
+ -- | A typed function (or data) application
eval e@(Appt exp ty) env = do
ti <- gets tab_indentation
let ?tab_indentation = ti
case exp of
(Var qvar) -> evalExpI exp env "Typed Var application "
- (Dcon qvar) -> evalExpI exp env $ "Typed Dcon application " ++ zDecodeQualified qvar
+ (Dcon qvar) -> do
+ v <- evalExpI exp env $ "Typed Dcon application " ++ zDecodeQualified qvar ++ ", to type " ++ show ty
+ case v of
+ tyconv@(TypeConstructor tycon@(MkDataCon id (t:ts)) tyname) -> return $ TypeConstructor (tycon { tyConExpectedTys = ts}) tyname
+ tyconapp@(TyConApp _ _) -> return tyconapp
+ otherwise -> return $ Wrong $ "The impossible happened: Typed application was expecting a type constructor or an applied type constructor, but got: " ++ show otherwise
_ -> evalExpI exp env "Typed application "
eval (Var ((Just (M (P ("base"),["GHC"],"Base"))),"zd")) env =
@@ -419,16 +424,18 @@ apply (Fun f d) id env = do
-- Applies a (possibly applied) type constructor that expects appliedValue of type ty.
-- The type constructor that we are applying has |vals| applied values
-apply (TyConApp tycon addresses) id env = do
+apply (TyConApp tycon@(MkDataCon _ (t:ts)) addresses) id env = do
addr <- getPointer id env
case addr of
- Pointer p -> return $ TyConApp tycon (addresses ++ [p])
+ Pointer p -> return $ TyConApp tycon { tyConExpectedTys = ts } (addresses ++ [p])
e@(Wrong s) -> return e
-
-apply (TypeConstructor tycon _) id env = do
+
+--apply tca@(TyConApp tycon@(MkDataCon _ ts) addresses) id env = return . Wrong $ "Applying " ++ (show . length) ts ++ " with argument " ++ show id
+
+apply (TypeConstructor tycon@(MkDataCon _ (t:ts)) _) id env = do
addr <- getPointer id env
case addr of
- Pointer p -> return $ TyConApp tycon ([p])
+ Pointer p -> return $ TyConApp (tycon { tyConExpectedTys = ts }) ([p])
e@(Wrong s) -> return e
apply w@(Wrong _) _ _ = return w
@@ -11,7 +11,7 @@ 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_args = [Tvar "aXX", Tvar "[a]YY", Tvar "XXXX"]
tycon = MkDataCon cons_name tycon_args
listConstructor :: (Id,Either Thunk Value) -- ([]) :: [a], kind * -> *
@@ -119,7 +119,7 @@ data Value = Wrong String
| Fun (Id -> Env -> IM Value) Description
-- | List [Value]
| Pair Pointer Pointer --HERE, heap addresses
- | TyConApp DataCon [Pointer] -- a data constructor applicated to some values
+ | TyConApp DataCon [Pointer] -- a data constructor applicated to some values, possible expecting some more types
| 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
@@ -144,8 +144,8 @@ data HaskellExpression = HaskellExpression String Module
-- | A data type constructor that has normally a qualified name and a list of
-- types that it expects.
data DataCon = MkDataCon {
- dataConId :: Id,
- dataConTys :: [Ty]
+ tyConId :: Id,
+ tyConExpectedTys :: [Ty]
} deriving Eq
type Description = String
@@ -262,7 +262,8 @@ instance Show Value where
| otherwise = "TypeConstructor " ++ show tycon ++ " of " ++ ty_name
instance Show DataCon where
- show (MkDataCon "ghc-prim:GHC.Types.[]" _) = "[]"
+ show (MkDataCon "ghc-prim:GHC.Types.[]" []) = "[]"
+ show (MkDataCon "ghc-prim:GHC.Types.[]" ty) = "[] expecting " ++ show ty
show (MkDataCon id []) = idName id
show (MkDataCon id types) = idName id ++ " :: " ++ types' where
types' :: String
@@ -54,14 +54,14 @@ showTyConApp tycon pointers = do
whnf_strings <- mapM showValue' vals -- [String]
return $ let
- tycon_name = (idName . dataConId) tycon
+ tycon_name = (idName . tyConId) tycon
arg_strings = separateWithSpaces whnf_strings
in tycon_name ++ " " ++ arg_strings
where
-- Should we wrap a value in parenthesis? Wrap the tycon apps! (iff they have applied vals)
showValue' :: Value -> IM String
- showValue' t@(TyConApp tycon []) = return . idName . dataConId $ tycon
+ showValue' t@(TyConApp tycon []) = return . idName . tyConId $ tycon
showValue' t@(TyConApp _ _) = showValue t >>= return . wrapInParenthesis
showValue' v = showValue v
@@ -83,7 +83,7 @@ showList ptrs = do
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' t@(TypeConstructor (MkDataCon "ghc-prim:GHC.Types.[]" []) "ghc-prim:GHC.Types.[]")= return ""
showValue' v = showValue v
wrapInParenthesis s = "(" ++ s ++ ")"

0 comments on commit 90d5a9d

Please sign in to comment.