git.iko.soy/elk
on 42f3721 help sign in
elk/compiler/src/Canonicalize/Pattern.hs
181 lines 4.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( verify
4 , Bindings
5 , DupsDict
6 , canonicalize
7 )
8 where
11import qualified Data.Map.Strict as Map
12import qualified Data.Name as Name
14import qualified AST.Canonical as Can
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Source as Src
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Data.Index as Index
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Region as R
23import qualified Reporting.Result as Result
27-- RESULTS
30type Result i w a =
31 Result.Result i w Error.Error a
34type Bindings =
35 Map.Map Name.Name R.Region
39-- VERIFY
42verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings)
43verify context (Result.Result k) =
44 Result.Result $ \info warnings bad good ->
45 k Dups.none warnings
46 (\_ warnings1 errors ->
47 bad info warnings1 errors
48 )
49 (\bindings warnings1 value ->
50 case Dups.detect (Error.DuplicatePattern context) bindings of
51 Result.Result k1 ->
52 k1 () ()
53 (\() () errs -> bad info warnings1 errs)
54 (\() () dict -> good info warnings1 (value, dict))
55 )
59-- CANONICALIZE
62type DupsDict =
63 Dups.Dict R.Region
66canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
67canonicalize env (A.At region pattern) =
68 A.At region <$>
69 case pattern of
70 Src.PAnything ->
71 Result.ok Can.PAnything
73 Src.PVar name ->
74 logVar name region (Can.PVar name)
76 Src.PRecord fields ->
77 logFields fields (Can.PRecord (map A.toValue fields))
79 Src.PUnit ->
80 Result.ok Can.PUnit
82 Src.PTuple a b cs ->
83 Can.PTuple
84 <$> canonicalize env a
85 <*> canonicalize env b
86 <*> canonicalizeTuple region env cs
88 Src.PCtor nameRegion name patterns ->
89 canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name
91 Src.PCtorQual nameRegion home name patterns ->
92 canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name
94 Src.PList patterns ->
95 Can.PList <$> canonicalizeList env patterns
97 Src.PCons first rest ->
98 Can.PCons
99 <$> canonicalize env first
100 <*> canonicalize env rest
102 Src.PAlias ptrn (A.At reg name) ->
103 do cpattern <- canonicalize env ptrn
104 logVar name reg (Can.PAlias cpattern name)
106 Src.PChr chr ->
107 Result.ok (Can.PChr chr)
109 Src.PStr str ->
110 Result.ok (Can.PStr str)
112 Src.PInt int ->
113 Result.ok (Can.PInt int)
116canonicalizeCtor :: Env.Env -> R.Region -> Name.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
117canonicalizeCtor env region name patterns ctor =
118 case ctor of
119 Env.Ctor home tipe union index args ->
120 let
121 toCanonicalArg argIndex argPattern argTipe =
122 Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern
123 in
124 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
125 case verifiedList of
126 Index.LengthMatch cargs ->
127 if tipe == Name.bool && home == ModuleName.basics then
128 Result.ok (Can.PBool union (name == Name.true))
129 else
130 Result.ok (Can.PCtor home tipe union name index cargs)
132 Index.LengthMismatch actualLength expectedLength ->
133 Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
135 Env.RecordCtor _ _ _ ->
136 Result.throw (Error.PatternHasRecordCtor region name)
139canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
140canonicalizeTuple tupleRegion env extras =
141 case extras of
142 [] ->
143 Result.ok Nothing
145 [three] ->
146 Just <$> canonicalize env three
148 _ ->
149 Result.throw $ Error.TupleLargerThanThree tupleRegion
152canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
153canonicalizeList env list =
154 case list of
155 [] ->
156 Result.ok []
158 pattern : otherPatterns ->
159 (:)
160 <$> canonicalize env pattern
161 <*> canonicalizeList env otherPatterns
165-- LOG BINDINGS
168logVar :: Name.Name -> R.Region -> a -> Result DupsDict w a
169logVar name region value =
170 Result.Result $ \bindings warnings _ ok ->
171 ok (Dups.insert name region region bindings) warnings value
174logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
175logFields fields value =
176 let
177 addField (A.At region name) dict =
178 Dups.insert name region region dict
179 in
180 Result.Result $ \bindings warnings _ ok ->
181 ok (foldr addField bindings fields) warnings value