git.iko.soy/elk
on 4ffd70a help sign in
elk/src/Type/Constrain/Pattern.hs
75 lines 2.3 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 (===) = CEqual Error.None region
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 = varN v === tipe
45 }
47 P.Alias name p ->
48 do v <- variable Flexible
49 fragment <- constrain env p tipe
50 return $ fragment
51 { typeEnv = Map.insert name (rvar v) (typeEnv fragment)
52 , vars = v : vars fragment
53 , typeConstraint = varN v === tipe /\ typeConstraint fragment
54 }
56 P.Data name patterns ->
57 do (_kind, cvars, args, result) <-
58 Env.freshDataScheme env (V.toString name)
60 fragList <- Monad.zipWithM (constrain env) patterns args
61 let fragment = joinFragments fragList
62 return $ fragment
63 { typeConstraint = typeConstraint fragment /\ tipe === result
64 , vars = cvars ++ vars fragment
65 }
67 P.Record fields ->
68 do pairs <- mapM (\name -> (,) name <$> variable Flexible) fields
69 let tenv = Map.fromList (map (second rvar) pairs)
70 c <- exists $ \t -> return (tipe === record (Map.map (\v -> [A.drop v]) tenv) t)
71 return $ Fragment
72 { typeEnv = tenv
73 , vars = map snd pairs
74 , typeConstraint = c
75 }