git.iko.soy/elk
on bca019d help sign in
elk/src/Type/Constrain/Pattern.hs
126 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 Type.Constraint
15import qualified Type.Constrain.Literal as Literal
16import qualified Type.Environment as Env
17import Type.Type
21-- PATTERN INFO
24data Info =
25 Info
26 { _headers :: Map.Map Text (A.Located Type)
27 , _vars :: [Variable]
28 , _cons :: Constraint
29 }
32emptyInfo :: Info
33emptyInfo =
34 Info Map.empty [] CTrue
37joinInfo :: Info -> Info -> Info
38joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
39 Info
40 { _headers = Map.union headers1 headers2
41 , _vars = vars1 ++ vars2
42 , _cons = cons1 /\ cons2
43 }
46joinInfos :: [Info] -> Info
47joinInfos infos =
48 List.foldl' (flip joinInfo) emptyInfo infos
51infoToScheme :: Info -> Scheme
52infoToScheme (Info headers vars cons) =
53 Scheme [] vars cons headers
57-- CONSTRAIN PATTERN
60constrain :: Env.Env -> P.Canonical -> Type -> IO Info
61constrain env (A.A region pattern) tipe =
62 let
63 equal patternError leftType rightType =
64 CEqual (Error.Pattern patternError) region leftType rightType
66 rvar v =
67 A.A region (VarN v)
68 in
69 case pattern of
70 P.Anything ->
71 return emptyInfo
73 P.Literal lit ->
74 do c <- Literal.constrain region lit tipe
75 return $ emptyInfo { _cons = c }
77 P.Var name ->
78 do variable <- mkFlexVar
79 return $ Info
80 { _headers = Map.singleton name (rvar variable)
81 , _vars = [variable]
82 , _cons = equal (Error.PVar name) (VarN variable) tipe
83 }
85 P.Alias name ptrn ->
86 do variable <- mkFlexVar
87 info <- constrain env ptrn tipe
88 return $ info
89 { _headers = Map.insert name (rvar variable) (_headers info)
90 , _vars = variable : _vars info
91 , _cons =
92 equal (Error.PAlias name) (VarN variable) tipe
93 /\ _cons info
94 }
96 P.Ctor name patterns ->
97 do (_kind, cvars, args, result) <-
98 Env.freshDataScheme env (Var.toText name)
100 fragList <- Monad.zipWithM (constrain env) patterns args
101 let info = joinInfos fragList
102 return $ info
103 { _vars = cvars ++ _vars info
104 , _cons =
105 equal (Error.PCtor name) result tipe
106 /\ _cons info
107 }
109 P.Record fields ->
110 do pairs <-
111 mapM (\name -> (,) name <$> mkFlexVar) fields
113 let tenv =
114 Map.fromList (map (second rvar) pairs)
116 let unannotatedTenv =
117 Map.map A.drop tenv
119 con <- exists $ \t ->
120 return (equal Error.PRecord tipe (RecordN unannotatedTenv t))
122 return $ Info
123 { _headers = tenv
124 , _vars = map snd pairs
125 , _cons = con
126 }