@@ -8,106 +8,69 @@ import Text.Parsec
88import Text.Parsec.Indent
99
1010import SourceSyntax.Location as Located
11−import SourceSyntax.Expression
12−import SourceSyntax.Declaration
11+--import SourceSyntax.PrettyPrint
12+import SourceSyntax.Type as T
13+--import qualified SourceSyntax.Expression as Expr
14+--import qualified SourceSyntax.Declaration as Decl
1315import Parse.Helpers
14−import Types.Types hiding (parens,string)
1516import Unique
1617
17−data ParseType = VarPT String
18− | LambdaPT ParseType ParseType
19− | ADTPT String [ParseType]
20− | RecordPT (Maybe ParseType) [(String,ParseType)]
21− deriving (Show)
22−
23−listPT t = ADTPT "List" [t]
24−tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
25−
26−typeVar :: IParser ParseType
27−typeVar = VarPT <$> lowVar <?> "type variable"
28−
29−typeList :: IParser ParseType
30−typeList = listPT <$> braces typeExpr
31−
32−typeTuple :: IParser ParseType
33−typeTuple = do ts <- parens (commaSep typeExpr)
34− return $ case ts of { [t] -> t ; _ -> tuplePT ts }
35−
36−typeRecord :: IParser ParseType
37−typeRecord = brackets (RecordPT <$> extend <*> fields)
38− where extend = optionMaybe . try $ do
39− t <- typeVar
40− whitespace >> string "|" >> whitespace
41− return t
42− fields = commaSep $ do
43− lbl <- rLabel
44− whitespace >> hasType >> whitespace
45− (,) lbl <$> typeExpr
46−
47−typeUnambiguous :: IParser ParseType
48−typeUnambiguous = typeList <|> typeTuple <|> typeRecord
49−
50−typeSimple :: IParser ParseType
51−typeSimple = VarPT <$> var
52−
53−typeApp :: IParser ParseType
54−typeApp = do name <- capVar <?> "type constructor"
55− args <- spacePrefix (typeUnambiguous <|> typeSimple)
56− return $ case args of
57− [] -> VarPT name
58− _ -> ADTPT name args
59−
60−typeExpr :: IParser ParseType
61−typeExpr = do
62− t1 <- typeVar <|> typeApp <|> typeUnambiguous
63− whitespace ; arr <- optionMaybe arrow ; whitespace
64− case arr of
65− Just _ -> LambdaPT t1 <$> typeExpr
66− Nothing -> return t1
67−
68−typeConstructor :: IParser (String, [ParseType])
69−typeConstructor = (,) <$> (capVar <?> "another type constructor")
70− <*> spacePrefix (typeSimple <|> typeUnambiguous)
71−
72−typeAlias :: IParser [Declaration t v]
73−typeAlias = do
74− start <- getPosition
75− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
76− forcedWS
77− alias <- capVar
78− args <- spacePrefix lowVar
79− whitespace ; string "=" ; whitespace
80− let n = length args
81− tipe <- typeExpr
82− end <- getPosition
83− case toTypeWith alias (zip args [1..n]) tipe of
84− Left msg -> fail msg
85− Right t -> return (TypeAlias alias [1..n] t : ctor)
86− where ctor = case tipe of
87− RecordPT extension kvs ->
88− [] --toConstructor start end alias extension kvs]
89− _ -> []
90−{--
91−toConstructor start end alias Nothing kvs =
92− Definition (Def alias args (loc (Record rec)))
93− where
94− loc = Located.at start end
95− args = map fst kvs
96− rec = map (\a -> (a, loc (Var a))) args
18+tvar :: IParser T.Type
19+tvar = T.Var <$> lowVar <?> "type variable"
9720
98−toConstructor start end alias (Just _) kvs =
99− Definition (Def alias (args++["_ext_"]) (loc rec))
21+list :: IParser T.Type
22+list = listOf <$> braces expr
23+
24+tuple :: IParser T.Type
25+tuple = do ts <- parens (commaSep expr)
26+ return $ case ts of
27+ [t] -> t
28+ _ -> tupleOf ts
29+
30+record :: IParser T.Type
31+record = brackets $ do
32+ ext <- extend
33+ fs <- fields
34+ return (T.Record (fieldMap fs) ext)
10035 where
101− loc = Located.at start end
102− args = map fst kvs
103− rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
104− insert e (k,v) = Insert (loc e) k v
105−--}
106−annotation :: IParser (Def t v)
107−annotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
108− where start = do v <- lowVar <|> parens symOp
109− whitespace ; hasType ; whitespace ; return v
36+ extend = option T.EmptyRecord . try $ do
37+ t <- tvar
38+ whitespace >> string "|" >> whitespace
39+ return t
40+ fields = commaSep $ do
41+ lbl <- rLabel
42+ whitespace >> hasType >> whitespace
43+ (,) lbl <$> expr
44+
45+constructor0 :: IParser T.Type
46+constructor0 =
47+ do name <- capVar
48+ return (T.Data name [])
49+
50+term :: IParser T.Type
51+term = list <|> tuple <|> record <|> tvar <|> constructor0
52+
53+app :: IParser T.Type
54+app =
55+ do name <- capVar <?> "type constructor"
56+ args <- spacePrefix term
57+ return (T.Data name args)
58+
59+expr :: IParser T.Type
60+expr =
61+ do t1 <- app <|> term
62+ whitespace
63+ arr <- optionMaybe arrow
64+ whitespace
65+ case arr of
66+ Just _ -> T.Lambda t1 <$> expr
67+ Nothing -> return t1
68+
69+constructor :: IParser (String, [T.Type])
70+constructor = (,) <$> (capVar <?> "another type constructor")
71+ <*> spacePrefix term
11072
73+{--
11174datatype :: IParser (Declaration t v)
11275datatype = do
11376 reserved "data" <?> "datatype definition (data T = A | B | ...)"
@@ -118,41 +81,41 @@ datatype = do
11881 Right dt -> return dt
11982 Left msg -> fail msg
12083
121−beta = liftM VarT guid
84+beta = liftM T.Var guid
12285
123−toType :: ParseType -> Type
86+toType :: T.Type -> Type
12487toType pt =
125− let frees :: ParseType -> [String]
88+ let frees :: T.Type -> [String]
12689 frees pt = case pt of
12790 LambdaPT a b -> frees a ++ frees b
12891 ADTPT _ ts -> concatMap frees ts
12992 RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
13093 VarPT (c:cs) | isLower c -> [c:cs]
13194 | otherwise -> []
132− in case toTypeWith "" (zip (frees pt) [1..]) pt of
95+ in case toTypeWith "" (zip (frees pt) ['a'..]) pt of
13396 Right t -> t
134− Left _ -> VarT 0
97+ Left _ -> T.Var 0
13598
136−toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
99+toTypeWith :: String -> [(String,String)] -> T.Type -> Either String Type
137100toTypeWith name tvarDict pt =
138101 let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
139102 toT = toTypeWith name tvarDict
140103 in case pt of
141− LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2
142− ADTPT name args -> ADT name <$> mapM toT args
104+ LambdaPT t1 t2 -> T.Lambda <$> toT t1 <*> toT t2
105+ ADTPT name args -> T.Data name <$> mapM toT args
143106 RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
144− ext <- maybe (return EmptyRecord) toT t
145− return (RecordT (recordT fs') ext)
107+ ext <- maybe (return T.EmptyRecord) toT t
108+ return (T.Record (T.record fs') ext)
146109 VarPT x@(c:_)
147− | not (isLower c) -> return $ ADT x []
148− | otherwise -> VarT <$> case lookup x tvarDict of
149− Just v -> Right v
150− Nothing -> Left (msg x)
110+ | not (isLower c) -> return $ T.Data x []
111+ | otherwise -> T.Var <$> case lookup x tvarDict of
112+ Just v -> Right v
113+ Nothing -> Left (msg x)
151114
152115
153116toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
154117 where n = length args
155− toType = toTypeWith name (zip args [1..n])
118+ toType = toTypeWith name (zip args (map (:[]) ['a'..]))
156119 toC (name,pt) = (,) name <$> mapM toType pt
157120
158121
@@ -161,18 +124,19 @@ toForeignType (LambdaPT t1 t2) =
161124 "Only simple values can be imported and exported in this release."
162125
163126toForeignType (ADTPT "JSArray" args) =
164− ADT "JSArray" <$> mapM toForeignType args
127+ T.Data "JSArray" <$> mapM toForeignType args
165128
166129toForeignType (ADTPT name _) =
167130 Left $ "'" ++ name ++ "' is not an exportable type " ++
168131 "constructor. Only 'JSArray' is exportable."
169132
170133toForeignType (VarPT x@(c:_))
171− | x `elem` jsTypes = Right (ADT x [])
134+ | x `elem` jsTypes = Right (T.Data x [])
172135 | isLower c =
173136 Left $ "All exported types must be concrete types." ++ msg
174137 | otherwise =
175138 Left $ "'" ++ x ++ "' is not an exportable type." ++ msg
176139 where
177140 msg = " The following types are exportable: " ++ intercalate ", " jsTypes
178− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
141+ jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
142+--}