git.iko.soy/elk
on fa9bfb9 help sign in
elk/src/Type/Constrain/Pattern.hs
91 lines 2.7 kB history raw
1{-# LANGUAGE FlexibleInstances #-}
2module Type.Constrain.Pattern where
4import Control.Arrow (second)
5import qualified Control.Monad as Monad
6import qualified Data.Map as Map
8import qualified AST.Pattern as P
9import qualified AST.Variable as V
10import qualified Reporting.Annotation as A
11import qualified Reporting.Error.Type as Error
12import qualified Type.Constrain.Literal as Literal
13import qualified Type.Environment as Env
14import Type.Fragment
15import Type.Type
18constrain
19 :: Env.Environment
20 -> P.CanonicalPattern
21 -> Type
22 -> IO Fragment
23constrain env (A.A region pattern) tipe =
24 let
25 equal patternError leftType rightType =
26 CEqual (Error.Pattern patternError) region leftType rightType
28 rvar v =
29 A.A region (varN v)
30 in
31 case pattern of
32 P.Anything ->
33 return emptyFragment
35 P.Literal lit ->
36 do c <- Literal.constrain env region lit tipe
37 return $ emptyFragment { typeConstraint = c }
39 P.Var name ->
40 do v <- variable Flexible
41 return $ Fragment
42 { typeEnv = Map.singleton name (rvar v)
43 , vars = [v]
44 , typeConstraint =
45 equal (Error.PVar name) (varN v) tipe
46 }
48 P.Alias name p ->
49 do v <- variable Flexible
50 fragment <- constrain env p tipe
51 return $ fragment
52 { typeEnv = Map.insert name (rvar v) (typeEnv fragment)
53 , vars = v : vars fragment
54 , typeConstraint =
55 equal (Error.PAlias name) (varN v) tipe
56 /\ typeConstraint fragment
57 }
59 P.Data name patterns ->
60 do let stringName = V.toString name
62 (_kind, cvars, args, result) <-
63 Env.freshDataScheme env stringName
65 fragList <- Monad.zipWithM (constrain env) patterns args
66 let fragment = joinFragments fragList
67 return $ fragment
68 { vars = cvars ++ vars fragment
69 , typeConstraint =
70 typeConstraint fragment
71 /\ equal (Error.PData stringName) tipe result
72 }
74 P.Record fields ->
75 do pairs <-
76 mapM (\name -> (,) name <$> variable Flexible) fields
78 let tenv =
79 Map.fromList (map (second rvar) pairs)
81 let unannotatedTenv =
82 Map.map (\v -> [A.drop v]) tenv
84 con <- exists $ \t ->
85 return (equal Error.PRecord tipe (record unannotatedTenv t))
87 return $ Fragment
88 { typeEnv = tenv
89 , vars = map snd pairs
90 , typeConstraint = con
91 }