git.iko.soy/elk
on e123780 help sign in
elk/compiler/Type/Constrain/Pattern.hs
79 lines 2.9 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 SourceSyntax.Annotation as A
13import qualified SourceSyntax.Pattern as P
14import SourceSyntax.PrettyPrint (pretty)
15import Type.Type
16import Type.Fragment
17import Type.Environment as Env
18import qualified Type.Constrain.Literal as Literal
21constrain :: Environment -> P.Pattern -> Type -> ErrorT (A.Region -> PP.Doc) IO Fragment
22constrain env pattern tipe =
23 let region = A.None (pretty pattern)
24 t1 === t2 = A.A region (CEqual t1 t2)
25 x <? t = A.A region (CInstance x t)
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 $ var 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 fragment <- constrain env p tipe
44 return $ fragment {
45 typeEnv = Map.insert name tipe (typeEnv fragment),
46 typeConstraint = name <? tipe /\ typeConstraint fragment
47 }
49 P.Data name patterns -> do
50 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
51 let msg = concat [ "Constructor '", name, "' expects ", show kind
52 , " argument", if kind == 1 then "" else "s"
53 , " but was given ", show (length patterns), "." ]
54 err span = PP.vcat [ PP.text $ "Type error " ++ show span
55 , PP.text msg ]
56 case length patterns == kind of
57 False -> throwError err
58 True -> do
59 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
60 return $ fragment {
61 typeConstraint = typeConstraint fragment /\ tipe === result,
62 vars = cvars ++ vars fragment
63 }
65 P.Record fields -> do
66 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
67 let tenv = Map.fromList (map (second VarN) pairs)
68 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
69 return $ Fragment {
70 typeEnv = tenv,
71 vars = map snd pairs,
72 typeConstraint = c
73 }
75instance Error (A.Region -> PP.Doc) where
76 noMsg _ = PP.empty
77 strMsg str span =
78 PP.vcat [ PP.text $ "Type error " ++ show span
79 , PP.text str ]