git.iko.soy/elk
on e8bc65e help sign in
elk/src/Type/Constrain/Pattern.hs
125 lines 3.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) where
4import Control.Arrow (second)
5import qualified Control.Monad as Monad
6import qualified Data.Map as Map
7import qualified Data.List as List
8import Data.Text (Text)
10import qualified AST.Pattern as P
11import qualified AST.Variable as Var
12import qualified Reporting.Annotation as A
13import qualified Reporting.Error.Type as Error
14import qualified Type.Constrain.Literal as Literal
15import qualified Type.Environment as Env
16import Type.Type
20-- PATTERN INFO
23data Info =
24 Info
25 { _headers :: Map.Map Text (A.Located Type)
26 , _vars :: [Variable]
27 , _cons :: TypeConstraint
28 }
31emptyInfo :: Info
32emptyInfo =
33 Info Map.empty [] CTrue
36joinInfo :: Info -> Info -> Info
37joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
38 Info
39 { _headers = Map.union headers1 headers2
40 , _vars = vars1 ++ vars2
41 , _cons = cons1 /\ cons2
42 }
45joinInfos :: [Info] -> Info
46joinInfos infos =
47 List.foldl' (flip joinInfo) emptyInfo infos
50infoToScheme :: Info -> Scheme Type Variable
51infoToScheme (Info headers vars cons) =
52 Scheme [] vars cons headers
56-- CONSTRAIN PATTERN
59constrain :: Env.Env -> P.Canonical -> Type -> IO Info
60constrain env (A.A region pattern) tipe =
61 let
62 equal patternError leftType rightType =
63 CEqual (Error.Pattern patternError) region leftType rightType
65 rvar v =
66 A.A region (VarN v)
67 in
68 case pattern of
69 P.Anything ->
70 return emptyInfo
72 P.Literal lit ->
73 do c <- Literal.constrain env region lit tipe
74 return $ emptyInfo { _cons = c }
76 P.Var name ->
77 do variable <- mkVar Nothing
78 return $ Info
79 { _headers = Map.singleton name (rvar variable)
80 , _vars = [variable]
81 , _cons = equal (Error.PVar name) (VarN variable) tipe
82 }
84 P.Alias name ptrn ->
85 do variable <- mkVar Nothing
86 info <- constrain env ptrn tipe
87 return $ info
88 { _headers = Map.insert name (rvar variable) (_headers info)
89 , _vars = variable : _vars info
90 , _cons =
91 equal (Error.PAlias name) (VarN variable) tipe
92 /\ _cons info
93 }
95 P.Ctor name patterns ->
96 do (_kind, cvars, args, result) <-
97 Env.freshDataScheme env (Var.toText name)
99 fragList <- Monad.zipWithM (constrain env) patterns args
100 let info = joinInfos fragList
101 return $ info
102 { _vars = cvars ++ _vars info
103 , _cons =
104 equal (Error.PCtor name) result tipe
105 /\ _cons info
106 }
108 P.Record fields ->
109 do pairs <-
110 mapM (\name -> (,) name <$> mkVar Nothing) fields
112 let tenv =
113 Map.fromList (map (second rvar) pairs)
115 let unannotatedTenv =
116 Map.map A.drop tenv
118 con <- exists $ \t ->
119 return (equal Error.PRecord tipe (record unannotatedTenv t))
121 return $ Info
122 { _headers = tenv
123 , _vars = map snd pairs
124 , _cons = con
125 }