git.iko.soy/elk
on master help sign in
Move Type.Fragment into Type.Constrain.Pattern
afb08b8Evan Czaplicki
elm-compiler.cabal−1
compare with master
unifiedsplit
@@ -130,7 +130,6 @@ Library
130 Type.Constrain.Literal,
130 Type.Constrain.Literal,
131 Type.Constrain.Pattern,
131 Type.Constrain.Pattern,
132 Type.Environment,
132 Type.Environment,
133− Type.Fragment,
134 Type.Inference,
133 Type.Inference,
135 Type.Solve,
134 Type.Solve,
136 Type.State,
135 Type.State,
src/Type/Constrain/Expression.hs+6−10
@@ -18,7 +18,6 @@ import qualified Type.Constrain.Effects as Effects
18import qualified Type.Constrain.Literal as Literal
18import qualified Type.Constrain.Literal as Literal
19import qualified Type.Constrain.Pattern as Pattern
19import qualified Type.Constrain.Pattern as Pattern
20import qualified Type.Environment as Env
20import qualified Type.Environment as Env
21−import qualified Type.Fragment as Fragment
22import Type.Type hiding (Descriptor(..))
21import Type.Type hiding (Descriptor(..))
23
22
24
23
@@ -87,14 +86,11 @@ constrain env annotatedExpr@(A.A region expression) tipe =
87 E.Lambda pattern body ->
86 E.Lambda pattern body ->
88 exists $ \argType ->
87 exists $ \argType ->
89 exists $ \resType ->
88 exists $ \resType ->
90− do fragment <- Pattern.constrain env pattern argType
89+ do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType
91 bodyCon <- constrain env body resType
90 bodyCon <- constrain env body resType
92− let con =
91+ return $
93− ex (Fragment.vars fragment)
92+ ex vars (CLet [monoscheme headers] (cons /\ bodyCon))
94− (CLet [monoscheme (Fragment.typeEnv fragment)]
95− (Fragment.typeConstraint fragment /\ bodyCon)
96− )
97− return $ con /\ CEqual Error.Lambda region (argType ==> resType) tipe
93+ /\ CEqual Error.Lambda region (argType ==> resType) tipe
98
94
99 E.App _ _ ->
95 E.App _ _ ->
100 let
96 let
@@ -391,11 +387,11 @@ constrainCase env region expr branches tipe =
391 where
387 where
392 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =
388 branch patternType (pattern, branchExpr@(A.A branchRegion _)) =
393 do branchVar <- mkVar Nothing
389 do branchVar <- mkVar Nothing
394− fragment <- Pattern.constrain env pattern patternType
390+ scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType
395 branchCon <- constrain env branchExpr (VarN branchVar)
391 branchCon <- constrain env branchExpr (VarN branchVar)
396 return
392 return
397 ( (branchVar, branchRegion)
393 ( (branchVar, branchRegion)
398− , CLet [Fragment.toScheme fragment] branchCon
394+ , CLet [scheme] branchCon
399 )
395 )
400
396
401 varToCon var =
397 varToCon var =
src/Type/Constrain/Pattern.hs+73−33
@@ -1,7 +1,9 @@
1+{-# OPTIONS_GHC -Wall #-}
1−module Type.Constrain.Pattern where
2+module Type.Constrain.Pattern (Info(..), infoToScheme, constrain) where
2
3
3import Control.Arrow (second)
4import Control.Arrow (second)
4import qualified Control.Monad as Monad
5import qualified Control.Monad as Monad
6+import qualified Data.List as List
5import qualified Data.Map as Map
7import qualified Data.Map as Map
6
8
7import qualified AST.Pattern as P
9import qualified AST.Pattern as P
@@ -10,11 +12,50 @@ import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Type as Error
12import qualified Reporting.Error.Type as Error
11import qualified Type.Constrain.Literal as Literal
13import qualified Type.Constrain.Literal as Literal
12import qualified Type.Environment as Env
14import qualified Type.Environment as Env
13−import Type.Fragment
14import Type.Type
15import Type.Type
15
16
16
17
18+
19+-- PATTERN INFO
20+
21+
22+data Info =
23+ Info
24+ { _headers :: Map.Map String (A.Located Type)
25+ , _vars :: [Variable]
26+ , _cons :: TypeConstraint
27+ }
28+
29+
30+emptyInfo :: Info
31+emptyInfo =
32+ Info Map.empty [] CTrue
33+
34+
35+joinInfo :: Info -> Info -> Info
36+joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
37+ Info
38+ { _headers = Map.union headers1 headers2
39+ , _vars = vars1 ++ vars2
40+ , _cons = cons1 /\ cons2
41+ }
42+
43+
44+joinInfos :: [Info] -> Info
45+joinInfos infos =
46+ List.foldl' (flip joinInfo) emptyInfo infos
47+
48+
49+infoToScheme :: Info -> Scheme Type Variable
50+infoToScheme (Info headers vars cons) =
51+ Scheme [] vars cons headers
52+
53+
54+
55+-- CONSTRAIN PATTERN
56+
57+
17−constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment
58+constrain :: Env.Environment -> P.Canonical -> Type -> IO Info
18constrain env (A.A region pattern) tipe =
59constrain env (A.A region pattern) tipe =
19 let
60 let
20 equal patternError leftType rightType =
61 equal patternError leftType rightType =
@@ -23,50 +64,49 @@ constrain env (A.A region pattern) tipe =
23 rvar v =
64 rvar v =
24 A.A region (VarN v)
65 A.A region (VarN v)
25 in
66 in
26− case pattern of
67+ case pattern of
27− P.Anything ->
68+ P.Anything ->
28− return emptyFragment
69+ return emptyInfo
29
70
30− P.Literal lit ->
71+ P.Literal lit ->
31 do c <- Literal.constrain env region lit tipe
72 do c <- Literal.constrain env region lit tipe
32− return $ emptyFragment { typeConstraint = c }
73+ return $ emptyInfo { _cons = c }
33
74
34− P.Var name ->
75+ P.Var name ->
35 do variable <- mkVar Nothing
76 do variable <- mkVar Nothing
36− return $ Fragment
77+ return $ Info
37− { typeEnv = Map.singleton name (rvar variable)
78+ { _headers = Map.singleton name (rvar variable)
38− , vars = [variable]
79+ , _vars = [variable]
39− , typeConstraint =
40− equal (Error.PVar name) (VarN variable) tipe
80+ , _cons = equal (Error.PVar name) (VarN variable) tipe
41 }
81 }
42
82
43− P.Alias name p ->
83+ P.Alias name ptrn ->
44 do variable <- mkVar Nothing
84 do variable <- mkVar Nothing
45− fragment <- constrain env p tipe
85+ info <- constrain env ptrn tipe
46− return $ fragment
86+ return $ info
47− { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)
87+ { _headers = Map.insert name (rvar variable) (_headers info)
48− , vars = variable : vars fragment
88+ , _vars = variable : _vars info
49− , typeConstraint =
89+ , _cons =
50 equal (Error.PAlias name) (VarN variable) tipe
90 equal (Error.PAlias name) (VarN variable) tipe
51− /\ typeConstraint fragment
91+ /\ _cons info
52 }
92 }
53
93
54− P.Data name patterns ->
94+ P.Data name patterns ->
55 do let stringName = V.toString name
95 do let stringName = V.toString name
56
96
57 (_kind, cvars, args, result) <-
97 (_kind, cvars, args, result) <-
58 Env.freshDataScheme env stringName
98 Env.freshDataScheme env stringName
59
99
60 fragList <- Monad.zipWithM (constrain env) patterns args
100 fragList <- Monad.zipWithM (constrain env) patterns args
61− let fragment = joinFragments fragList
101+ let info = joinInfos fragList
62− return $ fragment
102+ return $ info
63− { vars = cvars ++ vars fragment
103+ { _vars = cvars ++ _vars info
64− , typeConstraint =
104+ , _cons =
65− typeConstraint fragment
66− /\ equal (Error.PData stringName) tipe result
105+ equal (Error.PData stringName) result tipe
106+ /\ _cons info
67 }
107 }
68
108
69− P.Record fields ->
109+ P.Record fields ->
70 do pairs <-
110 do pairs <-
71 mapM (\name -> (,) name <$> mkVar Nothing) fields
111 mapM (\name -> (,) name <$> mkVar Nothing) fields
72
112
@@ -79,8 +119,8 @@ constrain env (A.A region pattern) tipe =
79 con <- exists $ \t ->
119 con <- exists $ \t ->
80 return (equal Error.PRecord tipe (record unannotatedTenv t))
120 return (equal Error.PRecord tipe (record unannotatedTenv t))
81
121
82− return $ Fragment
122+ return $ Info
83− { typeEnv = tenv
123+ { _headers = tenv
84− , vars = map snd pairs
124+ , _vars = map snd pairs
85− , typeConstraint = con
125+ , _cons = con
86 }
126 }
src/Type/Fragment.hsdeleted−44
@@ -1,44 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Type.Fragment where
3−
4−import qualified Data.List as List
5−import qualified Data.Map as Map
6−
7−import Reporting.Annotation as A
8−import Type.Type
9−
10−
11−data Fragment = Fragment
12− { typeEnv :: Map.Map String (A.Located Type)
13− , vars :: [Variable]
14− , typeConstraint :: TypeConstraint
15− }
16−
17−
18−emptyFragment :: Fragment
19−emptyFragment =
20− Fragment Map.empty [] CTrue
21−
22−
23−joinFragment :: Fragment -> Fragment -> Fragment
24−joinFragment f1 f2 =
25− Fragment
26− { typeEnv =
27− Map.union (typeEnv f1) (typeEnv f2)
28−
29− , vars =
30− vars f1 ++ vars f2
31−
32− , typeConstraint =
33− typeConstraint f1 /\ typeConstraint f2
34− }
35−
36−
37−joinFragments :: [Fragment] -> Fragment
38−joinFragments =
39− List.foldl' (flip joinFragment) emptyFragment
40−
41−
42−toScheme :: Fragment -> Scheme Type Variable
43−toScheme fragment =
44− Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment)