git.iko.soy/elk
on master help sign in
Generate type constraints for patterns without any type lookups!

Moved the type instantiation code to Type.Instantiate. I suspect there will be a couple different ways to instantiate types. Some go to Type, others to Variable. Some know all the free variables already, some do not in the current implementation. That sort of thing. From there, I redid the type constraint generation for patterns. The new version should generate fewer constraints and produce nicer error messages. This code should be faster because (1) it no longer looks up pattern types in a dictionary costing O(log2(n)) in the number of patterns and (2) there are fewer constraints to solve.

commit9bdfe2bb51e1091a9722fe16b8382fe997b08a10 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 6 Nov 2017, 15:48 (9 years ago) parent1aaf793
4 files changed+342−201
compare with master
unifiedsplit
src/Type/Constrain/Effects.hs+3−2 src/Type/Constrain/Pattern.hs+175−93 src/Type/Instantiate.hs+164 src/Type/Type.hs−106
src/Type/Constrain/Effects.hs+3−2
@@ -16,7 +16,8 @@ import qualified Elm.Name as N
1616import qualified Reporting.Error.Type as Error
1717import qualified Reporting.Region as R
1818import Type.Constraint (Constraint(..), Scheme(Scheme))
19−import Type.Type (Type(..), Variable, (==>), fromFlexSrcType, mkFlexVar)
19+import qualified Type.Instantiate as Instantiate
20+import Type.Type (Type(..), Variable, (==>), mkFlexVar)
2021
2122
2223
@@ -72,7 +73,7 @@ deport port_ =
7273
7374fromSrcType :: T.Canonical -> IO Type
7475fromSrcType tipe =
75− fst <$> fromFlexSrcType tipe
76+ fst <$> Instantiate.flexible tipe
7677
7778
7879command :: ModuleName.Canonical -> N.Name -> IO Type
src/Type/Constrain/Pattern.hs+175−93
@@ -1,126 +1,208 @@
11{-# 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
37
4−import Control.Arrow (second)
5−import qualified Control.Monad as Monad
8+
9+import Control.Monad (foldM)
610import qualified Data.Map.Strict as Map
7−import qualified Data.List as List
8−import Data.Text (Text)
911
10−import qualified AST.Pattern as P
11−import qualified AST.Variable as Var
12+import qualified AST.Expression.Canonical as Can
13+import qualified AST.Module.Name as ModuleName
14+import qualified Data.Bag as Bag
15+import qualified Elm.Name as N
1216import qualified Reporting.Annotation as A
1317import qualified Reporting.Error.Type as Error
18+import qualified Reporting.Region as R
1419import Type.Constraint
1520import qualified Type.Constrain.Literal as Literal
16−import qualified Type.Environment as Env
21+import qualified Type.Instantiate as Instantiate
1722import Type.Type
1823
1924
2025
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
2243
2344
2445data Info =
2546 Info
26− { _headers :: Map.Map Text (A.Located Type)
27− , _vars :: [Variable]
28− , _cons :: Constraint
47+ { _headers :: Map.Map N.Name (A.Located Type)
48+ , _vars :: Bag.Bag Variable
49+ , _cons :: [Constraint]
2950 }
3051
3152
32−emptyInfo :: Info
33−emptyInfo =
34− Info Map.empty [] CTrue
53+addConstraints :: Env -> Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
54+addConstraints env context (A.A region pattern) tipe info =
55+ case pattern of
56+ Can.PAnything ->
57+ return info
3558
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)
3663
37−joinInfo :: Info -> Info -> Info
38−joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
39− Info
40− { _headers = Map.union headers1 headers2
41− , _vars = vars1 ++ vars2
42− , _cons = cons1 /\ cons2
43− }
64+ Can.PVar name ->
65+ do let (Info headers vars revCons) = info
66+ let newHeaders = Map.insert name (A.A region tipe) headers
67+ return $ Info newHeaders vars revCons
4468
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
4573
46−joinInfos :: [Info] -> Info
47−joinInfos infos =
48− List.foldl' (flip joinInfo) emptyInfo infos
74+ Can.PUnit ->
75+ do let (Info headers vars revCons) = info
76+ let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe
77+ return $ Info headers vars (unitCon:revCons)
4978
79+ Can.PTuple a b maybeC ->
80+ addTupleConstraint env context region a b maybeC tipe info
5081
51−infoToScheme :: Info -> Scheme
52−infoToScheme (Info headers vars cons) =
53− Scheme [] vars cons headers
82+ Can.PCtor home typeName vs ctorName args ->
83+ do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
5484
85+ (Info headers vars revCons) <-
86+ foldM (addCtorConstraint env ctorName) info targs
5587
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+ }
5696
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+ }
58131
132+ Can.PRecord fields ->
133+ do extVar <- mkFlexVar
59134
60−constrain :: Env.Env -> P.Canonical -> Type -> IO Info
61−constrain env (A.A region pattern) tipe =
62− let
63− equal patternError leftType rightType =
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 }
76−
77− P.Var name ->
78− do variable <- mkFlexVar
79− return $ Info
80− { _headers = Map.singleton name (rvar variable)
81− , _vars = [variable]
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
135+ fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
136+ let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
137+
138+ let (Info headers vars revCons) = info
139+ return $
140+ Info
141+ { _headers = Map.union headers (Map.map (A.A region) fieldVarN)
142+ , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
91143 , _cons =
92− equal (Error.PAlias name) (VarN variable) tipe
93− /\ _cons info
144+ CEqual
145+ (Error.Pattern context Error.PRecord)
146+ region
147+ (RecordN fieldVarN (VarN extVar))
148+ tipe
149+ : revCons
94150 }
95151
96− P.Ctor name patterns ->
97− do (_kind, cvars, args, result) <-
98− Env.freshDataScheme env (Var.toText name)
99−
100− fragList <- Monad.zipWithM (constrain env) patterns args
101− let info = joinInfos fragList
102− return $ info
103− { _vars = cvars ++ _vars info
104− , _cons =
105− equal (Error.PCtor name) result tipe
106− /\ _cons info
107− }
108−
109− P.Record fields ->
110− do pairs <-
111− mapM (\name -> (,) name <$> mkFlexVar) fields
112−
113− let tenv =
114− Map.fromList (map (second rvar) pairs)
115−
116− let unannotatedTenv =
117− Map.map A.drop tenv
118−
119− con <- exists $ \t ->
120− return (equal Error.PRecord tipe (RecordN unannotatedTenv t))
121−
122− return $ Info
123− { _headers = tenv
124− , _vars = map snd pairs
125− , _cons = con
126− }
152+
153+
154+-- CONSTRAIN TUPLE
155+
156+
157+addTupleConstraint
158+ :: Env
159+ -> Error.PatternContext
160+ -> R.Region
161+ -> Can.Pattern
162+ -> Can.Pattern
163+ -> Maybe Can.Pattern
164+ -> Type
165+ -> Info
166+ -> IO Info
167+addTupleConstraint env context region a b maybeC tipe (Info headers vars revCons) =
168+ do let equal = CEqual (Error.Pattern context Error.PTuple) region
169+ let addCon = addConstraints env Error.PatternUnknown
170+
171+ aVar <- mkFlexVar
172+ bVar <- mkFlexVar
173+ let aVarN = VarN aVar
174+ let bVarN = VarN bVar
175+
176+ case maybeC of
177+ Nothing ->
178+ do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
179+ let newVars = Bag.insert aVar (Bag.insert bVar vars)
180+ addCon b bVarN =<<
181+ addCon a aVarN (Info headers newVars (tupleCon:revCons))
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
1919 , nameToFlex
2020 , nameToRigid
2121 , toSrcType
22− , fromFlexSrcType
23− , fromRigidSrcType
2422 )
2523 where
2624
@@ -29,7 +27,6 @@ import qualified Control.Monad.State.Strict as State
2927import qualified Data.Char as Char
3028import Data.Foldable (foldrM)
3129import qualified Data.Map.Strict as Map
32−import Data.Map.Strict ((!))
3330import Data.Monoid ((<>))
3431import qualified Data.Text as Text
3532import Data.Text (Text)
@@ -254,109 +251,6 @@ toSuper name =
254251
255252
256253
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−
360254-- TO SOURCE TYPES
361255
362256