1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Expression
5 , constrainRecursiveDefs
10import qualified Data.Map.Strict as Map
12import qualified AST.Canonical as Can
13import qualified AST.Module.Name as ModuleName
14import qualified AST.Utils.Shader as Shader
15import qualified Data.Index as Index
16import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
18import qualified Reporting.Region as R
19import Type.Constraint as C
20import qualified Type.Constrain.Pattern as Pattern
21import qualified Type.Instantiate as Instantiate
22import Type.Type as Type hiding (Descriptor(..))
29-- As we step past type annotations, the free type variables are added to
30-- the "rigid type variables" dict. Allowing sharing of rigid variables
31-- between nested type annotations.
33-- So if you have a top-level type annotation like (func : a -> b) the RTV
34-- dictionary will hold variables for `a` and `b`
40constrain :: RTV -> Can.Expr -> Expected Type -> IO Constraint
41constrain rtv (A.At region expression) expected =
44 return (CLookup region name expected)
46 Can.VarTopLevel _ name ->
47 return (CLookup region name expected)
52 Can.VarForeign _ name annotation ->
53 return $ CInstance region (FuncName name) annotation expected
55 Can.VarDebug _ name annotation ->
56 return $ CInstance region (FuncName name) annotation expected
58 Can.VarOperator op _ _ annotation ->
59 return $ CInstance region (OpName op) annotation expected
62 return $ CEqual region String Type.string expected
65 return $ CEqual region Char Type.char expected
68 do var <- mkFlexNumber
69 return $ exists [var] $ CEqual region C.Number (VarN var) expected
72 return $ CEqual region Float Type.float expected
75 constrainList rtv region elements expected
78 do numberVar <- mkFlexNumber
79 let numberType = VarN numberVar
80 numberCon <- constrain rtv expr (FromContext region Negate numberType)
81 let negateCon = CEqual region C.Number numberType expected
82 return $ exists [numberVar] $ CAnd [ numberCon, negateCon ]
84 Can.Binop op _ _ annotation leftExpr rightExpr ->
85 constrainBinop rtv region op annotation leftExpr rightExpr expected
87 Can.Lambda args body ->
88 constrainLambda rtv region args body expected
91 constrainCall rtv region func args expected
93 Can.If branches finally ->
94 constrainIf rtv region branches finally expected
96 Can.Case expr branches ->
97 constrainCase rtv region expr branches expected
101 =<< constrain rtv body expected
103 Can.LetRec defs body ->
104 constrainRecursiveDefs rtv defs
105 =<< constrain rtv body expected
107 Can.LetDestruct pattern expr body ->
108 constrainDestruct rtv region pattern expr
109 =<< constrain rtv body expected
111 Can.Accessor field ->
112 do extVar <- mkFlexVar
113 fieldVar <- mkFlexVar
114 let extType = VarN extVar
115 let fieldType = VarN fieldVar
116 let recordType = RecordN (Map.singleton field fieldType) extType
117 return $ exists [ fieldVar, extVar ] $
118 CEqual region (Accessor field) (FunN recordType fieldType) expected
120 Can.Access expr field ->
121 do extVar <- mkFlexVar
122 fieldVar <- mkFlexVar
123 let extType = VarN extVar
124 let fieldType = VarN fieldVar
125 let recordType = RecordN (Map.singleton field fieldType) extType
128 constrain rtv expr (FromContext region (RecordAccess field) recordType)
130 return $ exists [ fieldVar, extVar ] $
133 , CEqual region (Access field) recordType expected
136 Can.Update expr fields ->
137 constrainUpdate rtv region expr fields expected
140 constrainRecord rtv region fields expected
143 return $ CEqual region Unit UnitN expected
145 Can.Tuple a b maybeC ->
146 constrainTuple rtv region a b maybeC expected
148 Can.Shader _uid _src glType ->
149 constrainShader region glType expected
156constrainLambda :: RTV -> R.Region -> [Can.Pattern] -> Can.Expr -> Expected Type -> IO Constraint
157constrainLambda rtv region args body expected =
158 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-
162 constrain rtv body (NoExpectation resultType)
164 return $ exists vars $
170 , _headerCon = CAnd (reverse revCons)
173 , CEqual region Lambda tipe expected
181constrainCall :: RTV -> R.Region -> Can.Expr -> [Can.Expr] -> Expected Type -> IO Constraint
182constrainCall rtv region func args expected =
183 do let maybeFuncName = getFuncName func
186 resultVar <- mkFlexVar
187 let funcType = VarN funcVar
188 let resultType = VarN resultVar
190 funcCon <- constrain rtv func (NoExpectation funcType)
192 (argVars, argTypes, argCons) <-
193 unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
195 let arityType = foldr FunN resultType argTypes
196 let resultCon = CEqual region (CallResult maybeFuncName) resultType expected
198 return $ exists (funcVar:resultVar:argVars) $
204 , _eq = CAnd [ CAnd argCons, resultCon ]
205 , _neq = constrainCallBackup rtv region maybeFuncName func args
210constrainArg :: RTV -> R.Region -> Maybe FuncName -> Index.ZeroBased -> Can.Expr -> IO (Variable, Type, Constraint)
211constrainArg rtv region maybeFuncName index arg =
212 do argVar <- mkFlexVar
213 let argType = VarN argVar
214 argCon <- constrain rtv arg (FromContext region (CallArg maybeFuncName index) argType)
215 return (argVar, argType, argCon)
218constrainCallBackup :: RTV -> R.Region -> Maybe FuncName -> Can.Expr -> [Can.Expr] -> IO Constraint
219constrainCallBackup rtv region maybeFuncName func args =
220 do (argVars, argTypes, argCons) <-
221 unzip3 <$> Index.indexedTraverse (constrainArg rtv region maybeFuncName) args
223 resultVar <- mkFlexVar
224 let resultType = VarN resultVar
225 let arityType = foldr FunN resultType argTypes
227 funcCon <- constrain rtv func (FromContext region BadArity arityType)
229 return $ exists (resultVar:argVars) $ CAnd [ CAnd argCons, funcCon ]
232getFuncName :: Can.Expr -> Maybe FuncName
233getFuncName (A.At _ expr) =
238 Can.VarTopLevel _ name ->
241 Can.VarKernel _ name ->
244 Can.VarForeign _ name _ ->
247 Can.VarOperator op _ _ _ ->
258constrainBinop :: RTV -> R.Region -> N.Name -> Can.Annotation -> Can.Expr -> Can.Expr -> Expected Type -> IO Constraint
259constrainBinop rtv region op annotation leftExpr rightExpr expected =
260 do leftVar <- mkFlexVar
261 rightVar <- mkFlexVar
262 answerVar <- mkFlexVar
263 let leftType = VarN leftVar
264 let rightType = VarN rightVar
265 let answerType = VarN answerVar
266 let binopType = leftType ==> rightType ==> answerType
268 let opCon = CInstance region (OpName op) annotation (NoExpectation binopType)
270 leftCon <- constrain rtv leftExpr (FromContext region (OpLeft op) leftType)
271 rightCon <- constrain rtv rightExpr (FromContext region (OpRight op) rightType)
273 return $ exists [ leftVar, rightVar, answerVar ] $
278 , CEqual region (CallResult (Just (OpName op))) answerType expected
286constrainList :: RTV -> R.Region -> [Can.Expr] -> Expected Type -> IO Constraint
287constrainList rtv region entries expected =
288 do entryVar <- mkFlexVar
289 let entryType = VarN entryVar
290 let listType = AppN ModuleName.list N.list [entryType]
293 Index.indexedTraverse (constrainListEntry rtv region entryType) entries
295 return $ exists [entryVar] $
298 , CEqual region List listType expected
302constrainListEntry :: RTV -> R.Region -> Type -> Index.ZeroBased -> Can.Expr -> IO Constraint
303constrainListEntry rtv region tipe index expr =
304 constrain rtv expr (FromContext region (ListEntry index) tipe)
308-- CONSTRAIN IF EXPRESSIONS
311constrainIf :: RTV -> R.Region -> [(Can.Expr, Can.Expr)] -> Can.Expr -> Expected Type -> IO Constraint
312constrainIf rtv region branches final expected =
313 do let boolExpect = FromContext region IfCondition Type.bool
314 let (conditions, exprs) = foldr (\(c,e) (cs,es) -> (c:cs,e:es)) ([],[final]) branches
317 traverse (\c -> constrain rtv c boolExpect) conditions
320 FromAnnotation name arity _ tipe ->
321 do branchCons <- Index.indexedForA exprs $ \index expr ->
322 constrain rtv expr (FromAnnotation name arity (TypedIfBranch index) tipe)
330 do branchVar <- mkFlexVar
331 let branchType = VarN branchVar
333 branchCons <- Index.indexedForA exprs $ \index expr ->
334 constrain rtv expr (FromContext region (IfBranch index) branchType)
336 return $ exists [branchVar] $
340 , CEqual region If branchType expected
345-- CONSTRAIN CASE EXPRESSIONS
348constrainCase :: RTV -> R.Region -> Can.Expr -> [Can.CaseBranch] -> Expected Type -> IO Constraint
349constrainCase rtv region expr branches expected =
350 do ptrnVar <- mkFlexVar
351 let ptrnType = VarN ptrnVar
352 exprCon <- constrain rtv expr (NoExpectation ptrnType)
355 FromAnnotation name arity _ tipe ->
356 do branchCons <- Index.indexedForA branches $ \index branch ->
357 constrainCaseBranch rtv branch
358 (PFromContext region (PCaseMatch index) ptrnType)
359 (FromAnnotation name arity (TypedCaseBranch index) tipe)
361 return $ exists [ptrnVar] $ CAnd (exprCon:branchCons)
364 do branchVar <- mkFlexVar
365 let branchType = VarN branchVar
367 branchCons <- Index.indexedForA branches $ \index branch ->
368 constrainCaseBranch rtv branch
369 (PFromContext region (PCaseMatch index) ptrnType)
370 (FromContext region (CaseBranch index) branchType)
372 return $ exists [ptrnVar,branchVar] $
376 , CEqual region Case branchType expected
380constrainCaseBranch :: RTV -> Can.CaseBranch -> PExpected Type -> Expected Type -> IO Constraint
381constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect =
382 do (Pattern.State headers pvars revCons) <-
383 Pattern.add pattern pExpect Pattern.emptyState
385 CLet [] pvars headers (CAnd (reverse revCons))
386 <$> constrain rtv expr bExpect
393constrainRecord :: RTV -> R.Region -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint
394constrainRecord rtv region fields expected =
395 do dict <- traverse (constrainField rtv) fields
397 let getType (_, t, _) = t
398 let recordType = RecordN (Map.map getType dict) EmptyRecordN
399 let recordCon = CEqual region Record recordType expected
401 let vars = Map.foldr (\(v,_,_) vs -> v:vs) [] dict
402 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [recordCon] dict
404 return $ exists vars (CAnd cons)
407constrainField :: RTV -> Can.Expr -> IO (Variable, Type, Constraint)
408constrainField rtv expr =
411 con <- constrain rtv expr (NoExpectation tipe)
412 return (var, tipe, con)
416-- CONSTRAIN RECORD UPDATE
419constrainUpdate :: RTV -> R.Region -> Can.Expr -> Map.Map N.Name Can.Expr -> Expected Type -> IO Constraint
420constrainUpdate rtv region expr fields expected =
421 do sharedVar <- mkFlexVar
422 let sharedType = VarN sharedVar
424 oldVars <- traverse (\_ -> mkFlexVar) fields
425 let oldTypes = Map.map VarN oldVars
426 let oldRecordType = RecordN oldTypes sharedType
427 oldCon <- constrain rtv expr (FromContext region RecordUpdate oldRecordType)
429 newDict <- traverse (constrainField rtv) fields
431 let getType (_, t, _) = t
432 let newRecordType = RecordN (Map.map getType newDict) sharedType
433 let newCon = CEqual region Record newRecordType expected
435 let vars = Map.foldr (\(v,_,_) vs -> v:vs) (sharedVar : Map.elems oldVars) newDict
436 let cons = Map.foldr (\(_,_,c) cs -> c:cs) [newCon] newDict
438 return $ exists vars (CAnd (oldCon:cons))
445constrainTuple :: RTV -> R.Region -> Can.Expr -> Can.Expr -> Maybe Can.Expr -> Expected Type -> IO Constraint
446constrainTuple rtv region a b maybeC expected =
449 let aType = VarN aVar
450 let bType = VarN bVar
452 aCon <- constrain rtv a (NoExpectation aType)
453 bCon <- constrain rtv b (NoExpectation bType)
457 do let tupleType = TupleN aType bType Nothing
458 let tupleCon = CEqual region Tuple tupleType expected
459 return $ exists [ aVar, bVar ] $ CAnd [ aCon, bCon, tupleCon ]
463 let cType = VarN cVar
465 cCon <- constrain rtv c (NoExpectation cType)
467 let tupleType = TupleN aType bType (Just cType)
468 let tupleCon = CEqual region Tuple tupleType expected
470 return $ exists [ aVar, bVar, cVar ] $ CAnd [ aCon, bCon, cCon, tupleCon ]
477constrainShader :: R.Region -> Shader.Shader -> Expected Type -> IO Constraint
478constrainShader region (Shader.Shader attributes uniforms varyings) expected =
479 do attrVar <- mkFlexVar
481 let attrType = VarN attrVar
482 let unifType = VarN unifVar
485 AppN ModuleName.webgl N.shader
486 [ toShaderRecord attributes attrType
487 , toShaderRecord uniforms unifType
488 , toShaderRecord varyings EmptyRecordN
491 return $ exists [ attrVar, unifVar ] $
492 CEqual region Shader shaderType expected
495toShaderRecord :: Map.Map N.Name Shader.Type -> Type -> Type
496toShaderRecord types baseRecType =
497 if Map.null types then
500 RecordN (Map.map glToType types) baseRecType
503glToType :: Shader.Type -> Type
506 Shader.V2 -> Type.vec2
507 Shader.V3 -> Type.vec3
508 Shader.V4 -> Type.vec4
509 Shader.M4 -> Type.mat4
510 Shader.Int -> Type.int
511 Shader.Float -> Type.float
512 Shader.Texture -> Type.texture
516-- CONSTRAIN DESTRUCTURES
519constrainDestruct :: RTV -> R.Region -> Can.Pattern -> Can.Expr -> Constraint -> IO Constraint
520constrainDestruct rtv region pattern expr bodyCon =
521 do patternVar <- mkFlexVar
522 let patternType = VarN patternVar
524 (Pattern.State headers pvars revCons) <-
525 Pattern.add pattern (PNoExpectation patternType) Pattern.emptyState
528 constrain rtv expr (FromContext region Destructure patternType)
530 return $ CLet [] pvars headers (CAnd (reverse (exprCon:revCons))) bodyCon
537constrainDef :: RTV -> Can.Def -> Constraint -> IO Constraint
538constrainDef rtv def bodyCon =
540 Can.Def (A.At region name) args expr ->
541 do (Args vars tipe resultType (Pattern.State headers pvars revCons)) <-
545 constrain rtv expr (NoExpectation resultType)
551 , _header = Map.singleton name (A.At region tipe)
557 , _headerCon = CAnd (reverse revCons)
563 Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->
564 do let newNames = Map.difference freeVars rtv
565 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames
566 let newRtv = Map.union rtv (Map.map VarN newRigids)
568 (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-
569 constrainTypedArgs newRtv name typedArgs srcResultType
571 let expected = FromAnnotation name (length typedArgs) TypedBody resultType
573 constrain newRtv expr expected
577 { _rigidVars = Map.elems newRigids
579 , _header = Map.singleton name (A.At region tipe)
585 , _headerCon = CAnd (reverse revCons)
593-- CONSTRAIN RECURSIVE DEFS
598 { _vars :: [Variable]
599 , _cons :: [Constraint]
600 , _headers :: Map.Map N.Name (A.Located Type)
604{-# NOINLINE emptyInfo #-}
610constrainRecursiveDefs :: RTV -> [Can.Def] -> Constraint -> IO Constraint
611constrainRecursiveDefs rtv defs bodyCon =
612 recDefsHelp rtv defs bodyCon emptyInfo emptyInfo
615recDefsHelp :: RTV -> [Can.Def] -> Constraint -> Info -> Info -> IO Constraint
616recDefsHelp rtv defs bodyCon rigidInfo flexInfo =
619 do let (Info rigidVars rigidCons rigidHeaders) = rigidInfo
620 let (Info flexVars flexCons flexHeaders ) = flexInfo
622 CLet rigidVars [] rigidHeaders CTrue $
623 CLet [] flexVars flexHeaders (CLet [] [] flexHeaders CTrue (CAnd flexCons)) $
624 CAnd [ CAnd rigidCons, bodyCon ]
628 Can.Def (A.At region name) args expr ->
629 do let (Info flexVars flexCons flexHeaders) = flexInfo
631 (Args newFlexVars tipe resultType (Pattern.State headers pvars revCons)) <-
632 argsHelp args (Pattern.State Map.empty flexVars [])
635 constrain rtv expr (NoExpectation resultType)
642 , _headerCon = CAnd (reverse revCons)
646 recDefsHelp rtv otherDefs bodyCon rigidInfo $
648 { _vars = newFlexVars
649 , _cons = defCon : flexCons
650 , _headers = Map.insert name (A.At region tipe) flexHeaders
653 Can.TypedDef (A.At region name) freeVars typedArgs expr srcResultType ->
654 do let newNames = Map.difference freeVars rtv
655 newRigids <- Map.traverseWithKey (\n _ -> nameToRigid n) newNames
656 let newRtv = Map.union rtv (Map.map VarN newRigids)
658 (TypedArgs tipe resultType (Pattern.State headers pvars revCons)) <-
659 constrainTypedArgs newRtv name typedArgs srcResultType
662 constrain newRtv expr $
663 FromAnnotation name (length typedArgs) TypedBody resultType
670 , _headerCon = CAnd (reverse revCons)
674 let (Info rigidVars rigidCons rigidHeaders) = rigidInfo
675 recDefsHelp rtv otherDefs bodyCon
677 { _vars = Map.foldr (:) rigidVars newRigids
678 , _cons = defCon : rigidCons
679 , _headers = Map.insert name (A.At region tipe) rigidHeaders
691 { _a_vars :: [Variable]
694 , _a_state :: Pattern.State
698constrainArgs :: [Can.Pattern] -> IO Args
700 argsHelp args Pattern.emptyState
703argsHelp :: [Can.Pattern] -> Pattern.State -> IO Args
707 do resultVar <- mkFlexVar
708 let resultType = VarN resultVar
709 return $ Args [resultVar] resultType resultType state
711 pattern : otherArgs ->
712 do argVar <- mkFlexVar
713 let argType = VarN argVar
715 (Args vars tipe result newState) <-
716 argsHelp otherArgs =<<
717 Pattern.add pattern (PNoExpectation argType) state
719 return (Args (argVar:vars) (FunN argType tipe) result newState)
723-- CONSTRAIN TYPED ARGS
730 , _t_state :: Pattern.State
734constrainTypedArgs :: Map.Map N.Name Type -> N.Name -> [(Can.Pattern, Can.Type)] -> Can.Type -> IO TypedArgs
735constrainTypedArgs rtv name args srcResultType =
736 do resultType <- Instantiate.fromSrcType rtv srcResultType
737 typedArgsHelp rtv name Index.first args resultType Pattern.emptyState
740typedArgsHelp :: Map.Map N.Name Type -> N.Name -> Index.ZeroBased -> [(Can.Pattern, Can.Type)] -> Type -> Pattern.State -> IO TypedArgs
741typedArgsHelp rtv name index args resultType state =
744 return $ TypedArgs resultType resultType state
746 (pattern@(A.At region _), srcType) : otherArgs ->
747 do argType <- Instantiate.fromSrcType rtv srcType
748 let expected = PFromContext region (PTypedArg name index) argType
750 (TypedArgs tipe result newState) <-
751 typedArgsHelp rtv name (Index.next index) otherArgs resultType =<<
752 Pattern.add pattern expected state
754 return (TypedArgs (FunN argType tipe) result newState)
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list