git.iko.soy/elk
on ea77dcf help sign in
elk/src/Canonicalize/Pattern.hs
232 lines 7.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( canonicalizeArgs
4 , canonicalizeMatch
5 , canonicalizeBindings
6 , Binding(..)
7 )
8 where
11import Control.Monad (zipWithM)
12import qualified Data.Map.Strict as Map
14import qualified AST.Canonical as Can
15import qualified AST.Source as Src
16import qualified AST.Valid as Valid
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Data.Bag as Bag
20import qualified Data.Index as Index
21import qualified Elm.Name as N
22import qualified Reporting.Annotation as A
23import qualified Reporting.Error.Canonicalize as Error
24import qualified Reporting.Region as R
25import qualified Reporting.Result as Result
26import qualified Reporting.Warning as Warning
30-- RESULTS
33type Result i =
34 Result.Result i Warning.Warning Error.Error
38-- CANONICALIZE ARGS
41canonicalizeArgs :: Env.Env -> [Src.Pattern] -> Result () Can.Args
42canonicalizeArgs env patterns =
43 case Index.indexedTraverse (canonicalizeArg env) patterns of
44 Result.Result bag warnings (Result.Ok args) ->
45 do let toError name () () = Error.DuplicateArg name
46 destructors <- Dups.detect toError (Bag.toList bag)
47 Result.Result () warnings $ Result.Ok $
48 Can.Args args destructors
50 Result.Result _ warnings (Result.Err err) ->
51 Result.Result () warnings (Result.Err err)
54canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
55canonicalizeArg env index pattern =
56 Can.Arg index <$> canonicalize env (Can.DRoot index) pattern
60-- CANONICALIZE MATCH
63canonicalizeMatch :: Env.Env -> Src.Pattern -> Result () Can.Match
64canonicalizeMatch env pattern =
65 case canonicalize env (Can.DRoot Index.first) pattern of
66 Result.Result bag warnings (Result.Ok cpattern) ->
67 do let toError name () () = Error.DuplicateArg name
68 destructors <- Dups.detect toError (Bag.toList bag)
69 Result.Result () warnings $ Result.Ok $
70 Can.Match cpattern destructors
72 Result.Result _ warnings (Result.Err err) ->
73 Result.Result () warnings (Result.Err err)
77-- CANONICALIZE BINDINGS
80data Binding
81 = Define R.Region Int (A.Located N.Name) [Src.Pattern] Valid.Expr (Maybe Src.Type)
82 | Destruct R.Region Int Can.Match Valid.Expr
85canonicalizeBindings :: Env.Env -> [Valid.Def] -> Result () ( [Binding], Map.Map N.Name (A.Located Int) )
86canonicalizeBindings env defs =
87 case zipWithM (canonicalizeBinding env) defs [ 0 .. length defs ] of
88 Result.Result bag warnings (Result.Ok cdefs) ->
89 do let toError name () () = Error.DuplicateBindingName name
90 nodes <- Dups.detect toError (Bag.toList bag)
91 Result.Result () warnings (Result.Ok (cdefs, nodes))
93 Result.Result _ warnings (Result.Err err) ->
94 Result.Result () warnings (Result.Err err)
97type KeyBag =
98 Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
101canonicalizeBinding :: Env.Env -> Valid.Def -> Int -> Result KeyBag Binding
102canonicalizeBinding env def index =
103 case def of
104 Valid.Define region aname@(A.A reg name) args body maybeType ->
105 let info = Dups.info name reg () (A.A region index) in
106 Result.accumulate (Bag.one info) $
107 Define region index aname args body maybeType
109 Valid.Destruct region pattern body ->
110 case canonicalize env (Can.DRoot Index.first) pattern of
111 Result.Result bag warnings (Result.Ok cpattern) ->
112 do let toError name () () = Error.DuplicateBindingName name
113 destructors <- Result.untracked (Dups.detect toError (Bag.toList bag))
114 Result.Result (toKeyBag index bag) warnings $ Result.Ok $
115 Destruct region index (Can.Match cpattern destructors) body
117 Result.Result bag warnings (Result.Err err) ->
118 Result.Result (toKeyBag index bag) warnings (Result.Err err)
121toKeyBag :: Int -> Bag -> KeyBag
122toKeyBag index bag =
123 let
124 redoInfo (Dups.Info region () _) =
125 Dups.Info region () (A.A region index)
127 replaceWithIndex ( name, infos ) =
128 ( name, map redoInfo infos )
129 in
130 Bag.map replaceWithIndex bag
134-- CANONICALIZE
137type Bag =
138 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
141canonicalize :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
142canonicalize env destructor (A.A region pattern) =
143 A.A region <$>
144 case pattern of
145 Src.PAnything ->
146 Result.ok Can.PAnything
148 Src.PVar name ->
149 Result.accumulate
150 (Bag.one (Dups.info name region () (A.A region destructor)))
151 (Can.PVar name)
153 Src.PRecord fields ->
154 let
155 fieldToInfo (A.A reg name) =
156 Dups.info name reg () (A.A reg (Can.DField name destructor))
157 in
158 Result.accumulate
159 (Bag.fromList fieldToInfo fields)
160 (Can.PRecord (map A.drop fields))
162 Src.PUnit ->
163 Result.ok Can.PUnit
165 Src.PTuple a b cs ->
166 Can.PTuple
167 <$> canonicalize env (Can.DIndex Index.first destructor) a
168 <*> canonicalize env (Can.DIndex Index.second destructor) b
169 <*> canonicalizeTuple region env destructor cs
171 Src.PCtor nameRegion maybePrefix name patterns ->
172 let
173 toCanonicalArg index ptrn tipe =
174 Can.PatternCtorArg index tipe
175 <$> canonicalize env (Can.DIndex index destructor) ptrn
176 in
177 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
178 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
179 case verifiedList of
180 Index.LengthMatch cargs ->
181 Result.ok $ Can.PCtor home tipe vars name cargs
183 Index.LengthMismatch actualLength expectedLength ->
184 Result.throw region (error "TODO" actualLength expectedLength)
186 Src.PList patterns ->
187 Can.PList <$> canonicalizeList env destructor patterns
189 Src.PCons first rest ->
190 Can.PCons
191 <$> canonicalize env (Can.DIndex Index.first destructor) first
192 <*> canonicalize env (Can.DIndex Index.second destructor) rest
194 Src.PAlias ptrn (A.A reg name) ->
195 do cpattern <- canonicalize env destructor ptrn
196 let info = Dups.info name reg () (A.A reg destructor)
197 Result.accumulate (Bag.one info) (Can.PAlias cpattern name)
199 Src.PChr chr ->
200 Result.ok (Can.PChr chr)
202 Src.PStr str ->
203 Result.ok (Can.PStr str)
205 Src.PInt int ->
206 Result.ok (Can.PInt int)
209canonicalizeTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)
210canonicalizeTuple tupleRegion env destructor extras =
211 case extras of
212 [] ->
213 Result.ok Nothing
215 [three] ->
216 Just <$> canonicalize env (Can.DIndex Index.third destructor) three
218 _ : others ->
219 let (A.A r1 _, A.A r2 _) = (head others, last others) in
220 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
223canonicalizeList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]
224canonicalizeList env destructor list =
225 case list of
226 [] ->
227 Result.ok []
229 pattern : otherPatterns ->
230 (:)
231 <$> canonicalize env (Can.DIndex Index.first destructor) pattern
232 <*> canonicalizeList env (Can.DIndex Index.second destructor) otherPatterns