git.iko.soy/elk
on master help sign in
Add support for type annotations. Remaining bugs include `String` is not de-aliased and uses of the cons operator have not yet been switched over to the new (::) syntax.
commit021a27cc39a3b2c5801a88874d3ac58ed325cb07 authorevancz <info@elm-lang.org> dateMon 4 Feb 2013, 02:56 (14 years ago) parentb4dba5f
11 files changed+118−72
compare with master
unifiedsplit
elm/src/Ast.hs+2 elm/src/Gen/CompileToJS.hs+6 elm/src/Parse/Foreign.hs+2−2 elm/src/Parse/Library.hs+6−2 elm/src/Parse/Parser.hs+2−4 elm/src/Parse/Types.hs+44−14 elm/src/Rename.hs+12−8 elm/src/Types/Constrain.hs+36−35 elm/src/Types/Hints.hs+2 elm/src/Types/Substitutions.hs+6−5 elm/src/Types/Types.hs−2
elm/src/Ast.hs+2
@@ -52,6 +52,8 @@ data Def = FnDef String [String] CExpr
5252
5353data Statement = Definition Def
5454 | Datatype String [X] [(String,[Type])]
55+ | TypeAlias String Type
56+ | TypeAnnotation String Type
5557 | ImportEvent String CExpr String Type
5658 | ExportEvent String String Type
5759 deriving (Eq,Show)
elm/src/Gen/CompileToJS.hs+6
@@ -99,6 +99,8 @@ getExports names stmts = ret . braces $ intercalate ",\n" (op : map fnPair fns)
9999 Datatype _ _ tcs -> map (Left . fst) tcs
100100 ImportEvent _ _ x _ -> [ Left x ]
101101 ExportEvent _ _ _ -> []
102+ TypeAlias _ _ -> []
103+ TypeAnnotation _ _ -> []
102104
103105
104106jsImport (modul, how) =
@@ -136,6 +138,8 @@ stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
136138 if derename f == "main" then 5 else 4
137139 Definition _ -> 3
138140 ExportEvent _ _ _ -> 6
141+ TypeAlias _ _ -> 0
142+ TypeAnnotation _ _ -> 0
139143
140144class ToJS a where
141145 toJS :: a -> GuidCounter String
@@ -167,6 +171,8 @@ instance ToJS Statement where
167171 , "e.initEvent('", js, "', true, true);"
168172 , "e.value = v;"
169173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174+ toJS (TypeAnnotation _ _) = return ""
175+ toJS (TypeAlias _ _) = return ""
170176
171177toJS' :: CExpr -> GuidCounter String
172178toJS' (C txt span expr) =
elm/src/Parse/Foreign.hs+2−2
@@ -19,7 +19,7 @@ exportEvent = do
1919 try (reserved "export" >> whitespace >> reserved "jsevent" >> whitespace)
2020 js <- jsVar ; whitespace
2121 elm <- lowVar ; whitespace
22− string "::" ; whitespace
22+ hasType ; whitespace
2323 tipe <- typeExpr
2424 case tipe of
2525 ADTPT "Signal" [pt] ->
@@ -32,7 +32,7 @@ importEvent = do
3232 base <- term <?> "Base case for imported signal (signals cannot be undefined)"
3333 whitespace
3434 elm <- lowVar <?> "Name of imported signal"
35− whitespace ; string "::" ; whitespace
35+ whitespace ; hasType ; whitespace
3636 tipe <- typeExpr
3737 case tipe of
3838 ADTPT "Signal" [pt] ->
elm/src/Parse/Library.hs+6−2
@@ -12,8 +12,9 @@ import Text.Parsec hiding (newline,spaces,State)
1212import Text.Parsec.Indent
1313
1414reserveds = [ "if", "then", "else"
15− , "case", "of", "data"
15+ , "case", "of"
1616 , "let", "in"
17+ , "data", "type"
1718 , "module", "where"
1819 , "import", "as", "hiding"
1920 , "export", "foreign" ]
@@ -61,7 +62,7 @@ isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
6162
6263symOp :: IParser String
6364symOp = do op <- many1 (satisfy isOp)
64− guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
65+ guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
6566 case op of
6667 "." -> notFollowedBy lower >> return op
6768 "\8728" -> return "."
@@ -70,6 +71,9 @@ symOp = do op <- many1 (satisfy isOp)
7071arrow :: IParser String
7172arrow = string "->" <|> string "\8594" <?> "arrow (->)"
7273
74+hasType :: IParser String
75+hasType = string ":" <?> "':' (a type annotation)'"
76+
7377
7478commitIf check p = commit <|> try p
7579 where commit = do (try $ lookAhead check) >> p
elm/src/Parse/Parser.hs+2−4
@@ -14,10 +14,8 @@ import Parse.Modules
1414import Parse.Foreign
1515
1616
17−statement = (:[]) <$> foreignDef
18− <|> (:[]) <$> datatype
19− <|> def
20− <?> "datatype or variable definition"
17+statement = let defs = [ foreignDef, datatype, typeAlias, typeAnnotation ] in
18+ (:[]) <$> choice defs <|> def <?> "datatype or variable definition"
2119
2220freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
2321 freshLine
elm/src/Parse/Types.hs+44−14
@@ -34,7 +34,7 @@ typeTuple = do ts <- parens (commaSep typeExpr)
3434typeRecord :: IParser ParseType
3535typeRecord = fmap RecordPT . brackets . commaSep $ do
3636 lbl <- rLabel
37− whitespace >> string "::" >> whitespace
37+ whitespace >> hasType >> whitespace
3838 (,) lbl <$> typeExpr
3939
4040typeUnambiguous :: IParser ParseType
@@ -64,6 +64,18 @@ typeConstructor :: IParser (String, [ParseType])
6464typeConstructor = (,) <$> (capVar <?> "another type constructor")
6565 <*> spacePrefix (typeSimple <|> typeUnambiguous)
6666
67+typeAlias :: IParser Statement
68+typeAlias = do
69+ reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
70+ alias <- capVar
71+ whitespace ; string "=" ; whitespace
72+ TypeAlias alias <$> toType <$> typeExpr
73+
74+typeAnnotation :: IParser Statement
75+typeAnnotation =
76+ let start = do v <- lowVar ; whitespace ; hasType ; whitespace ; return v
77+ in TypeAnnotation <$> try start <*> (toType <$> typeExpr)
78+
6779datatype :: IParser Statement
6880datatype = do
6981 reserved "data" <?> "datatype definition (data T = A | B | ...)"
@@ -76,21 +88,39 @@ datatype = do
7688
7789beta = liftM VarT guid
7890
91+toType :: ParseType -> Type
92+toType pt =
93+ let frees :: ParseType -> [String]
94+ frees pt = case pt of
95+ LambdaPT a b -> frees a ++ frees b
96+ ADTPT _ ts -> concatMap frees ts
97+ RecordPT fs -> concatMap (frees . snd) fs
98+ VarPT (c:cs) | isLower c -> [c:cs]
99+ | otherwise -> []
100+ in case toTypeWith "" (zip (frees pt) [1..]) pt of
101+ Right t -> t
102+ Left _ -> VarT 0
103+
104+toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
105+toTypeWith name tvarDict pt =
106+ let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
107+ toT = toTypeWith name tvarDict
108+ in case pt of
109+ LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2
110+ ADTPT name args -> ADT name <$> mapM toT args
111+ RecordPT fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
112+ return (RecordT (recordT fs') EmptyRecord)
113+ VarPT x@(c:_)
114+ | not (isLower c) -> return $ ADT x []
115+ | otherwise -> VarT <$> case lookup x tvarDict of
116+ Just v -> Right v
117+ Nothing -> Left (msg x)
118+
119+
79120toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
80121 where n = length args
81− tvarDict = zip args [1..n]
82− toC (name,pt) = (,) name <$> mapM toT pt
83− toT (LambdaPT t1 t2) = (==>) <$> toT t1 <*> toT t2
84− toT (ADTPT name args) = ADT name <$> mapM toT args
85− toT (VarPT x@(c:_))
86− | isLower c = VarT <$> case lookup x tvarDict of
87− Just v -> Right v
88− Nothing -> Left $ msg x
89− | otherwise = return $ ADT x []
90− toT (RecordPT fs) = do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
91− return (RecordT (recordT fs') EmptyRecord)
92− msg x = "Type variable '" ++ x ++
93− "' is unbound in type constructor '" ++ name ++ "'."
122+ toType = toTypeWith name (zip args [1..n])
123+ toC (name,pt) = (,) name <$> mapM toType pt
94124
95125
96126toForeignType (LambdaPT t1 t2) =
elm/src/Rename.hs+12−8
@@ -32,14 +32,18 @@ instance Rename Def where
3232 FnDef (env f) (map env' args) `liftM` rename env' e
3333
3434instance Rename Statement where
35− rename env (Definition def) = Definition `liftM` rename env def
36− rename env (Datatype name args tcs) =
37− return $ Datatype name args $ map (first env) tcs
38− rename env (ImportEvent js base elm tipe) =
39− do base' <- rename env base
40− return $ ImportEvent js base' (env elm) tipe
41− rename env (ExportEvent js elm tipe) =
42− return $ ExportEvent js (env elm) tipe
35+ rename env stmt =
36+ case stmt of
37+ Definition def -> Definition `liftM` rename env def
38+ Datatype name args tcs ->
39+ return $ Datatype name args $ map (first env) tcs
40+ TypeAlias n t -> return (TypeAlias n t)
41+ TypeAnnotation n t -> return (TypeAnnotation (env n) t)
42+ ImportEvent js base elm tipe ->
43+ do base' <- rename env base
44+ return $ ImportEvent js base' (env elm) tipe
45+ ExportEvent js elm tipe ->
46+ return $ ExportEvent js (env elm) tipe
4347
4448renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
4549 mapM (rename env') stmts
elm/src/Types/Constrain.hs+36−35
@@ -198,7 +198,7 @@ gen (C _ span expr) =
198198 Str _ -> primitive string
199199 Boolean _ -> primitive bool
200200 Markdown _ -> primitive element
201− -- _ -> beta >>= primitive
201+
202202
203203primitive :: Type -> GuidCounter (TVarMap, ConstraintSet, Type)
204204primitive t = return (Map.empty, Set.empty, t)
@@ -258,38 +258,39 @@ defGenHelp name args e = do
258258 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
259259 return ( as', Set.empty, (name, scheme) )
260260
261−stmtGen (Definition def) = do (as,cs,hint) <- defGen def
262− return ( as, cs, [hint] )
263−
264−stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'
265− return (Map.empty, Set.empty, schemes)
266− where var n = length xs + n
267− ( a, b, c) = ( var 1, var 2, var 3)
268− (va,vb,vc) = (VarT a, VarT b, VarT c)
269− rnm (ADT n []) | n == "Number" = va
270− | n == "Appendable" = vb
271− | n == "Comparable" = vc
272− rnm t = t
273− tcs' = map (second (map rnm)) tcs
274− supers t = map (ctx name NoSpan) $
275− zipWith (:<:) [va,vb,vc] [number,appendable t,comparable]
276− gen' (n,ts) = do t <- beta
277− let s = Forall (xs ++ [a,b,c]) (supers t) $
278− foldr (==>) (ADT name $ map VarT xs) ts
279− (,) n `liftM` generalize [] s
280−
281−stmtGen (ExportEvent js elm tipe) = do
282− x <- guid
283− return ( Map.singleton elm [x]
284− , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
285− , [] )
286−
287−stmtGen (ImportEvent js e@(C txt span base) elm tipe) = do
288− (as,cs,t) <- gen e
289− return ( as
290− , Set.insert (C txt span (signalOf t :=: tipe)) cs
291− , [ (elm, Forall [] [] tipe) ] )
292261
293−getDatatypeInfo (Datatype name args tcs) =
294− Just (name, args, tcs)
295−getDatatypeInfo _ = Nothing
262+stmtGen :: Statement -> GuidCounter (TVarMap, ConstraintSet, [(String,Scheme)])
263+stmtGen stmt =
264+ case stmt of
265+ Definition def -> do (as,cs,hint) <- defGen def
266+ return ( as, cs, [hint] )
267+
268+ TypeAlias alias t -> return (Map.empty, Set.empty, [])
269+
270+ TypeAnnotation name t ->
271+ do Forall _ _ t' <- generalize [] (Forall [] [] t)
272+ x <- guid
273+ return (Map.singleton name [x],
274+ Set.singleton (ctx name NoSpan $ VarT x :=: t'),
275+ [])
276+
277+ Datatype name xs tcs ->
278+ let toType ts = foldl (==>) (ADT name $ map VarT xs) ts in
279+ do schemes <- mapM (toScheme . second toType) tcs
280+ return (Map.empty, Set.empty, schemes)
281+
282+ ExportEvent js elm tipe ->
283+ do x <- guid
284+ return ( Map.singleton elm [x]
285+ , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
286+ , [] )
287+
288+ ImportEvent js e@(C txt span base) elm tipe ->
289+ do (as,cs,t) <- gen e
290+ return ( as
291+ , Set.insert (C txt span (signalOf t :=: tipe)) cs
292+ , [ (elm, Forall [] [] tipe) ] )
293+
294+toScheme :: (String,Type) -> GuidCounter (String,Scheme)
295+toScheme (name,tipe) = do scheme <- generalize [] (Forall [] [] tipe)
296+ return (name, scheme)
elm/src/Types/Hints.hs+2
@@ -8,6 +8,8 @@ import Types.Substitutions (rescheme)
88
99ctx str = C (Just str) NoSpan
1010prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
11+hasType t = map (-: t)
12+
1113
1214-------- Text and Elements --------
1315
elm/src/Types/Substitutions.hs+6−5
@@ -1,9 +1,10 @@
11
2−module Types.Substitutions (subst
3− ,occurs
4− ,concretize
5− ,rescheme
6− ,generalize) where
2+module Types.Substitutions (subst,
3+ occurs,
4+ freeVars,
5+ concretize,
6+ rescheme,
7+ generalize) where
78
89import Context
910import Control.DeepSeq (NFData (..), deepseq)
elm/src/Types/Types.hs−2
@@ -82,8 +82,6 @@ t1 ==> t2 = LambdaT t1 t2
8282infix 8 -:
8383name -: tipe = (,) name $ Forall [] [] tipe
8484
85−hasType t = map (-: t)
86−
8785parens = ("("++) . (++")")
8886
8987instance Show Type where