git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Type/Constrain/Pattern.hs
80 lines 2.9 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 SourceSyntax.Pattern
12import SourceSyntax.Location
13import SourceSyntax.PrettyPrint
14import Text.PrettyPrint (render)
15import qualified SourceSyntax.Location as Loc
16import Type.Type
17import Type.Fragment
18import Type.Environment as Env
19import qualified Type.Constrain.Literal as Literal
22constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
23constrain env pattern tipe =
24 let span = Loc.NoSpan (render $ pretty pattern)
25 t1 === t2 = Loc.L span (CEqual t1 t2)
26 x <? t = Loc.L span (CInstance x t)
27 in
28 case pattern of
29 PAnything -> return emptyFragment
31 PLiteral lit -> do
32 c <- liftIO $ Literal.constrain env span lit tipe
33 return $ emptyFragment { typeConstraint = c }
35 PVar name -> do
36 v <- liftIO $ var Flexible
37 return $ Fragment {
38 typeEnv = Map.singleton name (VarN v),
39 vars = [v],
40 typeConstraint = VarN v === tipe
41 }
43 PAlias name p -> do
44 fragment <- constrain env p tipe
45 return $ fragment {
46 typeEnv = Map.insert name tipe (typeEnv fragment),
47 typeConstraint = name <? tipe /\ typeConstraint fragment
48 }
50 PData name patterns -> do
51 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
52 let msg = concat [ "Constructor '", name, "' expects ", show kind
53 , " argument", if kind == 1 then "" else "s"
54 , " but was given ", show (length patterns), "." ]
55 err span = PP.vcat [ PP.text $ "Type error " ++ show span
56 , PP.text msg ]
57 case length patterns == kind of
58 False -> throwError err
59 True -> do
60 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)
61 return $ fragment {
62 typeConstraint = typeConstraint fragment /\ tipe === result,
63 vars = cvars ++ vars fragment
64 }
66 PRecord fields -> do
67 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
68 let tenv = Map.fromList (map (second VarN) pairs)
69 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
70 return $ Fragment {
71 typeEnv = tenv,
72 vars = map snd pairs,
73 typeConstraint = c
74 }
76instance Error (SrcSpan -> PP.Doc) where
77 noMsg _ = PP.empty
78 strMsg str span =
79 PP.vcat [ PP.text $ "Type error " ++ show span
80 , PP.text str ]