git.iko.soy/elk
on 003ebfd help sign in
elk/compiler/Type/Constrain/Pattern.hs
90 lines 3.3 kB history raw
1module Type.Constrain.Pattern where
3import Control.Arrow (second)
4import Control.Applicative ((<$>))
5import qualified Control.Monad as Monad
6import qualified Data.List as List
7import qualified Data.Maybe as Maybe
8import Data.Map ((!))
9import qualified Data.Map as Map
11import SourceSyntax.Pattern
12import Type.Type
13import Type.Fragment
14import Type.Environment as Env
15import qualified Type.Constrain.Literal as Literal
18constrain :: Environment -> Pattern -> Type -> IO Fragment
19constrain env pattern tipe =
20 case pattern of
21 PAnything -> return emptyFragment
23 PLiteral lit ->
24 return $ emptyFragment {
25 typeConstraint = Literal.constrain env lit tipe
26 }
28 PVar name -> do
29 v <- flexibleVar
30 return $ Fragment {
31 typeEnv = Map.singleton name (VarN v),
32 vars = [v],
33 typeConstraint = VarN v === tipe
34 }
36 PAlias name p -> do
37 fragment <- constrain env p tipe
38 return $ fragment {
39 typeEnv = Map.insert name tipe (typeEnv fragment),
40 typeConstraint = name <? tipe /\ typeConstraint fragment
41 }
43 PData name patterns -> do
44 (cvars, ctipe) <- freshDataScheme env name
45 let (argTypes, resultType) = flattenFunction ctipe
46 msg = "Constructor '" ++ name ++ "' expects " ++ show (length argTypes) ++ " arguments."
47 if length patterns /= length argTypes then error msg else do
48 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns argTypes)
49 return $ fragment {
50 typeConstraint = typeConstraint fragment /\ tipe === resultType,
51 vars = cvars ++ vars fragment
52 }
54 PRecord fields -> do
55 pairs <- mapM (\name -> (,) name <$> flexibleVar) fields
56 let tenv = Map.fromList (map (second VarN) pairs)
57 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
58 return $ Fragment {
59 typeEnv = tenv,
60 vars = map snd pairs,
61 typeConstraint = c
62 }
64freshDataScheme :: Environment -> [Char] -> IO ([Variable], Type)
65freshDataScheme env name =
66 do let (vars, tipe) = Env.get env constructor name
67 freshVars <- mapM (\_ -> flexibleVar) vars
68 let assocList = zip vars freshVars
69 return (freshVars, substitute assocList tipe)
71substitute :: Eq a => [(a, a)] -> TermN a -> TermN a
72substitute assocs tipe =
73 case tipe of
74 VarN x -> VarN (Maybe.fromMaybe x (List.lookup x assocs))
75 TermN t -> TermN $
76 case t of
77 App1 a b -> App1 (substitute assocs a) (substitute assocs b)
78 Fun1 a b -> Fun1 (substitute assocs a) (substitute assocs b)
79 Var1 v -> Var1 (substitute assocs v)
80 EmptyRecord1 -> EmptyRecord1
81 Record1 fields extension ->
82 Record1 (Map.map (map $ substitute assocs) fields)
83 (substitute assocs extension)
85flattenFunction :: TermN t -> ([TermN t], TermN t)
86flattenFunction = go []
87 where go args tipe =
88 case tipe of
89 TermN (Fun1 a b) -> go (a:args) b
90 _ -> (reverse args, tipe)