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