@@ -2,56 +2,68 @@ module ParseTypes where
22
33import Ast
44import Combinators
5−import Data.Char (isUpper)
5+import Data.Char (isUpper,isLower)
6+import Data.Maybe (fromMaybe)
7+import Data.List (lookup)
68import ParserLib
79import Tokens
810import Types
11+import Guid
912import Control.Monad (liftM)
1013
11−typeVar = do whitespace; t <- item
12− case t of
13− ID "Int" -> return IntT
14− ID "String" -> return StringT
15− ID "Char" -> return CharT
16− ID "Bool" -> return BoolT
17− ID (v:vs) -> return (if isUpper v then ADT (v:vs) []
18− else VarT 0) --(v:vs))
19− _ -> zero
20−
21−typeList = do t LBRACKET; ti <- typeExpr; t RBRACKET; return $ ADT "List" []
14+data ParseType = VarPT String
15+ | LambdaPT ParseType ParseType
16+ | ADTPT String [ParseType]
17+
18+listPT t = ADTPT "List" [t]
19+tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
20+
21+typeVar = liftM VarPT lowVar
22+typeList = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te
2223typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN
23− ; return $ case ts of { [t] -> t; _ -> ADT "Tuple" [] } }
24+ ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } }
25+typeUnambiguous = typeList +|+ typeTuple
2426
25−typeUnamb = typeList +|+ typeTuple
27+typeSimple = liftM VarPT var
28+typeApp = do name <- capVar
29+ args <- star (typeSimple +|+ typeUnambiguous)
30+ return $ case args of
31+ [] -> VarPT name
32+ _ -> ADTPT name args
33+
34+typeExpr = do
35+ t1 <- typeVar +|+ typeApp +|+ typeUnambiguous
36+ arrow <- optional $ t ARROW
37+ case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr
38+ Nothing -> return t1
2639
27−typeTerm = typeApp +|+ typeUnamb
40+typeConstructor = do name <- capVar
41+ args <- star (typeSimple +|+ typeUnambiguous)
42+ return $ (,) name args
2843
29−typeApp = do
30− tipe <- typeVar
31− case tipe of
32− ADT name _ -> AppT name `liftM` star typeTerm
33− _ -> return tipe
44+datatype = do
45+ t DATA ; name <- capVar ; args <- star lowVar ; assign
46+ tcs <- sepBy1 (opParser (=="|")) typeConstructor
47+ return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
3448
35−typeExpr = do t1 <- typeTerm
36− arrow <- optional $ t ARROW
37− case arrow of
38− Just ARROW -> LambdaT t1 `liftM` typeTerm
39− Nothing -> return t1
49+beta = VarT `liftM` guid
4050
41−typeConstr = do
42− name <- capVar
43− args <- star (typeVar +|+ typeUnamb)
44− return (Constructor name args)
51+toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames
52+ where argNames = map (("a"++) . show) [1..length args]
4553
46−constr (Constructor name args) =
47− (name, foldr Lambda (Data name (map Var argNames)) argNames)
48− where argNames = map (("arg"++) . show) [1..length args]
54+toTypes name args constructors = do
55+ pairs <- mapM (\x -> (,) x `liftM` guid) args
56+ return $ map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors
4957
50−datatype = do
51− t DATA
52− adt <- capVar
53− vs <- star var
54− assign
55− ts <- sepBy1 (opParser (=="|")) typeConstr
56− -- (adt, foldr ForallT (ADT adt ts) vs)
57− return (map constr ts)
58+toType pairs outType (name,args) =
59+ foldr (==>) outType (map toT args)
60+ where toT (LambdaPT t1 t2) = toT t1 ==> toT t2
61+ toT (ADTPT name args) = ADT name $ map toT args
62+ toT (VarPT x@(c:_))
63+ | isLower c = VarT . fromMaybe (-1) $ lookup x pairs
64+ | otherwise = case x of "Int" -> IntT
65+ "Number" -> IntT
66+ "String" -> StringT
67+ "Char" -> CharT
68+ "Bool" -> BoolT
69+ _ -> ADT x []