git.iko.soy/elk
on master help sign in
Pipe source locations through the type checker
b1f53d0Evan Czaplicki
compiler/Type/Constrain/Expression.hs+25−19
compare with master
unifiedsplit
@@ -22,10 +22,16 @@ import qualified Transform.SortDefinitions as SD
22
22
23
23
24constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
24constrain :: Env.Environment -> LExpr a b -> Type -> IO TypeConstraint
25−constrain env (L _ expr) tipe =
25+constrain env (L span expr) tipe =
26− let list t = Env.get env Env.types "_List" <| t in
26+ let list t = Env.get env Env.types "_List" <| t
27+ and = L span . CAnd
28+ true = L span CTrue
29+ t1 === t2 = L span (CEqual t1 t2)
30+ x <? t = L span (CInstance x t)
31+ clet schemes c = L span (CLet schemes c)
32+ in
27 case expr of
33 case expr of
28− Literal lit -> Literal.constrain env lit tipe
34+ Literal lit -> Literal.constrain env span lit tipe
29
35
30 Var name -> return (name <? tipe)
36 Var name -> return (name <? tipe)
31
37
@@ -33,26 +39,26 @@ constrain env (L _ expr) tipe =
33 exists $ \x -> do
39 exists $ \x -> do
34 clo <- constrain env lo x
40 clo <- constrain env lo x
35 chi <- constrain env hi x
41 chi <- constrain env hi x
36− return $ CAnd [clo, chi, list x === tipe]
42+ return $ and [clo, chi, list x === tipe]
37
43
38 ExplicitList exprs ->
44 ExplicitList exprs ->
39 exists $ \x -> do
45 exists $ \x -> do
40 cs <- mapM (\e -> constrain env e x) exprs
46 cs <- mapM (\e -> constrain env e x) exprs
41− return $ CAnd (list x === tipe : cs)
47+ return . and $ list x === tipe : cs
42
48
43 Binop op e1 e2 ->
49 Binop op e1 e2 ->
44 exists $ \t1 ->
50 exists $ \t1 ->
45 exists $ \t2 -> do
51 exists $ \t2 -> do
46 c1 <- constrain env e1 t1
52 c1 <- constrain env e1 t1
47 c2 <- constrain env e2 t2
53 c2 <- constrain env e2 t2
48− return $ CAnd [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]
54+ return $ and [ c1, c2, op <? (t1 ==> t2 ==> tipe) ]
49
55
50 Lambda p e ->
56 Lambda p e ->
51 exists $ \t1 ->
57 exists $ \t1 ->
52 exists $ \t2 -> do
58 exists $ \t2 -> do
53 fragment <- Pattern.constrain env p t1
59 fragment <- Pattern.constrain env p t1
54 c2 <- constrain env e t2
60 c2 <- constrain env e t2
55− let c = ex (vars fragment) (CLet [monoscheme (typeEnv fragment)]
61+ let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]
56 (typeConstraint fragment /\ c2 ))
62 (typeConstraint fragment /\ c2 ))
57 return $ c /\ tipe === (t1 ==> t2)
63 return $ c /\ tipe === (t1 ==> t2)
58
64
@@ -62,7 +68,7 @@ constrain env (L _ expr) tipe =
62 c2 <- constrain env e2 t
68 c2 <- constrain env e2 t
63 return $ c1 /\ c2
69 return $ c1 /\ c2
64
70
65− MultiIf branches -> CAnd <$> mapM constrain' branches
71+ MultiIf branches -> and <$> mapM constrain' branches
66 where
72 where
67 bool = Env.get env Env.types "Bool"
73 bool = Env.get env Env.types "Bool"
68 constrain' (b,e) = do
74 constrain' (b,e) = do
@@ -75,12 +81,12 @@ constrain env (L _ expr) tipe =
75 ce <- constrain env exp t
81 ce <- constrain env exp t
76 let branch (p,e) = do
82 let branch (p,e) = do
77 fragment <- Pattern.constrain env p t
83 fragment <- Pattern.constrain env p t
78− CLet [toScheme fragment] <$> constrain env e tipe
84+ clet [toScheme fragment] <$> constrain env e tipe
79− CAnd . (:) ce <$> mapM branch branches
85+ and . (:) ce <$> mapM branch branches
80
86
81 Data name exprs ->
87 Data name exprs ->
82 do pairs <- mapM pair exprs
88 do pairs <- mapM pair exprs
83− (ctipe, cs) <- Monad.foldM step (tipe,CTrue) (reverse pairs)
89+ (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
84 return (cs /\ name <? ctipe)
90 return (cs /\ name <? ctipe)
85 where
91 where
86 pair e = do v <- var Flexible -- needs an ex
92 pair e = do v <- var Flexible -- needs an ex
@@ -104,7 +110,7 @@ constrain env (L _ expr) tipe =
104 cVal <- constrain env value tVal
110 cVal <- constrain env value tVal
105 cRec <- constrain env e tRec
111 cRec <- constrain env e tRec
106 let c = tipe === record (Map.singleton label [tVal]) tRec
112 let c = tipe === record (Map.singleton label [tVal]) tRec
107− return (CAnd [cVal, cRec, c])
113+ return (and [cVal, cRec, c])
108
114
109 Modify e fields ->
115 Modify e fields ->
110 exists $ \t -> do
116 exists $ \t -> do
@@ -118,28 +124,28 @@ constrain env (L _ expr) tipe =
118
124
119 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
125 cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
120
126
121− return $ cOld /\ ex newVars (CAnd (cNew : cs))
127+ return $ cOld /\ ex newVars (and (cNew : cs))
122
128
123 Record fields ->
129 Record fields ->
124 do vars <- forM fields $ \_ -> var Flexible
130 do vars <- forM fields $ \_ -> var Flexible
125 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
131 cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
126 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
132 let fields' = SrcT.fieldMap (zip (map fst fields) (map VarN vars))
127 recordType = record fields' (TermN EmptyRecord1)
133 recordType = record fields' (TermN EmptyRecord1)
128− return . ex vars $ CAnd (tipe === recordType : cs)
134+ return . ex vars . and $ tipe === recordType : cs
129
135
130 Markdown _ ->
136 Markdown _ ->
131 return $ tipe === Env.get env Env.types "Element"
137 return $ tipe === Env.get env Env.types "Element"
132
138
133 Let defs body ->
139 Let defs body ->
134 do c <- case body of
140 do c <- case body of
135− L _ (Var name) | name == saveEnvName -> return CSaveEnv
141+ L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)
136 _ -> constrain env body tipe
142 _ -> constrain env body tipe
137 (schemes, rqs, fqs, header, c2, c1) <-
143 (schemes, rqs, fqs, header, c2, c1) <-
138 Monad.foldM (constrainDef env)
144 Monad.foldM (constrainDef env)
139− ([], [], [], Map.empty, CTrue, CTrue)
145+ ([], [], [], Map.empty, true, true)
140 (collapseDefs defs)
146 (collapseDefs defs)
141− return $ CLet schemes
147+ return $ clet schemes
142− (CLet [Scheme rqs fqs (CLet [monoscheme header] c2) header ]
148+ (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]
143 (c1 /\ c))
149 (c1 /\ c))
144
150
145constrainDef env info (pattern, expr, maybeTipe) =
151constrainDef env info (pattern, expr, maybeTipe) =
@@ -154,7 +160,7 @@ constrainDef env info (pattern, expr, maybeTipe) =
154 (vars, typ) <- Env.instantiateType env tipe Map.empty
160 (vars, typ) <- Env.instantiateType env tipe Map.empty
155 let scheme = Scheme { rigidQuantifiers = [],
161 let scheme = Scheme { rigidQuantifiers = [],
156 flexibleQuantifiers = flexiVars ++ vars,
162 flexibleQuantifiers = flexiVars ++ vars,
157− constraint = CTrue,
163+ constraint = Loc.none CTrue,
158 header = Map.singleton name typ }
164 header = Map.singleton name typ }
159 c <- constrain env' expr typ
165 c <- constrain env' expr typ
160 return ( scheme : schemes
166 return ( scheme : schemes
compiler/Type/Constrain/Literal.hs+15−9
@@ -4,16 +4,22 @@ import Data.Map ((!))
4import qualified Data.Map as Map
4import qualified Data.Map as Map
5
5
6import SourceSyntax.Literal
6import SourceSyntax.Literal
7+import SourceSyntax.Location
7import Type.Type
8import Type.Type
8import Type.Fragment
9import Type.Fragment
9import Type.Environment as Env
10import Type.Environment as Env
10
11
11−constrain :: Environment -> Literal -> Type -> IO TypeConstraint
12+constrain :: Environment -> SrcSpan -> Literal -> Type -> IO TypeConstraint
12−constrain env literal tipe =
13+constrain env span literal tipe =
14+ do tipe' <- litType
15+ return . L span $ CEqual tipe tipe'
16+ where
13− let prim name = Env.get env Env.types name in
17+ prim name = Env.get env Env.types name
18+
19+ litType =
14− case literal of
20+ case literal of
15− IntNum _ -> fmap (\n -> tipe === VarN n) (var (Is Number))
21+ IntNum _ -> VarN `fmap` var (Is Number)
16− FloatNum _ -> return $ tipe === prim "Float"
22+ FloatNum _ -> return (prim "Float")
17− Chr _ -> return $ tipe === prim "Char"
23+ Chr _ -> return (prim "Char")
18− Str _ -> return $ tipe === TermN (App1 (prim "_List") (prim "Char"))
24+ Str _ -> return (TermN (App1 (prim "_List") (prim "Char")))
19− Boolean _ -> return $ tipe === prim "Bool"
25+ Boolean _ -> return (prim "Bool")
compiler/Type/Constrain/Pattern.hs+6−1
@@ -9,6 +9,7 @@ import Data.Map ((!))
9import qualified Data.Map as Map
9import qualified Data.Map as Map
10
10
11import SourceSyntax.Pattern
11import SourceSyntax.Pattern
12+import qualified SourceSyntax.Location as Loc
12import Type.Type
13import Type.Type
13import Type.Fragment
14import Type.Fragment
14import Type.Environment as Env
15import Type.Environment as Env
@@ -17,11 +18,15 @@ import qualified Type.Constrain.Literal as Literal
17
18
18constrain :: Environment -> Pattern -> Type -> IO Fragment
19constrain :: Environment -> Pattern -> Type -> IO Fragment
19constrain env pattern tipe =
20constrain env pattern tipe =
21+ let span = Loc.NoSpan
22+ t1 === t2 = Loc.L span (CEqual t1 t2)
23+ x <? t = Loc.L span (CInstance x t)
24+ in
20 case pattern of
25 case pattern of
21 PAnything -> return emptyFragment
26 PAnything -> return emptyFragment
22
27
23 PLiteral lit -> do
28 PLiteral lit -> do
24− c <- Literal.constrain env lit tipe
29+ c <- Literal.constrain env span lit tipe
25 return $ emptyFragment { typeConstraint = c }
30 return $ emptyFragment { typeConstraint = c }
26
31
27 PVar name -> do
32 PVar name -> do
compiler/Type/Fragment.hs+2−1
@@ -5,6 +5,7 @@ import qualified Data.Map as Map
5
5
6import Type.Type
6import Type.Type
7import SourceSyntax.Pattern
7import SourceSyntax.Pattern
8+import SourceSyntax.Location (none)
8
9
9data Fragment = Fragment {
10data Fragment = Fragment {
10 typeEnv :: Map.Map String Type,
11 typeEnv :: Map.Map String Type,
@@ -12,7 +13,7 @@ data Fragment = Fragment {
12 typeConstraint :: TypeConstraint
13 typeConstraint :: TypeConstraint
13} deriving Show
14} deriving Show
14
15
15−emptyFragment = Fragment Map.empty [] CTrue
16+emptyFragment = Fragment Map.empty [] (none CTrue)
16
17
17joinFragment f1 f2 = Fragment {
18joinFragment f1 f2 = Fragment {
18 typeEnv = Map.union (typeEnv f1) (typeEnv f2),
19 typeEnv = Map.union (typeEnv f1) (typeEnv f2),
compiler/Type/Inference.hs+2−1
@@ -10,6 +10,7 @@ import qualified Type.Solve as Solve
10
10
11import SourceSyntax.Module as Module
11import SourceSyntax.Module as Module
12import qualified SourceSyntax.Expression as Expr
12import qualified SourceSyntax.Expression as Expr
13+import SourceSyntax.Location (none)
13import SourceSyntax.PrettyPrint
14import SourceSyntax.PrettyPrint
14import Text.PrettyPrint
15import Text.PrettyPrint
15import qualified Type.State as TS
16import qualified Type.State as TS
@@ -37,7 +38,7 @@ infer interfaces modul = unsafePerformIO $ do
37 let allTypes = ctors ++ importedVars
38 let allTypes = ctors ++ importedVars
38 vars = concatMap (fst . snd) allTypes
39 vars = concatMap (fst . snd) allTypes
39 header = Map.map snd (Map.fromList allTypes)
40 header = Map.map snd (Map.fromList allTypes)
40− environ = T.CLet [ T.Scheme vars [] T.CTrue header ]
41+ environ = none . T.CLet [ T.Scheme vars [] (none T.CTrue) header ]
41
42
42 fvar <- T.var T.Flexible
43 fvar <- T.var T.Flexible
43 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
44 constraint <- environ `fmap` TcExpr.constrain env (program modul) (T.VarN fvar)
compiler/Type/Solve.hs+3−2
@@ -13,6 +13,7 @@ import Type.Unify
13import qualified Type.Environment as Env
13import qualified Type.Environment as Env
14import qualified Type.State as TS
14import qualified Type.State as TS
15import qualified Text.PrettyPrint as P
15import qualified Text.PrettyPrint as P
16+import SourceSyntax.Location (Located(L))
16
17
17
18
18-- | Every variable has rank less than or equal to the maxRank of the pool.
19-- | Every variable has rank less than or equal to the maxRank of the pool.
@@ -92,7 +93,7 @@ adjustRank youngMark visitedMark groupRank variable =
92
93
93
94
94solve :: TypeConstraint -> StateT TS.SolverState IO ()
95solve :: TypeConstraint -> StateT TS.SolverState IO ()
95−solve constraint =
96+solve (L span constraint) =
96 case constraint of
97 case constraint of
97 CTrue -> return ()
98 CTrue -> return ()
98
99
@@ -105,7 +106,7 @@ solve constraint =
105
106
106 CAnd cs -> mapM_ solve cs
107 CAnd cs -> mapM_ solve cs
107
108
108− CLet [Scheme [] fqs constraint' _] CTrue -> do
109+ CLet [Scheme [] fqs constraint' _] (L _ CTrue) -> do
109 oldEnv <- TS.getEnv
110 oldEnv <- TS.getEnv
110 mapM TS.introduce fqs
111 mapM TS.introduce fqs
111 solve constraint'
112 solve constraint'
compiler/Type/Type.hs+24−19
@@ -10,6 +10,7 @@ import System.IO.Unsafe
10import Control.Applicative ((<$>),(<*>))
10import Control.Applicative ((<$>),(<*>))
11import Control.Monad.State
11import Control.Monad.State
12import Data.Traversable (traverse)
12import Data.Traversable (traverse)
13+import SourceSyntax.Location
13import SourceSyntax.Helpers (isTuple)
14import SourceSyntax.Helpers (isTuple)
14import qualified SourceSyntax.Type as Src
15import qualified SourceSyntax.Type as Src
15
16
@@ -35,7 +36,8 @@ type Variable = UF.Point Descriptor
35type SchemeName = String
36type SchemeName = String
36type TypeName = String
37type TypeName = String
37
38
38−data Constraint a b
39+type Constraint a b = Located (BasicConstraint a b)
40+data BasicConstraint a b
39 = CTrue
41 = CTrue
40 | CSaveEnv
42 | CSaveEnv
41 | CEqual a a
43 | CEqual a a
@@ -54,20 +56,16 @@ data Scheme a b = Scheme {
54type TypeConstraint = Constraint Type Variable
56type TypeConstraint = Constraint Type Variable
55type TypeScheme = Scheme Type Variable
57type TypeScheme = Scheme Type Variable
56
58
57−monoscheme headers = Scheme [] [] CTrue headers
59+monoscheme headers = Scheme [] [] (none CTrue) headers
58
60
59infixl 8 /\
61infixl 8 /\
60
62
61(/\) :: Constraint a b -> Constraint a b -> Constraint a b
63(/\) :: Constraint a b -> Constraint a b -> Constraint a b
62−a /\ CTrue = a
64+a@(L s1 c1) /\ b@(L s2 c2) =
65+ case (c1, c2) of
63−CTrue /\ b = b
66+ (CTrue, _) -> b
67+ (_, CTrue) -> a
64−a /\ b = CAnd [a,b]
68+ _ -> merge a b (CAnd [a,b])
65−
66−(===) :: Type -> Type -> TypeConstraint
67−(===) = CEqual
68−
69−(<?) :: SchemeName -> Type -> TypeConstraint
70−x <? t = CInstance x t
71
69
72infixr 9 ==>
70infixr 9 ==>
73(==>) :: Type -> Type -> Type
71(==>) :: Type -> Type -> Type
@@ -126,11 +124,11 @@ structuredVar structure = UF.fresh $ Descriptor {
126
124
127-- ex qs constraint == exists qs. constraint
125-- ex qs constraint == exists qs. constraint
128ex :: [Variable] -> TypeConstraint -> TypeConstraint
126ex :: [Variable] -> TypeConstraint -> TypeConstraint
129−ex fqs constraint = CLet [Scheme [] fqs constraint Map.empty] CTrue
127+ex fqs constraint@(L s _) = L s $ CLet [Scheme [] fqs constraint Map.empty] (L s CTrue)
130
128
131-- fl qs constraint == forall qs. constraint
129-- fl qs constraint == forall qs. constraint
132fl :: [Variable] -> TypeConstraint -> TypeConstraint
130fl :: [Variable] -> TypeConstraint -> TypeConstraint
133−fl rqs constraint = CLet [Scheme rqs [] constraint Map.empty] CTrue
131+fl rqs constraint@(L s _) = L s $ CLet [Scheme rqs [] constraint Map.empty] (L s CTrue)
134
132
135exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
133exists :: (Type -> IO TypeConstraint) -> IO TypeConstraint
136exists f = do
134exists f = do
@@ -146,6 +144,10 @@ instance PrettyType a => PrettyType (UF.Point a) where
146 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
144 pretty when point = unsafePerformIO $ fmap (pretty when) (UF.descriptor point)
147
145
148
146
147+instance PrettyType a => PrettyType (Located a) where
148+ pretty when (L _ e) = pretty when e
149+
150+
149instance PrettyType a => PrettyType (Term1 a) where
151instance PrettyType a => PrettyType (Term1 a) where
150 pretty when term =
152 pretty when term =
151 let prty = pretty Never in
153 let prty = pretty Never in
@@ -194,7 +196,7 @@ instance PrettyType Descriptor where
194 _ -> P.text "?"
196 _ -> P.text "?"
195
197
196
198
197−instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
199+instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where
198 pretty _ constraint =
200 pretty _ constraint =
199 let prty = pretty Never in
201 let prty = pretty Never in
200 case constraint of
202 case constraint of
@@ -206,12 +208,12 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
206 CAnd cs ->
208 CAnd cs ->
207 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
209 P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs)
208
210
209− CLet [Scheme [] fqs constraint header] CTrue | Map.null header ->
211+ CLet [Scheme [] fqs constraint header] (L _ CTrue) | Map.null header ->
210 P.sep [ binder, pretty Never c ]
212 P.sep [ binder, pretty Never c ]
211 where
213 where
212− mergeExists vs c =
214+ mergeExists vs (L _ c) =
213 case c of
215 case c of
214− CLet [Scheme [] fqs' c' _] CTrue -> mergeExists (vs ++ fqs') c'
216+ CLet [Scheme [] fqs' c' _] (L _ CTrue) -> mergeExists (vs ++ fqs') c'
215 _ -> (vs, c)
217 _ -> (vs, c)
216
218
217 (fqs', c) = mergeExists fqs constraint
219 (fqs', c) = mergeExists fqs constraint
@@ -227,7 +229,7 @@ instance (PrettyType a, PrettyType b) => PrettyType (Constraint a b) where
227 P.text name <+> P.text "<" <+> prty tipe
229 P.text name <+> P.text "<" <+> prty tipe
228
230
229instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
231instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where
230− pretty _ (Scheme rqs fqs constraint headers) =
232+ pretty _ (Scheme rqs fqs (L _ constraint) headers) =
231 P.sep [ forall, cs, headers' ]
233 P.sep [ forall, cs, headers' ]
232 where
234 where
233 prty = pretty Never
235 prty = pretty Never
@@ -287,7 +289,10 @@ class Crawl t where
287 -> t
289 -> t
288 -> StateT CrawlState IO t
290 -> StateT CrawlState IO t
289
291
292+instance Crawl a => Crawl (Located a) where
293+ crawl nextState (L s e) = L s <$> crawl nextState e
294+
290−instance (Crawl t, Crawl v) => Crawl (Constraint t v) where
295+instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where
291 crawl nextState constraint =
296 crawl nextState constraint =
292 let rnm = crawl nextState in
297 let rnm = crawl nextState in
293 case constraint of
298 case constraint of