git.iko.soy/elk
on e5093cd 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.List as List
7import qualified Data.Map as Map
9import qualified AST.Pattern as P
10import qualified AST.Variable as V
11import qualified Reporting.Annotation as A
12import qualified Reporting.Error.Type as Error
13import qualified Type.Constrain.Literal as Literal
14import qualified Type.Environment as Env
15import Type.Type
19-- PATTERN INFO
22data Info =
23 Info
24 { _headers :: Map.Map String (A.Located Type)
25 , _vars :: [Variable]
26 , _cons :: TypeConstraint
27 }
30emptyInfo :: Info
31emptyInfo =
32 Info Map.empty [] CTrue
35joinInfo :: Info -> Info -> Info
36joinInfo (Info headers1 vars1 cons1) (Info headers2 vars2 cons2) =
37 Info
38 { _headers = Map.union headers1 headers2
39 , _vars = vars1 ++ vars2
40 , _cons = cons1 /\ cons2
41 }
44joinInfos :: [Info] -> Info
45joinInfos infos =
46 List.foldl' (flip joinInfo) emptyInfo infos
49infoToScheme :: Info -> Scheme Type Variable
50infoToScheme (Info headers vars cons) =
51 Scheme [] vars cons headers
55-- CONSTRAIN PATTERN
58constrain :: Env.Env -> P.Canonical -> Type -> IO Info
59constrain env (A.A region pattern) tipe =
60 let
61 equal patternError leftType rightType =
62 CEqual (Error.Pattern patternError) region leftType rightType
64 rvar v =
65 A.A region (VarN v)
66 in
67 case pattern of
68 P.Anything ->
69 return emptyInfo
71 P.Literal lit ->
72 do c <- Literal.constrain env region lit tipe
73 return $ emptyInfo { _cons = c }
75 P.Var name ->
76 do variable <- mkVar Nothing
77 return $ Info
78 { _headers = Map.singleton name (rvar variable)
79 , _vars = [variable]
80 , _cons = equal (Error.PVar name) (VarN variable) tipe
81 }
83 P.Alias name ptrn ->
84 do variable <- mkVar Nothing
85 info <- constrain env ptrn tipe
86 return $ info
87 { _headers = Map.insert name (rvar variable) (_headers info)
88 , _vars = variable : _vars info
89 , _cons =
90 equal (Error.PAlias name) (VarN variable) tipe
91 /\ _cons info
92 }
94 P.Data name patterns ->
95 do let stringName = V.toString name
97 (_kind, cvars, args, result) <-
98 Env.freshDataScheme env stringName
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.PData stringName) result tipe
106 /\ _cons info
107 }
109 P.Record fields ->
110 do pairs <-
111 mapM (\name -> (,) name <$> mkVar Nothing) 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 (record unannotatedTenv t))
122 return $ Info
123 { _headers = tenv
124 , _vars = map snd pairs
125 , _cons = con
126 }