@@ -1,248 +1,260 @@
11{-# OPTIONS_GHC -Wall #-}
22{-# LANGUAGE OverloadedStrings #-}
3−module Type.Constrain.Expression where
3+module Type.Constrain.Expression
4+ ( constrain
5+ )
6+ where
7+
48
59import Control.Arrow (second)
610import qualified Control.Monad as Monad
711import qualified Data.Map.Strict as Map
8−import qualified Data.Text as Text
912import Data.Text (Text)
1013
11−import qualified AST.Expression.Canonical as C
12−import qualified AST.Literal as Lit
13−import qualified AST.Pattern as P
14−import qualified AST.Type as ST
15−import qualified AST.Variable as V
14+import qualified AST.Canonical as Can
15+import qualified AST.Module.Name as ModuleName
16+import qualified AST.Utils.Shader as Shader
17+import qualified Data.Bag as Bag
18+import qualified Data.Index as Index
19+import qualified Elm.Name as N
1620import qualified Reporting.Annotation as A
1721import qualified Reporting.Error.Type as Error
1822import qualified Reporting.Region as R
1923import Type.Constraint
20−import qualified Type.Constrain.Effects as Effects
21−import qualified Type.Constrain.Literal as Literal
2224import qualified Type.Constrain.Pattern as Pattern
23−import qualified Type.Environment as Env
2425import Type.Type as Type hiding (Descriptor(..))
2526
2627
2728
28−constrain :: Env.Env -> C.Expr -> Type -> IO Constraint
29−constrain env annotatedExpr@(A.A region expression) tipe =
29+-- CONSTRAIN
30+
31+
32+-- The environment contains all known type variables.
33+--
34+-- So if you have a top-level type annotation like (func : a -> b) then
35+-- the environment will hold variables for `a` and `b`
36+--
37+type Env = Map.Map N.Name Variable
38+
39+
40+constrain :: Env -> R.Region -> Error.Context -> Can.Expr -> Type -> IO Constraint
41+constrain env parentRegion context (A.A region expression) tipe =
3042 case expression of
31− C.Literal lit ->
32− Literal.constrain region lit tipe
43+ Can.VarLocal name ->
44+ return (CLookup parentRegion context region name tipe)
3345
34− C.Cmd _ _ ->
35− return CTrue
46+ Can.VarTopLevel _ name ->
47+ return (CLookup parentRegion context region name tipe)
3648
37− C.Sub _ _ ->
49+ Can.VarKernel _ _ ->
3850 return CTrue
3951
40− C.OutgoingPort _ _ ->
41− return CTrue
52+ Can.VarForeign _ name annotation ->
53+ error "TODO figure out foreign types"
4254
43− C.IncomingPort _ _ ->
44− return CTrue
55+ Can.VarOperator op _ _ annotation ->
56+ error "TODO figure out foreign types"
4557
46− C.Program _ _ ->
47− error "DANGER - Program AST nodes should not be in type inference."
48−
49− C.SaveEnv moduleName effects ->
50− Effects.constrain moduleName effects
51−
52− C.GLShader _uid _src glType ->
53− exists $ \attr ->
54− exists $ \unif ->
55− let
56− shaderTipe a u v =
57− AppN V.shader [a, u, v]
58−
59− glToType gl =
60− AppN (Lit.glTypeToVar gl) []
61−
62− makeRec accessor baseRec =
63− let decls = accessor glType
64− in
65− if Map.null decls then
66− baseRec
67− else
68− RecordN (Map.map glToType decls) baseRec
69−
70− attribute = makeRec Lit.attribute attr
71− uniform = makeRec Lit.uniform unif
72− varying = makeRec Lit.varying EmptyRecordN
73− in
74− return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)
75−
76− C.Var var ->
77− return (CInstance region (V.toText var) tipe)
78−
79− C.List exprs ->
80− constrainList env region exprs tipe
81−
82− C.Binop op leftExpr rightExpr ->
83− constrainBinop env region op leftExpr rightExpr tipe
84−
85− C.Lambda pattern body ->
86− exists $ \argType ->
87− exists $ \resType ->
88− do (Pattern.Info headers vars cons) <- Pattern.constrain env pattern argType
89− bodyCon <- constrain env body resType
90− return $
91− ex vars (CLet [monoscheme headers] (cons /\ bodyCon))
92− /\ CEqual Error.Lambda region (argType ==> resType) tipe
93−
94− C.App _ _ ->
95− let
96− (f:args) = C.collectApps annotatedExpr
97− in
98− constrainApp env region f args tipe
99−
100− C.If branches finally ->
101− constrainIf env region branches finally tipe
102−
103− C.Case expr branches ->
104− constrainCase env region expr branches tipe
105−
106− C.Ctor name exprs ->
107− do vars <- mapM (\_ -> mkFlexVar) exprs
108− let pairs = zip exprs (map VarN vars)
109− (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)
110− return $ ex vars (cs /\ CInstance region (V.toText name) ctipe)
111− where
112− step (t,c) (e,x) =
113− do c' <- constrain env e x
114− return (x ==> t, c /\ c')
115−
116− C.Access expr field ->
117− exists $ \recordType ->
118− exists $ \ext ->
119− do recordCon <- constrain env expr recordType
120− let maybeBody = C.collectFields expr
121− let desiredType = RecordN (Map.singleton field tipe) ext
122− let fieldCon = CEqual (Error.Access maybeBody field) region recordType desiredType
123− return $ recordCon /\ fieldCon
124−
125− C.Update expr fields ->
126− exists $ \t ->
127− do oldVars <- mapM (\_ -> mkFlexVar) fields
128− let oldFields = Map.fromList (zip (map fst fields) (map VarN oldVars))
129− cOld <- ex oldVars <$> constrain env expr (RecordN oldFields t)
130−
131− newVars <- mapM (\_ -> mkFlexVar) fields
132− let newFields = Map.fromList (zip (map fst fields) (map VarN newVars))
133− let cNew = CEqual Error.Record region (RecordN newFields t) tipe
134−
135− cs <- Monad.zipWithM (constrain env) (map snd fields) (map VarN newVars)
136−
137− return $ cOld /\ ex newVars (CAnd (cNew : cs))
138−
139− C.Record fields ->
140− do vars <- mapM (\_ -> mkFlexVar) fields
141− fieldCons <-
142− Monad.zipWithM
143− (constrain env)
144− (map snd fields)
145− (map VarN vars)
146− let fields' = Map.fromList (zip (map fst fields) (map VarN vars))
147− let recordType = RecordN fields' EmptyRecordN
148− return (ex vars (CAnd (fieldCons ++ [CEqual Error.Record region recordType tipe])))
149−
150− C.Let defs body ->
151− do bodyCon <- constrain env body tipe
152−
153− (Info schemes rqs fqs headers c2 c1) <-
154− Monad.foldM
155− (constrainDef env)
156− (Info [] [] [] Map.empty CTrue CTrue)
157− (concatMap expandPattern defs)
158−
159− let letScheme =
160− [ Scheme rqs fqs (CLet [monoscheme headers] c2) headers ]
161−
162− return $ CLet schemes (CLet letScheme (c1 /\ bodyCon))
163−
164−
165−
166−-- CONSTRAIN APP
167−
168−
169−constrainApp
170− :: Env.Env
171− -> R.Region
172− -> C.Expr
173− -> [C.Expr]
174− -> Type
175− -> IO Constraint
176−constrainApp env region f args tipe =
177− do funcVar <- mkFlexVar
178− funcCon <- constrain env f (VarN funcVar)
58+ Can.Str _ ->
59+ return $ CEqual parentRegion context Error.String region Type.string tipe
17960
180− (vars, argCons, numberOfArgsCons, argMatchCons, _, returnVar) <-
181− argConstraints env maybeName region (length args) funcVar 1 args
61+ Can.Chr _ ->
62+ return $ CEqual parentRegion context Error.Char region Type.char tipe
18263
183− let returnCon =
184− CEqual (Error.Function maybeName) region (VarN returnVar) tipe
64+ Can.Int _ ->
65+ do var <- mkFlexNumber
66+ return $ ex [var] $
67+ CEqual parentRegion context Error.Number region (VarN var) tipe
18568
186− return $ ex (funcVar : vars) $
187− CAnd (funcCon : argCons ++ numberOfArgsCons ++ argMatchCons ++ [returnCon])
188− where
189− maybeName =
190− case f of
191− A.A _ (C.Var canonicalName) ->
192− Just canonicalName
69+ Can.Float _ ->
70+ return $ CEqual parentRegion context Error.Float region Type.float tipe
19371
194− _ ->
195− Nothing
72+ Can.List elements ->
73+ constrainList env parentRegion context region elements tipe
19674
75+ Can.Negate expr ->
76+ do numberVar <- mkFlexNumber
77+ let numberType = VarN numberVar
78+ numberCon <- constrain env region Error.Negate expr numberType
79+ let negateCon = CEqual parentRegion context Error.Number region numberType tipe
80+ return $ ex [numberVar] $ CAnd [ numberCon, negateCon ]
19781
198−argConstraints
199− :: Env.Env
200− -> Maybe V.Canonical
201− -> R.Region
202− -> Int
203− -> Variable
204− -> Int
205− -> [C.Expr]
206− -> IO ([Variable], [Constraint], [Constraint], [Constraint], Maybe R.Region, Variable)
207−argConstraints env name region totalArgs overallVar index args =
82+ Can.Binop op home name annotation leftExpr rightExpr ->
83+ constrainBinop env parentRegion context region op annotation leftExpr rightExpr tipe
84+
85+ Can.Lambda args body ->
86+ constrainLambda parentRegion context env region args body tipe
87+
88+ Can.Call func args ->
89+ constrainCall env parentRegion context region func args tipe
90+
91+ Can.If branches finally ->
92+ constrainIf env parentRegion context region branches finally tipe
93+
94+ Can.Case expr branches ->
95+ constrainCase env parentRegion context region expr branches tipe
96+
97+ Can.Let def body ->
98+ constrainLet env parentRegion context region def body tipe
99+
100+ Can.LetRec defs body ->
101+ error "TODO let rec" defs body
102+
103+ Can.LetDestruct pattern destructors expr body ->
104+ error "TODO let destruct" pattern destructors expr body
105+
106+ Can.Accessor field ->
107+ do extVar <- mkFlexVar
108+ fieldVar <- mkFlexVar
109+ let extType = VarN extVar
110+ let fieldType = VarN fieldVar
111+ let recordType = RecordN (Map.singleton field fieldType) extType
112+ return $ ex [ fieldVar, extVar ] $
113+ CEqual parentRegion context (Error.Accessor field) region (FunN recordType fieldType) tipe
114+
115+ Can.Access expr field ->
116+ do extVar <- mkFlexVar
117+ fieldVar <- mkFlexVar
118+ let extType = VarN extVar
119+ let fieldType = VarN fieldVar
120+ let recordType = RecordN (Map.singleton field fieldType) extType
121+ recordCon <- constrain env region (Error.RecordAccess field) expr recordType
122+ return $ ex [ fieldVar, extVar ] $
123+ CAnd
124+ [ recordCon
125+ , CEqual parentRegion context (Error.Access field) region recordType tipe
126+ ]
127+
128+ Can.Update expr fields ->
129+ constrainUpdate env parentRegion context region expr fields tipe
130+
131+ Can.Record fields ->
132+ constrainRecord env parentRegion context region fields tipe
133+
134+ Can.Unit ->
135+ return $ CEqual parentRegion context Error.Unit region UnitN tipe
136+
137+ Can.Tuple a b maybeC ->
138+ constrainTuple env parentRegion context region a b maybeC tipe
139+
140+ Can.Shader _uid _src glType ->
141+ constrainShader env parentRegion context region glType tipe
142+
143+
144+
145+-- CONSTRAIN LAMBDA
146+
147+
148+constrainLambda :: R.Region -> Error.Context -> Env -> R.Region -> Can.Args -> Can.Expr -> Type -> IO Constraint
149+constrainLambda parentRegion context env lambdaRegion (Can.Args args _) body tipe =
150+ constrainLambdaHelp parentRegion context env lambdaRegion args body [] Pattern.emptyState tipe
151+
152+
153+constrainLambdaHelp :: R.Region -> Error.Context -> Env -> R.Region -> [Can.Arg] -> Can.Expr -> [Type] -> Pattern.State -> Type -> IO Constraint
154+constrainLambdaHelp parentRegion context env lambdaRegion args body revArgTypes state tipe =
155+ case args of
156+ (Can.Arg index pattern) : otherArgs ->
157+ do argVar <- mkFlexVar
158+ let argType = VarN argVar
159+ let newTypes = argType : revArgTypes
160+ let lambdaContext = Error.PatternArg Error.UnknownCall index
161+ newState <- Pattern.addConstraints lambdaRegion lambdaContext pattern argType state
162+ constrainLambdaHelp parentRegion context env lambdaRegion otherArgs body newTypes newState tipe
163+
164+ [] ->
165+ do resultVar <- mkFlexVar
166+ let resultType = VarN resultVar
167+ let lambdaType = foldr (==>) resultType revArgTypes
168+ let lambdaCon = CEqual parentRegion context Error.Lambda lambdaRegion lambdaType tipe
169+ bodyCon <- constrain env lambdaRegion Error.LambdaBody body resultType
170+
171+ let (Pattern.State headers vars revCons) = state
172+ let scheme = Scheme [] (resultVar : Bag.toList vars) headers (CAnd (reverse revCons))
173+
174+ return $ CLet [scheme] $ CAnd [ bodyCon, lambdaCon ]
175+
176+
177+
178+-- CONSTRAIN CALL
179+
180+
181+constrainCall :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.Expr] -> Type -> IO Constraint
182+constrainCall env parentRegion context callRegion func args tipe =
183+ do let callName = toCallName func
184+ let (A.A lastArgRegion _) = last args
185+
186+ funcVar <- mkFlexVar
187+ let funcType = VarN funcVar
188+ funcCon <- constrain env callRegion Error.Whatever func funcType
189+
190+ (vars, revCons, resultType) <-
191+ constrainCallHelp env callRegion callName lastArgRegion args Index.first [funcVar] funcType [funcCon]
192+
193+ let callCon = CEqual parentRegion context (Error.CallResult callName) callRegion resultType tipe
194+
195+ return $ ex vars $ CAnd (reverse (callCon:revCons))
196+
197+
198+constrainCallHelp
199+ :: Env
200+ -> R.Region
201+ -> Error.CallName
202+ -> R.Region
203+ -> [Can.Expr]
204+ -> Index.ZeroBased
205+ -> [Variable]
206+ -> Type
207+ -> [Constraint]
208+ -> IO ([Variable], [Constraint], Type)
209+constrainCallHelp env callRegion callName lastArgRegion args index vars funcType revCons =
208210 case args of
209211 [] ->
210− return ([], [], [], [], Nothing, overallVar)
212+ return (vars, revCons, funcType)
211213
212− expr@(A.A subregion _) : rest ->
214+ arg@(A.A argRegion _) : otherArgs ->
213215 do argVar <- mkFlexVar
214− argCon <- constrain env expr (VarN argVar)
215− argIndexVar <- mkFlexVar
216− localReturnVar <- mkFlexVar
216+ resultVar <- mkFlexVar
217+ let argType = VarN argVar
218+ let resultType = VarN resultVar
219+
220+ -- check arity
221+ let aRegion = R.merge argRegion lastArgRegion
222+ let aContext = Error.CallArity callName index
223+ let aCategory = Error.Call callName
224+ let arityCon = CEqual callRegion aContext aCategory aRegion funcType (argType ==> resultType)
217225
218− (vars, argConRest, numberOfArgsRest, argMatchRest, restRegion, returnVar) <-
219− argConstraints env name region totalArgs localReturnVar (index + 1) rest
226+ -- check arg type
227+ argCon <- constrain env callRegion (Error.CallArg callName index) arg argType
220228
221− let arityRegion =
222− maybe subregion (R.merge subregion) restRegion
229+ let newIndex = Index.next index
230+ let newVars = argVar : resultVar : vars
231+ let newCons = argCon : arityCon : revCons
232+ constrainCallHelp env callRegion callName lastArgRegion otherArgs newIndex newVars resultType newCons
223233
224− let numberOfArgsCon =
225− CEqual
226− (Error.FunctionArity name (index - 1) totalArgs arityRegion)
227− region
228− (VarN argIndexVar ==> VarN localReturnVar)
229− (VarN overallVar)
230234
231− let argMatchCon =
232− CEqual
233− (Error.UnexpectedArg name index totalArgs subregion)
234− region
235− (VarN argIndexVar)
236− (VarN argVar)
235+toCallName :: Can.Expr -> Error.CallName
236+toCallName (A.A _ expr) =
237+ case expr of
238+ Can.VarLocal name ->
239+ Error.FuncCall name
237240
238− return
239− ( argVar : argIndexVar : localReturnVar : vars
240− , argCon : argConRest
241− , numberOfArgsCon : numberOfArgsRest
242− , argMatchCon : argMatchRest
243− , Just arityRegion
244− , returnVar
245− )
241+ Can.VarTopLevel _ name ->
242+ Error.FuncCall name
243+
244+ Can.VarKernel _ name ->
245+ Error.FuncCall name
246+
247+ Can.VarForeign _ name _ ->
248+ Error.FuncCall name
249+
250+ Can.VarOperator op _ _ _ ->
251+ Error.OpCall op
252+
253+ Can.Accessor field ->
254+ Error.AccessCall field
255+
256+ _ ->
257+ Error.UnknownCall
246258
247259
248260
@@ -250,34 +262,35 @@ argConstraints env name region totalArgs overallVar index args =
250262
251263
252264constrainBinop
253− :: Env.Env
265+ :: Env
266+ -> R.Region
267+ -> Error.Context
254268 -> R.Region
255− -> V.Canonical
256− -> C.Expr
257− -> C.Expr
269+ -> N.Name
270+ -> Can.Annotation
271+ -> Can.Expr
272+ -> Can.Expr
258273 -> Type
259274 -> IO Constraint
260−constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightRegion _) tipe =
275+constrainBinop env parentRegion context opRegion op srcType leftExpr rightExpr tipe =
261276 do leftVar <- mkFlexVar
262277 rightVar <- mkFlexVar
263−
264− leftCon <- constrain env leftExpr (VarN leftVar)
265− rightCon <- constrain env rightExpr (VarN rightVar)
266−
267− leftVar' <- mkFlexVar
268− rightVar' <- mkFlexVar
269278 answerVar <- mkFlexVar
279+ let leftType = VarN leftVar
280+ let rightType = VarN rightVar
281+ let answerType = VarN answerVar
270282
271− let opType = VarN leftVar' ==> VarN rightVar' ==> VarN answerVar
283+ let opCon = error "TODO CInstance" srcType (leftType ==> rightType ==> answerType)
272284
273− return $
274− ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $
275− [ leftCon
285+ leftCon <- constrain env opRegion (Error.OpLeft op) leftExpr leftType
286+ rightCon <- constrain env opRegion (Error.OpRight op) rightExpr rightType
287+
288+ return $ ex [ leftVar, rightVar, answerVar ] $
289+ CAnd
290+ [ opCon
291+ , leftCon
276292 , rightCon
277− , CInstance region (V.toText op) opType
278− , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)
279− , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)
280− , CEqual (Error.Binop op) region (VarN answerVar) tipe
293+ , CEqual parentRegion context (Error.Call (Error.OpCall op)) opRegion answerType tipe
281294 ]
282295
283296
@@ -285,320 +298,220 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg
285298-- CONSTRAIN LISTS
286299
287300
288−constrainList :: Env.Env -> R.Region -> [C.Expr] -> Type -> IO Constraint
289−constrainList env region exprs tipe =
290− do (exprInfo, exprCons) <-
291− unzip <$> mapM elementConstraint exprs
301+constrainList :: Env -> R.Region -> Error.Context -> R.Region -> [Can.Expr] -> Type -> IO Constraint
302+constrainList env parentRegion context listRegion entries tipe =
303+ do entryVar <- mkFlexVar
304+ let entryType = VarN entryVar
305+ entryCons <- Index.indexedTraverse (constrainListEntry env listRegion entryType) entries
306+ let listType = AppN ModuleName.list N.list [entryType]
307+ return $ ex [entryVar] $
308+ CAnd
309+ [ CAnd entryCons
310+ , CEqual parentRegion context Error.List listRegion listType tipe
311+ ]
292312
293− (vars, cons) <- pairCons region Error.ListElement varToCon exprInfo
294313
295− return $ ex vars (CAnd (exprCons ++ cons))
296− where
297− elementConstraint expr@(A.A region' _) =
298− do var <- mkFlexVar
299− con <- constrain env expr (VarN var)
300− return ( (var, region'), con )
314+constrainListEntry :: Env -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
315+constrainListEntry env listRegion tipe index expr =
316+ constrain env listRegion (Error.ListEntry index) expr tipe
301317
302− varToCon var =
303− CEqual Error.List region (AppN V.list [VarN var]) tipe
304318
305319
306320
307321-- CONSTRAIN IF EXPRESSIONS
308322
309323
310−constrainIf
311− :: Env.Env
312− -> R.Region
313− -> [(C.Expr, C.Expr)]
314− -> C.Expr
315− -> Type
316− -> IO Constraint
317−constrainIf env region branches finally tipe =
318− do let (conditions, branchExprs) =
319− second (++ [finally]) (unzip branches)
320−
321− (condVars, condCons) <-
322− unzip <$> mapM constrainCondition conditions
324+constrainIf :: Env -> R.Region -> Error.Context -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Type -> IO Constraint
325+constrainIf env parentRegion context ifRegion branches final tipe =
326+ do branchVar <- mkFlexVar
327+ let branchType = VarN branchVar
323328
324− (branchInfo, branchExprCons) <-
325− unzip <$> mapM constrainBranch branchExprs
329+ branchCons <- Index.indexedTraverse (constrainIfBranch env ifRegion branchType) branches
330+ finalCon <- constrain env ifRegion (Error.IfBranchFinal (length branches)) final branchType
326331
327− (vars,cons) <- branchCons branchInfo
332+ return $ ex [branchVar] $
333+ CAnd
334+ [ CAnd branchCons
335+ , finalCon
336+ , CEqual parentRegion context Error.If ifRegion branchType tipe
337+ ]
328338
329− return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))
330− where
331− constrainCondition condition@(A.A condRegion _) =
332− do condVar <- mkFlexVar
333− condCon <- constrain env condition (VarN condVar)
334− let boolCon = CEqual Error.IfCondition condRegion (VarN condVar) Type.bool
335− return (condVar, CAnd [ condCon, boolCon ])
336−
337− constrainBranch expr@(A.A branchRegion _) =
338− do branchVar <- mkFlexVar
339− exprCon <- constrain env expr (VarN branchVar)
340− return
341− ( (branchVar, branchRegion)
342− , exprCon
343− )
344−
345− branchCons branchInfo =
346− case branchInfo of
347− [(thenVar, _), (elseVar, _)] ->
348− return
349− ( [thenVar,elseVar]
350− , [ CEqual Error.IfBranches region (VarN thenVar) (VarN elseVar)
351− , varToCon thenVar
352− ]
353− )
354−
355− _ ->
356− pairCons region Error.MultiIfBranch varToCon branchInfo
357−
358− varToCon var =
359− CEqual Error.If region (VarN var) tipe
360339
340+constrainIfBranch :: Env -> R.Region -> Type -> Index.ZeroBased -> (Can.Expr, Can.Expr) -> IO Constraint
341+constrainIfBranch env ifRegion branchType index (condition, branch) =
342+ do condCon <- constrain env ifRegion Error.IfCondition condition Type.bool
343+ branchCon <- constrain env ifRegion (Error.IfBranch index) branch branchType
344+ return $ CAnd [ condCon, branchCon ]
361345
362346
363347-- CONSTRAIN CASE EXPRESSIONS
364348
365349
366−constrainCase
367− :: Env.Env
368− -> R.Region
369− -> C.Expr
370− -> [(P.Canonical, C.Expr)]
371− -> Type
372− -> IO Constraint
373−constrainCase env region expr branches tipe =
350+constrainCase :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Type -> IO Constraint
351+constrainCase env parentRegion context caseRegion expr branches tipe =
374352 do exprVar <- mkFlexVar
375− exprCon <- constrain env expr (VarN exprVar)
353+ branchVar <- mkFlexVar
354+ let exprType = VarN exprVar
355+ let branchType = VarN branchVar
376356
377− (branchInfo, branchExprCons) <-
378− unzip <$> mapM (branch (VarN exprVar)) branches
357+ exprCon <- constrain env caseRegion Error.CaseExpr expr exprType
358+ revCons <- constrainCaseHelp env caseRegion branches exprType branchType [exprCon]
359+ let caseCon = CEqual parentRegion context Error.Case caseRegion branchType tipe
379360
380− (vars, cons) <- pairCons region Error.CaseBranch varToCon branchInfo
361+ return $ ex [ exprVar, branchVar ] $ CAnd (reverse (caseCon:revCons))
381362
382− return $ ex (exprVar : vars) (CAnd (exprCon : branchExprCons ++ cons))
383− where
384− branch patternType (pattern, branchExpr@(A.A branchRegion _)) =
385− do branchVar <- mkFlexVar
386− scheme <- Pattern.infoToScheme <$> Pattern.constrain env pattern patternType
387− branchCon <- constrain env branchExpr (VarN branchVar)
388− return
389− ( (branchVar, branchRegion)
390− , CLet [scheme] branchCon
391− )
392−
393− varToCon var =
394− CEqual Error.Case region tipe (VarN var)
395−
396−
397−
398−-- COLLECT PAIRS
399−
400−
401−data Pair = Pair
402− { _index :: Int
403− , _var1 :: Variable
404− , _var2 :: Variable
405− , _region :: R.Region
406− }
407−
408−
409−pairCons
410− :: R.Region
411− -> (Int -> R.Region -> Error.Hint)
412− -> (Variable -> Constraint)
413− -> [(Variable, R.Region)]
414− -> IO ([Variable], [Constraint])
415−pairCons region pairHint varToCon items =
416− let
417− pairToCon (Pair index var1 var2 subregion) =
418− CEqual (pairHint index subregion) region (VarN var1) (VarN var2)
419− in
420− case collectPairs 2 items of
421− Nothing ->
422− do var <- mkFlexVar
423− return ([var], [varToCon var])
424363
425− Just (pairs, var) ->
426− return (map fst items, map pairToCon pairs ++ [varToCon var])
427364
428−
429−collectPairs :: Int -> [(Variable, R.Region)] -> Maybe ([Pair], Variable)
430−collectPairs index items =
431− case items of
365+constrainCaseHelp :: Env -> R.Region -> [Can.CaseBranch] -> Type -> Type -> [Constraint] -> IO [Constraint]
366+constrainCaseHelp env caseRegion branches patternType exprType revCons =
367+ case branches of
432368 [] ->
433− Nothing
369+ return revCons
434370
435− (var,_) : [] ->
436− Just ([], var)
371+ (Can.CaseBranch index pattern destructors expr) : otherBranches ->
372+ do (Pattern.State headers vars revCons) <-
373+ Pattern.addConstraints caseRegion (Error.PatternCaseMatch index) pattern patternType Pattern.emptyState
437374
438− (var,_) : rest@((var',region) : _) ->
439− do (pairs, summaryVar) <- collectPairs (index+1) rest
440− return (Pair index var var' region : pairs, summaryVar)
375+ exprCon <- constrain env caseRegion (Error.CaseBranch index) expr exprType
376+ let branchCon = CLet [ Scheme [] (Bag.toList vars) headers (CAnd (reverse revCons)) ] exprCon
377+ constrainCaseHelp env caseRegion otherBranches patternType exprType (branchCon:revCons)
441378
442379
443380
444−-- EXPAND PATTERNS
381+-- CONSTRAIN RECORD
445382
446383
447−expandPattern :: C.Def -> [C.Def]
448−expandPattern def@(C.Def facts lpattern expr maybeType) =
449− let
450− (A.A patternRegion pattern) =
451− lpattern
452− in
453− case pattern of
454− P.Var _ ->
455− [def]
384+constrainRecord :: Env -> R.Region -> Error.Context -> R.Region -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
385+constrainRecord env parentRegion context recordRegion fields tipe =
386+ do dict <- Map.traverseWithKey (constrainField env recordRegion) fields
456387
457− _ ->
458− mainDef : map toDef vars
459− where
460− vars =
461− P.boundVarList lpattern
388+ let getType (_, t, _) = t
389+ let recordType = RecordN (Map.map getType dict) EmptyRecordN
390+ let recordCon = CEqual parentRegion context Error.Record recordRegion recordType tipe
462391
463− combinedName =
464− Text.intercalate "$" ("" : vars)
392+ let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
393+ let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
465394
466− pvar name =
467− A.A patternRegion (P.Var name)
395+ return $ ex vars (CAnd cons)
468396
469− localVar name =
470− A.A patternRegion (C.localVar name)
471397
472− mainDef =
473− C.Def facts (pvar combinedName) expr maybeType
398+constrainField :: Env -> R.Region -> N.Name -> Can.Expr -> IO (Variable, Type, Constraint)
399+constrainField env recordRegion name expr =
400+ do var <- mkFlexVar
401+ let tipe = VarN var
402+ con <- constrain env recordRegion (Error.RecordField name) expr tipe
403+ return (var, tipe, con)
474404
475− toDef name =
476− let
477− extract =
478− C.Case (localVar combinedName) [(lpattern, localVar name)]
479− in
480− C.Def facts (pvar name) (A.A patternRegion extract) Nothing
481405
482406
407+-- CONSTRAIN RECORD UPDATE
483408
484−-- CONSTRAIN DEFINITIONS
485409
410+constrainUpdate :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Type -> IO Constraint
411+constrainUpdate env parentRegion context recordRegion expr fields tipe =
412+ do sharedVar <- mkFlexVar
413+ let sharedType = VarN sharedVar
486414
487−data Info =
488− Info
489− { iSchemes :: [Scheme]
490− , iRigid :: [Variable]
491− , iFlex :: [Variable]
492− , iHeaders :: Map.Map Text (A.Located Type)
493− , iC2 :: Constraint
494− , iC1 :: Constraint
495− }
415+ oldVars <- traverse (\_ -> mkFlexVar) fields
416+ let oldTypes = Map.map VarN oldVars
417+ let oldRecordType = RecordN oldTypes sharedType
418+ oldCon <- constrain env recordRegion Error.RecordUpdate expr oldRecordType
496419
420+ newDict <- Map.traverseWithKey (constrainField env recordRegion) fields
497421
498−constrainDef :: Env.Env -> Info -> C.Def -> IO Info
499−constrainDef env info (C.Def defRegion (A.A patternRegion pattern) expr maybeTipe) =
500− case (pattern, maybeTipe) of
501− (P.Var name, Nothing) ->
502− constrainUnannotatedDef env patternRegion name expr info
422+ let getType (_, t, _) = t
423+ let newRecordType = RecordN (Map.map getType newDict) sharedType
424+ let newCon = CEqual parentRegion context Error.Record recordRegion newRecordType tipe
503425
504− (P.Var name, Just (A.A _ tipe)) ->
505− constrainAnnotatedDef env defRegion patternRegion name expr tipe info
426+ let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
427+ let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
506428
507− _ ->
508− error "canonical definitions must not have complex patterns as names in the contstraint generation phase"
429+ return $ ex vars (CAnd (oldCon:cons))
509430
510431
511−constrainUnannotatedDef
512− :: Env.Env
513− -> R.Region
514− -> Text
515− -> C.Expr
516− -> Info
517− -> IO Info
518−constrainUnannotatedDef env patternRegion name expr info =
519− do v <- mkFlexVar
520− let tipe = VarN v
521− defCon <- constrain env expr tipe
522− return $ info
523− { iFlex = v : iFlex info
524− , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)
525− , iC2 = defCon /\ iC2 info
526− }
527−
528−
529−constrainAnnotatedDef
530− :: Env.Env
531− -> R.Region
532− -> R.Region
533− -> Text
534− -> C.Expr
535− -> ST.Canonical
536− -> Info
537− -> IO Info
538−constrainAnnotatedDef env defRegion region name expr tipe info =
539− do (flexType, flexVars) <- Env.instantiateFlex env tipe
540−
541− let scheme =
542− Scheme
543− { _rigidQuantifiers = []
544− , _flexibleQuantifiers = Map.elems flexVars
545− , _constraint = CTrue
546− , _header = Map.singleton name (A.A region flexType)
547− }
548−
549− defCon <- constrainAnnDefHelp expr tipe (ArgInfo name defRegion env [] [])
550−
551− return $ info
552− { iSchemes = scheme : iSchemes info
553− , iC1 = iC1 info /\ defCon
554− }
555−
556−
557−data ArgInfo =
558− ArgInfo
559− { _name :: Text
560− , _def :: R.Region
561− , _env :: Env.Env
562− , _args :: [(P.Canonical, Type)]
563− , _vars :: [Variable]
564− }
565−
566−
567−constrainAnnDefHelp :: C.Expr -> ST.Canonical -> ArgInfo -> IO Constraint
568−constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =
569− case (expr, tipe) of
570− (A.A _ (C.Lambda arg result), ST.Lambda argType resultType) ->
571− do (rigidArgType, newVars) <- Env.instantiateRigid env argType
572−
573− constrainAnnDefHelp result resultType $
574− ArgInfo
575− { _name = name
576− , _def = defRegion
577− , _env = Env.addValues newVars env
578− , _args = (arg, rigidArgType) : args
579− , _vars = Map.elems newVars ++ vars
580− }
581−
582− (A.A region _, _) ->
583− do (rigidType, newVars) <- Env.instantiateRigid env tipe
584−
585− let finalEnv = Env.addValues newVars env
586− let finalArgs = reverse args
587− let rigidVars = Map.elems newVars ++ vars
588−
589− (Pattern.Info headers argVars argCons) <-
590− Pattern.joinInfos <$> mapM (uncurry (Pattern.constrain finalEnv)) finalArgs
591432
592− resultVar <- mkFlexVar
593− let resultType = VarN resultVar
594− defCon <- constrain finalEnv expr resultType
433+-- CONSTRAIN TUPLE
434+
435+
436+constrainTuple :: Env -> R.Region -> Error.Context -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Type -> IO Constraint
437+constrainTuple env parentRegion context tupleRegion a b maybeC tipe =
438+ do aVar <- mkFlexVar
439+ bVar <- mkFlexVar
440+ let aType = VarN aVar
441+ let bType = VarN bVar
442+
443+ aCon <- constrain env tupleRegion Error.Whatever a aType
444+ bCon <- constrain env tupleRegion Error.Whatever b bType
445+
446+ case maybeC of
447+ Nothing ->
448+ do let tupleType = TupleN aType bType Nothing
449+ let tupleCon = CEqual parentRegion context Error.Tuple tupleRegion tupleType tipe
450+ return $ ex [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
451+
452+ Just c ->
453+ do cVar <- mkFlexVar
454+ let cType = VarN cVar
455+
456+ cCon <- constrain env tupleRegion Error.Whatever c cType
457+
458+ let tupleType = TupleN aType bType (Just cType)
459+ let tupleCon = CEqual parentRegion context Error.Tuple tupleRegion tupleType tipe
460+
461+ return $ ex [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
462+
463+
464+
465+-- CONSTRAIN SHADER
595466
596− let sharedArity = length args
597− let typeArity = sharedArity + length (ST.collectLambdas tipe) - 1
598− let argsArity = sharedArity + length (fst (C.collectLambdas expr))
599− let hint = Error.ReturnType name typeArity argsArity region
600− let resultCon =
601− CEqual hint defRegion rigidType resultType
602467
603− return $ forall rigidVars $ ex (resultVar : argVars) $ CLet [monoscheme headers] $
604− CAnd [ argCons, defCon, resultCon ]
468+constrainShader :: Env -> R.Region -> Error.Context -> R.Region -> Shader.Shader -> Type -> IO Constraint
469+constrainShader env parentRegion context shaderRegion (Shader.Shader attributes uniforms varyings) tipe =
470+ do attrVar <- mkFlexVar
471+ unifVar <- mkFlexVar
472+ let attrType = VarN attrVar
473+ let unifType = VarN unifVar
474+
475+ let shaderType =
476+ AppN ModuleName.webgl N.shader
477+ [ toShaderRecord attributes attrType
478+ , toShaderRecord uniforms unifType
479+ , toShaderRecord varyings EmptyRecordN
480+ ]
481+
482+ return $ ex [ attrVar, unifVar ] $
483+ CEqual parentRegion context Error.Shader shaderRegion shaderType tipe
484+
485+
486+toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
487+toShaderRecord types baseRecType =
488+ if Map.null types then
489+ baseRecType
490+ else
491+ RecordN (Map.map glToType types) baseRecType
492+
493+
494+glToType :: Shader.Type -> Type
495+glToType glType =
496+ case glType of
497+ Shader.V2 -> Type.vec2
498+ Shader.V3 -> Type.vec3
499+ Shader.V4 -> Type.vec4
500+ Shader.M4 -> Type.mat4
501+ Shader.Int -> Type.int
502+ Shader.Float -> Type.float
503+ Shader.Texture -> Type.texture
504+
505+
506+
507+-- CONSTRAIN LET
508+
509+
510+constrainLet :: Env -> R.Region -> Error.Context -> R.Region -> Can.Def -> Can.Expr -> Type -> IO Constraint
511+constrainLet env parentRegion context letRegion (Can.Def (A.A _ name) (Can.Args args _) expr maybeType) body tipe =
512+ case maybeType of
513+ Nothing ->
514+ error "TODO"
515+
516+ Just srcType ->
517+ error "TODO"