git.iko.soy/elk
on master help sign in
Make AST more general and try to give its phases better names

Also change the constructors for the Pattern ADT

commit9dd5dff279aa9797f7c363fc097f191d72becf92 authorEvan Czaplicki <info@elm-lang.org> dateMon 10 Feb 2014, 00:17 (13 years ago) parent594ed19
34 files changed+711−633
compare with master
unifiedsplit
Elm.cabal+9−8 compiler/Generate/Cases.hs+32−31 compiler/Generate/JavaScript.hs+52−47 compiler/Parse/Binop.hs+17−16 compiler/Parse/Expression.hs+67−66 compiler/Parse/Helpers.hs+14−11 compiler/Parse/Pattern.hs+29−27 compiler/SourceSyntax/Annotation.hs+74 compiler/SourceSyntax/Declaration.hs+2−2 compiler/SourceSyntax/Expression.hs+88−62 compiler/SourceSyntax/Location.hs−58 compiler/SourceSyntax/Module.hs+2−2 compiler/SourceSyntax/Pattern.hs+30−26 compiler/SourceSyntax/PrettyPrint.hs+5 compiler/SourceSyntax/Type.hs+3−6 compiler/SourceSyntax/Variable.hs+11 compiler/Transform/Canonicalize.hs+23−21 compiler/Transform/Declaration.hs+1−1 compiler/Transform/Definition.hs+1−1 compiler/Transform/Expression.hs+15−13 compiler/Transform/SafeNames.hs+19−18 compiler/Transform/SortDefinitions.hs+18−17 compiler/Transform/Substitute.hs+8−6 compiler/Type/Constrain/Declaration.hs+23−23 compiler/Type/Constrain/Expression.hs+34−33 compiler/Type/Constrain/Literal.hs+5−4 compiler/Type/Constrain/Pattern.hs+17−18 compiler/Type/ExtraChecks.hs+39−36 compiler/Type/Fragment.hs+12−13 compiler/Type/Inference.hs+1−1 compiler/Type/Solve.hs+19−19 compiler/Type/State.hs+12−20 compiler/Type/Type.hs+14−12 compiler/Type/Unify.hs+15−15
Elm.cabal+9−8
@@ -37,19 +37,19 @@ Library
3737 Elm.Internal.Utils,
3838 Elm.Internal.Version
3939 Hs-Source-Dirs: compiler
40− other-modules: SourceSyntax.Declaration,
40+ other-modules: SourceSyntax.Annotation,
41+ SourceSyntax.Declaration,
4142 SourceSyntax.Expression,
4243 SourceSyntax.Helpers,
4344 SourceSyntax.Literal,
44− SourceSyntax.Location,
4545 SourceSyntax.Module,
4646 SourceSyntax.Pattern,
4747 SourceSyntax.PrettyPrint,
4848 SourceSyntax.Type,
49+ SourceSyntax.Variable,
4950 Generate.JavaScript,
5051 Generate.JavaScript.Helpers,
5152 Generate.JavaScript.Ports,
52− Generate.Noscript,
5353 Generate.Markdown,
5454 Generate.Html,
5555 Generate.Cases,
@@ -119,19 +119,19 @@ Executable elm
119119 Main-is: Compiler.hs
120120 ghc-options: -threaded -O2
121121 Hs-Source-Dirs: compiler
122− other-modules: SourceSyntax.Declaration,
122+ other-modules: SourceSyntax.Annotation,
123+ SourceSyntax.Declaration,
123124 SourceSyntax.Expression,
124125 SourceSyntax.Helpers,
125126 SourceSyntax.Literal,
126− SourceSyntax.Location,
127127 SourceSyntax.Module,
128128 SourceSyntax.Pattern,
129129 SourceSyntax.PrettyPrint,
130130 SourceSyntax.Type,
131+ SourceSyntax.Variable,
131132 Generate.JavaScript,
132133 Generate.JavaScript.Helpers,
133134 Generate.JavaScript.Ports,
134− Generate.Noscript,
135135 Generate.Markdown,
136136 Generate.Html,
137137 Generate.Cases,
@@ -200,15 +200,16 @@ Executable elm
200200Executable elm-doc
201201 Main-is: Docs.hs
202202 Hs-Source-Dirs: compiler
203− other-modules: SourceSyntax.Declaration,
203+ other-modules: SourceSyntax.Annotation,
204+ SourceSyntax.Declaration,
204205 SourceSyntax.Expression,
205206 SourceSyntax.Helpers,
206207 SourceSyntax.Literal,
207− SourceSyntax.Location,
208208 SourceSyntax.Module,
209209 SourceSyntax.Pattern,
210210 SourceSyntax.PrettyPrint,
211211 SourceSyntax.Type,
212+ SourceSyntax.Variable,
212213 Parse.Binop,
213214 Parse.Declaration,
214215 Parse.Expression,
compiler/Generate/Cases.hs+32−31
@@ -6,14 +6,15 @@ import Control.Monad.State
66import Data.List (groupBy,sortBy)
77import Data.Maybe (fromMaybe)
88
9−import SourceSyntax.Location
10−import SourceSyntax.Literal
11−import SourceSyntax.Pattern
9+import SourceSyntax.Annotation
1210import SourceSyntax.Expression
11+import SourceSyntax.Literal
12+import qualified SourceSyntax.Pattern as P
13+import qualified SourceSyntax.Variable as V
1314import Transform.Substitute
1415
1516
16−toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)
17+toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)
1718toMatch patterns = do
1819 v <- newVar
1920 (,) v <$> match [v] (map (first (:[])) patterns) Fail
@@ -27,7 +28,7 @@ data Match
2728 = Match String [Clause] Match
2829 | Break
2930 | Fail
30− | Other LExpr
31+ | Other Expr
3132 | Seq [Match]
3233 deriving Show
3334
@@ -39,8 +40,8 @@ matchSubst :: [(String,String)] -> Match -> Match
3940matchSubst _ Break = Break
4041matchSubst _ Fail = Fail
4142matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
42−matchSubst pairs (Other (L s e)) =
43− Other . L s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
43+matchSubst pairs (Other (A a e)) =
44+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs
4445matchSubst pairs (Match n cs m) =
4546 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
4647 where varSubst v = fromMaybe v (lookup v pairs)
@@ -49,13 +50,13 @@ matchSubst pairs (Match n cs m) =
4950
5051isCon (p:_, _) =
5152 case p of
52− PData _ _ -> True
53− PLiteral _ -> True
54− _ -> False
53+ P.Data _ _ -> True
54+ P.Literal _ -> True
55+ _ -> False
5556
5657isVar p = not (isCon p)
5758
58−match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
59+match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
5960match [] [] def = return def
6061match [] [([],e)] Fail = return $ Other e
6162match [] [([],e)] Break = return $ Other e
@@ -67,46 +68,46 @@ match vs@(v:_) cs def
6768 where
6869 cs' = map (dealias v) cs
6970
70−dealias v c@(p:ps, L s e) =
71+dealias v c@(p:ps, A a e) =
7172 case p of
72− PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)
73+ P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)
7374 _ -> c
7475
75−matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
76+matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
7677matchVar (v:vs) cs def = match vs (map subVar cs) def
7778 where
78− subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)
79+ subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)
7980 where
8081 subOnePattern pattern e =
8182 case pattern of
82− PVar x -> subst x (Var v) e
83− PAnything -> e
84− PRecord fs ->
85− foldr (\x -> subst x (Access (L s (Var v)) x)) e fs
83+ P.Var x -> subst x (rawVar v) e
84+ P.Anything -> e
85+ P.Record fs ->
86+ foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs
8687
87−matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
88+matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
8889matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css
8990 where
9091 css = groupBy eq (sortBy cmp cs)
9192
9293 cmp (p1:_,_) (p2:_,_) =
9394 case (p1,p2) of
94− (PData n1 _, PData n2 _) -> compare n1 n2
95+ (P.Data n1 _, P.Data n2 _) -> compare n1 n2
9596 _ -> compare p1 p2
9697
9798 eq (p1:_,_) (p2:_,_) =
9899 case (p1,p2) of
99− (PData n1 _, PData n2 _) -> n1 == n2
100+ (P.Data n1 _, P.Data n2 _) -> n1 == n2
100101 _ -> p1 == p2
101102
102103 toClause cs =
103104 case head cs of
104− (PData name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
105− (PLiteral lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
105+ (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break
106+ (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break
106107
107108matchClause :: Either String Literal
108109 -> [String]
109− -> [([Pattern],LExpr)]
110+ -> [([P.Pattern],Expr)]
110111 -> Match
111112 -> State Int Clause
112113matchClause c (_:vs) cs def =
@@ -116,14 +117,14 @@ matchClause c (_:vs) cs def =
116117
117118 flatten (p:ps, e) =
118119 case p of
119− PData _ ps' -> (ps' ++ ps, e)
120− PLiteral _ -> (ps, e)
120+ P.Data _ ps' -> (ps' ++ ps, e)
121+ P.Literal _ -> (ps, e)
121122
122123 getVars =
123124 case head cs of
124− (PData _ ps : _, _) -> forM ps (const newVar)
125− (PLiteral _ : _, _) -> return []
125+ (P.Data _ ps : _, _) -> forM ps (const newVar)
126+ (P.Literal _ : _, _) -> return []
126127
127−matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match
128+matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match
128129matchMix vs cs def = foldM (flip $ match vs) def (reverse css)
129− where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
130+ where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs
compiler/Generate/JavaScript.hs+52−47
@@ -1,25 +1,27 @@
11{-# OPTIONS_GHC -W #-}
22module Generate.JavaScript (generate) where
33
4−import Control.Arrow (first,(***))
54import Control.Applicative ((<$>),(<*>))
5+import Control.Arrow (first,(***))
66import Control.Monad.State
77import qualified Data.List as List
88import qualified Data.Map as Map
99import qualified Data.Set as Set
10+import Language.ECMAScript3.PrettyPrint
11+import Language.ECMAScript3.Syntax
1012
1113import Generate.JavaScript.Helpers
1214import qualified Generate.Cases as Case
1315import qualified Generate.JavaScript.Ports as Port
1416import qualified Generate.Markdown as MD
17+import SourceSyntax.Annotation
18+import SourceSyntax.Expression
1519import qualified SourceSyntax.Helpers as Help
1620import SourceSyntax.Literal
17−import SourceSyntax.Pattern as Pattern
18−import SourceSyntax.Location
19−import SourceSyntax.Expression
2021import SourceSyntax.Module
21−import Language.ECMAScript3.Syntax
22−import Language.ECMAScript3.PrettyPrint
22+import qualified SourceSyntax.Pattern as P
23+import SourceSyntax.PrettyPrint (renderPretty)
24+import qualified SourceSyntax.Variable as V
2325import qualified Transform.SafeNames as MakeSafe
2426
2527varDecl :: String -> Expression () -> VarDecl ()
@@ -50,10 +52,10 @@ literal lit =
5052 FloatNum n -> NumLit () n
5153 Boolean b -> BoolLit () b
5254
53−expression :: LExpr -> State Int (Expression ())
54−expression (L span expr) =
55+expression :: Expr -> State Int (Expression ())
56+expression (A region expr) =
5557 case expr of
56− Var x -> return $ ref x
58+ Var (V.Raw x) -> return $ ref x
5759 Literal lit -> return $ literal lit
5860
5961 Range lo hi ->
@@ -93,9 +95,9 @@ expression (L span expr) =
9395 Map.toList . Map.filter (not . null) $ Map.map tail fs
9496 visible fs = map (first prop) . Map.toList $ Map.map head fs
9597
96− Binop op e1 e2 -> binop span op e1 e2
98+ Binop op e1 e2 -> binop region op e1 e2
9799
98− Lambda p e@(L s _) ->
100+ Lambda p e@(A ann _) ->
99101 do (args, body) <- foldM depattern ([], innerBody) (reverse patterns)
100102 body' <- expression body
101103 return $ case length args < 2 || length args > 9 of
@@ -104,13 +106,14 @@ expression (L span expr) =
104106 where
105107 depattern (args, body) pattern =
106108 case pattern of
107− PVar x -> return (args ++ [x], body)
109+ P.Var x -> return (args ++ [x], body)
108110 _ -> do arg <- Case.newVar
109− return (args ++ [arg], L s (Case (L s (Var arg)) [(pattern, body)]))
111+ return ( args ++ [arg]
112+ , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))
110113
111114 (patterns, innerBody) = collect [p] e
112115
113− collect patterns lexpr@(L _ expr) =
116+ collect patterns lexpr@(A _ expr) =
114117 case expr of
115118 Lambda p e -> collect (p:patterns) e
116119 _ -> (patterns, lexpr)
@@ -127,7 +130,7 @@ expression (L span expr) =
127130 (func, args) = getArgs e1 [e2]
128131 getArgs func args =
129132 case func of
130− (L _ (App f arg)) -> getArgs f (arg : args)
133+ (A _ (App f arg)) -> getArgs f (arg : args)
131134 _ -> (func, args)
132135
133136 Let defs e ->
@@ -139,9 +142,9 @@ expression (L span expr) =
139142 MultiIf branches ->
140143 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e
141144 return $ case last branches of
142− (L _ (Var "Basics.otherwise"), _) -> safeIfs branches'
143− (L _ (Literal (Boolean True)), _) -> safeIfs branches'
144− _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (show span) ])
145+ (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'
146+ (A _ (Literal (Boolean True)), _) -> safeIfs branches'
147+ _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])
145148 where
146149 safeIfs branches = ifs (init branches) (snd (last branches))
147150 ifs branches finally = foldr iff finally branches
@@ -151,10 +154,12 @@ expression (L span expr) =
151154 do (tempVar,initialMatch) <- Case.toMatch cases
152155 (revisedMatch, stmt) <-
153156 case e of
154− L _ (Var x) -> return (Case.matchSubst [(tempVar,x)] initialMatch, [])
155− _ -> do e' <- expression e
156− return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
157− match' <- match span revisedMatch
157+ A _ (Var (V.Raw x)) ->
158+ return (Case.matchSubst [(tempVar,x)] initialMatch, [])
159+ _ ->
160+ do e' <- expression e
161+ return (initialMatch, [VarDeclStmt () [varDecl tempVar e']])
162+ match' <- match region revisedMatch
158163 return (function [] (stmt ++ match') `call` [])
159164
160165 ExplicitList es ->
@@ -184,28 +189,28 @@ expression (L span expr) =
184189 [ string name, Port.outgoing tipe, value' ]
185190
186191definition :: Def -> State Int [Statement ()]
187−definition (Definition pattern expr@(L span _) _) = do
192+definition (Definition pattern expr@(A region _) _) = do
188193 expr' <- expression expr
189194 let assign x = varDecl x expr'
190195 case pattern of
191− PVar x
196+ P.Var x
192197 | Help.isOp x ->
193198 let op = LBracket () (ref "_op") (string x) in
194199 return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]
195200 | otherwise ->
196201 return [ VarDeclStmt () [ assign x ] ]
197202
198− PRecord fields ->
203+ P.Record fields ->
199204 let setField f = varDecl f (dotSep ["$",f]) in
200205 return [ VarDeclStmt () (assign "$" : map setField fields) ]
201206
202− PData name patterns | vars /= Nothing ->
207+ P.Data name patterns | vars /= Nothing ->
203208 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]
204209 where
205210 vars = getVars patterns
206211 getVars patterns =
207212 case patterns of
208− PVar x : rest -> (x:) `fmap` getVars rest
213+ P.Var x : rest -> (x:) `fmap` getVars rest
209214 [] -> Just []
210215 _ -> Nothing
211216
@@ -216,23 +221,23 @@ definition (Definition pattern expr@(L span _) _) = do
216221
217222 safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)
218223 if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)
219− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]
224+ exception = obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]
220225
221226 _ ->
222227 do defs' <- concat <$> mapM toDef vars
223228 return (VarDeclStmt () [assign "$"] : defs')
224229 where
225− vars = Set.toList $ Pattern.boundVars pattern
226− mkVar = L span . Var
227− toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]
228− in definition $ Definition (PVar y) expr Nothing
230+ vars = P.boundVarList pattern
231+ mkVar = A region . rawVar
232+ toDef y = let expr = A region $ Case (mkVar "$") [(pattern, mkVar y)]
233+ in definition $ Definition (P.Var y) expr Nothing
229234
230−match :: SrcSpan -> Case.Match -> State Int [Statement ()]
231−match span mtch =
235+match :: Region -> Case.Match -> State Int [Statement ()]
236+match region mtch =
232237 case mtch of
233238 Case.Match name clauses mtch' ->
234− do (isChars, clauses') <- unzip <$> mapM (clause span name) clauses
235− mtch'' <- match span mtch'
239+ do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses
240+ mtch'' <- match region mtch'
236241 return (SwitchStmt () (format isChars (access name)) clauses' : mtch'')
237242 where
238243 isLiteral p = case p of
@@ -244,13 +249,13 @@ match span mtch =
244249 | otherwise = e
245250
246251 Case.Fail ->
247− return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (show span)]) ]
252+ return [ ExprStmt () (obj "_E.Case" `call` [ref "$moduleName", string (renderPretty region)]) ]
248253
249254 Case.Break -> return [BreakStmt () Nothing]
250255 Case.Other e ->
251256 do e' <- expression e
252257 return [ ret e' ]
253− Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)
258+ Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms)
254259 where
255260 dropEnd acc [] = acc
256261 dropEnd acc (m:ms) =
@@ -258,9 +263,9 @@ match span mtch =
258263 Case.Other _ -> acc ++ [m]
259264 _ -> dropEnd (acc ++ [m]) ms
260265
261−clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())
262−clause span variable (Case.Clause value vars mtch) =
263− (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)
266+clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ())
267+clause region variable (Case.Clause value vars mtch) =
268+ (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch)
264269 where
265270 vars' = map (\n -> variable ++ "._" ++ show n) [0..]
266271 (isChar, pattern) =
@@ -273,8 +278,8 @@ clause span variable (Case.Clause value vars mtch) =
273278 [] -> name
274279 is -> drop (last is + 1) name
275280
276−flattenLets :: [Def] -> LExpr -> ([Def], LExpr)
277−flattenLets defs lexpr@(L _ expr) =
281+flattenLets :: [Def] -> Expr -> ([Def], Expr)
282+flattenLets defs lexpr@(A _ expr) =
278283 case expr of
279284 Let ds body -> flattenLets (defs ++ ds) body
280285 _ -> (defs, lexpr)
@@ -321,8 +326,8 @@ generate unsafeModule =
321326 Nothing -> tail . init $ List.inits path
322327 Just nmspc -> drop 2 . init . List.inits $ nmspc : path
323328
324−binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())
325−binop span op e1 e2 =
329+binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())
330+binop region op e1 e2 =
326331 case op of
327332 "Basics.." ->
328333 do es <- mapM expression (e1 : collect [] e2)
@@ -335,7 +340,7 @@ binop span op e1 e2 =
335340 do e1' <- expression e1
336341 e2' <- expression e2
337342 return $ obj "_L.append" `call` [e1', e2']
338− "::" -> expression (L span (Data "::" [e1,e2]))
343+ "::" -> expression (A region (Data "::" [e1,e2]))
339344 _ ->
340345 do e1' <- expression e1
341346 e2' <- expression e2
@@ -345,7 +350,7 @@ binop span op e1 e2 =
345350 where
346351 collect es e =
347352 case e of
348− L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
353+ A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2
349354 _ -> es ++ [e]
350355
351356 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)
compiler/Parse/Binop.hs+17−16
@@ -1,10 +1,11 @@
1+{-# OPTIONS_GHC -W #-}
12module Parse.Binop (binops, OpTable) where
23
34import Control.Applicative ((<$>))
4−import Data.List (intercalate)
5+import qualified Data.List as List
56import qualified Data.Map as Map
67
7−import SourceSyntax.Location (merge)
8+import SourceSyntax.Annotation (merge)
89import qualified SourceSyntax.Expression as E
910import SourceSyntax.Declaration (Assoc(..))
1011import Text.Parsec
@@ -16,13 +17,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table
1617opAssoc :: OpTable -> String -> Assoc
1718opAssoc table op = snd $ Map.findWithDefault (9,L) op table
1819
19−hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool
20+hasLevel :: OpTable -> Int -> (String, E.ParseExpr) -> Bool
2021hasLevel table n (op,_) = opLevel table op == n
2122
22−binops :: IParser E.LParseExpr
23− -> IParser E.LParseExpr
23+binops :: IParser E.ParseExpr
24+ -> IParser E.ParseExpr
2425 -> IParser String
25− -> IParser E.LParseExpr
26+ -> IParser E.ParseExpr
2627binops term last anyOp =
2728 do e <- term
2829 table <- getState
@@ -38,9 +39,9 @@ binops term last anyOp =
3839
3940split :: OpTable
4041 -> Int
41− -> E.LParseExpr
42− -> [(String, E.LParseExpr)]
43− -> IParser E.LParseExpr
42+ -> E.ParseExpr
43+ -> [(String, E.ParseExpr)]
44+ -> IParser E.ParseExpr
4445split _ _ e [] = return e
4546split table n e eops = do
4647 assoc <- getAssoc table n eops
@@ -49,26 +50,26 @@ split table n e eops = do
4950 case assoc of R -> joinR es ops
5051 _ -> joinL es ops
5152
52−splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]
53− -> [IParser E.LParseExpr]
53+splitLevel :: OpTable -> Int -> E.ParseExpr -> [(String, E.ParseExpr)]
54+ -> [IParser E.ParseExpr]
5455splitLevel table n e eops =
5556 case break (hasLevel table n) eops of
56− (lops, (op,e'):rops) ->
57+ (lops, (_op,e'):rops) ->
5758 split table (n+1) e lops : splitLevel table n e' rops
5859 (lops, []) -> [ split table (n+1) e lops ]
5960
60−joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
61+joinL :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
6162joinL [e] [] = return e
6263joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops
6364joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."
6465
65−joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr
66+joinR :: [E.ParseExpr] -> [String] -> IParser E.ParseExpr
6667joinR [e] [] = return e
6768joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops
6869 return (merge a e (E.Binop op a e))
6970joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."
7071
71−getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc
72+getAssoc :: OpTable -> Int -> [(String,E.ParseExpr)] -> IParser Assoc
7273getAssoc table n eops
7374 | all (==L) assocs = return L
7475 | all (==R) assocs = return R
@@ -79,5 +80,5 @@ getAssoc table n eops
7980 assocs = map (opAssoc table . fst) levelOps
8081 msg problem =
8182 concat [ "Conflicting " ++ problem ++ " for binary operators ("
82− , intercalate ", " (map fst eops), "). "
83+ , List.intercalate ", " (map fst eops), "). "
8384 , "Consider adding parentheses to disambiguate." ]
compiler/Parse/Expression.hs+67−66
@@ -5,45 +5,45 @@ import Data.List (foldl')
55import Text.Parsec hiding (newline,spaces)
66import Text.Parsec.Indent
77
8+import Parse.Binop
89import Parse.Helpers
10+import Parse.Literal
911import qualified Parse.Pattern as Pattern
1012import qualified Parse.Type as Type
11−import Parse.Binop
12−import Parse.Literal
1313
14−import SourceSyntax.Location as Location
15−import SourceSyntax.Pattern hiding (tuple,list)
16−import qualified SourceSyntax.Literal as Literal
14+import SourceSyntax.Annotation as Annotation
15+import qualified SourceSyntax.Pattern as P
16+import qualified SourceSyntax.Literal as L
1717import SourceSyntax.Expression
1818
1919
2020-------- Basic Terms --------
2121
22−varTerm :: IParser ParseExpr
22+varTerm :: IParser ParseExpr'
2323varTerm = toVar <$> var <?> "variable"
2424
25−toVar :: String -> ParseExpr
26−toVar v = case v of "True" -> Literal (Literal.Boolean True)
27− "False" -> Literal (Literal.Boolean False)
28− _ -> Var v
25+toVar :: String -> ParseExpr'
26+toVar v = case v of "True" -> Literal (L.Boolean True)
27+ "False" -> Literal (L.Boolean False)
28+ _ -> rawVar v
2929
30−accessor :: IParser ParseExpr
30+accessor :: IParser ParseExpr'
3131accessor = do
3232 (start, lbl, end) <- located (try (string "." >> rLabel))
33− let loc e = Location.at start end e
34− return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))
33+ let loc e = Annotation.at start end e
34+ return (Lambda (P.Var "_") (loc $ Access (loc $ rawVar "_") lbl))
3535
36−negative :: IParser ParseExpr
36+negative :: IParser ParseExpr'
3737negative = do
3838 (start, nTerm, end) <-
3939 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)
40− let loc e = Location.at start end e
41− return (Binop "-" (loc $ Literal (Literal.IntNum 0)) nTerm)
40+ let loc e = Annotation.at start end e
41+ return (Binop "-" (loc $ Literal (L.IntNum 0)) nTerm)
4242
4343
4444-------- Complex Terms --------
4545
46−listTerm :: IParser ParseExpr
46+listTerm :: IParser ParseExpr'
4747listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
4848 where
4949 range = do
@@ -66,86 +66,87 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)
6666 string "}}"
6767 return (span uid (length exprs), exprs ++ [e])
6868
69−parensTerm :: IParser LParseExpr
69+parensTerm :: IParser ParseExpr
7070parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)
7171 where
7272 opFn = do
7373 (start, op, end) <- located anyOp
74− let loc = Location.at start end
75− return . loc . Lambda (PVar "x") . loc . Lambda (PVar "y") . loc $
76− Binop op (loc $ Var "x") (loc $ Var "y")
74+ let loc = Annotation.at start end
75+ return . loc . Lambda (P.Var "x") . loc . Lambda (P.Var "y") . loc $
76+ Binop op (loc $ rawVar "x") (loc $ rawVar "y")
7777
7878 tupleFn = do
7979 let comma = char ',' <?> "comma ','"
8080 (start, commas, end) <- located (comma >> many (whitespace >> comma))
8181 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
82− loc = Location.at start end
82+ loc = Annotation.at start end
8383 return $ foldr (\x e -> loc $ Lambda x e)
84− (loc . tuple $ map (loc . Var) vars) (map PVar vars)
84+ (loc . tuple $ map (loc . rawVar) vars) (map P.Var vars)
8585
8686 parened = do
8787 (start, es, end) <- located (commaSep expr)
8888 return $ case es of
8989 [e] -> e
90− _ -> Location.at start end (tuple es)
90+ _ -> Annotation.at start end (tuple es)
9191
92−recordTerm :: IParser LParseExpr
92+recordTerm :: IParser ParseExpr
9393recordTerm = brackets $ choice [ misc, addLocation record ]
94− where field = do
95− label <- rLabel
96− patterns <- spacePrefix Pattern.term
97− padded equals
98− body <- expr
99− return (label, makeFunction patterns body)
94+ where
95+ field = do
96+ label <- rLabel
97+ patterns <- spacePrefix Pattern.term
98+ padded equals
99+ body <- expr
100+ return (label, makeFunction patterns body)
100101
101− record = Record <$> commaSep field
102+ record = Record <$> commaSep field
102103
103− change = do
104− lbl <- rLabel
105− padded (string "<-")
106− (,) lbl <$> expr
104+ change = do
105+ lbl <- rLabel
106+ padded (string "<-")
107+ (,) lbl <$> expr
107108
108− remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
109110
110− insert r = addLocation $ do
111− string "|" >> whitespace
112− Insert r <$> rLabel <*> (padded equals >> expr)
111+ insert r = addLocation $ do
112+ string "|" >> whitespace
113+ Insert r <$> rLabel <*> (padded equals >> expr)
113114
114− modify r = addLocation
115− (string "|" >> whitespace >> Modify r <$> commaSep1 change)
115+ modify r =
116+ addLocation (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116117
117− misc = try $ do
118− record <- addLocation (Var <$> rLabel)
119− opt <- padded (optionMaybe (remove record))
120− case opt of
121− Just e -> try (insert e) <|> return e
122− Nothing -> try (insert record) <|> try (modify record)
118+ misc = try $ do
119+ record <- addLocation (rawVar <$> rLabel)
120+ opt <- padded (optionMaybe (remove record))
121+ case opt of
122+ Just e -> try (insert e) <|> return e
123+ Nothing -> try (insert record) <|> try (modify record)
123124
124125
125−term :: IParser LParseExpr
126+term :: IParser ParseExpr
126127term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])
127128 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
128129 <?> "basic term (4, x, 'c', etc.)"
129130
130131-------- Applications --------
131132
132−appExpr :: IParser LParseExpr
133+appExpr :: IParser ParseExpr
133134appExpr = do
134135 t <- term
135136 ts <- constrainedSpacePrefix term $ \str ->
136137 if null str then notFollowedBy (char '-') else return ()
137138 return $ case ts of
138139 [] -> t
139− _ -> foldl' (\f x -> Location.merge f x $ App f x) t ts
140+ _ -> foldl' (\f x -> Annotation.merge f x $ App f x) t ts
140141
141142-------- Normal Expressions --------
142143
143−binaryExpr :: IParser LParseExpr
144+binaryExpr :: IParser ParseExpr
144145binaryExpr = binops appExpr lastExpr anyOp
145146 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
146147 <|> lambdaExpr
147148
148−ifExpr :: IParser ParseExpr
149+ifExpr :: IParser ParseExpr'
149150ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
150151 where
151152 normal = do
@@ -155,13 +156,13 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
155156 whitespace <?> "an 'else' branch" ; reserved "else" <?> "an 'else' branch" ; whitespace
156157 elseBranch <- expr
157158 return $ MultiIf [(bool, thenBranch),
158− (Location.sameAs elseBranch (Literal . Literal.Boolean $ True), elseBranch)]
159+ (Annotation.sameAs elseBranch (Literal . L.Boolean $ True), elseBranch)]
159160 multiIf = MultiIf <$> spaceSep1 iff
160161 where iff = do string "|" ; whitespace
161162 b <- expr ; padded arrow
162163 (,) b <$> expr
163164
164−lambdaExpr :: IParser LParseExpr
165+lambdaExpr :: IParser ParseExpr
165166lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
166167 whitespace
167168 args <- spaceSep1 Pattern.term
@@ -172,14 +173,14 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
172173defSet :: IParser [ParseDef]
173174defSet = block (do d <- def ; whitespace ; return d)
174175
175−letExpr :: IParser ParseExpr
176+letExpr :: IParser ParseExpr'
176177letExpr = do
177178 reserved "let" ; whitespace
178179 defs <- defSet
179180 padded (reserved "in")
180181 Let defs <$> expr
181182
182−caseExpr :: IParser ParseExpr
183+caseExpr :: IParser ParseExpr'
183184caseExpr = do
184185 reserved "case"; e <- padded expr; reserved "of"; whitespace
185186 Case e <$> (with <|> without)
@@ -189,35 +190,35 @@ caseExpr = do
189190 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
190191 without = block (do c <- case_ ; whitespace ; return c)
191192
192−expr :: IParser LParseExpr
193+expr :: IParser ParseExpr
193194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
194195 <|> lambdaExpr
195196 <|> binaryExpr
196197 <?> "an expression"
197198
198−defStart :: IParser [Pattern]
199+defStart :: IParser [P.Pattern]
199200defStart =
200201 choice [ do p1 <- try Pattern.term
201202 infics p1 <|> func p1
202− , func =<< (PVar <$> parens symOp)
203+ , func =<< (P.Var <$> parens symOp)
203204 , (:[]) <$> Pattern.expr
204205 ] <?> "the definition of a variable (x = ...)"
205206 where
206207 func pattern =
207208 case pattern of
208− PVar _ -> (pattern:) <$> spacePrefix Pattern.term
209+ P.Var _ -> (pattern:) <$> spacePrefix Pattern.term
209210 _ -> do try (lookAhead (whitespace >> string "="))
210211 return [pattern]
211212
212213 infics p1 = do
213214 o:p <- try (whitespace >> anyOp)
214215 p2 <- (whitespace >> Pattern.term)
215− return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
216− else [ PVar (o:p), p1, p2 ]
216+ return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ]
217+ else [ P.Var (o:p), p1, p2 ]
217218
218−makeFunction :: [Pattern] -> LParseExpr -> LParseExpr
219−makeFunction args body@(L s _) =
220− foldr (\arg body' -> L s $ Lambda arg body') body args
219+makeFunction :: [P.Pattern] -> ParseExpr -> ParseExpr
220+makeFunction args body@(A ann _) =
221+ foldr (\arg body' -> A ann $ Lambda arg body') body args
221222
222223definition :: IParser ParseDef
223224definition = withPos $ do
compiler/Parse/Helpers.hs+14−11
@@ -12,11 +12,12 @@ import Text.Parsec hiding (newline,spaces,State)
1212import Text.Parsec.Indent
1313import qualified Text.Parsec.Token as T
1414
15−import SourceSyntax.Helpers as Help
16−import SourceSyntax.Location as Location
15+import SourceSyntax.Annotation as Annotation
16+import SourceSyntax.Declaration (Assoc)
1717import SourceSyntax.Expression
18+import SourceSyntax.Helpers as Help
1819import SourceSyntax.PrettyPrint
19−import SourceSyntax.Declaration (Assoc)
20+import SourceSyntax.Variable as Variable
2021
2122reserveds = [ "if", "then", "else"
2223 , "case", "of"
@@ -181,10 +182,10 @@ parens = surround '(' ')' "paren"
181182brackets :: IParser a -> IParser a
182183brackets = surround '{' '}' "bracket"
183184
184−addLocation :: (Pretty a) => IParser a -> IParser (Location.Located a)
185+addLocation :: (Pretty a) => IParser a -> IParser (Annotation.Located a)
185186addLocation expr = do
186187 (start, e, end) <- located expr
187− return (Location.at start end e)
188+ return (Annotation.at start end e)
188189
189190located :: IParser a -> IParser (SourcePos, a, SourcePos)
190191located p = do
@@ -193,10 +194,10 @@ located p = do
193194 end <- getPosition
194195 return (start, e, end)
195196
196−accessible :: IParser LParseExpr -> IParser LParseExpr
197+accessible :: IParser ParseExpr -> IParser ParseExpr
197198accessible expr = do
198199 start <- getPosition
199− ce@(L _ e) <- expr
200+ ce@(A _ e) <- expr
200201 let rest f = do
201202 let dot = char '.' >> notFollowedBy (char '.')
202203 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
@@ -205,10 +206,12 @@ accessible expr = do
205206 Just _ -> accessible $ do
206207 v <- var <?> "field access (e.g. List.map)"
207208 end <- getPosition
208− return (Location.at start end (f v))
209− case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
210− | otherwise -> rest (Access ce)
211− _ -> rest (Access ce)
209+ return (Annotation.at start end (f v))
210+ case e of
211+ Var (Variable.Raw (c:cs))
212+ | isUpper c -> rest (\v -> rawVar (c:cs ++ '.':v))
213+ | otherwise -> rest (Access ce)
214+ _ -> rest (Access ce)
212215
213216
214217spaces :: IParser String
compiler/Parse/Pattern.hs+29−27
@@ -3,57 +3,59 @@ module Parse.Pattern (term, expr) where
33
44import Control.Applicative ((<$>))
55import Data.Char (isUpper)
6−import Data.List (intercalate)
6+import qualified Data.List as List
77import Text.Parsec hiding (newline,spaces,State)
88
99import Parse.Helpers
1010import Parse.Literal
1111import SourceSyntax.Literal
12−import SourceSyntax.Pattern hiding (tuple, list)
13−import qualified SourceSyntax.Pattern as Pattern
12+import qualified SourceSyntax.Pattern as P
1413
15−basic :: IParser Pattern
14+basic :: IParser P.Pattern
1615basic = choice
17− [ char '_' >> return PAnything
16+ [ char '_' >> return P.Anything
1817 , do v <- var
1918 return $ case v of
20− "True" -> PLiteral (Boolean True)
21− "False" -> PLiteral (Boolean False)
22− c:_ | isUpper c -> PData v []
23− _ -> PVar v
24− , PLiteral <$> literal
19+ "True" -> P.Literal (Boolean True)
20+ "False" -> P.Literal (Boolean False)
21+ c:_ | isUpper c -> P.Data v []
22+ _ -> P.Var v
23+ , P.Literal <$> literal
2524 ]
2625
27−asPattern :: Pattern -> IParser Pattern
26+asPattern :: P.Pattern -> IParser P.Pattern
2827asPattern pattern = do
2928 var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar))
3029 return $ case var of
31− Just v -> PAlias v pattern
30+ Just v -> P.Alias v pattern
3231 Nothing -> pattern
3332
34−record :: IParser Pattern
35−record = PRecord <$> brackets (commaSep1 lowVar)
33+record :: IParser P.Pattern
34+record = P.Record <$> brackets (commaSep1 lowVar)
3635
37−tuple :: IParser Pattern
38−tuple = do ps <- parens (commaSep expr)
39− return $ case ps of { [p] -> p; _ -> Pattern.tuple ps }
36+tuple :: IParser P.Pattern
37+tuple = do
38+ ps <- parens (commaSep expr)
39+ return $ case ps of
40+ [p] -> p
41+ _ -> P.tuple ps
4042
41−list :: IParser Pattern
42−list = Pattern.list <$> braces (commaSep expr)
43+list :: IParser P.Pattern
44+list = P.list <$> braces (commaSep expr)
4345
44−term :: IParser Pattern
46+term :: IParser P.Pattern
4547term =
4648 (choice [ record, tuple, list, basic ]) <?> "pattern"
4749
48−patternConstructor :: IParser Pattern
50+patternConstructor :: IParser P.Pattern
4951patternConstructor = do
50− v <- intercalate "." <$> dotSep1 capVar
52+ v <- List.intercalate "." <$> dotSep1 capVar
5153 case v of
52− "True" -> return $ PLiteral (Boolean True)
53− "False" -> return $ PLiteral (Boolean False)
54− _ -> PData v <$> spacePrefix term
54+ "True" -> return $ P.Literal (Boolean True)
55+ "False" -> return $ P.Literal (Boolean False)
56+ _ -> P.Data v <$> spacePrefix term
5557
56−expr :: IParser Pattern
58+expr :: IParser P.Pattern
5759expr = do
5860 patterns <- consSep1 (patternConstructor <|> term)
59− asPattern (foldr1 Pattern.cons patterns) <?> "pattern"
61+ asPattern (foldr1 P.cons patterns) <?> "pattern"
compiler/SourceSyntax/Annotation.hsnew file+74
@@ -0,0 +1,74 @@
1+{-# OPTIONS_GHC -W #-}
2+module SourceSyntax.Annotation where
3+
4+import qualified Text.Parsec.Pos as Parsec
5+import qualified Text.PrettyPrint as P
6+import SourceSyntax.PrettyPrint
7+
8+data Annotated annotation expr = A annotation expr
9+ deriving (Show)
10+
11+data Region
12+ = Span Position Position P.Doc
13+ | None P.Doc
14+ deriving (Show)
15+
16+data Position = Position
17+ { line :: Int
18+ , column :: Int
19+ } deriving (Show)
20+
21+type Located expr = Annotated Region expr
22+
23+none e = A (None (pretty e)) e
24+noneNoDocs e = A (None P.empty) e
25+
26+at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr
27+ -> Annotated Region expr
28+at start end e =
29+ A (Span (position start) (position end) (pretty e)) e
30+ where
31+ position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc)
32+
33+merge (A s1 _) (A s2 _) e =
34+ A (span (pretty e)) e
35+ where
36+ span = case (s1,s2) of
37+ (Span start _ _, Span _ end _) -> Span start end
38+ (Span start end _, _) -> Span start end
39+ (_, Span start end _) -> Span start end
40+ (_, _) -> None
41+
42+mergeOldDocs (A s1 _) (A s2 _) e =
43+ A span e
44+ where
45+ span = case (s1,s2) of
46+ (Span start _ d1, Span _ end d2) ->
47+ Span start end (P.vcat [d1, P.text "\n", d2])
48+
49+ (Span _ _ _, _) -> s1
50+ (_, Span _ _ _) -> s2
51+ (_, _) -> None P.empty
52+
53+sameAs :: Annotated a expr -> expr' -> Annotated a expr'
54+sameAs (A annotation _) expr = A annotation expr
55+
56+getRegionDocs region =
57+ case region of
58+ Span _ _ doc -> doc
59+ None doc -> doc
60+
61+instance Pretty Region where
62+ pretty span =
63+ case span of
64+ None _ -> P.empty
65+ Span start end _ ->
66+ P.text $
67+ case line start == line end of
68+ False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
69+ True -> "on line " ++ show (line end) ++ ", column " ++
70+ show (column start) ++ " to " ++ show (column end)
71+
72+instance Pretty e => Pretty (Annotated a e) where
73+ pretty (A _ e) = pretty e
74+
compiler/SourceSyntax/Declaration.hs+2−2
@@ -20,11 +20,11 @@ data Assoc = L | N | R
2020
2121data ParsePort
2222 = PPAnnotation String T.Type
23− | PPDef String Expr.LParseExpr
23+ | PPDef String Expr.ParseExpr
2424 deriving (Show)
2525
2626data Port
27− = Out String Expr.LExpr T.Type
27+ = Out String Expr.Expr T.Type
2828 | In String T.Type
2929 deriving (Show)
3030
compiler/SourceSyntax/Expression.hs+88−62
@@ -11,49 +11,54 @@ module SourceSyntax.Expression where
1111import SourceSyntax.PrettyPrint
1212import Text.PrettyPrint as P
1313import qualified SourceSyntax.Helpers as Help
14−import qualified SourceSyntax.Location as Location
14+import qualified SourceSyntax.Annotation as Annotation
1515import qualified SourceSyntax.Pattern as Pattern
1616import qualified SourceSyntax.Type as SrcType
1717import qualified SourceSyntax.Literal as Literal
18+import qualified SourceSyntax.Variable as Variable
1819
1920---- GENERAL AST ----
2021
21−{-| This is a located expression, meaning it is tagged with info about where it
22−came from in the source code. Expr' is defined in terms of LExpr' so that the
23−location information does not need to be an extra field on every constructor.
24−-}
25−type LExpr' def = Location.Located (Expr' def)
26−
2722{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
2823"type holes" that allow us to enrich the AST with additional information as we
29−move through the compilation process. The type holes let us show these
30−structural changes in the types. The only type hole right now is:
24+move through the compilation process. The type holes are used to represent:
25+
26+ ann: Annotations for arbitrary expressions. Allows you to add information
27+ to the AST like position in source code or inferred types.
28+
29+ def: Definition style. The source syntax separates type annotations and
30+ definitions, but after parsing we check that they are well formed and
31+ collapse them.
3132
32− def: Parsing allows two kinds of definitions (type annotations or definitions),
33− but later checks will see that they are well formed and combine them.
33+ var: Representation of variables. Starts as strings, but is later enriched
34+ with information about what module a variable came from.
3435
3536-}
36−data Expr' def
37+type GeneralExpr annotation definition variable =
38+ Annotation.Annotated annotation (GeneralExpr' annotation definition variable)
39+
40+data GeneralExpr' ann def var
3741 = Literal Literal.Literal
38− | Var String
39− | Range (LExpr' def) (LExpr' def)
40− | ExplicitList [LExpr' def]
41− | Binop String (LExpr' def) (LExpr' def)
42− | Lambda Pattern.Pattern (LExpr' def)
43− | App (LExpr' def) (LExpr' def)
44− | MultiIf [(LExpr' def,LExpr' def)]
45− | Let [def] (LExpr' def)
46− | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
47− | Data String [LExpr' def]
48− | Access (LExpr' def) String
49− | Remove (LExpr' def) String
50− | Insert (LExpr' def) String (LExpr' def)
51− | Modify (LExpr' def) [(String, LExpr' def)]
52− | Record [(String, LExpr' def)]
53− | Markdown String String [LExpr' def]
42+ | Var var
43+ | Range (GeneralExpr ann def var) (GeneralExpr ann def var)
44+ | ExplicitList [GeneralExpr ann def var]
45+ | Binop String (GeneralExpr ann def var) (GeneralExpr ann def var)
46+ | Lambda Pattern.Pattern (GeneralExpr ann def var)
47+ | App (GeneralExpr ann def var) (GeneralExpr ann def var)
48+ | MultiIf [(GeneralExpr ann def var,GeneralExpr ann def var)]
49+ | Let [def] (GeneralExpr ann def var)
50+ | Case (GeneralExpr ann def var) [(Pattern.Pattern, GeneralExpr ann def var)]
51+ | Data String [GeneralExpr ann def var]
52+ | Access (GeneralExpr ann def var) String
53+ | Remove (GeneralExpr ann def var) String
54+ | Insert (GeneralExpr ann def var) String (GeneralExpr ann def var)
55+ | Modify (GeneralExpr ann def var) [(String, GeneralExpr ann def var)]
56+ | Record [(String, GeneralExpr ann def var)]
57+ | Markdown String String [GeneralExpr ann def var]
5458 -- for type checking and code gen only
5559 | PortIn String SrcType.Type
56− | PortOut String SrcType.Type (LExpr' def)
60+ | PortOut String SrcType.Type (GeneralExpr ann def var)
61+ deriving (Show)
5762
5863
5964---- SPECIALIZED ASTs ----
@@ -62,81 +67,100 @@ data Expr' def
6267annotations and definitions, which is how they appear in source code and how
6368they are parsed.
6469-}
65−type ParseExpr = Expr' ParseDef
66−type LParseExpr = LExpr' ParseDef
70+type ParseExpr = GeneralExpr Annotation.Region ParseDef Variable.Raw
71+type ParseExpr' = GeneralExpr' Annotation.Region ParseDef Variable.Raw
6772
6873data ParseDef
69− = Def Pattern.Pattern LParseExpr
74+ = Def Pattern.Pattern ParseExpr
7075 | TypeAnnotation String SrcType.Type
71− deriving (Show)
76+ deriving (Show)
7277
7378{-| "Normal" expressions. When the compiler checks that type annotations and
7479ports are all paired with definitions in the appropriate order, it collapses
7580them into a Def that is easier to work with in later phases of compilation.
7681-}
77−type LExpr = LExpr' Def
78−type Expr = Expr' Def
82+type Expr = GeneralExpr Annotation.Region Def Variable.Raw
83+type Expr' = GeneralExpr' Annotation.Region Def Variable.Raw
7984
80−data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)
85+data Def = Definition Pattern.Pattern Expr (Maybe SrcType.Type)
8186 deriving (Show)
8287
8388
89+
8490---- UTILITIES ----
8591
86−tuple :: [LExpr' def] -> Expr' def
92+rawVar :: String -> GeneralExpr' ann def Variable.Raw
93+rawVar x = Var (Variable.Raw x)
94+
95+tuple :: [GeneralExpr ann def var] -> GeneralExpr' ann def var
8796tuple es = Data ("_Tuple" ++ show (length es)) es
8897
89−delist :: LExpr' def -> [LExpr' def]
90−delist (Location.L _ (Data "::" [h,t])) = h : delist t
98+delist :: GeneralExpr ann def var -> [GeneralExpr ann def var]
99+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
91100delist _ = []
92101
93102saveEnvName :: String
94103saveEnvName = "_save_the_environment!!!"
95104
96−dummyLet :: Pretty def => [def] -> LExpr' def
105+dummyLet :: (Pretty def) => [def] -> GeneralExpr Annotation.Region def Variable.Raw
97106dummyLet defs =
98− Location.none $ Let defs (Location.none $ Var saveEnvName)
107+ Annotation.none $ Let defs (Annotation.none $ rawVar saveEnvName)
99108
100−instance Pretty def => Show (Expr' def) where
101− show = render . pretty
102−
103−instance Pretty def => Pretty (Expr' def) where
109+instance (Pretty def, Pretty var) => Pretty (GeneralExpr' ann def var) where
104110 pretty expr =
105111 case expr of
106112 Literal lit -> pretty lit
107− Var x -> variable x
113+
114+ Var x -> pretty x
115+
108116 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
117+
109118 ExplicitList es -> P.brackets (commaCat (map pretty es))
110− Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
119+
120+ Binop "-" (Annotation.A _ (Literal (Literal.IntNum 0))) e ->
111121 P.text "-" <> prettyParens e
122+
112123 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
113− where op' = if Help.isOp op then op else "`" ++ op ++ "`"
124+ where
125+ op' = if Help.isOp op then op else "`" ++ op ++ "`"
126+
114127 Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
115128 where
116− (ps,body) = collectLambdas (Location.none $ Lambda p e)
129+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
117130 args = P.sep (map Pattern.prettyParens ps)
131+
118132 App _ _ -> P.hang func 2 (P.sep args)
119− where func:args = map prettyParens (collectApps (Location.none expr))
120− MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
133+ where
134+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))
135+
136+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
121137 where
122138 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
139+
123140 Let defs e ->
124141 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
125142 , P.text "in" <+> pretty e ]
143+
126144 Case e pats ->
127145 P.hang pexpr 2 (P.vcat (map pretty' pats))
128146 where
129147 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
130148 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
149+
131150 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
132151 Data "[]" [] -> P.text "[]"
133152 Data name es
134153 | Help.isTuple name -> P.parens (commaCat (map pretty es))
135154 | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
155+
136156 Access e x -> prettyParens e <> P.text "." <> variable x
157+
137158 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
138− Insert (Location.L _ (Remove e y)) x v ->
139− P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
159+
160+ Insert (Annotation.A _ (Remove e y)) x v ->
161+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
162+ , variable x, P.equals, pretty v ]
163+
140164 Insert e x v ->
141165 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
142166
@@ -175,21 +199,23 @@ instance Pretty Def where
175199 Nothing -> P.empty
176200 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
177201
178−collectApps :: LExpr' def -> [LExpr' def]
179−collectApps lexpr@(Location.L _ expr) =
202+collectApps :: GeneralExpr ann def var -> [GeneralExpr ann def var]
203+collectApps annExpr@(Annotation.A _ expr) =
180204 case expr of
181205 App a b -> collectApps a ++ [b]
182− _ -> [lexpr]
206+ _ -> [annExpr]
183207
184−collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)
185−collectLambdas lexpr@(Location.L _ expr) =
208+collectLambdas :: GeneralExpr ann def var -> ([Pattern.Pattern], GeneralExpr ann def var)
209+collectLambdas lexpr@(Annotation.A _ expr) =
186210 case expr of
187− Lambda pattern body -> (pattern : ps, body')
188− where (ps, body') = collectLambdas body
211+ Lambda pattern body ->
212+ let (ps, body') = collectLambdas body
213+ in (pattern : ps, body')
214+
189215 _ -> ([], lexpr)
190216
191−prettyParens :: (Pretty def) => LExpr' def -> Doc
192−prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
217+prettyParens :: (Pretty def, Pretty var) => GeneralExpr ann def var -> Doc
218+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
193219 where
194220 needed =
195221 case expr of
compiler/SourceSyntax/Location.hsdeleted−58
@@ -1,58 +0,0 @@
1−module SourceSyntax.Location where
2−
3−import Text.PrettyPrint
4−import SourceSyntax.PrettyPrint
5−import qualified Text.Parsec.Pos as Parsec
6−
7−data SrcPos = Pos { line :: Int, column :: Int }
8− deriving (Eq, Ord)
9−
10−data SrcSpan = Span SrcPos SrcPos String | NoSpan String
11− deriving (Eq, Ord)
12−
13−data Located e = L SrcSpan e
14− deriving (Eq, Ord)
15−
16−none e = L (NoSpan (render $ pretty e)) e
17−noneNoDocs = L (NoSpan "")
18−
19−at start end e = L (Span (Pos (Parsec.sourceLine start) (Parsec.sourceColumn start))
20− (Pos (Parsec.sourceLine end ) (Parsec.sourceColumn end ))
21− (render $ pretty e)) e
22−
23−merge (L s1 _) (L s2 _) e = L (span (render $ pretty e)) e
24− where span = case (s1,s2) of
25− (Span start _ _, Span _ end _) -> Span start end
26− (Span start end _, _) -> Span start end
27− (_, Span start end _) -> Span start end
28− (_, _) -> NoSpan
29−
30−mergeOldDocs (L s1 _) (L s2 _) e = L span e
31− where span = case (s1,s2) of
32− (Span start _ d1, Span _ end d2) -> Span start end (d1 ++ "\n\n" ++ d2)
33− (Span _ _ _, _) -> s1
34− (_, Span _ _ _) -> s2
35− (_, _) -> NoSpan ""
36−
37−sameAs (L s _) = L s
38−
39−
40−instance Show SrcPos where
41− show (Pos r c) = show r ++ "," ++ show c
42−
43−instance Show SrcSpan where
44− show span =
45− case span of
46− NoSpan _ -> ""
47− Span start end _ ->
48− case line start == line end of
49− False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)
50− True -> "on line " ++ show (line end) ++ ", column " ++
51− show (column start) ++ " to " ++ show (column end)
52−
53−instance Show e => Show (Located e) where
54− show (L _ e) = show e
55−
56−instance Pretty a => Pretty (Located a) where
57− pretty (L _ e) = pretty e
58−
compiler/SourceSyntax/Module.hs+2−2
@@ -7,7 +7,7 @@ import qualified Data.Map as Map
77import Control.Applicative ((<$>), (<*>))
88import Text.PrettyPrint as P
99
10−import SourceSyntax.Expression (LExpr)
10+import SourceSyntax.Expression (Expr)
1111import SourceSyntax.Declaration
1212import SourceSyntax.PrettyPrint
1313import SourceSyntax.Type
@@ -72,7 +72,7 @@ data MetadataModule =
7272 , path :: FilePath
7373 , exports :: [String]
7474 , imports :: [(String, ImportMethod)]
75− , program :: LExpr
75+ , program :: Expr
7676 , types :: Map.Map String Type
7777 , fixities :: [(Assoc, Int, String)]
7878 , aliases :: [Alias]
compiler/SourceSyntax/Pattern.hs+30−26
@@ -7,50 +7,54 @@ import Text.PrettyPrint as PP
77import qualified Data.Set as Set
88import SourceSyntax.Literal as Literal
99
10−data Pattern = PData String [Pattern]
11− | PRecord [String]
12− | PAlias String Pattern
13− | PVar String
14− | PAnything
15− | PLiteral Literal.Literal
16− deriving (Eq, Ord, Show)
10+data Pattern
11+ = Data String [Pattern]
12+ | Record [String]
13+ | Alias String Pattern
14+ | Var String
15+ | Anything
16+ | Literal Literal.Literal
17+ deriving (Eq, Ord, Show)
1718
1819cons :: Pattern -> Pattern -> Pattern
19−cons h t = PData "::" [h,t]
20+cons h t = Data "::" [h,t]
2021
2122nil :: Pattern
22−nil = PData "[]" []
23+nil = Data "[]" []
2324
2425list :: [Pattern] -> Pattern
2526list = foldr cons nil
2627
2728tuple :: [Pattern] -> Pattern
28−tuple es = PData ("_Tuple" ++ show (length es)) es
29+tuple es = Data ("_Tuple" ++ show (length es)) es
30+
31+boundVarList :: Pattern -> [String]
32+boundVarList = Set.toList . boundVars
2933
3034boundVars :: Pattern -> Set.Set String
3135boundVars pattern =
3236 case pattern of
33− PVar x -> Set.singleton x
34− PAlias x p -> Set.insert x (boundVars p)
35− PData _ ps -> Set.unions (map boundVars ps)
36− PRecord fields -> Set.fromList fields
37− PAnything -> Set.empty
38− PLiteral _ -> Set.empty
37+ Var x -> Set.singleton x
38+ Alias x p -> Set.insert x (boundVars p)
39+ Data _ ps -> Set.unions (map boundVars ps)
40+ Record fields -> Set.fromList fields
41+ Anything -> Set.empty
42+ Literal _ -> Set.empty
3943
4044
4145instance Pretty Pattern where
4246 pretty pattern =
4347 case pattern of
44− PVar x -> variable x
45− PLiteral lit -> pretty lit
46− PRecord fs -> PP.braces (commaCat $ map variable fs)
47− PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x
48− PAnything -> PP.text "_"
49− PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
48+ Var x -> variable x
49+ Literal lit -> pretty lit
50+ Record fs -> PP.braces (commaCat $ map variable fs)
51+ Alias x p -> prettyParens p <+> PP.text "as" <+> variable x
52+ Anything -> PP.text "_"
53+ Data "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl
5054 where isCons = case hd of
51− PData "::" _ -> True
55+ Data "::" _ -> True
5256 _ -> False
53− PData name ps ->
57+ Data name ps ->
5458 if Help.isTuple name then
5559 PP.parens . commaCat $ map pretty ps
5660 else hsep (PP.text name : map prettyParens ps)
@@ -60,6 +64,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)
6064 where
6165 needsThem =
6266 case pattern of
63− PData name (_:_) | not (Help.isTuple name) -> True
64− PAlias _ _ -> True
67+ Data name (_:_) | not (Help.isTuple name) -> True
68+ Alias _ _ -> True
6569 _ -> False
compiler/SourceSyntax/PrettyPrint.hs+5
@@ -10,11 +10,16 @@ class Pretty a where
1010instance Pretty () where
1111 pretty () = empty
1212
13+renderPretty :: (Pretty a) => a -> String
14+renderPretty e = render (pretty e)
15+
1316commaCat docs = cat (punctuate comma docs)
1417commaSep docs = sep (punctuate comma docs)
1518
19+parensIf :: Bool -> Doc -> Doc
1620parensIf bool doc = if bool then parens doc else doc
1721
22+variable :: String -> Doc
1823variable x =
1924 if Help.isOp x then parens (text x)
2025 else text (reprime x)
compiler/SourceSyntax/Type.hs+3−6
@@ -1,18 +1,18 @@
11{-# OPTIONS_GHC -W #-}
22module SourceSyntax.Type where
33
4+import Control.Applicative ((<$>), (<*>))
45import Data.Binary
56import qualified Data.Map as Map
6−import qualified SourceSyntax.Helpers as Help
7−import Control.Applicative ((<$>), (<*>))
87import SourceSyntax.PrettyPrint
8+import qualified SourceSyntax.Helpers as Help
99import Text.PrettyPrint as P
1010
1111data Type = Lambda Type Type
1212 | Var String
1313 | Data String [Type]
1414 | Record [(String,Type)] (Maybe String)
15− deriving (Eq)
15+ deriving (Eq,Show)
1616
1717fieldMap :: [(String,a)] -> Map.Map String [a]
1818fieldMap fields =
@@ -27,9 +27,6 @@ listOf t = Data "_List" [t]
2727tupleOf :: [Type] -> Type
2828tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts
2929
30−instance Show Type where
31− show = render . pretty
32−
3330instance Pretty Type where
3431 pretty tipe =
3532 case tipe of
compiler/SourceSyntax/Variable.hsnew file+11
@@ -0,0 +1,11 @@
1+
2+module SourceSyntax.Variable where
3+
4+import qualified Text.PrettyPrint as P
5+import SourceSyntax.PrettyPrint
6+
7+newtype Raw = Raw String
8+ deriving (Eq,Ord,Show)
9+
10+instance Pretty Raw where
11+ pretty (Raw var) = variable var
compiler/Transform/Canonicalize.hs+23−21
@@ -1,19 +1,20 @@
1−{-# OPTIONS_GHC -W #-}
1+{-# OPTIONS_GHC -Wall #-}
22module Transform.Canonicalize (interface, metadataModule) where
33
44import Control.Arrow ((***))
55import Control.Applicative (Applicative,(<$>),(<*>))
66import Control.Monad.Identity
7−import qualified Data.Traversable as T
7+import qualified Data.Either as Either
8+import qualified Data.List as List
89import qualified Data.Map as Map
910import qualified Data.Set as Set
10−import qualified Data.List as List
11−import qualified Data.Either as Either
12−import SourceSyntax.Module
11+import qualified Data.Traversable as T
12+import SourceSyntax.Annotation as A
1313import SourceSyntax.Expression
14−import SourceSyntax.Location as Loc
14+import SourceSyntax.Module
1515import qualified SourceSyntax.Pattern as P
1616import qualified SourceSyntax.Type as Type
17+import qualified SourceSyntax.Variable as Var
1718import Text.PrettyPrint as P
1819
1920interface :: String -> ModuleInterface -> ModuleInterface
@@ -96,8 +97,7 @@ type Env = Map.Map String String
9697
9798extend :: Env -> P.Pattern -> Env
9899extend env pattern = Map.union (Map.fromList (zip xs xs)) env
99− where xs = Set.toList (P.boundVars pattern)
100−
100+ where xs = P.boundVarList pattern
101101
102102replace :: String -> Env -> String -> Either String String
103103replace variable env v =
@@ -110,14 +110,15 @@ replace variable env v =
110110 msg = if null matches then "" else
111111 "\nClose matches include: " ++ List.intercalate ", " matches
112112
113−rename :: Env -> LExpr -> Either [Doc] LExpr
114−rename env (L s expr) =
113+-- TODO: Var.Raw -> Var.Canonical
114+rename :: Env -> Expr -> Either [Doc] Expr
115+rename env (A ann expr) =
115116 let rnm = rename env
116− throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]
117+ throw err = Left [ P.text $ "Error " ++ show ann ++ "\n" ++ err ]
117118 format = Either.either throw return
118− renameType' env = renameType (format . replace "variable" env)
119+ renameType' environ = renameType (format . replace "variable" environ)
119120 in
120− L s <$>
121+ A ann <$>
121122 case expr of
122123 Literal _ -> return expr
123124
@@ -155,7 +156,8 @@ rename env (L s expr) =
155156 <*> rename env' body
156157 <*> T.traverse (renameType' env') mtipe
157158
158− Var x -> Var <$> format (replace "variable" env x)
159+ -- TODO: Raw -> Canonical
160+ Var (Var.Raw x) -> rawVar <$> format (replace "variable" env x)
159161
160162 Data name es -> Data name <$> mapM rnm es
161163
@@ -176,10 +178,10 @@ rename env (L s expr) =
176178renamePattern :: Env -> P.Pattern -> Either String P.Pattern
177179renamePattern env pattern =
178180 case pattern of
179− P.PVar _ -> return pattern
180− P.PLiteral _ -> return pattern
181− P.PRecord _ -> return pattern
182− P.PAnything -> return pattern
183− P.PAlias x p -> P.PAlias x <$> renamePattern env p
184− P.PData name ps -> P.PData <$> replace "pattern" env name
185− <*> mapM (renamePattern env) ps
181+ P.Var _ -> return pattern
182+ P.Literal _ -> return pattern
183+ P.Record _ -> return pattern
184+ P.Anything -> return pattern
185+ P.Alias x p -> P.Alias x <$> renamePattern env p
186+ P.Data name ps -> P.Data <$> replace "pattern" env name
187+ <*> mapM (renamePattern env) ps
compiler/Transform/Declaration.hs+1−1
@@ -42,7 +42,7 @@ combineAnnotations = go
4242
4343 TypeAnnotation name tipe ->
4444 case defRest of
45− D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->
45+ D.Definition (Def pat@(P.Var name') expr) : rest | name == name' ->
4646 do expr' <- exprCombineAnnotations expr
4747 let def' = E.Definition pat expr' (Just tipe)
4848 (:) (D.Definition def') <$> go rest
compiler/Transform/Definition.hs+1−1
@@ -16,7 +16,7 @@ combineAnnotations = go
1616
1717 go defs =
1818 case defs of
19− TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->
19+ TypeAnnotation name tipe : Def pat@(P.Var name') expr : rest | name == name' ->
2020 do expr' <- exprCombineAnnotations expr
2121 let def = Definition pat expr' (Just tipe)
2222 (:) def <$> go rest
compiler/Transform/Expression.hs+15−13
@@ -2,17 +2,19 @@
22module Transform.Expression (crawlLet, checkPorts) where
33
44import Control.Applicative ((<$>),(<*>))
5+import SourceSyntax.Annotation ( Annotated(A) )
56import SourceSyntax.Expression
6−import SourceSyntax.Location
7−import qualified SourceSyntax.Type as ST
7+import SourceSyntax.Type (Type)
88
9−crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')
9+crawlLet :: ([def] -> Either a [def'])
10+ -> GeneralExpr ann def var
11+ -> Either a (GeneralExpr ann def' var)
1012crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())
1113
12−checkPorts :: (String -> ST.Type -> Either a ())
13− -> (String -> ST.Type -> Either a ())
14− -> LExpr
15− -> Either a LExpr
14+checkPorts :: (String -> Type -> Either a ())
15+ -> (String -> Type -> Either a ())
16+ -> Expr
17+ -> Either a Expr
1618checkPorts inCheck outCheck expr =
1719 crawl inCheck outCheck (mapM checkDef) expr
1820 where
@@ -20,15 +22,15 @@ checkPorts inCheck outCheck expr =
2022 do _ <- checkPorts inCheck outCheck body
2123 return def
2224
23−crawl :: (String -> ST.Type -> Either a ())
24− -> (String -> ST.Type -> Either a ())
25+crawl :: (String -> Type -> Either a ())
26+ -> (String -> Type -> Either a ())
2527 -> ([def] -> Either a [def'])
26− -> LExpr' def
27− -> Either a (LExpr' def')
28+ -> GeneralExpr ann def var
29+ -> Either a (GeneralExpr ann def' var)
2830crawl portInCheck portOutCheck defsTransform = go
2931 where
30− go (L srcSpan expr) =
31− L srcSpan <$>
32+ go (A srcSpan expr) =
33+ A srcSpan <$>
3234 case expr of
3335 Var x -> return (Var x)
3436 Lambda p e -> Lambda p <$> go e
compiler/Transform/SafeNames.hs+19−18
@@ -1,43 +1,44 @@
11{-# OPTIONS_GHC -Wall #-}
22module Transform.SafeNames (metadataModule) where
33
4−import Control.Arrow (first, (***))
5−import Data.List (intercalate)
6−
4+import Control.Arrow (first, (***))
5+import qualified Data.List as List
76import qualified Data.Set as Set
87
9−import qualified Parse.Helpers as PHelp
8+import qualified Parse.Helpers as PHelp
9+import SourceSyntax.Annotation
1010import SourceSyntax.Expression
1111import qualified SourceSyntax.Helpers as SHelp
12−import SourceSyntax.Location
1312import SourceSyntax.Module
14−import SourceSyntax.Pattern
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Variable as Variable
1515
1616var :: String -> String
17−var = intercalate "." . map (dereserve . deprime) . SHelp.splitDots
17+var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots
1818 where
1919 deprime = map (\c -> if c == '\'' then '$' else c)
2020 dereserve x = case Set.member x PHelp.jsReserveds of
2121 False -> x
2222 True -> "$" ++ x
2323
24−pattern :: Pattern -> Pattern
24+pattern :: P.Pattern -> P.Pattern
2525pattern pat =
2626 case pat of
27− PVar x -> PVar (var x)
28− PLiteral _ -> pat
29− PRecord fs -> PRecord (map var fs)
30− PAnything -> pat
31− PAlias x p -> PAlias (var x) (pattern p)
32− PData name ps -> PData name (map pattern ps)
27+ P.Var x -> P.Var (var x)
28+ P.Literal _ -> pat
29+ P.Record fs -> P.Record (map var fs)
30+ P.Anything -> pat
31+ P.Alias x p -> P.Alias (var x) (pattern p)
32+ P.Data name ps -> P.Data name (map pattern ps)
3333
34−expression :: LExpr -> LExpr
35−expression (L loc expr) =
34+-- TODO: should be "normal expression" -> "expression for JS generation"
35+expression :: Expr -> Expr
36+expression (A ann expr) =
3637 let f = expression in
37− L loc $
38+ A ann $
3839 case expr of
3940 Literal _ -> expr
40− Var x -> Var (var x)
41+ Var (Variable.Raw x) -> rawVar (var x)
4142 Range e1 e2 -> Range (f e1) (f e2)
4243 ExplicitList es -> ExplicitList (map f es)
4344 Binop op e1 e2 -> Binop op (f e1) (f e2)
compiler/Transform/SortDefinitions.hs+18−17
@@ -3,23 +3,24 @@ module Transform.SortDefinitions (sortDefs) where
33
44import Control.Monad.State
55import Control.Applicative ((<$>),(<*>))
6+import qualified Data.Graph as Graph
67import qualified Data.Map as Map
8+import qualified Data.Maybe as Maybe
9+import qualified Data.Set as Set
10+import SourceSyntax.Annotation
711import SourceSyntax.Expression
8−import SourceSyntax.Location
912import qualified SourceSyntax.Pattern as P
10−import qualified Data.Graph as Graph
11−import qualified Data.Set as Set
12−import qualified Data.Maybe as Maybe
13+import qualified SourceSyntax.Variable as V
1314
1415ctors :: P.Pattern -> [String]
1516ctors pattern =
1617 case pattern of
17− P.PVar _ -> []
18− P.PAlias _ p -> ctors p
19− P.PData ctor ps -> ctor : concatMap ctors ps
20− P.PRecord _ -> []
21− P.PAnything -> []
22− P.PLiteral _ -> []
18+ P.Var _ -> []
19+ P.Alias _ p -> ctors p
20+ P.Data ctor ps -> ctor : concatMap ctors ps
21+ P.Record _ -> []
22+ P.Anything -> []
23+ P.Literal _ -> []
2324
2425free :: String -> State (Set.Set String) ()
2526free x = modify (Set.insert x)
@@ -27,15 +28,15 @@ free x = modify (Set.insert x)
2728bound :: Set.Set String -> State (Set.Set String) ()
2829bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)
2930
30−sortDefs :: LExpr -> LExpr
31+sortDefs :: Expr -> Expr
3132sortDefs expr = evalState (reorder expr) Set.empty
3233
33−reorder :: LExpr -> State (Set.Set String) LExpr
34−reorder (L s expr) =
35− L s <$>
34+reorder :: Expr -> State (Set.Set String) Expr
35+reorder (A ann expr) =
36+ A ann <$>
3637 case expr of
3738 -- Be careful adding and restricting freeVars
38− Var x -> free x >> return expr
39+ Var (V.Raw x) -> free x >> return expr
3940
4041 Lambda p e ->
4142 uncurry Lambda <$> bindingReorder (p,e)
@@ -103,11 +104,11 @@ reorder (L s expr) =
103104 bound (P.boundVars pattern)
104105 mapM free (ctors pattern)
105106
106− let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss
107+ let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss
107108
108109 return let'
109110
110−bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)
111+bindingReorder :: (P.Pattern, Expr) -> State (Set.Set String) (P.Pattern, Expr)
111112bindingReorder (pattern,expr) =
112113 do expr' <- reorder expr
113114 bound (P.boundVars pattern)
compiler/Transform/Substitute.hs+8−6
@@ -2,14 +2,16 @@
22module Transform.Substitute (subst) where
33
44import Control.Arrow (second, (***))
5+import qualified Data.Set as Set
6+
7+import SourceSyntax.Annotation
58import SourceSyntax.Expression
6−import SourceSyntax.Location
79import qualified SourceSyntax.Pattern as Pattern
8−import qualified Data.Set as Set
10+import qualified SourceSyntax.Variable as V
911
10−subst :: String -> Expr -> Expr -> Expr
12+subst :: String -> Expr' -> Expr' -> Expr'
1113subst old new expr =
12− let f (L s e) = L s (subst old new e) in
14+ let f (A a e) = A a (subst old new e) in
1315 case expr of
1416 Range e1 e2 -> Range (f e1) (f e2)
1517 ExplicitList es -> ExplicitList (map f es)
@@ -28,7 +30,7 @@ subst old new expr =
2830 anyShadow =
2931 any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]
3032
31− Var x -> if x == old then new else expr
33+ Var (V.Raw x) -> if x == old then new else expr
3234 Case e cases -> Case (f e) $ map (second f) cases
3335 Data name es -> Data name (map f es)
3436 Access e x -> Access (f e) x
@@ -39,4 +41,4 @@ subst old new expr =
3941 Literal _ -> expr
4042 Markdown uid md es -> Markdown uid md (map f es)
4143 PortIn name st -> PortIn name st
42− PortOut name st signal -> PortOut name st (f signal)
44+ PortOut name st signal -> PortOut name st (f signal)
compiler/Type/Constrain/Declaration.hs+23−23
@@ -1,62 +1,62 @@
11{-# OPTIONS_GHC -Wall #-}
22module Type.Constrain.Declaration where
33
4−import SourceSyntax.Declaration
4+import qualified SourceSyntax.Annotation as A
5+import qualified SourceSyntax.Declaration as D
56import qualified SourceSyntax.Expression as E
6−import qualified SourceSyntax.Location as L
77import qualified SourceSyntax.Pattern as P
88import qualified SourceSyntax.Type as T
99
10−toExpr :: [Declaration] -> [E.Def]
10+toExpr :: [D.Declaration] -> [E.Def]
1111toExpr = concatMap toDefs
1212
13−toDefs :: Declaration -> [E.Def]
13+toDefs :: D.Declaration -> [E.Def]
1414toDefs decl =
1515 case decl of
16− Definition def -> [def]
16+ D.Definition def -> [def]
1717
18− Datatype name tvars constructors -> concatMap toDefs' constructors
18+ D.Datatype name tvars constructors -> concatMap toDefs' constructors
1919 where
2020 toDefs' (ctor, tipes) =
2121 let vars = take (length tipes) arguments
2222 tbody = T.Data name $ map T.Var tvars
23− body = L.none . E.Data ctor $ map (L.none . E.Var) vars
23+ body = A.none . E.Data ctor $ map (A.none . E.rawVar) vars
2424 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
2525
26− TypeAlias name _ tipe@(T.Record fields ext) ->
26+ D.TypeAlias name _ tipe@(T.Record fields ext) ->
2727 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
2828 where
2929 args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
3030
31− var = L.none . E.Var
31+ var = A.none . E.rawVar
3232 vars = take (length args) arguments
3333
3434 efields = zip (map fst fields) (map var vars)
3535 record = case ext of
36− Nothing -> L.none $ E.Record efields
37− Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields
36+ Nothing -> A.none $ E.Record efields
37+ Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields
3838
3939 -- Type aliases must be added to an extended equality dictionary,
4040 -- but they do not require any basic constraints.
41− TypeAlias _ _ _ -> []
41+ D.TypeAlias _ _ _ -> []
4242
43− Port port ->
43+ D.Port port ->
4444 case port of
45− Out name expr@(L.L s _) tipe ->
46− [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]
47− In name tipe ->
48− [ definition name (L.none $ E.PortIn name tipe) tipe ]
45+ D.Out name expr@(A.A s _) tipe ->
46+ [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]
47+ D.In name tipe ->
48+ [ definition name (A.none $ E.PortIn name tipe) tipe ]
4949
5050 -- no constraints are needed for fixity declarations
51− Fixity _ _ _ -> []
51+ D.Fixity _ _ _ -> []
5252
5353
5454arguments :: [String]
5555arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]
5656
57−buildFunction :: E.LExpr -> [String] -> E.LExpr
58−buildFunction body@(L.L s _) vars =
59− foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
57+buildFunction :: E.Expr -> [String] -> E.Expr
58+buildFunction body@(A.A s _) vars =
59+ foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars)
6060
61−definition :: String -> E.LExpr -> T.Type -> E.Def
62−definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
61+definition :: String -> E.Expr -> T.Type -> E.Def
62+definition name expr tipe = E.Definition (P.Var name) expr (Just tipe)
compiler/Type/Constrain/Expression.hs+34−33
@@ -1,38 +1,39 @@
11{-# OPTIONS_GHC -W #-}
22module Type.Constrain.Expression where
33
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−import qualified Data.Set as Set
74import Control.Applicative ((<$>))
85import qualified Control.Monad as Monad
96import Control.Monad.Error
7+import qualified Data.List as List
8+import qualified Data.Map as Map
109import qualified Text.PrettyPrint as PP
1110
12−import SourceSyntax.Location as Loc
13−import SourceSyntax.Pattern (Pattern(PVar), boundVars)
11+import SourceSyntax.Annotation as Ann
1412import SourceSyntax.Expression
15−import qualified SourceSyntax.Type as SrcT
13+import qualified SourceSyntax.Pattern as P
14+import qualified SourceSyntax.Type as ST
15+import qualified SourceSyntax.Variable as V
1616import Type.Type hiding (Descriptor(..))
1717import Type.Fragment
1818import qualified Type.Environment as Env
1919import qualified Type.Constrain.Literal as Literal
2020import qualified Type.Constrain.Pattern as Pattern
2121
22−constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
23−constrain env (L span expr) tipe =
22+constrain :: Env.Environment -> Expr -> Type -> ErrorT [PP.Doc] IO TypeConstraint
23+constrain env (A region expr) tipe =
2424 let list t = Env.get env Env.types "_List" <| t
25− and = L span . CAnd
26− true = L span CTrue
27− t1 === t2 = L span (CEqual t1 t2)
28− x <? t = L span (CInstance x t)
29− clet schemes c = L span (CLet schemes c)
25+ and = A region . CAnd
26+ true = A region CTrue
27+ t1 === t2 = A region (CEqual t1 t2)
28+ x <? t = A region (CInstance x t)
29+ clet schemes c = A region (CLet schemes c)
3030 in
3131 case expr of
32− Literal lit -> liftIO $ Literal.constrain env span lit tipe
32+ Literal lit -> liftIO $ Literal.constrain env region lit tipe
3333
34− Var name | name == saveEnvName -> return (L span CSaveEnv)
35− | otherwise -> return (name <? tipe)
34+ Var (V.Raw name)
35+ | name == saveEnvName -> return (A region CSaveEnv)
36+ | otherwise -> return (name <? tipe)
3637
3738 Range lo hi ->
3839 exists $ \x -> do
@@ -55,7 +56,7 @@ constrain env (L span expr) tipe =
5556 Lambda p e ->
5657 exists $ \t1 ->
5758 exists $ \t2 -> do
58− fragment <- try span $ Pattern.constrain env p t1
59+ fragment <- try region $ Pattern.constrain env p t1
5960 c2 <- constrain env e t2
6061 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
6162 (typeConstraint fragment /\ c2 ))
@@ -79,7 +80,7 @@ constrain env (L span expr) tipe =
7980 exists $ \t -> do
8081 ce <- constrain env exp t
8182 let branch (p,e) = do
82− fragment <- try span $ Pattern.constrain env p t
83+ fragment <- try region $ Pattern.constrain env p t
8384 clet [toScheme fragment] <$> constrain env e tipe
8485 and . (:) ce <$> mapM branch branches
8586
@@ -112,11 +113,11 @@ constrain env (L span expr) tipe =
112113 Modify e fields ->
113114 exists $ \t -> do
114115 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
115− let oldFields = SrcT.fieldMap (zip (map fst fields) (map VarN oldVars))
116+ let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
116117 cOld <- ex oldVars <$> constrain env e (record oldFields t)
117118
118119 newVars <- forM fields $ \_ -> liftIO (var Flexible)
119− let newFields = SrcT.fieldMap (zip (map fst fields) (map VarN newVars))
120+ let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
120121 let cNew = tipe === record newFields t
121122
122123 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
@@ -126,7 +127,7 @@ constrain env (L span expr) tipe =
126127 Record fields ->
127128 do vars <- forM fields $ \_ -> liftIO (var Flexible)
128129 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
129− let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
130+ let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
130131 recordType = record fields' (TermN EmptyRecord1)
131132 return . ex vars . and $ tipe === recordType : cs
132133
@@ -158,14 +159,14 @@ constrainDef env info (Definition pattern expr maybeTipe) =
158159 do rigidVars <- forM qs (\_ -> liftIO $ var Rigid) -- Some mistake may be happening here.
159160 -- Currently, qs is always [].
160161 case (pattern, maybeTipe) of
161− (PVar name, Just tipe) -> do
162+ (P.Var name, Just tipe) -> do
162163 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
163164 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
164165 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
165166 (vars, typ) <- Env.instantiateType env tipe Map.empty
166167 let scheme = Scheme { rigidQuantifiers = [],
167168 flexibleQuantifiers = flexiVars ++ vars,
168− constraint = Loc.noneNoDocs CTrue,
169+ constraint = Ann.noneNoDocs CTrue,
169170 header = Map.singleton name typ }
170171 c <- constrain env' expr typ
171172 return ( scheme : schemes
@@ -175,7 +176,7 @@ constrainDef env info (Definition pattern expr maybeTipe) =
175176 , c2
176177 , fl rigidVars c /\ c1 )
177178
178− (PVar name, Nothing) -> do
179+ (P.Var name, Nothing) -> do
179180 v <- liftIO $ var Flexible
180181 let tipe = VarN v
181182 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
@@ -191,19 +192,19 @@ constrainDef env info (Definition pattern expr maybeTipe) =
191192 _ -> error (show pattern)
192193
193194expandPattern :: Def -> [Def]
194−expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =
195+expandPattern def@(Definition pattern lexpr@(A r _) maybeType) =
195196 case pattern of
196− PVar _ -> [def]
197− _ -> Definition (PVar x) lexpr maybeType : map toDef vars
197+ P.Var _ -> [def]
198+ _ -> Definition (P.Var x) lexpr maybeType : map toDef vars
198199 where
199− vars = Set.toList $ boundVars pattern
200+ vars = P.boundVarList pattern
200201 x = "$" ++ concat vars
201− mkVar = L s . Var
202− toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
202+ mkVar = A r . rawVar
203+ toDef y = Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing
203204
204−try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
205−try span computation = do
205+try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a
206+try region computation = do
206207 result <- liftIO $ runErrorT computation
207208 case result of
208− Left err -> throwError [err span]
209+ Left err -> throwError [err region]
209210 Right value -> return value
compiler/Type/Constrain/Literal.hs+5−4
@@ -1,14 +1,15 @@
1+{-# OPTIONS_GHC -W #-}
12module Type.Constrain.Literal where
23
4+import SourceSyntax.Annotation
35import SourceSyntax.Literal
4−import SourceSyntax.Location
56import Type.Type
67import Type.Environment as Env
78
8−constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
9−constrain env span literal tipe =
9+constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint
10+constrain env region literal tipe =
1011 do tipe' <- litType
11− return . L span $ CEqual tipe tipe'
12+ return . A region $ CEqual tipe tipe'
1213 where
1314 prim name = return (Env.get env Env.types name)
1415
compiler/Type/Constrain/Pattern.hs+17−18
@@ -1,3 +1,4 @@
1+{-# OPTIONS_GHC -W #-}
12{-# LANGUAGE FlexibleInstances #-}
23module Type.Constrain.Pattern where
34
@@ -8,31 +9,29 @@ import Control.Monad.Error
89import qualified Data.Map as Map
910import qualified Text.PrettyPrint as PP
1011
11−import SourceSyntax.Pattern
12−import SourceSyntax.Location
13−import SourceSyntax.PrettyPrint
14−import Text.PrettyPrint (render)
15−import qualified SourceSyntax.Location as Loc
12+import qualified SourceSyntax.Annotation as A
13+import qualified SourceSyntax.Pattern as P
14+import SourceSyntax.PrettyPrint (pretty)
1615import Type.Type
1716import Type.Fragment
1817import Type.Environment as Env
1918import qualified Type.Constrain.Literal as Literal
2019
2120
22−constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
21+constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
2322constrain env pattern tipe =
24− let span = Loc.NoSpan (render $ pretty pattern)
25− t1 === t2 = Loc.L span (CEqual t1 t2)
26− x <? t = Loc.L span (CInstance x t)
23+ let region = A.None (pretty pattern)
24+ t1 === t2 = A.A region (CEqual t1 t2)
25+ x <? t = A.A region (CInstance x t)
2726 in
2827 case pattern of
29− PAnything -> return emptyFragment
28+ P.Anything -> return emptyFragment
3029
31− PLiteral lit -> do
32− c <- liftIO $ Literal.constrain env span lit tipe
30+ P.Literal lit -> do
31+ c <- liftIO $ Literal.constrain env region lit tipe
3332 return $ emptyFragment { typeConstraint = c }
3433
35− PVar name -> do
34+ P.Var name -> do
3635 v <- liftIO $ var Flexible
3736 return $ Fragment {
3837 typeEnv = Map.singleton name (VarN v),
@@ -40,14 +39,14 @@ constrain env pattern tipe =
4039 typeConstraint = VarN v === tipe
4140 }
4241
43− PAlias name p -> do
42+ P.Alias name p -> do
4443 fragment <- constrain env p tipe
4544 return $ fragment {
4645 typeEnv = Map.insert name tipe (typeEnv fragment),
4746 typeConstraint = name <? tipe /\ typeConstraint fragment
4847 }
4948
50− PData name patterns -> do
49+ P.Data name patterns -> do
5150 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
5251 let msg = concat [ "Constructor '", name, "' expects ", show kind
5352 , " argument", if kind == 1 then "" else "s"
@@ -63,7 +62,7 @@ constrain env pattern tipe =
6362 vars = cvars ++ vars fragment
6463 }
6564
66− PRecord fields -> do
65+ P.Record fields -> do
6766 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
6867 let tenv = Map.fromList (map (second VarN) pairs)
6968 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
@@ -73,8 +72,8 @@ constrain env pattern tipe =
7372 typeConstraint = c
7473 }
7574
76−instance Error (SrcSpan -> PP.Doc) where
75+instance Error (A.Region -> PP.Doc) where
7776 noMsg _ = PP.empty
7877 strMsg str span =
7978 PP.vcat [ PP.text $ "Type error " ++ show span
80− , PP.text str ]
79+ , PP.text str ]
compiler/Type/ExtraChecks.hs+39−36
@@ -1,32 +1,35 @@
11{-# OPTIONS_GHC -W #-}
2+
3+{-| This module contains checks to be run *after* type inference has completed
4+successfully. At that point we still need to do occurs checks and ensure that
5+`main` has an acceptable type.
6+-}
27module Type.ExtraChecks (mainType, occurs, portTypes) where
3−-- This module contains checks to be run *after* type inference has
4−-- completed successfully. At that point we still need to do occurs
5−-- checks and ensure that `main` has an acceptable type.
68
79import Control.Applicative ((<$>),(<*>))
810import Control.Monad.State
911import qualified Data.List as List
1012import qualified Data.Map as Map
13+import qualified Data.Traversable as Traverse
1114import qualified Data.UnionFind.IO as UF
12−import Type.Type ( Variable, structure, Term1(..), toSrcType )
13−import qualified Type.State as TS
14−import qualified Type.Alias as Alias
1515import Text.PrettyPrint as P
16−import SourceSyntax.PrettyPrint (pretty)
17−import qualified SourceSyntax.Helpers as Help
18−import qualified SourceSyntax.Type as T
16+
17+import qualified SourceSyntax.Annotation as A
1918import qualified SourceSyntax.Expression as E
20−import qualified SourceSyntax.Location as L
19+import qualified SourceSyntax.Helpers as Help
20+import qualified SourceSyntax.PrettyPrint as SPP
21+import qualified SourceSyntax.Type as ST
2122import qualified Transform.Expression as Expr
22−import qualified Data.Traversable as Traverse
23+import qualified Type.Type as TT
24+import qualified Type.State as TS
25+import qualified Type.Alias as Alias
2326
2427throw err = Left [ P.vcat err ]
2528
26−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27−mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
29+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.Type))
30+mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
2831 where
29− mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
32+ mainCheck :: Alias.Rules -> Map.Map String ST.Type -> Either [P.Doc] (Map.Map String ST.Type)
3033 mainCheck rules env =
3134 case Map.lookup "main" env of
3235 Nothing -> Right env
@@ -37,40 +40,40 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
3740 acceptable = [ "Graphics.Element.Element"
3841 , "Signal.Signal Graphics.Element.Element" ]
3942
40− tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
43+ tipe = SPP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
4144 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
4245 , P.text "Instead 'main' has type:\n"
43− , P.nest 4 . pretty $ Alias.realias rules mainType
46+ , P.nest 4 . SPP.pretty $ Alias.realias rules mainType
4447 , P.text " " ]
4548
4649data Direction = In | Out
4750
48−portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
51+portTypes :: Alias.Rules -> E.Expr -> Either [P.Doc] ()
4952portTypes rules expr =
5053 const () <$> Expr.checkPorts (check In) (check Out) expr
5154 where
5255 check = isValid True False False
5356 isValid isTopLevel seenFunc seenSignal direction name tipe =
5457 case tipe of
55− T.Data ctor ts
58+ ST.Data ctor ts
5659 | isJs ctor || isElm ctor -> mapM_ valid ts
5760 | ctor == "Signal.Signal" -> handleSignal ts
5861 | otherwise -> err' True "an unsupported type"
5962
60− T.Var _ -> err "free type variables"
63+ ST.Var _ -> err "free type variables"
6164
62− T.Lambda _ _ ->
65+ ST.Lambda _ _ ->
6366 case direction of
6467 In -> err "functions"
6568 Out | seenFunc -> err "higher-order functions"
6669 | seenSignal -> err "signals that contain functions"
6770 | otherwise ->
68− forM_ (T.collectLambdas tipe)
71+ forM_ (ST.collectLambdas tipe)
6972 (isValid' True seenSignal direction name)
7073
71− T.Record _ (Just _) -> err "extended records with free type variables"
74+ ST.Record _ (Just _) -> err "extended records with free type variables"
7275
73− T.Record fields Nothing ->
76+ ST.Record fields Nothing ->
7477 mapM_ (\(k,v) -> (,) k <$> valid v) fields
7578
7679 where
@@ -100,7 +103,7 @@ portTypes rules expr =
100103 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
101104 , " through port '", name, "' is invalid." ]
102105 , txt [ "It contains ", kind, ":\n" ]
103− , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
106+ , (P.nest 4 . SPP.pretty $ Alias.realias rules tipe) <> P.text "\n"
104107 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
105108 , " ports include JavaScript values and" ]
106109 , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]
@@ -112,37 +115,37 @@ portTypes rules expr =
112115 , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]
113116 ]
114117
115−occurs :: (String, Variable) -> StateT TS.SolverState IO ()
118+occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
116119occurs (name, variable) =
117120 do vars <- liftIO $ infiniteVars [] variable
118121 case vars of
119122 [] -> return ()
120123 var:_ -> do
121124 desc <- liftIO $ UF.descriptor var
122− case structure desc of
125+ case TT.structure desc of
123126 Nothing ->
124127 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
125128 Just _ ->
126− do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
129+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
127130 var' <- liftIO $ UF.fresh desc
128− TS.addError (L.NoSpan name) (Just msg) var var'
131+ TS.addError (A.None (P.text name)) (Just msg) var var'
129132 where
130133 msg = "Infinite types are not allowed"
131134 fallback _ = return $ P.text msg
132135
133− infiniteVars :: [Variable] -> Variable -> IO [Variable]
134− infiniteVars seen var =
136+ infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
137+ infiniteVars seen var =
135138 let go = infiniteVars (var:seen) in
136139 if var `elem` seen
137140 then return [var]
138141 else do
139142 desc <- UF.descriptor var
140− case structure desc of
143+ case TT.structure desc of
141144 Nothing -> return []
142145 Just struct ->
143146 case struct of
144− App1 a b -> (++) <$> go a <*> go b
145− Fun1 a b -> (++) <$> go a <*> go b
146− Var1 a -> go a
147− EmptyRecord1 -> return []
148− Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
147+ TT.App1 a b -> (++) <$> go a <*> go b
148+ TT.Fun1 a b -> (++) <$> go a <*> go b
149+ TT.Var1 a -> go a
150+ TT.EmptyRecord1 -> return []
151+ TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))
compiler/Type/Fragment.hs+12−13
@@ -5,24 +5,23 @@ import qualified Data.Map as Map
55
66import Type.Type
77import SourceSyntax.Pattern
8−import SourceSyntax.Location (noneNoDocs)
8+import SourceSyntax.Annotation (noneNoDocs)
99
10−data Fragment = Fragment {
11− typeEnv :: Map.Map String Type,
12− vars :: [Variable],
13− typeConstraint :: TypeConstraint
14−} deriving Show
10+data Fragment = Fragment
11+ { typeEnv :: Map.Map String Type
12+ , vars :: [Variable]
13+ , typeConstraint :: TypeConstraint
14+ } deriving Show
1515
1616emptyFragment = Fragment Map.empty [] (noneNoDocs CTrue)
1717
18−joinFragment f1 f2 = Fragment {
19− typeEnv = Map.union (typeEnv f1) (typeEnv f2),
20− vars = vars f1 ++ vars f2,
21− typeConstraint = typeConstraint f1 /\ typeConstraint f2
22−}
18+joinFragment f1 f2 = Fragment
19+ { typeEnv = Map.union (typeEnv f1) (typeEnv f2)
20+ , vars = vars f1 ++ vars f2
21+ , typeConstraint = typeConstraint f1 /\ typeConstraint f2
22+ }
2323
2424joinFragments = List.foldl' (flip joinFragment) emptyFragment
2525
26−
2726toScheme fragment =
28− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
27+ Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)
compiler/Type/Inference.hs+1−1
@@ -9,7 +9,7 @@ import qualified Type.Constrain.Expression as TcExpr
99import qualified Type.Solve as Solve
1010
1111import SourceSyntax.Module as Module
12−import SourceSyntax.Location (noneNoDocs)
12+import SourceSyntax.Annotation (noneNoDocs)
1313import SourceSyntax.Type (Type)
1414import Text.PrettyPrint
1515import qualified Type.State as TS
compiler/Type/Solve.hs+19−19
@@ -3,15 +3,15 @@ module Type.Solve (solve) where
33
44import Control.Monad
55import Control.Monad.State
6−import qualified Data.UnionFind.IO as UF
6+import qualified Data.List as List
77import qualified Data.Map as Map
88import qualified Data.Traversable as Traversable
9−import qualified Data.List as List
9+import qualified Data.UnionFind.IO as UF
1010import Type.Type
1111import Type.Unify
1212import qualified Type.ExtraChecks as Check
1313import qualified Type.State as TS
14−import SourceSyntax.Location (Located(L), SrcSpan)
14+import qualified SourceSyntax.Annotation as A
1515
1616
1717-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -96,7 +96,7 @@ adjustRank youngMark visitedMark groupRank variable =
9696
9797
9898solve :: TypeConstraint -> StateT TS.SolverState IO ()
99−solve (L span constraint) =
99+solve (A.A region constraint) =
100100 case constraint of
101101 CTrue -> return ()
102102
@@ -105,11 +105,11 @@ solve (L span constraint) =
105105 CEqual term1 term2 -> do
106106 t1 <- TS.flatten term1
107107 t2 <- TS.flatten term2
108− unify span t1 t2
108+ unify region t1 t2
109109
110110 CAnd cs -> mapM_ solve cs
111111
112− CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
112+ CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do
113113 oldEnv <- TS.getEnv
114114 mapM TS.introduce fqs
115115 solve constraint'
@@ -117,7 +117,7 @@ solve (L span constraint) =
117117
118118 CLet schemes constraint' -> do
119119 oldEnv <- TS.getEnv
120− headers <- Map.unions `fmap` mapM (solveScheme span) schemes
120+ headers <- Map.unions `fmap` mapM (solveScheme region) schemes
121121 TS.modifyEnv $ \env -> Map.union headers env
122122 solve constraint'
123123 mapM Check.occurs $ Map.toList headers
@@ -134,10 +134,10 @@ solve (L span constraint) =
134134 error ("Could not find '" ++ name ++ "' when solving type constraints.")
135135
136136 t <- TS.flatten term
137− unify span freshCopy t
137+ unify region freshCopy t
138138
139−solveScheme :: SrcSpan -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140−solveScheme span scheme =
139+solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
140+solveScheme region scheme =
141141 case scheme of
142142 Scheme [] [] constraint header -> do
143143 solve constraint
@@ -154,39 +154,39 @@ solveScheme span scheme =
154154 header' <- Traversable.traverse TS.flatten header
155155 solve constraint
156156
157− allDistinct span rigidQuantifiers
157+ allDistinct region rigidQuantifiers
158158 youngPool <- TS.getPool
159159 TS.switchToPool oldPool
160160 generalize youngPool
161− mapM (isGeneric span) rigidQuantifiers
161+ mapM (isGeneric region) rigidQuantifiers
162162 return header'
163163
164164
165165-- Checks that all of the given variables belong to distinct equivalence classes.
166166-- Also checks that their structure is Nothing, so they represent a variable, not
167167-- a more complex term.
168−allDistinct :: SrcSpan -> [Variable] -> StateT TS.SolverState IO ()
169−allDistinct span vars = do
168+allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO ()
169+allDistinct region vars = do
170170 seen <- TS.uniqueMark
171171 let check var = do
172172 desc <- liftIO $ UF.descriptor var
173173 case structure desc of
174− Just _ -> TS.addError span (Just msg) var var
174+ Just _ -> TS.addError region (Just msg) var var
175175 where msg = "Cannot generalize something that is not a type variable."
176176
177177 Nothing -> do
178178 if mark desc == seen
179179 then let msg = "Duplicate variable during generalization."
180− in TS.addError span (Just msg) var var
180+ in TS.addError region (Just msg) var var
181181 else return ()
182182 liftIO $ UF.setDescriptor var (desc { mark = seen })
183183 mapM_ check vars
184184
185185-- Check that a variable has rank == noRank, meaning that it can be generalized.
186−isGeneric :: SrcSpan -> Variable -> StateT TS.SolverState IO ()
187−isGeneric span var = do
186+isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO ()
187+isGeneric region var = do
188188 desc <- liftIO $ UF.descriptor var
189189 if rank desc == noRank
190190 then return ()
191191 else let msg = "Unable to generalize a type variable. It is not unranked."
192− in TS.addError span (Just msg) var var
192+ in TS.addError region (Just msg) var var
compiler/Type/State.hs+12−20
@@ -1,16 +1,17 @@
11{-# OPTIONS_GHC -W #-}
22module Type.State where
33
4−import Type.Type
5−import qualified Data.Map as Map
6−import qualified Data.UnionFind.IO as UF
7−import Control.Monad.State
84import Control.Applicative ((<$>),(<*>), Applicative)
5+import Control.Monad.State
6+import qualified Data.Map as Map
97import qualified Data.Traversable as Traversable
10−import Text.PrettyPrint as P
8+import qualified Data.UnionFind.IO as UF
9+
10+import qualified SourceSyntax.Annotation as A
1111import SourceSyntax.PrettyPrint
12−import SourceSyntax.Location
12+import Text.PrettyPrint as P
1313import qualified Type.Alias as Alias
14+import Type.Type
1415
1516-- Pool
1617-- Holds a bunch of variables
@@ -46,7 +47,7 @@ initialState = SS {
4647modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
4748modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
4849
49−addError span hint t1 t2 =
50+addError region hint t1 t2 =
5051 modify $ \state -> state { sErrors = makeError : sErrors state }
5152 where
5253 makeError rules = do
@@ -54,24 +55,15 @@ addError span hint t1 t2 =
5455 t1' <- prettiest <$> toSrcType t1
5556 t2' <- prettiest <$> toSrcType t2
5657 return . P.vcat $
57− [ P.text $ "Type error" ++ location ++ ":"
58+ [ P.text "Type error" <+> pretty region <> P.colon
5859 , maybe P.empty P.text hint
59− , display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
60+ , P.text ""
61+ , P.nest 8 $ A.getRegionDocs region
62+ , P.text ""
6063 , P.text " Expected Type:" <+> t1'
6164 , P.text " Actual Type:" <+> t2'
6265 ]
6366
64− location = case span of
65− NoSpan _ -> ""
66− Span p1 p2 _ ->
67− if line p1 == line p2 then " on line " ++ show (line p1)
68− else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
69−
70− display msg =
71− P.vcat [ P.text $ concatMap ("\n "++) (lines msg)
72− , P.text " " ]
73−
74−
7567switchToPool pool = modifyPool (\_ -> pool)
7668
7769getPool :: StateT SolverState IO Pool
compiler/Type/Type.hs+14−12
@@ -11,7 +11,7 @@ import Control.Applicative ((<$>),(<*>))
1111import Control.Monad.State
1212import Control.Monad.Error
1313import Data.Traversable (traverse)
14−import SourceSyntax.Location
14+import SourceSyntax.Annotation
1515import SourceSyntax.Helpers (isTuple)
1616import qualified SourceSyntax.Type as Src
1717
@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers
6262infixl 8 /\
6363
6464(/\) :: Constraint a b -> Constraint a b -> Constraint a b
65−a@(L _ c1) /\ b@(L _ c2) =
65+a@(A _ c1) /\ b@(A _ c2) =
6666 case (c1, c2) of
6767 (CTrue, _) -> b
6868 (_, CTrue) -> a
@@ -128,11 +128,13 @@ structuredVar structure = UF.fresh $ Descriptor {
128128
129129-- ex qs constraint == exists qs. constraint
130130ex :: [Variable] -> TypeConstraint -> TypeConstraint
131−ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
131+ex fqs constraint@(A ann _) =
132+ A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue)
132133
133134-- fl qs constraint == forall qs. constraint
134135fl :: [Variable] -> TypeConstraint -> TypeConstraint
135−fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
136+fl rqs constraint@(A ann _) =
137+ A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue)
136138
137139exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
138140exists f = do
@@ -148,8 +150,8 @@ instance PrettyType a => PrettyType (UF.Point a) where
148150 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
149151
150152
151−instance PrettyType a => PrettyType (Located a) where
152− pretty when (L _ e) = pretty when e
153+instance PrettyType t => PrettyType (Annotated a t) where
154+ pretty when (A _ e) = pretty when e
153155
154156
155157instance PrettyType a => PrettyType (Term1 a) where
@@ -212,12 +214,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
212214 CAnd cs ->
213215 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
214216
215− CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
217+ CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header ->
216218 P.sep [ binder, pretty Never c ]
217219 where
218− mergeExists vs (L _ c) =
220+ mergeExists vs (A _ c) =
219221 case c of
220− CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
222+ CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c'
221223 _ -> (vs, c)
222224
223225 (fqs', c) = mergeExists fqs constraint
@@ -233,7 +235,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
233235 P.text name <+> P.text "<" <+> prty tipe
234236
235237instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
236− pretty _ (Scheme rqs fqs (L _ constraint) headers) =
238+ pretty _ (Scheme rqs fqs (A _ constraint) headers) =
237239 P.sep [ forall, cs, headers' ]
238240 where
239241 prty = pretty Never
@@ -297,8 +299,8 @@ class Crawl t where
297299 -> t
298300 -> StateT CrawlState IO t
299301
300−instance Crawl a => Crawl (Located a) where
301− crawl nextState (L s e) = L s <$> crawl nextState e
302+instance Crawl e => Crawl (Annotated a e) where
303+ crawl nextState (A ann e) = A ann <$> crawl nextState e
302304
303305instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
304306 crawl nextState constraint =
compiler/Type/Unify.hs+15−15
@@ -1,27 +1,27 @@
11{-# OPTIONS_GHC -W #-}
22module Type.Unify (unify) where
33
4−import Type.Type
5−import qualified Data.UnionFind.IO as UF
4+import Control.Monad.State
65import qualified Data.Map as Map
76import qualified Data.Maybe as Maybe
7+import qualified Data.UnionFind.IO as UF
8+import qualified SourceSyntax.Annotation as A
89import qualified Type.State as TS
9−import Control.Monad.State
10−import SourceSyntax.Location
10+import Type.Type
1111import Type.PrettyPrint
1212import Text.PrettyPrint (render)
1313
14−unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
15−unify span variable1 variable2 = do
14+unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
15+unify region variable1 variable2 = do
1616 equivalent <- liftIO $ UF.equivalent variable1 variable2
1717 if equivalent then return ()
18− else actuallyUnify span variable1 variable2
18+ else actuallyUnify region variable1 variable2
1919
20−actuallyUnify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()
21−actuallyUnify span variable1 variable2 = do
20+actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()
21+actuallyUnify region variable1 variable2 = do
2222 desc1 <- liftIO $ UF.descriptor variable1
2323 desc2 <- liftIO $ UF.descriptor variable2
24− let unify' = unify span
24+ let unify' = unify region
2525
2626 name' :: Maybe String
2727 name' = case (name desc1, name desc2) of
@@ -79,11 +79,11 @@ actuallyUnify span variable1 variable2 = do
7979
8080 unifyNumber svar name
8181 | name `elem` ["Int","Float","number"] = flexAndUnify svar
82− | otherwise = TS.addError span (Just hint) variable1 variable2
82+ | otherwise = TS.addError region (Just hint) variable1 variable2
8383 where hint = "A number must be an Int or Float."
8484
8585 comparableError maybe =
86− TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
86+ TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
8787 where msg = "A comparable must be an Int, Float, Char, String, list, or tuple."
8888
8989 unifyComparable var name
@@ -110,7 +110,7 @@ actuallyUnify span variable1 variable2 = do
110110 List _ -> flexAndUnify varSuper
111111 _ -> comparableError Nothing
112112
113− rigidError variable = TS.addError span (Just hint) variable1 variable2
113+ rigidError variable = TS.addError region (Just hint) variable1 variable2
114114 where
115115 var = "'" ++ render (pretty Never variable) ++ "'"
116116 hint = "Cannot unify rigid type variable " ++ var ++
@@ -141,7 +141,7 @@ actuallyUnify span variable1 variable2 = do
141141
142142 (Rigid, _, _, _) -> rigidError variable1
143143 (_, Rigid, _, _) -> rigidError variable2
144− _ -> TS.addError span Nothing variable1 variable2
144+ _ -> TS.addError region Nothing variable1 variable2
145145
146146 case (structure desc1, structure desc2) of
147147 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@@ -196,5 +196,5 @@ actuallyUnify span variable1 variable2 = do
196196 eat (_:xs) (_:ys) = eat xs ys
197197 eat xs _ = xs
198198
199− _ -> TS.addError span Nothing variable1 variable2
199+ _ -> TS.addError region Nothing variable1 variable2
200200