git.iko.soy/elk
on 2e58494 help sign in
elk/src/Type/Constrain/Pattern.hs
208 lines 6.4 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
29type Env = ()
32constrain :: Env -> Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)
33constrain env pattern tipe =
34 do (Info headers vars cons) <-
35 addConstraints env Error.PatternUnknown pattern tipe $
36 Info Map.empty Bag.empty []
38 return ( headers, Bag.toList vars, CAnd (reverse cons) )
42-- ADD CONSTRAINTS
45data Info =
46 Info
47 { _headers :: Map.Map N.Name (A.Located Type)
48 , _vars :: Bag.Bag Variable
49 , _cons :: [Constraint]
50 }
53addConstraints :: Env -> Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info
54addConstraints env context (A.A region pattern) tipe info =
55 case pattern of
56 Can.PAnything ->
57 return info
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)
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
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
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)
79 Can.PTuple a b maybeC ->
80 addTupleConstraint env context region a b maybeC tipe info
82 Can.PCtor home typeName vs ctorName args ->
83 do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args
85 (Info headers vars revCons) <-
86 foldM (addCtorConstraint env ctorName) info targs
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 }
97 Can.PList patterns ->
98 do entryVar <- mkFlexVar
99 let entryVarN = VarN entryVar
100 let listType = AppN ModuleName.list N.list [entryVarN]
102 (Info headers vars revCons) <-
103 foldM
104 (addListConstraint env entryVarN)
105 info
106 (zip patterns [ 1 .. length patterns ])
108 let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe
109 return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)
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]
118 (Info headers vars revCons) <-
119 addConstraints env Error.PatternTail tailPattern tailType =<<
120 addConstraints env Error.PatternUnknown headPattern headVarN info
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 }
132 Can.PRecord fields ->
133 do extVar <- mkFlexVar
135 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields
136 let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)
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))
143 , _cons =
144 CEqual
145 (Error.Pattern context Error.PRecord)
146 region
147 (RecordN fieldVarN (VarN extVar))
148 tipe
149 : revCons
150 }
154-- CONSTRAIN CONSTRUCTORS
157addCtorConstraint :: Env -> N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info
158addCtorConstraint env name info (index, argType, argPattern) =
159 addConstraints env (Error.PatternArg name index) argPattern argType info
163-- CONSTRAIN LIST
166addListConstraint :: Env -> Type -> Info -> (Can.Pattern, Int) -> IO Info
167addListConstraint env tipe info (pattern, index) =
168 addConstraints env (Error.PatternList index) pattern tipe info
172-- CONSTRAIN TUPLE
175addTupleConstraint
176 :: Env
177 -> Error.PatternContext
178 -> R.Region
179 -> Can.Pattern
180 -> Can.Pattern
181 -> Maybe Can.Pattern
182 -> Type
183 -> Info
184 -> IO Info
185addTupleConstraint env context region a b maybeC tipe (Info headers vars revCons) =
186 do let equal = CEqual (Error.Pattern context Error.PTuple) region
187 let addCon = addConstraints env Error.PatternUnknown
189 aVar <- mkFlexVar
190 bVar <- mkFlexVar
191 let aVarN = VarN aVar
192 let bVarN = VarN bVar
194 case maybeC of
195 Nothing ->
196 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe
197 let newVars = Bag.insert aVar (Bag.insert bVar vars)
198 addCon b bVarN =<<
199 addCon a aVarN (Info headers newVars (tupleCon:revCons))
201 Just c ->
202 do cVar <- mkFlexVar
203 let cVarN = VarN cVar
204 let tupleCon = equal (TupleN aVarN bVarN (Just cVarN)) tipe
205 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))
206 addCon c cVarN =<<
207 addCon b bVarN =<<
208 addCon a aVarN (Info headers newVars (tupleCon:revCons))