git.iko.soy/elk
on 69a4366 help sign in
elk/src/Type/Constrain/Pattern.hs
81 lines 3.0 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 Control.Monad.Error
8import qualified Data.Map as Map
9import qualified Text.PrettyPrint as PP
11import qualified AST.Annotation as A
12import qualified AST.Pattern as P
13import qualified AST.Variable as V
14import AST.PrettyPrint (pretty)
15import Type.Type
16import Type.Fragment
17import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
21constrain :: Environment -> P.CanonicalPattern -> Type
22 -> ErrorT (A.Region -> PP.Doc) IO Fragment
23constrain env pattern tipe =
24 let region = A.None (pretty pattern)
25 t1 === t2 = A.A region (CEqual t1 t2)
26 in
27 case pattern of
28 P.Anything -> return emptyFragment
30 P.Literal lit -> do
31 c <- liftIO $ Literal.constrain env region lit tipe
32 return $ emptyFragment { typeConstraint = c }
34 P.Var name -> do
35 v <- liftIO $ variable Flexible
36 return $ Fragment {
37 typeEnv = Map.singleton name (varN v),
38 vars = [v],
39 typeConstraint = varN v === tipe
40 }
42 P.Alias name p -> do
43 v <- liftIO $ variable Flexible
44 fragment <- constrain env p tipe
45 return $ fragment
46 { typeEnv = Map.insert name (varN v) (typeEnv fragment)
47 , vars = v : vars fragment
48 , typeConstraint = varN v === tipe /\ typeConstraint fragment
49 }
51 P.Data name patterns -> do
52 (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name)
53 let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind
54 , " argument", if kind == 1 then "" else "s"
55 , " but was given ", show (length patterns), "." ]
56 err span = PP.vcat [ PP.text $ "Type error " ++ show span
57 , PP.text msg ]
58 case length patterns == kind of
59 False -> throwError err
60 True -> do
61 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
62 return $ fragment {
63 typeConstraint = typeConstraint fragment /\ tipe === result,
64 vars = cvars ++ vars fragment
65 }
67 P.Record fields -> do
68 pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields
69 let tenv = Map.fromList (map (second varN) pairs)
70 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
71 return $ Fragment {
72 typeEnv = tenv,
73 vars = map snd pairs,
74 typeConstraint = c
75 }
77instance Error (A.Region -> PP.Doc) where
78 noMsg _ = PP.empty
79 strMsg str span =
80 PP.vcat [ PP.text $ "Type error " ++ show span
81 , PP.text str ]