@@ -1,7 +1,9 @@
1−module Type.Constrain.Pattern where
1+{-# OPTIONS_GHC -Wall #-}
2+module Type.Constrain.Pattern (Info(..), infoToScheme, constrain) where
23
34import Control.Arrow (second)
45import qualified Control.Monad as Monad
6+import qualified Data.List as List
57import qualified Data.Map as Map
68
79import qualified AST.Pattern as P
@@ -10,11 +12,50 @@ import qualified Reporting.Annotation as A
1012import qualified Reporting.Error.Type as Error
1113import qualified Type.Constrain.Literal as Literal
1214import qualified Type.Environment as Env
13−import Type.Fragment
1415import Type.Type
1516
1617
17−constrain :: Env.Environment -> P.Canonical -> Type -> IO Fragment
18+
19+-- PATTERN INFO
20+
21+
22+data Info =
23+ Info
24+ { _headers :: Map.Map String (A.Located Type)
25+ , _vars :: [Variable]
26+ , _cons :: TypeConstraint
27+ }
28+
29+
30+emptyInfo :: Info
31+emptyInfo =
32+ Info Map.empty [] CTrue
33+
34+
35+joinInfo :: Info -> Info -> Info
36+joinInfo (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+ }
42+
43+
44+joinInfos :: [Info] -> Info
45+joinInfos infos =
46+ List.foldl' (flip joinInfo) emptyInfo infos
47+
48+
49+infoToScheme :: Info -> Scheme Type Variable
50+infoToScheme (Info headers vars cons) =
51+ Scheme [] vars cons headers
52+
53+
54+
55+-- CONSTRAIN PATTERN
56+
57+
58+constrain :: Env.Environment -> P.Canonical -> Type -> IO Info
1859constrain env (A.A region pattern) tipe =
1960 let
2061 equal patternError leftType rightType =
@@ -23,50 +64,49 @@ constrain env (A.A region pattern) tipe =
2364 rvar v =
2465 A.A region (VarN v)
2566 in
26− case pattern of
27− P.Anything ->
28− return emptyFragment
67+ case pattern of
68+ P.Anything ->
69+ return emptyInfo
2970
30− P.Literal lit ->
71+ P.Literal lit ->
3172 do c <- Literal.constrain env region lit tipe
32− return $ emptyFragment { typeConstraint = c }
73+ return $ emptyInfo { _cons = c }
3374
34− P.Var name ->
75+ P.Var name ->
3576 do variable <- mkVar Nothing
36− return $ Fragment
37− { typeEnv = Map.singleton name (rvar variable)
38− , vars = [variable]
39− , typeConstraint =
40− equal (Error.PVar name) (VarN variable) tipe
77+ return $ Info
78+ { _headers = Map.singleton name (rvar variable)
79+ , _vars = [variable]
80+ , _cons = equal (Error.PVar name) (VarN variable) tipe
4181 }
4282
43− P.Alias name p ->
83+ P.Alias name ptrn ->
4484 do variable <- mkVar Nothing
45− fragment <- constrain env p tipe
46− return $ fragment
47− { typeEnv = Map.insert name (rvar variable) (typeEnv fragment)
48− , vars = variable : vars fragment
49− , typeConstraint =
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 =
5090 equal (Error.PAlias name) (VarN variable) tipe
51− /\ typeConstraint fragment
91+ /\ _cons info
5292 }
5393
54− P.Data name patterns ->
94+ P.Data name patterns ->
5595 do let stringName = V.toString name
5696
5797 (_kind, cvars, args, result) <-
5898 Env.freshDataScheme env stringName
5999
60100 fragList <- Monad.zipWithM (constrain env) patterns args
61− let fragment = joinFragments fragList
62− return $ fragment
63− { vars = cvars ++ vars fragment
64− , typeConstraint =
65− typeConstraint fragment
66− /\ equal (Error.PData stringName) tipe result
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
67107 }
68108
69− P.Record fields ->
109+ P.Record fields ->
70110 do pairs <-
71111 mapM (\name -> (,) name <$> mkVar Nothing) fields
72112
@@ -79,8 +119,8 @@ constrain env (A.A region pattern) tipe =
79119 con <- exists $ \t ->
80120 return (equal Error.PRecord tipe (record unannotatedTenv t))
81121
82− return $ Fragment
83− { typeEnv = tenv
84− , vars = map snd pairs
85− , typeConstraint = con
122+ return $ Info
123+ { _headers = tenv
124+ , _vars = map snd pairs
125+ , _cons = con
86126 }