git.iko.soy/elk
on 684504e help sign in
elk/src/Type/Constrain/Pattern.hs
86 lines 2.7 kB history raw
1module Type.Constrain.Pattern where
3import Control.Arrow (second)
4import qualified Control.Monad as Monad
5import qualified Data.Map as Map
7import qualified AST.Pattern as P
8import qualified AST.Variable as V
9import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Type as Error
11import qualified Type.Constrain.Literal as Literal
12import qualified Type.Environment as Env
13import Type.Fragment
14import Type.Type
17constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment
18constrain env (A.A region pattern) tipe =
19 let
20 equal patternError leftType rightType =
21 CEqual (Error.Pattern patternError) region leftType rightType
23 rvar v =
24 A.A region (VarN v)
25 in
26 case pattern of
27 P.Anything ->
28 return emptyFragment
30 P.Literal lit ->
31 do c <- Literal.constrain env region lit tipe
32 return $ emptyFragment { typeConstraint = c }
34 P.Var name ->
35 do variable <- mkVar Nothing
36 return $ Fragment
37 { typeEnv = Map.singleton name (rvar variable)
38 , vars = [variable]
39 , typeConstraint =
40 equal (Error.PVar name) (VarN variable) tipe
41 }
43 P.Alias name p ->
44 do variable <- mkVar Nothing
45 fragment <- constrain env p tipe
46 return $ fragment
47 { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)
48 , vars = variable : vars fragment
49 , typeConstraint =
50 equal (Error.PAlias name) (VarN variable) tipe
51 /\ typeConstraint fragment
52 }
54 P.Data name patterns ->
55 do let stringName = V.toString name
57 (_kind, cvars, args, result) <-
58 Env.freshDataScheme env stringName
60 fragList <- Monad.zipWithM (constrain env) patterns args
61 let fragment = joinFragments fragList
62 return $ fragment
63 { vars = cvars ++ vars fragment
64 , typeConstraint =
65 typeConstraint fragment
66 /\ equal (Error.PData stringName) tipe result
67 }
69 P.Record fields ->
70 do pairs <-
71 mapM (\name -> (,) name <$> mkVar Nothing) fields
73 let tenv =
74 Map.fromList (map (second rvar) pairs)
76 let unannotatedTenv =
77 Map.map A.drop tenv
79 con <- exists $ \t ->
80 return (equal Error.PRecord tipe (record unannotatedTenv t))
82 return $ Fragment
83 { typeEnv = tenv
84 , vars = map snd pairs
85 , typeConstraint = con
86 }