git.iko.soy/elk
on cd4b4e2 help sign in
elk/compiler/Type/Constrain/Pattern.hs
82 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.List as List
9import qualified Data.Maybe as Maybe
10import qualified Data.Map as Map
11import qualified Text.PrettyPrint as PP
13import SourceSyntax.Pattern
14import SourceSyntax.Location
15import SourceSyntax.PrettyPrint
16import Text.PrettyPrint (render)
17import qualified SourceSyntax.Location as Loc
18import Type.Type
19import Type.Fragment
20import Type.Environment as Env
21import qualified Type.Constrain.Literal as Literal
24constrain :: Environment -> Pattern -> Type -> ErrorT (SrcSpan -> PP.Doc) IO Fragment
25constrain env pattern tipe =
26 let span = Loc.NoSpan (render $ pretty pattern)
27 t1 === t2 = Loc.L span (CEqual t1 t2)
28 x <? t = Loc.L span (CInstance x t)
29 in
30 case pattern of
31 PAnything -> return emptyFragment
33 PLiteral lit -> do
34 c <- liftIO $ Literal.constrain env span lit tipe
35 return $ emptyFragment { typeConstraint = c }
37 PVar name -> do
38 v <- liftIO $ var Flexible
39 return $ Fragment {
40 typeEnv = Map.singleton name (VarN v),
41 vars = [v],
42 typeConstraint = VarN v === tipe
43 }
45 PAlias name p -> do
46 fragment <- constrain env p tipe
47 return $ fragment {
48 typeEnv = Map.insert name tipe (typeEnv fragment),
49 typeConstraint = name <? tipe /\ typeConstraint fragment
50 }
52 PData name patterns -> do
53 (kind, cvars, args, result) <- liftIO $ freshDataScheme env name
54 let msg = concat [ "Constructor '", 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 PRecord fields -> do
69 pairs <- liftIO $ mapM (\name -> (,) name <$> var 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 (SrcSpan -> PP.Doc) where
79 noMsg _ = PP.empty
80 strMsg str span =
81 PP.vcat [ PP.text $ "Type error " ++ show span
82 , PP.text str ]