git.iko.soy/elk
on 64038dc help sign in
elk/src/Type/Constrain/Pattern.hs
204 lines 6.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern
3 ( Info(..)
4 , constrain
5 )
6 where
9import Control.Monad (foldM)
10import qualified Data.Map.Strict as Map
12import qualified AST.Expression.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified Data.Bag as Bag
15import qualified Elm.Name as N
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Type as Error
18import qualified Reporting.Region as R
19import Type.Constraint
20import qualified Type.Constrain.Literal as Literal
21import qualified Type.Instantiate as Instantiate
22import Type.Type
26-- CONSTRAIN PATTERN
29constrain :: Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)
30constrain pattern tipe =
31 do (Info headers vars cons) <-
32 addConstraints Error.PatternUnknown pattern tipe $
33 Info Map.empty Bag.empty []
35 return ( headers, Bag.toList vars, CAnd (reverse cons) )
39-- ADD CONSTRAINTS
42data Info =
43 Info
44 { _headers :: Map.Map N.Name (A.Located Type)
45 , _vars :: Bag.Bag Variable
46 , _cons :: [Constraint]
47 }
50addConstraints :: Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
51addConstraints context (A.A region pattern) tipe info =
52 case pattern of
53 Can.PAnything ->
54 return info
56 Can.PLiteral lit ->
57 do let (Info headers vars revCons) = info
58 litCon <- Literal.constrain region lit tipe
59 return $ Info headers vars (litCon:revCons)
61 Can.PVar name ->
62 do let (Info headers vars revCons) = info
63 let newHeaders = Map.insert name (A.A region tipe) headers
64 return $ Info newHeaders vars revCons
66 Can.PAlias realPattern name ->
67 do let (Info headers vars revCons) = info
68 addConstraints context realPattern tipe $
69 Info (Map.insert name (A.A region tipe) headers) vars revCons
71 Can.PUnit ->
72 do let (Info headers vars revCons) = info
73 let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe
74 return $ Info headers vars (unitCon:revCons)
76 Can.PTuple a b maybeC ->
77 addTupleConstraint context region a b maybeC tipe info
79 Can.PCtor home typeName vs ctorName args ->
80 do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
82 (Info headers vars revCons) <-
83 foldM (addCtorConstraint ctorName) info targs
85 return $
86 Info
87 { _headers = headers
88 , _vars = Bag.append vars (Bag.fromList id tvars)
89 , _cons =
90 CEqual (Error.Pattern context (Error.PCtor ctorName)) region ttype tipe
91 : revCons
92 }
94 Can.PList patterns ->
95 do entryVar <- mkFlexVar
96 let entryVarN = VarN entryVar
97 let listType = AppN ModuleName.list N.list [entryVarN]
99 (Info headers vars revCons) <-
100 foldM
101 (addListConstraint entryVarN)
102 info
103 (zip patterns [ 1 .. length patterns ])
105 let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe
106 return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)
108 Can.PCons headPattern tailPattern ->
109 do headVar <- mkFlexVar
110 tailVar <- mkFlexVar
111 let headVarN = VarN headVar
112 let tailVarN = VarN tailVar
113 let tailType = AppN ModuleName.list N.list [tailVarN]
115 (Info headers vars revCons) <-
116 addConstraints Error.PatternTail tailPattern tailType =<<
117 addConstraints Error.PatternUnknown headPattern headVarN info
119 return $
120 Info
121 { _headers = headers
122 , _vars = Bag.insert headVar (Bag.insert tailVar vars)
123 , _cons =
124 CEqual (Error.Pattern context Error.PList) region tailType tipe
125 : CEqual Error.PatternCons region headVarN tailVarN
126 : revCons
127 }
129 Can.PRecord fields ->
130 do extVar <- mkFlexVar
132 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
133 let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
135 let (Info headers vars revCons) = info
136 return $
137 Info
138 { _headers = Map.union headers (Map.map (A.A region) fieldVarN)
139 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))
140 , _cons =
141 CEqual
142 (Error.Pattern context Error.PRecord)
143 region
144 (RecordN fieldVarN (VarN extVar))
145 tipe
146 : revCons
147 }
151-- CONSTRAIN CONSTRUCTORS
154addCtorConstraint :: N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info
155addCtorConstraint name info (index, argType, argPattern) =
156 addConstraints (Error.PatternArg name index) argPattern argType info
160-- CONSTRAIN LIST
163addListConstraint :: Type -> Info -> (Can.Pattern, Int) -> IO Info
164addListConstraint tipe info (pattern, index) =
165 addConstraints (Error.PatternList index) pattern tipe info
169-- CONSTRAIN TUPLE
172addTupleConstraint
173 :: Error.PatternContext
174 -> R.Region
175 -> Can.Pattern
176 -> Can.Pattern
177 -> Maybe Can.Pattern
178 -> Type
179 -> Info
180 -> IO Info
181addTupleConstraint context region a b maybeC tipe (Info headers vars revCons) =
182 do let equal = CEqual (Error.Pattern context Error.PTuple) region
183 let addCon = addConstraints Error.PatternUnknown
185 aVar <- mkFlexVar
186 bVar <- mkFlexVar
187 let aVarN = VarN aVar
188 let bVarN = VarN bVar
190 case maybeC of
191 Nothing ->
192 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
193 let newVars = Bag.insert aVar (Bag.insert bVar vars)
194 addCon b bVarN =<<
195 addCon a aVarN (Info headers newVars (tupleCon:revCons))
197 Just c ->
198 do cVar <- mkFlexVar
199 let cVarN = VarN cVar
200 let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
201 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
202 addCon c cVarN =<<
203 addCon b bVarN =<<
204 addCon a aVarN (Info headers newVars (tupleCon:revCons))