git.iko.soy/elk
on master help sign in
Generate type constraints for patterns without any type lookups!
9bdfe2bEvan Czaplicki
src/Type/Constrain/Effects.hs+3−2
compare with master
unifiedsplit
@@ -16,7 +16,8 @@ import qualified Elm.Name as N
16import qualified Reporting.Error.Type as Error
16import qualified Reporting.Error.Type as Error
17import qualified Reporting.Region as R
17import qualified Reporting.Region as R
18import Type.Constraint (Constraint(..), Scheme(Scheme))
18import Type.Constraint (Constraint(..), Scheme(Scheme))
19+import qualified Type.Instantiate as Instantiate
19−import Type.Type (Type(..), Variable, (==>), fromFlexSrcType, mkFlexVar)
20+import Type.Type (Type(..), Variable, (==>), mkFlexVar)
20
21
21
22
22
23
@@ -72,7 +73,7 @@ deport port_ =
72
73
73fromSrcType :: T.Canonical -> IO Type
74fromSrcType :: T.Canonical -> IO Type
74fromSrcType tipe =
75fromSrcType tipe =
75− fst <$> fromFlexSrcType tipe
76+ fst <$> Instantiate.flexible tipe
76
77
77
78
78command :: ModuleName.Canonical -> N.Name -> IO Type
79command :: ModuleName.Canonical -> N.Name -> IO Type
src/Type/Constrain/Pattern.hs+175−93
@@ -1,126 +1,208 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) where
2+module Type.Constrain.Pattern
3+ ( Info(..)
4+ , constrain
5+ )
6+ where
3
7
8+
4−import Control.Arrow (second)
9+import Control.Monad (foldM)
5−import qualified Control.Monad as Monad
6import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
7−import qualified Data.List as List
8−import Data.Text (Text)
9
11
10−import qualified AST.Pattern as P
12+import qualified AST.Expression.Canonical as Can
11−import qualified AST.Variable as Var
13+import qualified AST.Module.Name as ModuleName
14+import qualified Data.Bag as Bag
15+import qualified Elm.Name as N
12import qualified Reporting.Annotation as A
16import qualified Reporting.Annotation as A
13import qualified Reporting.Error.Type as Error
17import qualified Reporting.Error.Type as Error
18+import qualified Reporting.Region as R
14import Type.Constraint
19import Type.Constraint
15import qualified Type.Constrain.Literal as Literal
20import qualified Type.Constrain.Literal as Literal
16−import qualified Type.Environment as Env
21+import qualified Type.Instantiate as Instantiate
17import Type.Type
22import Type.Type
18
23
19
24
20
25
21−-- PATTERN INFO
26+-- CONSTRAIN PATTERN
27+
28+
29+type Env = ()
30+
31+
32+constrain :: Env -> Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)
33+constrain env pattern tipe =
34+ do (Info headers vars cons) <-
35+ addConstraints env Error.PatternUnknown pattern tipe $
36+ Info Map.empty Bag.empty []
37+
38+ return ( headers, Bag.toList vars, CAnd (reverse cons) )
39+
40+
41+
42+-- ADD CONSTRAINTS
22
43
23
44
24data Info =
45data Info =
25 Info
46 Info
26− { _headers :: Map.Map Text (A.Located Type)
47+ { _headers :: Map.Map N.Name (A.Located Type)
27− , _vars :: [Variable]
48+ , _vars :: Bag.Bag Variable
28− , _cons :: Constraint
49+ , _cons :: [Constraint]
29 }
50 }
30
51
31
52
32−emptyInfo :: Info
53+addConstraints :: Env -> Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
33−emptyInfo =
54+addConstraints env context (A.A region pattern) tipe info =
34− Info Map.empty [] CTrue
55+ case pattern of
56+ Can.PAnything ->
57+ return info
35
58
59+ Can.PLiteral lit ->
60+ do let (Info headers vars revCons) = info
61+ litCon <- Literal.constrain region lit tipe
62+ return $ Info headers vars (litCon:revCons)
36
63
37−joinInfo :: Info -> Info -> Info
64+ Can.PVar name ->
38−joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
65+ do let (Info headers vars revCons) = info
39− Info
66+ let newHeaders = Map.insert name (A.A region tipe) headers
40− { _headers = Map.union headers1 headers2
67+ return $ Info newHeaders vars revCons
41− , _vars = vars1 ++ vars2
42− , _cons = cons1 /\ cons2
43− }
44
68
69+ Can.PAlias realPattern name ->
70+ do let (Info headers vars revCons) = info
71+ addConstraints env context realPattern tipe $
72+ Info (Map.insert name (A.A region tipe) headers) vars revCons
45
73
46−joinInfos :: [Info] -> Info
74+ Can.PUnit ->
47−joinInfos infos =
75+ do let (Info headers vars revCons) = info
48− List.foldl' (flip joinInfo) emptyInfo infos
76+ let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe
77+ return $ Info headers vars (unitCon:revCons)
49
78
79+ Can.PTuple a b maybeC ->
80+ addTupleConstraint env context region a b maybeC tipe info
50
81
51−infoToScheme :: Info -> Scheme
82+ Can.PCtor home typeName vs ctorName args ->
52−infoToScheme (Info headers vars cons) =
83+ do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
53− Scheme [] vars cons headers
54
84
85+ (Info headers vars revCons) <-
86+ foldM (addCtorConstraint env ctorName) info targs
55
87
88+ return $
89+ Info
90+ { _headers = headers
91+ , _vars = Bag.append vars (Bag.fromList id tvars)
92+ , _cons =
93+ CEqual (Error.Pattern context (Error.PCtor ctorName)) region ttype tipe
94+ : revCons
95+ }
56
96
57−-- CONSTRAIN PATTERN
97+ Can.PList patterns ->
98+ do entryVar <- mkFlexVar
99+ let entryVarN = VarN entryVar
100+ let listType = AppN ModuleName.list N.list [entryVarN]
101+
102+ (Info headers vars revCons) <-
103+ foldM
104+ (addListConstraint env entryVarN)
105+ info
106+ (zip patterns [ 1 .. length patterns ])
107+
108+ let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe
109+ return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)
110+
111+ Can.PCons headPattern tailPattern ->
112+ do headVar <- mkFlexVar
113+ tailVar <- mkFlexVar
114+ let headVarN = VarN headVar
115+ let tailVarN = VarN tailVar
116+ let tailType = AppN ModuleName.list N.list [tailVarN]
117+
118+ (Info headers vars revCons) <-
119+ addConstraints env Error.PatternTail tailPattern tailType =<<
120+ addConstraints env Error.PatternUnknown headPattern headVarN info
121+
122+ return $
123+ Info
124+ { _headers = headers
125+ , _vars = Bag.insert headVar (Bag.insert tailVar vars)
126+ , _cons =
127+ CEqual (Error.Pattern context Error.PList) region tailType tipe
128+ : CEqual Error.PatternCons region headVarN tailVarN
129+ : revCons
130+ }
58
131
132+ Can.PRecord fields ->
133+ do extVar <- mkFlexVar
59
134
60−constrain :: Env.Env -> P.Canonical -> Type -> IO Info
135+ fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
61−constrain env (A.A region pattern) tipe =
136+ let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
62− let
137+
63− equal patternError leftType rightType =
138+ let (Info headers vars revCons) = info
64− CEqual (Error.Pattern patternError) region leftType rightType
65−
66− rvar v =
67− A.A region (VarN v)
68− in
69− case pattern of
70− P.Anything ->
71− return emptyInfo
72−
73− P.Literal lit ->
74− do c <- Literal.constrain region lit tipe
75− return $ emptyInfo { _cons = c }
139+ return $
76−
77− P.Var name ->
78− do variable <- mkFlexVar
79− return $ Info
140+ Info
80− { _headers = Map.singleton name (rvar variable)
141+ { _headers = Map.union headers (Map.map (A.A region) fieldVarN)
81− , _vars = [variable]
142+ , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
82− , _cons = equal (Error.PVar name) (VarN variable) tipe
83− }
84−
85− P.Alias name ptrn ->
86− do variable <- mkFlexVar
87− info <- constrain env ptrn tipe
88− return $ info
89− { _headers = Map.insert name (rvar variable) (_headers info)
90− , _vars = variable : _vars info
91 , _cons =
143 , _cons =
92− equal (Error.PAlias name) (VarN variable) tipe
144+ CEqual
93− /\ _cons info
145+ (Error.Pattern context Error.PRecord)
146+ region
147+ (RecordN fieldVarN (VarN extVar))
148+ tipe
149+ : revCons
94 }
150 }
95
151
96− P.Ctor name patterns ->
152+
97− do (_kind, cvars, args, result) <-
153+
98− Env.freshDataScheme env (Var.toText name)
154+-- CONSTRAIN TUPLE
99−
155+
100− fragList <- Monad.zipWithM (constrain env) patterns args
156+
101− let info = joinInfos fragList
157+addTupleConstraint
102− return $ info
158+ :: Env
103− { _vars = cvars ++ _vars info
159+ -> Error.PatternContext
104− , _cons =
160+ -> R.Region
105− equal (Error.PCtor name) result tipe
161+ -> Can.Pattern
106− /\ _cons info
162+ -> Can.Pattern
107− }
163+ -> Maybe Can.Pattern
108−
164+ -> Type
109− P.Record fields ->
165+ -> Info
110− do pairs <-
166+ -> IO Info
111− mapM (\name -> (,) name <$> mkFlexVar) fields
167+addTupleConstraint env context region a b maybeC tipe (Info headers vars revCons) =
112−
168+ do let equal = CEqual (Error.Pattern context Error.PTuple) region
113− let tenv =
169+ let addCon = addConstraints env Error.PatternUnknown
114− Map.fromList (map (second rvar) pairs)
170+
115−
171+ aVar <- mkFlexVar
116− let unannotatedTenv =
172+ bVar <- mkFlexVar
117− Map.map A.drop tenv
173+ let aVarN = VarN aVar
118−
174+ let bVarN = VarN bVar
119− con <- exists $ \t ->
175+
120− return (equal Error.PRecord tipe (RecordN unannotatedTenv t))
176+ case maybeC of
121−
177+ Nothing ->
122− return $ Info
178+ do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
123− { _headers = tenv
179+ let newVars = Bag.insert aVar (Bag.insert bVar vars)
124− , _vars = map snd pairs
180+ addCon b bVarN =<<
125− , _cons = con
181+ addCon a aVarN (Info headers newVars (tupleCon:revCons))
126− }
182+
183+ Just c ->
184+ do cVar <- mkFlexVar
185+ let cVarN = VarN cVar
186+ let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
187+ let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
188+ addCon c cVarN =<<
189+ addCon b bVarN =<<
190+ addCon a aVarN (Info headers newVars (tupleCon:revCons))
191+
192+
193+
194+-- CONSTRAIN CONSTRUCTORS
195+
196+
197+addCtorConstraint :: Env -> N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info
198+addCtorConstraint env name info (index, argType, argPattern) =
199+ addConstraints env (Error.PatternArg name index) argPattern argType info
200+
201+
202+
203+-- CONSTRAIN LIST
204+
205+
206+addListConstraint :: Env -> Type -> Info -> (Can.Pattern, Int) -> IO Info
207+addListConstraint env tipe info (pattern, index) =
208+ addConstraints env (Error.PatternList index) pattern tipe info
src/Type/Instantiate.hsnew file+164
@@ -0,0 +1,164 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Type.Instantiate
4+ ( Ctor(..)
5+ , pattern
6+ , flexible
7+ , rigid
8+ )
9+ where
10+
11+
12+import Control.Arrow (second)
13+import qualified Data.Map.Strict as Map
14+import Data.Map.Strict ((!))
15+
16+import qualified AST.Expression.Canonical as Can
17+import qualified AST.Module.Name as ModuleName
18+import qualified AST.Type as T
19+import qualified Elm.Name as N
20+import Type.Type
21+
22+
23+
24+-- FROM PATTERN
25+
26+
27+data Ctor =
28+ Ctor
29+ { _vars :: [Variable]
30+ , _args :: [(Int, Type, Can.Pattern)]
31+ , _type :: Type
32+ }
33+
34+
35+pattern :: ModuleName.Canonical -> N.Name -> [N.Name] -> [(Int, T.Canonical, Can.Pattern)] -> IO Ctor
36+pattern home tipe tvars args =
37+ do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) tvars
38+ let typePairs = map (second VarN) varPairs
39+
40+ targs <- traverse (patternHelp (Map.fromList typePairs)) args
41+
42+ return $
43+ Ctor
44+ { _vars = map snd varPairs
45+ , _args = targs
46+ , _type = AppN home tipe (map snd typePairs)
47+ }
48+
49+
50+patternHelp :: Map.Map N.Name Type -> (i, T.Canonical, p) -> IO (i, Type, p)
51+patternHelp freeVarDict (index, srcType, arg) =
52+ do tipe <- fromSrcType freeVarDict srcType
53+ return (index, tipe, arg)
54+
55+
56+
57+-- FROM SOURCE TYPES
58+
59+
60+-- TODO should the freeFlexVars be ranked a certain way?
61+-- How does this interact with `TS.flatten` exactly?
62+flexible :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
63+flexible srcType =
64+ do let freeVars = gatherFreeVars srcType Map.empty
65+ freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars
66+ tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType
67+ return ( tipe, freeFlexVars )
68+
69+
70+rigid :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
71+rigid srcType =
72+ do let freeVars = gatherFreeVars srcType Map.empty
73+ freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars
74+ tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType
75+ return ( tipe, freeRigidVars )
76+
77+
78+
79+-- GATHER FREE VARS
80+
81+
82+gatherFreeVars :: T.Canonical -> Map.Map N.Name () -> Map.Map N.Name ()
83+gatherFreeVars tipe dict =
84+ case tipe of
85+ T.Lambda arg result ->
86+ gatherFreeVars result (gatherFreeVars arg dict)
87+
88+ T.Var name ->
89+ Map.insert name () dict
90+
91+ T.Type _ _ args ->
92+ foldr gatherFreeVars dict args
93+
94+ T.Aliased _ _ args _ ->
95+ foldr gatherFreeVars dict (map snd args)
96+
97+ T.Tuple a b maybeC ->
98+ gatherFreeVars a $ gatherFreeVars b $
99+ case maybeC of
100+ Nothing ->
101+ dict
102+
103+ Just c ->
104+ gatherFreeVars c dict
105+
106+ T.Unit ->
107+ dict
108+
109+ T.Record fields maybeExt ->
110+ case maybeExt of
111+ Nothing ->
112+ Map.foldr gatherFreeVars dict fields
113+
114+ Just ext ->
115+ Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields
116+
117+
118+
119+-- FROM SOURCE TYPE
120+
121+
122+fromSrcType :: Map.Map N.Name Type -> T.Canonical -> IO Type
123+fromSrcType freeVars sourceType =
124+ case sourceType of
125+ T.Lambda arg result ->
126+ FunN
127+ <$> fromSrcType freeVars arg
128+ <*> fromSrcType freeVars result
129+
130+ T.Var name ->
131+ return (freeVars ! name)
132+
133+ T.Type home name args ->
134+ AppN home name <$> traverse (fromSrcType freeVars) args
135+
136+ T.Aliased home name args aliasedType ->
137+ do targs <- traverse (traverse (fromSrcType freeVars)) args
138+ AliasN home name targs <$>
139+ case aliasedType of
140+ T.Filled realType ->
141+ fromSrcType freeVars realType
142+
143+ T.Holey realType ->
144+ fromSrcType (Map.fromList targs) realType
145+
146+ T.Tuple a b maybeC ->
147+ TupleN
148+ <$> fromSrcType freeVars a
149+ <*> fromSrcType freeVars b
150+ <*> traverse (fromSrcType freeVars) maybeC
151+
152+ T.Unit ->
153+ return UnitN
154+
155+ T.Record fields maybeExt ->
156+ RecordN
157+ <$> traverse (fromSrcType freeVars) fields
158+ <*>
159+ case maybeExt of
160+ Nothing ->
161+ return EmptyRecordN
162+
163+ Just ext ->
164+ fromSrcType freeVars ext
src/Type/Type.hs−106
@@ -19,8 +19,6 @@ module Type.Type
19 , nameToFlex
19 , nameToFlex
20 , nameToRigid
20 , nameToRigid
21 , toSrcType
21 , toSrcType
22− , fromFlexSrcType
23− , fromRigidSrcType
24 )
22 )
25 where
23 where
26
24
@@ -29,7 +27,6 @@ import qualified Control.Monad.State.Strict as State
29import qualified Data.Char as Char
27import qualified Data.Char as Char
30import Data.Foldable (foldrM)
28import Data.Foldable (foldrM)
31import qualified Data.Map.Strict as Map
29import qualified Data.Map.Strict as Map
32−import Data.Map.Strict ((!))
33import Data.Monoid ((<>))
30import Data.Monoid ((<>))
34import qualified Data.Text as Text
31import qualified Data.Text as Text
35import Data.Text (Text)
32import Data.Text (Text)
@@ -254,109 +251,6 @@ toSuper name =
254
251
255
252
256
253
257−-- FROM SOURCE TYPES
258−
259−
260−-- TODO should the freeFlexVars be ranked a certain way?
261−-- How does this interact with `TS.flatten` exactly?
262−fromFlexSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
263−fromFlexSrcType srcType =
264− do let freeVars = gatherFreeVars srcType Map.empty
265− freeFlexVars <- Map.traverseWithKey (\name () -> nameToFlex name) freeVars
266− tipe <- fromSrcType (Map.map VarN freeFlexVars) srcType
267− return ( tipe, freeFlexVars )
268−
269−
270−fromRigidSrcType :: T.Canonical -> IO ( Type, Map.Map N.Name Variable )
271−fromRigidSrcType srcType =
272− do let freeVars = gatherFreeVars srcType Map.empty
273− freeRigidVars <- Map.traverseWithKey (\name () -> nameToRigid name) freeVars
274− tipe <- fromSrcType (Map.map VarN freeRigidVars) srcType
275− return ( tipe, freeRigidVars )
276−
277−
278−gatherFreeVars :: T.Canonical -> Map.Map N.Name () -> Map.Map N.Name ()
279−gatherFreeVars tipe dict =
280− case tipe of
281− T.Lambda arg result ->
282− gatherFreeVars result (gatherFreeVars arg dict)
283−
284− T.Var name ->
285− Map.insert name () dict
286−
287− T.Type _ _ args ->
288− foldr gatherFreeVars dict args
289−
290− T.Aliased _ _ args _ ->
291− foldr gatherFreeVars dict (map snd args)
292−
293− T.Tuple a b maybeC ->
294− gatherFreeVars a $ gatherFreeVars b $
295− case maybeC of
296− Nothing ->
297− dict
298−
299− Just c ->
300− gatherFreeVars c dict
301−
302− T.Unit ->
303− dict
304−
305− T.Record fields maybeExt ->
306− case maybeExt of
307− Nothing ->
308− Map.foldr gatherFreeVars dict fields
309−
310− Just ext ->
311− Map.foldr gatherFreeVars (gatherFreeVars ext dict) fields
312−
313−
314−fromSrcType :: Map.Map N.Name Type -> T.Canonical -> IO Type
315−fromSrcType freeVars sourceType =
316− case sourceType of
317− T.Lambda arg result ->
318− FunN
319− <$> fromSrcType freeVars arg
320− <*> fromSrcType freeVars result
321−
322− T.Var name ->
323− return (freeVars ! name)
324−
325− T.Type home name args ->
326− AppN home name <$> traverse (fromSrcType freeVars) args
327−
328− T.Aliased home name args aliasedType ->
329− do targs <- traverse (traverse (fromSrcType freeVars)) args
330− AliasN home name targs <$>
331− case aliasedType of
332− T.Filled realType ->
333− fromSrcType freeVars realType
334−
335− T.Holey realType ->
336− fromSrcType (Map.fromList targs) realType
337−
338− T.Tuple a b maybeC ->
339− TupleN
340− <$> fromSrcType freeVars a
341− <*> fromSrcType freeVars b
342− <*> traverse (fromSrcType freeVars) maybeC
343−
344− T.Unit ->
345− return UnitN
346−
347− T.Record fields maybeExt ->
348− RecordN
349− <$> traverse (fromSrcType freeVars) fields
350− <*>
351− case maybeExt of
352− Nothing ->
353− return EmptyRecordN
354−
355− Just ext ->
356− fromSrcType freeVars ext
357−
358−
359−
360-- TO SOURCE TYPES
254-- TO SOURCE TYPES
361
255
362
256