git.iko.soy/elk
on master help sign in
Switch name of Context to Located. Whoo static types :)
6b28feaevancz
Elm.cabal+3−3
compare with master
unifiedsplit
@@ -34,7 +34,7 @@ Library
34 Language.Elm.Quasi
34 Language.Elm.Quasi
35 Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform
35 Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform
36 other-modules: Ast,
36 other-modules: Ast,
37− Context,
37+ Located,
38 CompileToJS,
38 CompileToJS,
39 Cases,
39 Cases,
40 Substitute,
40 Substitute,
@@ -88,7 +88,7 @@ Executable elm
88 extensions: CPP
88 extensions: CPP
89 cpp-options: -DELM_COMPILEDATADIR="dist/data"
89 cpp-options: -DELM_COMPILEDATADIR="dist/data"
90 other-modules: Ast,
90 other-modules: Ast,
91− Context,
91+ Located,
92 CompileToJS,
92 CompileToJS,
93 Cases,
93 Cases,
94 Substitute,
94 Substitute,
@@ -138,7 +138,7 @@ Executable elm-doc
138 Main-is: Docs.hs
138 Main-is: Docs.hs
139 Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform
139 Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform
140 other-modules: Ast,
140 other-modules: Ast,
141− Context,
141+ Located,
142 Parse.Library,
142 Parse.Library,
143 Parse.Modules,
143 Parse.Modules,
144 Rename
144 Rename
compiler/Gen/Cases.hs+7−7
@@ -7,7 +7,7 @@ import Data.List (groupBy,sortBy,lookup)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
8
8
9import Ast
9import Ast
10−import Context
10+import Located
11import Guid
11import Guid
12import Substitute
12import Substitute
13
13
@@ -32,8 +32,8 @@ matchSubst :: [(String,String)] -> Match -> Match
32matchSubst _ Break = Break
32matchSubst _ Break = Break
33matchSubst _ Fail = Fail
33matchSubst _ Fail = Fail
34matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
34matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)
35−matchSubst pairs (Other (C t s e)) =
35+matchSubst pairs (Other (L t s e)) =
36− Other . C t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
36+ Other . L t s $ foldr ($) e $ map (\(x,y) -> subst x (Var y)) pairs
37matchSubst pairs (Match n cs m) =
37matchSubst pairs (Match n cs m) =
38 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
38 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)
39 where varSubst v = fromMaybe v (lookup v pairs)
39 where varSubst v = fromMaybe v (lookup v pairs)
@@ -58,13 +58,13 @@ match vs cs def
58matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
58matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
59matchVar (v:vs) cs def = match vs (map subVar cs) def
59matchVar (v:vs) cs def = match vs (map subVar cs) def
60 where
60 where
61− subVar (p:ps, ce@(C t s e)) =
61+ subVar (p:ps, ce@(L t s e)) =
62− let ctx = C t s in
62+ let loc = L t s in
63 (ps, case p of
63 (ps, case p of
64− PVar x -> C t s $ subst x (Var v) e
64+ PVar x -> L t s $ subst x (Var v) e
65 PAnything -> ce
65 PAnything -> ce
66 PRecord fs ->
66 PRecord fs ->
67− ctx $ foldr (\x -> subst x (Access (ctx (Var v)) x)) e fs
67+ loc $ foldr (\x -> subst x (Access (loc (Var v)) x)) e fs
68 )
68 )
69
69
70matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
70matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
compiler/Gen/CompileToJS.hs+9−9
@@ -9,7 +9,7 @@ import Data.Either (partitionEithers)
9import qualified Text.Pandoc as Pan
9import qualified Text.Pandoc as Pan
10
10
11import Ast
11import Ast
12−import Context
12+import Located
13import Rename (derename)
13import Rename (derename)
14import Cases
14import Cases
15import Guid
15import Guid
@@ -156,8 +156,8 @@ instance ToJS Statement where
156 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
156 Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
157 where toDef (name,args) =
157 where toDef (name,args) =
158 let vars = map (('a':) . show) [1..length args] in
158 let vars = map (('a':) . show) [1..length args] in
159− Definition . FnDef name vars . noContext $
159+ Definition . FnDef name vars . notLocated $
160− Data (derename name) (map (noContext . Var) vars)
160+ Data (derename name) (map (notLocated . Var) vars)
161 ImportEvent js base elm _ ->
161 ImportEvent js base elm _ ->
162 do v <- toJS' base
162 do v <- toJS' base
163 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
163 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
@@ -174,7 +174,7 @@ instance ToJS Statement where
174 TypeAlias n _ t -> return ""
174 TypeAlias n _ t -> return ""
175
175
176toJS' :: CExpr -> GuidCounter String
176toJS' :: CExpr -> GuidCounter String
177−toJS' (C txt span expr) =
177+toJS' (L txt span expr) =
178 case expr of
178 case expr of
179 MultiIf ps -> multiIfToJS span ps
179 MultiIf ps -> multiIfToJS span ps
180 Case e cases -> caseToJS span e cases
180 Case e cases -> caseToJS span e cases
@@ -189,8 +189,8 @@ makeRecord kvs = record `liftM` collect kvs
189 where
189 where
190 combine r (k,v) = Map.insertWith (++) k v r
190 combine r (k,v) = Map.insertWith (++) k v r
191 collect = liftM (foldl' combine Map.empty) . mapM prep
191 collect = liftM (foldl' combine Map.empty) . mapM prep
192− prep (k, as, e@(C t s _)) =
192+ prep (k, as, e@(L t s _)) =
193− do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
193+ do v <- toJS' (foldr (\x e -> L t s $ Lambda x e) e as)
194 return (k,[v])
194 return (k,[v])
195 fields fs =
195 fields fs =
196 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
196 brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
@@ -246,7 +246,7 @@ jsApp e1 e2 =
246 (func, args) = go [e2] e1
246 (func, args) = go [e2] e1
247 go args e =
247 go args e =
248 case e of
248 case e of
249− (C _ _ (App e1 e2)) -> go (e2 : args) e1
249+ (L _ _ (App e1 e2)) -> go (e2 : args) e1
250 _ -> (e, args)
250 _ -> (e, args)
251
251
252formatMarkdown = concatMap f
252formatMarkdown = concatMap f
@@ -257,7 +257,7 @@ formatMarkdown = concatMap f
257
257
258multiIfToJS span ps =
258multiIfToJS span ps =
259 case last ps of
259 case last ps of
260− (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
260+ (L _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
261 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
261 _ -> format ("_E.If" ++ parens (quoted (show span))) ps
262 where
262 where
263 format base ps =
263 format base ps =
@@ -280,7 +280,7 @@ caseToJS span e ps = do
280 match <- caseToMatch ps
280 match <- caseToMatch ps
281 e' <- toJS' e
281 e' <- toJS' e
282 let (match',stmt) = case (match,e) of
282 let (match',stmt) = case (match,e) of
283− (Match name _ _, C _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
283+ (Match name _ _, L _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
284 (Match name _ _, _) -> (match, assign name e')
284 (Match name _ _, _) -> (match, assign name e')
285 _ -> (match, "")
285 _ -> (match, "")
286 matches <- matchToJS span match'
286 matches <- matchToJS span match'
compiler/Gen/ExtractNoscript.hs+9−10
@@ -1,8 +1,7 @@
1−
2module ExtractNoscript (extractNoscript) where
1module ExtractNoscript (extractNoscript) where
3
2
4import Ast
3import Ast
5−import Context
4+import Located
6import qualified Text.Pandoc as Pan
5import qualified Text.Pandoc as Pan
7
6
8extractNoscript :: Module -> String
7extractNoscript :: Module -> String
@@ -23,8 +22,8 @@ instance Extract Def where
23 extract (FnDef _ _ e) = extract e
22 extract (FnDef _ _ e) = extract e
24 extract (OpDef _ _ _ e) = extract e
23 extract (OpDef _ _ _ e) = extract e
25
24
26−instance Extract e => Extract (Context e) where
25+instance Extract e => Extract (Located e) where
27− extract (C _ _ e) = extract e
26+ extract (L _ _ e) = extract e
28
27
29instance Extract Expr where
28instance Extract Expr where
30 extract expr =
29 extract expr =
@@ -35,12 +34,12 @@ instance Extract Expr where
35 ("++", [s1], [s2]) -> [s1 ++ s2]
34 ("++", [s1], [s2]) -> [s1 ++ s2]
36 (_ , ss1 , ss2 ) -> ss1 ++ ss2
35 (_ , ss1 , ss2 ) -> ss1 ++ ss2
37 Lambda v e -> f e
36 Lambda v e -> f e
38− App (C _ _ (App (C _ _ (Var "link")) src)) txt -> linkExtract src txt
37+ App (L _ _ (App (L _ _ (Var "link")) src)) txt -> linkExtract src txt
39− App (C _ _ (App (C _ _ (Var "Text.link")) src)) txt -> linkExtract src txt
38+ App (L _ _ (App (L _ _ (Var "Text.link")) src)) txt -> linkExtract src txt
40− App (C _ _ (Var "header")) e -> tag "h1" e
39+ App (L _ _ (Var "header")) e -> tag "h1" e
41− App (C _ _ (Var "bold")) e -> tag "b" e
40+ App (L _ _ (Var "bold")) e -> tag "b" e
42− App (C _ _ (Var "italic")) e -> tag "i" e
41+ App (L _ _ (Var "italic")) e -> tag "i" e
43− App (C _ _ (Var "monospace")) e -> tag "code" e
42+ App (L _ _ (Var "monospace")) e -> tag "code" e
44 App e1 e2 -> f e1 ++ f e2
43 App e1 e2 -> f e1 ++ f e2
45 If eb et ef -> f et ++ f ef
44 If eb et ef -> f et ++ f ef
46 Let defs e -> concatMap extract defs ++ f e
45 Let defs e -> concatMap extract defs ++ f e
compiler/Model/Ast.hs+10−10
@@ -1,7 +1,7 @@
1
1
2module Ast where
2module Ast where
3
3
4−import Context
4+import Located
5import Data.Char (isDigit, isSymbol)
5import Data.Char (isDigit, isSymbol)
6import Data.List (intercalate)
6import Data.List (intercalate)
7import Types.Types
7import Types.Types
@@ -22,7 +22,7 @@ data Pattern = PData String [Pattern]
22 | PAnything
22 | PAnything
23 deriving (Eq)
23 deriving (Eq)
24
24
25−type CExpr = Context Expr
25+type CExpr = Located Expr
26data Expr = IntNum Int
26data Expr = IntNum Int
27 | FloatNum Float
27 | FloatNum Float
28 | Chr Char
28 | Chr Char
@@ -59,11 +59,11 @@ data Statement = Definition Def
59 deriving (Eq,Show)
59 deriving (Eq,Show)
60
60
61cons h t = epos h t (Data "Cons" [h,t])
61cons h t = epos h t (Data "Cons" [h,t])
62−nil = C (Just "[]") NoSpan (Data "Nil" [])
62+nil = L (Just "[]") NoSpan (Data "Nil" [])
63list = foldr cons nil
63list = foldr cons nil
64tuple es = Data ("Tuple" ++ show (length es)) es
64tuple es = Data ("Tuple" ++ show (length es)) es
65
65
66−delist (C _ _ (Data "Cons" [h,t])) = h : delist t
66+delist (L _ _ (Data "Cons" [h,t])) = h : delist t
67delist _ = []
67delist _ = []
68
68
69
69
@@ -93,7 +93,7 @@ instance Show Pattern where
93
93
94instance Show Expr where
94instance Show Expr where
95 show e =
95 show e =
96− let show' (C _ _ e) = parensIf (needsParens e) (show e) in
96+ let show' (L _ _ e) = parensIf (needsParens e) (show e) in
97 case e of
97 case e of
98 IntNum n -> show n
98 IntNum n -> show n
99 FloatNum n -> show n
99 FloatNum n -> show n
@@ -103,7 +103,7 @@ instance Show Expr where
103 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
103 Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
104 Access e x -> show' e ++ "." ++ x
104 Access e x -> show' e ++ "." ++ x
105 Remove e x -> brkt (show e ++ " - " ++ x)
105 Remove e x -> brkt (show e ++ " - " ++ x)
106− Insert (C _ _ (Remove e y)) x v ->
106+ Insert (L _ _ (Remove e y)) x v ->
107 brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
107 brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
108 Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
108 Insert e x v -> brkt (show e ++ " | " ++ x ++ " = " ++ show v)
109 Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
109 Modify e fs -> brkt (show e ++" | "++ intercalate ", " (map field fs))
@@ -111,7 +111,7 @@ instance Show Expr where
111 Record r -> brkt (intercalate ", " (map fields r))
111 Record r -> brkt (intercalate ", " (map fields r))
112 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
112 where fields (f,args,e) = f ++ concatMap (' ':) args ++ " = " ++ show e
113 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
113 Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
114− Lambda x e -> let (xs,e') = getLambdas (noContext $ Lambda x e) in
114+ Lambda x e -> let (xs,e') = getLambdas (notLocated $ Lambda x e) in
115 concat [ "\\", intercalate " " xs, " -> ", show e' ]
115 concat [ "\\", intercalate " " xs, " -> ", show e' ]
116 App e1 e2 -> show' e1 ++ " " ++ show' e2
116 App e1 e2 -> show' e1 ++ " " ++ show' e2
117 If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
117 If e1 e2 e3 -> concat [ "if ", show e1, " then ", show e2, " else ", show e3 ]
@@ -124,7 +124,7 @@ instance Show Expr where
124 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
124 where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
125 Data name es
125 Data name es
126 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
126 | name == "Cons" -> ("["++) . (++"]") . intercalate "," . map show $
127− delist (noContext $ Data "Cons" es)
127+ delist (notLocated $ Data "Cons" es)
128 | name == "Nil" -> "[]"
128 | name == "Nil" -> "[]"
129 | otherwise -> name ++ " " ++ intercalate " " (map show' es)
129 | otherwise -> name ++ " " ++ intercalate " " (map show' es)
130 Markdown _ -> "[markdown| ... |]"
130 Markdown _ -> "[markdown| ... |]"
@@ -134,10 +134,10 @@ instance Show Def where
134 show e =
134 show e =
135 case e of
135 case e of
136 FnDef v [] e -> v ++ " = " ++ show e
136 FnDef v [] e -> v ++ " = " ++ show e
137− FnDef f args e -> f ++ " " ++ intercalate " " args ++ " = " ++ show e
137+ FnDef f args e -> f ++ concatMap (' ':) args ++ " = " ++ show e
138 OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
138 OpDef op a1 a2 e -> intercalate " " [a1,op,a2] ++ " = " ++ show e
139
139
140−getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
140+getLambdas (L _ _ (Lambda x e)) = (x:xs,e')
141 where (xs,e') = getLambdas e
141 where (xs,e') = getLambdas e
142getLambdas e = ([],e)
142getLambdas e = ([],e)
143
143
compiler/Model/Context.hs → compiler/Model/Located.hsrenamed+9−9
@@ -1,5 +1,5 @@
1
1
2−module Context where
2+module Located where
3
3
4import Text.Parsec.Pos
4import Text.Parsec.Pos
5
5
@@ -10,7 +10,7 @@ data SrcPos = Pos Int Int
10data SrcSpan = Span SrcPos SrcPos | NoSpan
10data SrcSpan = Span SrcPos SrcPos | NoSpan
11 deriving (Eq,Ord)
11 deriving (Eq,Ord)
12
12
13−data Context e = C (Maybe String) SrcSpan e deriving (Eq,Ord)
13+data Located e = L (Maybe String) SrcSpan e deriving (Eq,Ord)
14
14
15
15
16instance Show SrcPos where
16instance Show SrcPos where
@@ -22,22 +22,22 @@ instance Show SrcSpan where
22 Span start end -> show start
22 Span start end -> show start
23 NoSpan -> ""
23 NoSpan -> ""
24
24
25−instance Show e => Show (Context e) where
25+instance Show e => Show (Located e) where
26− show (C _ _ e) = show e
26+ show (L _ _ e) = show e
27
27
28
28
29
29
30−noContext = C Nothing NoSpan
30+notLocated = L Nothing NoSpan
31
31
32−pos start end = C Nothing
32+pos start end = L Nothing
33 (Span (Pos (sourceLine start) (sourceColumn start))
33 (Span (Pos (sourceLine start) (sourceColumn start))
34 (Pos (sourceLine end ) (sourceColumn end )))
34 (Pos (sourceLine end ) (sourceColumn end )))
35
35
36−epos (C _ s1 _) (C _ s2 _) = C Nothing span
36+epos (L _ s1 _) (L _ s2 _) = L Nothing span
37 where span = case (s1,s2) of
37 where span = case (s1,s2) of
38 (Span start _, Span _ end) -> Span start end
38 (Span start _, Span _ end) -> Span start end
39 (_, NoSpan) -> s1
39 (_, NoSpan) -> s1
40 (NoSpan, _) -> s2
40 (NoSpan, _) -> s2
41
41
42−addCtx x (C Nothing span e) = C (Just (show x)) span e
42+addLoc x (L Nothing span e) = L (Just (show x)) span e
43−addCtx x (C txt span e) = C txt span e
43+addLoc x (L txt span e) = L txt span e
compiler/Parse/Binops.hs+1−1
@@ -1,7 +1,6 @@
1module Parse.Binops (binops) where
1module Parse.Binops (binops) where
2
2
3import Ast
3import Ast
4−import Context
5import Control.Monad (liftM,guard)
4import Control.Monad (liftM,guard)
6import Control.Monad.Error
5import Control.Monad.Error
7import Data.List (foldl',splitAt,elemIndices
6import Data.List (foldl',splitAt,elemIndices
@@ -9,6 +8,7 @@ import Data.List (foldl',splitAt,elemIndices
9import qualified Data.Map as Map
8import qualified Data.Map as Map
10import Data.Maybe (mapMaybe)
9import Data.Maybe (mapMaybe)
11
10
11+import Located (epos)
12import Text.Parsec
12import Text.Parsec
13import Parse.Library
13import Parse.Library
14
14
compiler/Parse/Expr.hs+18−18
@@ -1,7 +1,7 @@
1module Parse.Expr (def,term) where
1module Parse.Expr (def,term) where
2
2
3import Ast
3import Ast
4−import Context
4+import Located
5import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
6import Control.Monad
6import Control.Monad
7import Data.Char (isSymbol, isDigit)
7import Data.Char (isSymbol, isDigit)
@@ -51,8 +51,8 @@ accessor = do
51 start <- getPosition
51 start <- getPosition
52 lbl <- try (string "." >> rLabel)
52 lbl <- try (string "." >> rLabel)
53 end <- getPosition
53 end <- getPosition
54− let ctx e = addCtx ("." ++ lbl) (pos start end e)
54+ let loc e = addLoc ("." ++ lbl) (pos start end e)
55− return (Lambda "_" (ctx $ Access (ctx $ Var "_") lbl))
55+ return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))
56
56
57
57
58-------- Complex Terms --------
58-------- Complex Terms --------
@@ -65,7 +65,7 @@ listTerm =
65 <|> (braces $ choice
65 <|> (braces $ choice
66 [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
66 [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
67 ; Range lo <$> expr }
67 ; Range lo <$> expr }
68− , do (C _ _ e) <- list <$> commaSep expr
68+ , do (L _ _ e) <- list <$> commaSep expr
69 return e
69 return e
70 ])
70 ])
71
71
@@ -74,17 +74,17 @@ parensTerm = parens $ choice
74 [ do start <- getPosition
74 [ do start <- getPosition
75 op <- try anyOp
75 op <- try anyOp
76 end <- getPosition
76 end <- getPosition
77− let ctxt = pos start end
77+ let loc = pos start end
78− return . ctxt . Lambda "x" . ctxt . Lambda "y" . ctxt $
78+ return . loc . Lambda "x" . loc . Lambda "y" . loc $
79− Binop op (ctxt $ Var "x") (ctxt $ Var "y")
79+ Binop op (loc $ Var "x") (loc $ Var "y")
80 , do start <- getPosition
80 , do start <- getPosition
81 let comma = char ',' <?> "comma ','"
81 let comma = char ',' <?> "comma ','"
82 commas <- comma >> many (whitespace >> comma)
82 commas <- comma >> many (whitespace >> comma)
83 end <- getPosition
83 end <- getPosition
84 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
84 let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
85− ctxt = pos start end
85+ loc = pos start end
86− return $ foldr (\x e -> ctxt $ Lambda x e)
86+ return $ foldr (\x e -> loc $ Lambda x e)
87− (ctxt . tuple $ map (ctxt . Var) vars) vars
87+ (loc . tuple $ map (loc . Var) vars) vars
88 , do start <- getPosition
88 , do start <- getPosition
89 es <- commaSep expr
89 es <- commaSep expr
90 end <- getPosition
90 end <- getPosition
@@ -93,7 +93,7 @@ parensTerm = parens $ choice
93 ]
93 ]
94
94
95recordTerm :: IParser CExpr
95recordTerm :: IParser CExpr
96−recordTerm = brackets $ choice [ misc, addContext record ]
96+recordTerm = brackets $ choice [ misc, addLocation record ]
97 where field = do
97 where field = do
98 fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
98 fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
99 whitespace
99 whitespace
@@ -107,15 +107,15 @@ recordTerm = brackets $ choice [ misc, addContext record ]
107 lbl <- rLabel
107 lbl <- rLabel
108 whitespace >> string "<-" >> whitespace
108 whitespace >> string "<-" >> whitespace
109 (,) lbl <$> expr
109 (,) lbl <$> expr
110− remove r = addContext (string "-" >> whitespace >> Remove r <$> rLabel)
110+ remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
111− insert r = addContext $ do
111+ insert r = addLocation $ do
112 string "|" >> whitespace
112 string "|" >> whitespace
113 Insert r <$> rLabel <*>
113 Insert r <$> rLabel <*>
114 (whitespace >> string "=" >> whitespace >> expr)
114 (whitespace >> string "=" >> whitespace >> expr)
115− modify r = addContext
115+ modify r = addLocation
116 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
116 (string "|" >> whitespace >> Modify r <$> commaSep1 change)
117 misc = try $ do
117 misc = try $ do
118− record <- addContext (Var <$> rLabel)
118+ record <- addLocation (Var <$> rLabel)
119 whitespace
119 whitespace
120 opt <- optionMaybe (remove record)
120 opt <- optionMaybe (remove record)
121 whitespace
121 whitespace
@@ -125,8 +125,8 @@ recordTerm = brackets $ choice [ misc, addContext record ]
125
125
126
126
127term :: IParser CExpr
127term :: IParser CExpr
128−term = addContext (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
128+term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
129− <|> accessible (addContext varTerm <|> parensTerm <|> recordTerm)
129+ <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
130 <?> "basic term (4, x, 'c', etc.)"
130 <?> "basic term (4, x, 'c', etc.)"
131
131
132-------- Applications --------
132-------- Applications --------
@@ -182,7 +182,7 @@ caseExpr = do
182 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
182 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
183 without = block (do c <- case_ ; whitespace ; return c)
183 without = block (do c <- case_ ; whitespace ; return c)
184
184
185−expr = addContext (choice [ ifExpr, letExpr, caseExpr ])
185+expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
186 <|> lambdaExpr
186 <|> lambdaExpr
187 <|> binaryExpr
187 <|> binaryExpr
188 <?> "an expression"
188 <?> "an expression"
compiler/Parse/Library.hs+4−4
@@ -2,7 +2,7 @@
2module Parse.Library where
2module Parse.Library where
3
3
4import Ast
4import Ast
5−import Context
5+import Located
6import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad
7import Control.Monad
8import Control.Monad.State
8import Control.Monad.State
@@ -124,8 +124,8 @@ parens = surround '(' ')' "paren"
124brackets :: IParser a -> IParser a
124brackets :: IParser a -> IParser a
125brackets = surround '{' '}' "bracket"
125brackets = surround '{' '}' "bracket"
126
126
127−addContext :: IParser Expr -> IParser CExpr
127+addLocation :: IParser Expr -> IParser CExpr
128−addContext expr = do
128+addLocation expr = do
129 start <- getPosition
129 start <- getPosition
130 e <- expr
130 e <- expr
131 end <- getPosition
131 end <- getPosition
@@ -134,7 +134,7 @@ addContext expr = do
134accessible :: IParser CExpr -> IParser CExpr
134accessible :: IParser CExpr -> IParser CExpr
135accessible expr = do
135accessible expr = do
136 start <- getPosition
136 start <- getPosition
137− ce@(C s t e) <- expr
137+ ce@(L s t e) <- expr
138 let rest f = do
138 let rest f = do
139 let dot = char '.' >> notFollowedBy (char '.')
139 let dot = char '.' >> notFollowedBy (char '.')
140 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
140 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
compiler/Parse/Patterns.hs+15−15
@@ -2,7 +2,7 @@
2module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
2module Parse.Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where
3
3
4import Ast
4import Ast
5−import Context
5+import Located
6import Control.Applicative ((<$>),(<*>))
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad
7import Control.Monad
8import Control.Monad.State
8import Control.Monad.State
@@ -42,13 +42,13 @@ patternExpr = foldr1 pcons <$> consSep1 (patternConstructor <|> patternTerm) <?>
42makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
42makeLambda :: [Pattern] -> CExpr -> GuidCounter CExpr
43makeLambda pats body = go (reverse pats) body
43makeLambda pats body = go (reverse pats) body
44 where go [] body = return body
44 where go [] body = return body
45− go (p:ps) body@(C t s _) = do
45+ go (p:ps) body@(L t s _) = do
46 (x,e) <- extract p body
46 (x,e) <- extract p body
47− go ps (C t s $ Lambda x e)
47+ go ps (L t s $ Lambda x e)
48
48
49extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
49extract :: Pattern -> CExpr -> GuidCounter (String, CExpr)
50−extract pattern body@(C t s _) =
50+extract pattern body@(L t s _) =
51− let ctx = C t s in
51+ let loc = L t s in
52 let fn x e = (x,e) in
52 let fn x e = (x,e) in
53 case pattern of
53 case pattern of
54 PAnything -> return $ fn "_" body
54 PAnything -> return $ fn "_" body
@@ -56,12 +56,12 @@ extract pattern body@(C t s _) =
56 PData name ps -> do
56 PData name ps -> do
57 x <- guid
57 x <- guid
58 let a = '_' : show x
58 let a = '_' : show x
59− return . fn a . ctx $ Case (ctx (Var a)) [(pattern, body)]
59+ return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]
60 PRecord fs -> do
60 PRecord fs -> do
61 x <- guid
61 x <- guid
62 let a = '_' : show x
62 let a = '_' : show x
63− toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)
63+ toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
64− return . fn a . ctx $ Let (map toDef fs) body
64+ return . fn a . loc $ Let (map toDef fs) body
65
65
66extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
66extracts :: [Pattern] -> CExpr -> GuidCounter ([String], CExpr)
67extracts ps body = go [] (reverse ps) body
67extracts ps body = go [] (reverse ps) body
@@ -70,8 +70,8 @@ extracts ps body = go [] (reverse ps) body
70 go (x:args) ps e
70 go (x:args) ps e
71
71
72flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
72flattenPatterns :: [Pattern] -> CExpr -> GuidCounter (IParser [Def])
73−flattenPatterns patterns exp@(C t s _) =
73+flattenPatterns patterns exp@(L t s _) =
74− let ctx = C t s in
74+ let loc = L t s in
75 case patterns of
75 case patterns of
76 PVar f : args -> do
76 PVar f : args -> do
77 (as,e) <- extracts args exp
77 (as,e) <- extracts args exp
@@ -85,21 +85,21 @@ flattenPatterns patterns exp@(C t s _) =
85 ") cannot be used on the left-hand side of an assign statement."
85 ") cannot be used on the left-hand side of an assign statement."
86
86
87matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
87matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
88−matchSingle pat exp@(C t s _) p =
88+matchSingle pat exp@(L t s _) p =
89− let ctx = C t s in
89+ let loc = L t s in
90 case p of
90 case p of
91 PData _ ps -> do
91 PData _ ps -> do
92 x <- guid
92 x <- guid
93 let v = '_' : show x
93 let v = '_' : show x
94− dss <- mapM (matchSingle pat . ctx $ Var v) ps
94+ dss <- mapM (matchSingle pat . loc $ Var v) ps
95 return (FnDef v [] exp : concat dss)
95 return (FnDef v [] exp : concat dss)
96
96
97 PVar x ->
97 PVar x ->
98− return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]
98+ return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]
99
99
100 PRecord fs -> do
100 PRecord fs -> do
101 a <- (\x -> '_' : show x) `liftM` guid
101 a <- (\x -> '_' : show x) `liftM` guid
102− let toDef f = FnDef f [] (ctx $ Access (ctx $ Var a) f)
102+ let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)
103 return (FnDef a [] exp : map toDef fs)
103 return (FnDef a [] exp : map toDef fs)
104
104
105 PAnything -> return []
105 PAnything -> return []
compiler/Parse/Types.hs+4−4
@@ -9,7 +9,7 @@ import Data.List (lookup,intercalate)
9import Text.Parsec
9import Text.Parsec
10import Text.Parsec.Indent
10import Text.Parsec.Indent
11
11
12−import Context
12+import Located
13import Parse.Library
13import Parse.Library
14import Types.Types hiding (parens,string)
14import Types.Types hiding (parens,string)
15import Guid
15import Guid
@@ -88,11 +88,11 @@ typeAlias = do
88 _ -> []
88 _ -> []
89
89
90toConstructor start end alias kvs =
90toConstructor start end alias kvs =
91− Definition (FnDef alias args (ctxt (Record rec)))
91+ Definition (FnDef alias args (loc (Record rec)))
92 where
92 where
93− ctxt = pos start end
93+ loc = pos start end
94 args = map fst kvs
94 args = map fst kvs
95− rec = map (\a -> (a, [], ctxt (Var a))) args
95+ rec = map (\a -> (a, [], loc (Var a))) args
96
96
97
97
98typeAnnotation :: IParser Statement
98typeAnnotation :: IParser Statement
compiler/Transform/Optimize.hs+27−27
@@ -1,7 +1,7 @@
1module Optimize (optimize) where
1module Optimize (optimize) where
2
2
3import Ast
3import Ast
4−import Context
4+import Located
5import Control.Arrow (second)
5import Control.Arrow (second)
6import Data.Char (isAlpha)
6import Data.Char (isAlpha)
7import Substitute
7import Substitute
@@ -24,8 +24,8 @@ instance Simplify Def where
24 simp (FnDef func args e) = FnDef func args (simp e)
24 simp (FnDef func args e) = FnDef func args (simp e)
25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
25 simp (OpDef op a1 a2 e) = OpDef op a1 a2 (simp e)
26
26
27−instance Simplify e => Simplify (Context e) where
27+instance Simplify e => Simplify (Located e) where
28− simp (C t s e) = C t s (simp e)
28+ simp (L t s e) = L t s (simp e)
29
29
30instance Simplify Expr where
30instance Simplify Expr where
31 simp expr =
31 simp expr =
@@ -35,10 +35,10 @@ instance Simplify Expr where
35 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
35 Binop op e1 e2 -> simp_binop op (f e1) (f e2)
36 Lambda x e -> Lambda x (f e)
36 Lambda x e -> Lambda x (f e)
37 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
37 Record fs -> Record (map (\(f,as,e) -> (f, as, simp e)) fs)
38− App (C t s (Lambda x e1)) e2 ->
38+ App (L t s (Lambda x e1)) e2 ->
39− if isValue e2' then subst x e2' e1' else App (C t s (Lambda x ce1')) ce2'
39+ if isValue e2' then subst x e2' e1' else App (L t s (Lambda x ce1')) ce2'
40− where ce1'@(C _ _ e1') = f e1
40+ where ce1'@(L _ _ e1') = f e1
41− ce2'@(C _ _ e2') = f e2
41+ ce2'@(L _ _ e2') = f e2
42 App e1 e2 -> App (f e1) (f e2)
42 App e1 e2 -> App (f e1) (f e2)
43 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
43 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)
44 Let defs e -> Let (map simp defs) (f e)
44 Let defs e -> Let (map simp defs) (f e)
@@ -46,7 +46,7 @@ instance Simplify Expr where
46 Case e cases -> Case (f e) (map (second f) cases)
46 Case e cases -> Case (f e) (map (second f) cases)
47 _ -> expr
47 _ -> expr
48
48
49−simp_if (C _ _ (Boolean b)) (C _ _ e2) (C _ _ e3) = if b then e2 else e3
49+simp_if (L _ _ (Boolean b)) (L _ _ e2) (L _ _ e3) = if b then e2 else e3
50simp_if a b c = If a b c
50simp_if a b c = If a b c
51
51
52isValue e =
52isValue e =
@@ -61,9 +61,9 @@ isValue e =
61
61
62simp_binop = binop
62simp_binop = binop
63
63
64−binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
64+binop op ce1@(L t1 s1 e1) ce2@(L t2 s2 e2) =
65− let c1 = C t1 s1 in
65+ let c1 = L t1 s1 in
66− let c2 = C t2 s2 in
66+ let c2 = L t2 s2 in
67 case (op, e1, e2) of
67 case (op, e1, e2) of
68 (_, IntNum n, IntNum m) -> case op of
68 (_, IntNum n, IntNum m) -> case op of
69 { "+" -> IntNum $ (+) n m
69 { "+" -> IntNum $ (+) n m
@@ -85,19 +85,19 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
85 ("*", _, IntNum n) -> binop "*" ce2 ce1
85 ("*", _, IntNum n) -> binop "*" ce2 ce1
86
86
87 ("+", IntNum 0, _) -> e2
87 ("+", IntNum 0, _) -> e2
88− ("+", IntNum n, Binop "+" (C _ _ (IntNum m)) ce) ->
88+ ("+", IntNum n, Binop "+" (L _ _ (IntNum m)) ce) ->
89 binop "+" (c1 $ IntNum (n+m)) ce
89 binop "+" (c1 $ IntNum (n+m)) ce
90− ("+", Binop "+" (C _ _ (IntNum n)) ce1'
90+ ("+", Binop "+" (L _ _ (IntNum n)) ce1'
91− , Binop "+" (C _ _ (IntNum m)) ce2') ->
91+ , Binop "+" (L _ _ (IntNum m)) ce2') ->
92− binop "+" (noContext $ IntNum (n+m)) (noContext $ Binop "+" ce1' ce2')
92+ binop "+" (notLocated $ IntNum (n+m)) (notLocated $ Binop "+" ce1' ce2')
93
93
94 ("*", IntNum 0, _) -> e1
94 ("*", IntNum 0, _) -> e1
95 ("*", IntNum 1, _) -> e2
95 ("*", IntNum 1, _) -> e2
96− ("*", IntNum n, Binop "*" (C _ _ (IntNum m)) ce) ->
96+ ("*", IntNum n, Binop "*" (L _ _ (IntNum m)) ce) ->
97− binop "*" (noContext $ IntNum (n*m)) ce
97+ binop "*" (notLocated $ IntNum (n*m)) ce
98− ("*", Binop "*" (C _ _ (IntNum n)) ce1'
98+ ("*", Binop "*" (L _ _ (IntNum n)) ce1'
99− , Binop "*" (C _ _ (IntNum m)) ce2') ->
99+ , Binop "*" (L _ _ (IntNum m)) ce2') ->
100− binop "*" (noContext $ IntNum (n*m)) (noContext $ Binop "*" ce1' ce2')
100+ binop "*" (notLocated $ IntNum (n*m)) (notLocated $ Binop "*" ce1' ce2')
101
101
102 ("-", _, IntNum 0) -> e1
102 ("-", _, IntNum 0) -> e1
103 ("/", _, IntNum 1) -> e1
103 ("/", _, IntNum 1) -> e1
@@ -112,24 +112,24 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
112 ("||", Boolean True, _) -> Boolean True
112 ("||", Boolean True, _) -> Boolean True
113 ("||", Boolean False, _) -> e2
113 ("||", Boolean False, _) -> e2
114
114
115− ("::", _, _) -> let (C _ _ e) = cons ce1 ce2 in e
115+ ("::", _, _) -> let (L _ _ e) = cons ce1 ce2 in e
116
116
117 ("++", Str s1, Str s2) -> Str $ s1 ++ s2
117 ("++", Str s1, Str s2) -> Str $ s1 ++ s2
118− ("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->
118+ ("++", Str s1, Binop "++" (L _ _ (Str s2)) ce) ->
119 Binop "++" (c1 $ Str $ s1 ++ s2) ce
119 Binop "++" (c1 $ Str $ s1 ++ s2) ce
120− ("++", Binop "++" e (C _ _ (Str s1)), Str s2) ->
120+ ("++", Binop "++" e (L _ _ (Str s1)), Str s2) ->
121 Binop "++" e (c1 $ Str $ s1 ++ s2)
121 Binop "++" e (c1 $ Str $ s1 ++ s2)
122
122
123 ("++", Data "Nil" [], _) -> e2
123 ("++", Data "Nil" [], _) -> e2
124 ("++", _, Data "Nil" []) -> e1
124 ("++", _, Data "Nil" []) -> e1
125− ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]
125+ ("++", Data "Cons" [h,t], _) -> Data "Cons" [h, notLocated $ binop "++" t ce2]
126
126
127 ("|>", _, _) -> App ce2 ce1
127 ("|>", _, _) -> App ce2 ce1
128 ("<|", _, _) -> App ce1 ce2
128 ("<|", _, _) -> App ce1 ce2
129 (".", _, _) ->
129 (".", _, _) ->
130− Lambda "x" (noContext $
130+ Lambda "x" (notLocated $
131− App ce1 (noContext $ App ce2 (noContext $ Var "x")))
131+ App ce1 (notLocated $ App ce2 (notLocated $ Var "x")))
132
132
133 _ | isAlpha (head op) || '_' == head op ->
133 _ | isAlpha (head op) || '_' == head op ->
134− App (noContext $ App (noContext $ Var op) ce1) ce2
134+ App (notLocated $ App (notLocated $ Var op) ce1) ce2
135 | otherwise -> Binop op ce1 ce2
135 | otherwise -> Binop op ce1 ce2
compiler/Transform/Rename.hs+3−3
@@ -2,7 +2,7 @@
2module Rename (renameModule, derename, deprime) where
2module Rename (renameModule, derename, deprime) where
3
3
4import Ast
4import Ast
5−import Context
5+import Located
6import Control.Arrow (first)
6import Control.Arrow (first)
7import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
7import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)
8import Control.Monad.State (evalState, State, get, put)
8import Control.Monad.State (evalState, State, get, put)
@@ -53,8 +53,8 @@ renameStmts env stmts = do env' <- extends env $ concatMap getNames stmts
53 ImportEvent _ _ n _ -> [n]
53 ImportEvent _ _ n _ -> [n]
54 _ -> []
54 _ -> []
55
55
56−instance Rename a => Rename (Context a) where
56+instance Rename a => Rename (Located a) where
57− rename env (C t s e) = C t s `liftM` rename env e
57+ rename env (L t s e) = L t s `liftM` rename env e
58
58
59instance Rename Expr where
59instance Rename Expr where
60 rename env expr =
60 rename env expr =
compiler/Transform/Substitute.hs+2−2
@@ -1,12 +1,12 @@
1module Substitute (subst) where
1module Substitute (subst) where
2
2
3import Ast
3import Ast
4−import Context
4+import Located
5import Control.Arrow (second, (***))
5import Control.Arrow (second, (***))
6
6
7subst :: String -> Expr -> Expr -> Expr
7subst :: String -> Expr -> Expr -> Expr
8subst old new expr =
8subst old new expr =
9− let f (C t s e) = C t s (subst old new e) in
9+ let f (L t s e) = L t s (subst old new e) in
10 case expr of
10 case expr of
11 Range e1 e2 -> Range (f e1) (f e2)
11 Range e1 e2 -> Range (f e1) (f e2)
12 Access e x -> Access (f e) x
12 Access e x -> Access (f e) x
compiler/Types/Constrain.hs+40−40
@@ -10,7 +10,7 @@ import qualified Data.Map as Map
10import qualified Data.Set as Set
10import qualified Data.Set as Set
11
11
12import Ast
12import Ast
13−import Context
13+import Located
14import Guid
14import Guid
15
15
16import Types.Types
16import Types.Types
@@ -62,7 +62,7 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
62 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
62 kvs = Map.toList $ Map.unionsWith (++) (map (Map.map (:[])) schmss)
63 split (k,vs) =
63 split (k,vs) =
64 let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
64 let ps = zipWith (\s v -> (s++k,v)) (map (flip replicate '_') [0..]) vs
65− eq t u = C (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
65+ eq t u = L (Just $ msg ++ k) NoSpan (VarT t :=: VarT u)
66 msg = "the definition of "
66 msg = "the definition of "
67 in do xs <- mapM (\_ -> guid) vs
67 in do xs <- mapM (\_ -> guid) vs
68 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
68 return ( Map.fromList $ zip (map fst ps) (map (:[]) xs)
@@ -81,7 +81,7 @@ constrain typeHints (Module _ _ imports stmts) = do
81 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
81 insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
82 assumptions <- foldM insert as (Map.keys schemes)
82 assumptions <- foldM insert as (Map.keys schemes)
83 findAmbiguous (map fst aliasHints) assumptions $ do
83 findAmbiguous (map fst aliasHints) assumptions $ do
84− let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
84+ let f k s vs = map (\v -> L (Just k) NoSpan $ v :<<: s) vs
85 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
85 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
86 escapees = Map.keys $ Map.difference assumptions allHints
86 escapees = Map.keys $ Map.difference assumptions allHints
87 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
87 msg = "Warning! Type-checker could not find variables:\n" ++ intercalate ", " escapees
@@ -91,13 +91,13 @@ constrain typeHints (Module _ _ imports stmts) = do
91 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
91 --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
92
92
93type TVarMap = Map.Map String [X]
93type TVarMap = Map.Map String [X]
94−type ConstraintSet = Set.Set (Context Constraint)
94+type ConstraintSet = Set.Set (Located Constraint)
95
95
96−ctx e span = C (Just $ show e) span
96+loc e span = L (Just $ show e) span
97
97
98gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
98gen :: CExpr -> GuidCounter (TVarMap, ConstraintSet, Type)
99−gen (C _ span expr) =
99+gen (L _ span expr) =
100− let ctx' = C (Just $ show expr) span in
100+ let loc' = L (Just $ show expr) span in
101 case expr of
101 case expr of
102 Var x ->
102 Var x ->
103 do b <- guid
103 do b <- guid
@@ -109,7 +109,7 @@ gen (C _ span expr) =
109 b <- beta
109 b <- beta
110 return ( unionA a1 a2
110 return ( unionA a1 a2
111 , Set.unions [c1,c2
111 , Set.unions [c1,c2
112− ,Set.singleton . ctx' $ t1 :=: (LambdaT t2 b)]
112+ ,Set.singleton . loc' $ t1 :=: (LambdaT t2 b)]
113 , b )
113 , b )
114
114
115 Lambda x e ->
115 Lambda x e ->
@@ -118,7 +118,7 @@ gen (C _ span expr) =
118 v <- guid
118 v <- guid
119 return ( Map.delete x a
119 return ( Map.delete x a
120 , Set.union c . Set.fromList .
120 , Set.union c . Set.fromList .
121− map (\x -> ctx' $ VarT x :=: b) $
121+ map (\x -> loc' $ VarT x :=: b) $
122 Map.findWithDefault [v] x a
122 Map.findWithDefault [v] x a
123 , LambdaT b t )
123 , LambdaT b t )
124
124
@@ -132,7 +132,7 @@ gen (C _ span expr) =
132 genCs name s = do
132 genCs name s = do
133 v <- guid
133 v <- guid
134 let vs = Map.findWithDefault [v] name assumptions
134 let vs = Map.findWithDefault [v] name assumptions
135− return $ map (\x -> ctx name span $ x :<<: s) vs
135+ return $ map (\x -> loc name span $ x :<<: s) vs
136 cs' <- zipWithM genCs names schemes
136 cs' <- zipWithM genCs names schemes
137 return ( foldr Map.delete assumptions names
137 return ( foldr Map.delete assumptions names
138 , Set.union (Set.fromList . concat $ cs') cs
138 , Set.union (Set.fromList . concat $ cs') cs
@@ -143,9 +143,9 @@ gen (C _ span expr) =
143 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
143 (ass,css,ts) <- liftM unzip3 $ mapM (caseGen t) cases
144 return ( unionsA $ as:ass
144 return ( unionsA $ as:ass
145 , let cases' = map snd cases
145 , let cases' = map snd cases
146− ctxs = zipWith epos cases' (tail cases')
146+ locs = zipWith epos cases' (tail cases')
147 csts = zipWith (:=:) ts (tail ts)
147 csts = zipWith (:=:) ts (tail ts)
148− cs' = Set.fromList (zipWith ($) ctxs csts)
148+ cs' = Set.fromList (zipWith ($) locs csts)
149 in Set.unions $ cs' : cs : css
149 in Set.unions $ cs' : cs : css
150 , head ts)
150 , head ts)
151
151
@@ -154,30 +154,30 @@ gen (C _ span expr) =
154 (a2,c2,t2) <- gen e2
154 (a2,c2,t2) <- gen e2
155 (a3,c3,t3) <- gen e3
155 (a3,c3,t3) <- gen e3
156 return ( unionsA [a1,a2,a3]
156 return ( unionsA [a1,a2,a3]
157− , let c4 = Set.fromList [ ctx e1 span (t1 :=: bool)
157+ , let c4 = Set.fromList [ loc e1 span (t1 :=: bool)
158− , ctx' (t2 :=: t3) ]
158+ , loc' (t2 :=: t3) ]
159 in Set.unions [c1,c2,c3,c4]
159 in Set.unions [c1,c2,c3,c4]
160 , t2 )
160 , t2 )
161
161
162 Data name es ->
162 Data name es ->
163− gen $ foldl' (\f x -> epos f x $ App f x) (ctx' $ Var name) es
163+ gen $ foldl' (\f x -> epos f x $ App f x) (loc' $ Var name) es
164
164
165 Binop op e1 e2 ->
165 Binop op e1 e2 ->
166− gen $ ctx' (App (ctx' $ App (ctx' $ Var op) e1) e2)
166+ gen $ loc' (App (loc' $ App (loc' $ Var op) e1) e2)
167
167
168 Access e label ->
168 Access e label ->
169 do (as,cs,rtype) <- gen e
169 do (as,cs,rtype) <- gen e
170 t <- beta
170 t <- beta
171 rtype' <- beta
171 rtype' <- beta
172 let fs = Map.singleton label [t]
172 let fs = Map.singleton label [t]
173− c = (ctx' (RecordT fs rtype' :=: rtype))
173+ c = (loc' (RecordT fs rtype' :=: rtype))
174 return (as, Set.insert c cs, t)
174 return (as, Set.insert c cs, t)
175
175
176 Remove e x ->
176 Remove e x ->
177 do (as,cs,rtype) <- gen e
177 do (as,cs,rtype) <- gen e
178 t <- beta
178 t <- beta
179 rtype' <- beta
179 rtype' <- beta
180− let c = (ctx' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
180+ let c = (loc' (RecordT (Map.singleton x [t]) rtype' :=: rtype))
181 return (as, Set.insert c cs, rtype')
181 return (as, Set.insert c cs, rtype')
182
182
183 Insert e x v ->
183 Insert e x v ->
@@ -193,7 +193,7 @@ gen (C _ span expr) =
193 oldTs <- mapM (\_ -> beta) fields
193 oldTs <- mapM (\_ -> beta) fields
194 rtype' <- beta
194 rtype' <- beta
195 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
195 let rT ts = RecordT (recordT (zip (map fst fields) ts)) rtype'
196− c = Set.singleton (ctx' (rtype :=: rT oldTs))
196+ c = Set.singleton (loc' (rtype :=: rT oldTs))
197 return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
197 return ( unionsA (ras:ass), Set.unions (c : rcs : css), rT newTs )
198
198
199 Record fields ->
199 Record fields ->
@@ -206,27 +206,27 @@ gen (C _ span expr) =
206 , Set.fromList (concat css)
206 , Set.fromList (concat css)
207 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
207 , RecordT (foldr ($) Map.empty fs) EmptyRecord )
208
208
209− Range e1@(C w1 s1 _) e2@(C w2 s2 _) ->
209+ Range e1@(L w1 s1 _) e2@(L w2 s2 _) ->
210 do (a1,c1,t1) <- gen e1
210 do (a1,c1,t1) <- gen e1
211 (a2,c2,t2) <- gen e2
211 (a2,c2,t2) <- gen e2
212 return ( unionsA [a1,a2]
212 return ( unionsA [a1,a2]
213− , Set.unions [ c1, c2, Set.fromList [ C w1 s1 (t1 :=: int)
213+ , Set.unions [ c1, c2, Set.fromList [ L w1 s1 (t1 :=: int)
214− , C w1 s2 (t2 :=: int) ] ]
214+ , L w1 s2 (t2 :=: int) ] ]
215 , listOf int )
215 , listOf int )
216
216
217 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
217 MultiIf ps -> do (ass,css,t:ts) <- unzip3 `liftM` mapM genPair ps
218− let cs = Set.fromList (map (ctx' . (t :=:)) ts)
218+ let cs = Set.fromList (map (loc' . (t :=:)) ts)
219 return (unionsA ass, Set.unions (cs:css), t)
219 return (unionsA ass, Set.unions (cs:css), t)
220− where genPair (b@(C t s _),e) = do
220+ where genPair (b@(L t s _),e) = do
221 (a1,c1,t1) <- gen b
221 (a1,c1,t1) <- gen b
222 (a2,c2,t2) <- gen e
222 (a2,c2,t2) <- gen e
223 return ( unionsA [a1,a2]
223 return ( unionsA [a1,a2]
224 , Set.unions [ c1, c2
224 , Set.unions [ c1, c2
225− , Set.singleton (C t s (t1 :=: bool)) ]
225+ , Set.singleton (L t s (t1 :=: bool)) ]
226 , t2 )
226 , t2 )
227
227
228 IntNum _ -> do t <- beta
228 IntNum _ -> do t <- beta
229− return (Map.empty, Set.singleton (ctx' $ t :<: number), t)
229+ return (Map.empty, Set.singleton (loc' $ t :<: number), t)
230
230
231 FloatNum _ -> primitive float
231 FloatNum _ -> primitive float
232 Chr _ -> primitive char
232 Chr _ -> primitive char
@@ -241,41 +241,41 @@ primitive t = return (Map.empty, Set.empty, t)
241caseGen :: Type
241caseGen :: Type
242 -> (Pattern, CExpr)
242 -> (Pattern, CExpr)
243 -> GuidCounter (TVarMap, ConstraintSet, Type)
243 -> GuidCounter (TVarMap, ConstraintSet, Type)
244−caseGen tipe (p, ce@(C _ span e)) = do
244+caseGen tipe (p, ce@(L _ span e)) = do
245 (as ,cs ,t) <- gen ce
245 (as ,cs ,t) <- gen ce
246− (as',cs',_) <- patternGen (ctx p span) tipe as p
246+ (as',cs',_) <- patternGen (loc p span) tipe as p
247 return ( as', Set.union cs cs', t )
247 return ( as', Set.union cs cs', t )
248
248
249−patternGen :: (Constraint -> Context Constraint)
249+patternGen :: (Constraint -> Located Constraint)
250 -> Type -- Type of e in `case e of ...`
250 -> Type -- Type of e in `case e of ...`
251 -> TVarMap
251 -> TVarMap
252 -> Pattern
252 -> Pattern
253 -> GuidCounter (TVarMap, ConstraintSet, Type)
253 -> GuidCounter (TVarMap, ConstraintSet, Type)
254−patternGen ctxt tipe as pattern =
254+patternGen loc tipe as pattern =
255 case pattern of
255 case pattern of
256 PAnything -> do b <- beta ; return ( as, Set.empty, b )
256 PAnything -> do b <- beta ; return ( as, Set.empty, b )
257 PVar v -> do
257 PVar v -> do
258 b <- beta
258 b <- beta
259− let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)
259+ let cs = map (loc . (b :=:) . VarT) (Map.findWithDefault [] v as)
260− return ( Map.delete v as, Set.fromList (ctxt (b :=: tipe) : cs), b )
260+ return ( Map.delete v as, Set.fromList (loc (b :=: tipe) : cs), b )
261 PData name ps -> do
261 PData name ps -> do
262 constr <- guid
262 constr <- guid
263 output <- beta
263 output <- beta
264 let step (as,cs,tipe) p = do b <- beta
264 let step (as,cs,tipe) p = do b <- beta
265− (as',cs',t) <- patternGen ctxt b as p
265+ (as',cs',t) <- patternGen loc b as p
266 return (as', Set.union cs cs', t ==> tipe)
266 return (as', Set.union cs cs', t ==> tipe)
267 (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
267 (as',cs, t) <- foldM step (as,Set.empty,tipe) (reverse ps)
268 return ( Map.insert name [constr] as'
268 return ( Map.insert name [constr] as'
269− , Set.insert (ctxt (VarT constr :=: t)) cs
269+ , Set.insert (loc (VarT constr :=: t)) cs
270 , output )
270 , output )
271 PRecord fs ->
271 PRecord fs ->
272 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
272 do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
273 b <- beta
273 b <- beta
274 let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
274 let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
275− mkCs (name,tipe) = map (ctxt . (tipe :=:) . VarT)
275+ mkCs (name,tipe) = map (loc . (tipe :=:) . VarT)
276 (Map.findWithDefault [] name as)
276 (Map.findWithDefault [] name as)
277 return ( foldr Map.delete as fs
277 return ( foldr Map.delete as fs
278− , Set.fromList (ctxt (t :=: tipe) : concatMap mkCs pairs)
278+ , Set.fromList (loc (t :=: tipe) : concatMap mkCs pairs)
279 , t )
279 , t )
280
280
281
281
@@ -295,7 +295,7 @@ defGenHelp name args e = do
295 genCs (arg,x) = do
295 genCs (arg,x) = do
296 v <- guid
296 v <- guid
297 let as' = Map.findWithDefault [v] arg as
297 let as' = Map.findWithDefault [v] arg as
298− return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'
298+ return $ map (\y -> loc arg NoSpan $ VarT x :=: VarT y) as'
299 cs' <- concat `liftM` mapM genCs argDict
299 cs' <- concat `liftM` mapM genCs argDict
300 scheme <- Subs.generalize (concat $ Map.elems as') $
300 scheme <- Subs.generalize (concat $ Map.elems as') $
301 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
301 Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
@@ -316,13 +316,13 @@ stmtGen stmt =
316 ExportEvent js elm tipe ->
316 ExportEvent js elm tipe ->
317 do x <- guid
317 do x <- guid
318 return ( Map.singleton elm [x]
318 return ( Map.singleton elm [x]
319− , Set.singleton . ctx elm NoSpan $ VarT x :=: tipe
319+ , Set.singleton . loc elm NoSpan $ VarT x :=: tipe
320 , Map.empty )
320 , Map.empty )
321
321
322− ImportEvent js e@(C txt span base) elm tipe ->
322+ ImportEvent js e@(L txt span base) elm tipe ->
323 do (as,cs,t) <- gen e
323 do (as,cs,t) <- gen e
324 return ( as
324 return ( as
325− , Set.insert (C txt span (signalOf t :=: tipe)) cs
325+ , Set.insert (L txt span (signalOf t :=: tipe)) cs
326 , Map.singleton elm (Forall [] [] tipe) )
326 , Map.singleton elm (Forall [] [] tipe) )
327
327
328 TypeAnnotation name tipe ->
328 TypeAnnotation name tipe ->
compiler/Types/Solver.hs+17−17
@@ -1,7 +1,7 @@
1
1
2module Types.Solver (solver) where
2module Types.Solver (solver) where
3
3
4−import Context
4+import Located
5import Control.Arrow (second)
5import Control.Arrow (second)
6import Control.Monad (liftM)
6import Control.Monad (liftM)
7import Data.Either (lefts,rights)
7import Data.Either (lefts,rights)
@@ -14,8 +14,8 @@ import Types.Types
14import Types.Substitutions
14import Types.Substitutions
15import Types.Alias (dealias)
15import Types.Alias (dealias)
16
16
17−isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2
17+isSolved ss (L _ _ (t1 :=: t2)) = t1 == t2
18−isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)
18+isSolved ss (L _ _ (x :<<: _)) = isJust (lookup x ss)
19isSolved ss c = False
19isSolved ss c = False
20
20
21type Aliases = Map.Map String ([X],Type)
21type Aliases = Map.Map String ([X],Type)
@@ -31,7 +31,7 @@ crush aliases (Forall xs cs t) =
31schemeSubHelp txt span x s t1 rltn t2 = do
31schemeSubHelp txt span x s t1 rltn t2 = do
32 (t1',cs1) <- sub t1
32 (t1',cs1) <- sub t1
33 (t2',cs2) <- sub t2
33 (t2',cs2) <- sub t2
34− return (C txt span (rltn t1' t2') : cs1 ++ cs2)
34+ return (L txt span (rltn t1' t2') : cs1 ++ cs2)
35 where sub t | not (occurs x t) = return (t, [])
35 where sub t | not (occurs x t) = return (t, [])
36 | otherwise = do (st, cs) <- concretize s
36 | otherwise = do (st, cs) <- concretize s
37 return (subst [(x,st)] t, cs)
37 return (subst [(x,st)] t, cs)
@@ -42,7 +42,7 @@ schemeSub aliases x s c =
42 Right s'' -> Right `liftM` schemeSub' x s'' c
42 Right s'' -> Right `liftM` schemeSub' x s'' c
43 Left err -> return $ Left err
43 Left err -> return $ Left err
44
44
45−schemeSub' x s c@(C txt span constraint) =
45+schemeSub' x s c@(L txt span constraint) =
46 case constraint of
46 case constraint of
47 (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
47 (t1 :=: t2) -> schemeSubHelp txt span x s t1 (:=:) t2
48 (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
48 (t1 :<: t2) -> schemeSubHelp txt span x s t1 (:<:) t2
@@ -53,7 +53,7 @@ schemeSub' x s c@(C txt span constraint) =
53 let ss = [(x,tipe)]
53 let ss = [(x,tipe)]
54 constraints = subst ss (cs ++ ccs)
54 constraints = subst ss (cs ++ ccs)
55 c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
55 c' = y :<<: Forall (cxs ++ xs) constraints (subst ss ctipe)
56− return [ C txt span c' ]
56+ return [ L txt span c' ]
57
57
58recordConstraints eq fs t fs' t' =
58recordConstraints eq fs t fs' t' =
59 liftM concat . sequence $
59 liftM concat . sequence $
@@ -64,11 +64,11 @@ recordConstraints eq fs t fs' t' =
64 Map.difference fs' fs
64 Map.difference fs' fs
65 ]
65 ]
66 where constrain :: Map.Map String [Type] -> Map.Map String [Type]
66 where constrain :: Map.Map String [Type] -> Map.Map String [Type]
67− -> GuidCounter [Context Constraint]
67+ -> GuidCounter [Located Constraint]
68 constrain as bs = liftM concat . sequence . Map.elems $
68 constrain as bs = liftM concat . sequence . Map.elems $
69 Map.intersectionWithKey (zipper []) as bs
69 Map.intersectionWithKey (zipper []) as bs
70− zipper :: [Context Constraint] -> String -> [Type] -> [Type]
70+ zipper :: [Located Constraint] -> String -> [Type] -> [Type]
71− -> GuidCounter [Context Constraint]
71+ -> GuidCounter [Located Constraint]
72 zipper cs k xs ys =
72 zipper cs k xs ys =
73 case (xs,ys) of
73 case (xs,ys) of
74 (a:as, b:bs) -> zipper (eq a b : cs) k as bs
74 (a:as, b:bs) -> zipper (eq a b : cs) k as bs
@@ -82,12 +82,12 @@ recordConstraints eq fs t fs' t' =
82
82
83solver :: Aliases
83solver :: Aliases
84 -> Map.Map X Type
84 -> Map.Map X Type
85− -> [Context Constraint]
85+ -> [Located Constraint]
86 -> GuidCounter (Either String (Map.Map X Type))
86 -> GuidCounter (Either String (Map.Map X Type))
87solver _ subs [] = return $ Right subs
87solver _ subs [] = return $ Right subs
88−solver aliases subs (C txt span c : cs) =
88+solver aliases subs (L txt span c : cs) =
89− let ctx = C txt span
89+ let loc = L txt span
90− eq t1 t2 = ctx (t1 :=: t2)
90+ eq t1 t2 = loc (t1 :=: t2)
91 solv = solver aliases subs
91 solv = solver aliases subs
92 uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
92 uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
93 in case c of
93 in case c of
@@ -133,14 +133,14 @@ solver aliases subs (C txt span c : cs) =
133 Just (Super ts) ->
133 Just (Super ts) ->
134 let ts' = Set.intersection ts (Set.singleton t) in
134 let ts' = Set.intersection ts (Set.singleton t) in
135 case Set.toList ts' of
135 case Set.toList ts' of
136− [] -> solv (ctx (t :<: Super ts) : cs)
136+ [] -> solv (loc (t :<: Super ts) : cs)
137 [t'] -> let cs5 = subst [(x,t)] cs in
137 [t'] -> let cs5 = subst [(x,t)] cs in
138 solver aliases (Map.insert x t' subs) cs5
138 solver aliases (Map.insert x t' subs) cs5
139 _ -> solver aliases (Map.insert x (Super ts') subs) cs
139 _ -> solver aliases (Map.insert x (Super ts') subs) cs
140− Just t' -> solv (ctx (t' :=: t) : cs)
140+ Just t' -> solv (loc (t' :=: t) : cs)
141 )
141 )
142
142
143− t :=: VarT x -> solv ((ctx (VarT x :=: t)) : cs)
143+ t :=: VarT x -> solv ((loc (VarT x :=: t)) : cs)
144
144
145 t1 :=: t2 | t1 == t2 -> solv cs
145 t1 :=: t2 | t1 == t2 -> solv cs
146 | otherwise -> uniError' t1 t2
146 | otherwise -> uniError' t1 t2
@@ -176,7 +176,7 @@ solver aliases subs (C txt span c : cs) =
176 [] -> solv (concat (rights css))
176 [] -> solv (concat (rights css))
177 | otherwise ->
177 | otherwise ->
178 do (t,cs7) <- concretize s
178 do (t,cs7) <- concretize s
179− solv (cs ++ ctx (VarT x :=: t) : cs7)
179+ solv (cs ++ loc (VarT x :=: t) : cs7)
180
180
181showMsg msg = case msg of
181showMsg msg = case msg of
182 Just str -> "\nIn context: " ++ str
182 Just str -> "\nIn context: " ++ str
compiler/Types/Substitutions.hs+7−7
@@ -8,7 +8,7 @@ module Types.Substitutions (subst,
8 superize) where
8 superize) where
9
9
10import Ast
10import Ast
11−import Context
11+import Located
12import Control.Monad (liftM, liftM2)
12import Control.Monad (liftM, liftM2)
13import Control.Monad.State (runState, State, get, put)
13import Control.Monad.State (runState, State, get, put)
14import Data.List (nub)
14import Data.List (nub)
@@ -41,8 +41,8 @@ instance Subst Constraint where
41 subst ss (t :<: super) = subst ss t :<: super
41 subst ss (t :<: super) = subst ss t :<: super
42 subst ss (x :<<: poly) = x :<<: subst ss poly
42 subst ss (x :<<: poly) = x :<<: subst ss poly
43
43
44−instance Subst a => Subst (Context a) where
44+instance Subst a => Subst (Located a) where
45− subst ss (C str span c) = C str span (subst ss c)
45+ subst ss (L str span c) = L str span (subst ss c)
46
46
47instance Subst a => Subst [a] where
47instance Subst a => Subst [a] where
48 subst ss as = map (subst ss) as
48 subst ss as = map (subst ss) as
@@ -67,15 +67,15 @@ instance FreeVars Constraint where
67 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
67 freeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees
68 where frees = concatMap freeVars cs ++ freeVars t
68 where frees = concatMap freeVars cs ++ freeVars t
69
69
70−instance FreeVars a => FreeVars (Context a) where
70+instance FreeVars a => FreeVars (Located a) where
71− freeVars (C _ _ c) = freeVars c
71+ freeVars (L _ _ c) = freeVars c
72
72
73instance FreeVars a => FreeVars [a] where
73instance FreeVars a => FreeVars [a] where
74 freeVars = concatMap freeVars
74 freeVars = concatMap freeVars
75
75
76occurs x t = x `elem` freeVars t
76occurs x t = x `elem` freeVars t
77
77
78−concretize :: Scheme -> GuidCounter (Type, [Context Constraint])
78+concretize :: Scheme -> GuidCounter (Type, [Located Constraint])
79concretize (Forall xs cs t) = do
79concretize (Forall xs cs t) = do
80 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
80 ss <- zip xs `liftM` mapM (\_ -> liftM VarT guid) xs
81 return (subst ss t, subst ss cs)
81 return (subst ss t, subst ss cs)
@@ -104,7 +104,7 @@ superize name tipe =
104 where
104 where
105 (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
105 (tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
106 t <: super = do x <- guid
106 t <: super = do x <- guid
107− return $ C (Just name) NoSpan (VarT t :<: super x)
107+ return $ L (Just name) NoSpan (VarT t :<: super x)
108
108
109 nmbr t = number
109 nmbr t = number
110 apnd t = appendable t
110 apnd t = appendable t
compiler/Types/Types.hs+2−2
@@ -1,7 +1,7 @@
1
1
2module Types.Types where
2module Types.Types where
3
3
4−import Context
4+import Located
5import Data.Char (isDigit)
5import Data.Char (isDigit)
6import Data.List (intercalate,isPrefixOf)
6import Data.List (intercalate,isPrefixOf)
7import qualified Data.Set as Set
7import qualified Data.Set as Set
@@ -17,7 +17,7 @@ data Type = LambdaT Type Type
17 | Super (Set.Set Type)
17 | Super (Set.Set Type)
18 deriving (Eq, Ord)
18 deriving (Eq, Ord)
19
19
20−data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord, Show)
20+data Scheme = Forall [X] [Located Constraint] Type deriving (Eq, Ord, Show)
21
21
22data Constraint = Type :=: Type
22data Constraint = Type :=: Type
23 | Type :<: Type
23 | Type :<: Type