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