git.iko.soy/elk
on 577fc17 help sign in
elk/compiler/Type/Constrain/Pattern.hs
81 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 x <? t = A.A region (CInstance x t)
28 in
29 case pattern of
30 P.Anything -> return emptyFragment
32 P.Literal lit -> do
33 c <- liftIO $ Literal.constrain env region lit tipe
34 return $ emptyFragment { typeConstraint = c }
36 P.Var name -> do
37 v <- liftIO $ variable Flexible
38 return $ Fragment {
39 typeEnv = Map.singleton name (varN v),
40 vars = [v],
41 typeConstraint = varN v === tipe
42 }
44 P.Alias name p -> do
45 fragment <- constrain env p tipe
46 return $ fragment {
47 typeEnv = Map.insert name tipe (typeEnv fragment),
48 typeConstraint = name <? 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 ]