git.iko.soy/elk
on a4e2560 help sign in
elk/src/Canonicalize/Pattern.hs
233 lines 7.4 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.Expression.Canonical as Can
15import qualified AST.Expression.Source as Src
16import qualified AST.Expression.Valid as Valid
17import qualified AST.Type as Type
18import qualified Canonicalize.Environment as Env
19import qualified Canonicalize.Environment.Dups as Dups
20import qualified Data.Bag as Bag
21import qualified Data.Index as Index
22import qualified Elm.Name as N
23import qualified Reporting.Annotation as A
24import qualified Reporting.Error.Canonicalize as Error
25import qualified Reporting.Region as R
26import qualified Reporting.Result as Result
27import qualified Reporting.Warning as Warning
31-- RESULTS
34type Result i =
35 Result.Result i Warning.Warning Error.Error
39-- CANONICALIZE ARGS
42canonicalizeArgs :: Env.Env -> [Src.Pattern] -> Result () Can.Args
43canonicalizeArgs env patterns =
44 case Index.indexedTraverse (canonicalizeArg env) patterns of
45 Result.Result bag warnings (Result.Ok args) ->
46 do let toError name () () = Error.DuplicateArg name
47 destructors <- Dups.detect toError (Bag.toList bag)
48 Result.Result () warnings $ Result.Ok $
49 Can.Args args destructors
51 Result.Result _ warnings (Result.Err err) ->
52 Result.Result () warnings (Result.Err err)
55canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
56canonicalizeArg env index pattern =
57 Can.Arg index <$> canonicalize env (Can.DRoot index) pattern
61-- CANONICALIZE MATCH
64canonicalizeMatch :: Env.Env -> Src.Pattern -> Result () Can.Match
65canonicalizeMatch env pattern =
66 case canonicalize env (Can.DRoot Index.first) pattern of
67 Result.Result bag warnings (Result.Ok cpattern) ->
68 do let toError name () () = Error.DuplicateArg name
69 destructors <- Dups.detect toError (Bag.toList bag)
70 Result.Result () warnings $ Result.Ok $
71 Can.Match cpattern destructors
73 Result.Result _ warnings (Result.Err err) ->
74 Result.Result () warnings (Result.Err err)
78-- CANONICALIZE BINDINGS
81data Binding
82 = Define R.Region Int (A.Located N.Name) [Src.Pattern] Valid.Expr (Maybe Type.Raw)
83 | Destruct R.Region Int Can.Match Valid.Expr
86canonicalizeBindings :: Env.Env -> [Valid.Def] -> Result () ( [Binding], Map.Map N.Name (A.Located Int) )
87canonicalizeBindings env defs =
88 case zipWithM (canonicalizeBinding env) defs [ 0 .. length defs ] of
89 Result.Result bag warnings (Result.Ok cdefs) ->
90 do let toError name () () = Error.DuplicateBindingName name
91 nodes <- Dups.detect toError (Bag.toList bag)
92 Result.Result () warnings (Result.Ok (cdefs, nodes))
94 Result.Result _ warnings (Result.Err err) ->
95 Result.Result () warnings (Result.Err err)
98type KeyBag =
99 Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
102canonicalizeBinding :: Env.Env -> Valid.Def -> Int -> Result KeyBag Binding
103canonicalizeBinding env def index =
104 case def of
105 Valid.Define region aname@(A.A reg name) args body maybeType ->
106 let info = Dups.info name reg () (A.A region index) in
107 Result.accumulate (Bag.one info) $
108 Define region index aname args body maybeType
110 Valid.Destruct region pattern body ->
111 case canonicalize env (Can.DRoot Index.first) pattern of
112 Result.Result bag warnings (Result.Ok cpattern) ->
113 do let toError name () () = Error.DuplicateBindingName name
114 destructors <- Result.untracked (Dups.detect toError (Bag.toList bag))
115 Result.Result (toKeyBag index bag) warnings $ Result.Ok $
116 Destruct region index (Can.Match cpattern destructors) body
118 Result.Result bag warnings (Result.Err err) ->
119 Result.Result (toKeyBag index bag) warnings (Result.Err err)
122toKeyBag :: Int -> Bag -> KeyBag
123toKeyBag index bag =
124 let
125 redoInfo (Dups.Info region () _) =
126 Dups.Info region () (A.A region index)
128 replaceWithIndex ( name, infos ) =
129 ( name, map redoInfo infos )
130 in
131 Bag.map replaceWithIndex bag
135-- CANONICALIZE
138type Bag =
139 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
142canonicalize :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
143canonicalize env destructor (A.A region pattern) =
144 A.A region <$>
145 case pattern of
146 Src.PAnything ->
147 Result.ok Can.PAnything
149 Src.PVar name ->
150 Result.accumulate
151 (Bag.one (Dups.info name region () (A.A region destructor)))
152 (Can.PVar name)
154 Src.PRecord fields ->
155 let
156 fieldToInfo (A.A reg name) =
157 Dups.info name reg () (A.A reg (Can.DField name destructor))
158 in
159 Result.accumulate
160 (Bag.fromList fieldToInfo fields)
161 (Can.PRecord (map A.drop fields))
163 Src.PUnit ->
164 Result.ok Can.PUnit
166 Src.PTuple a b cs ->
167 Can.PTuple
168 <$> canonicalize env (Can.DIndex Index.first destructor) a
169 <*> canonicalize env (Can.DIndex Index.second destructor) b
170 <*> canonicalizeTuple region env destructor cs
172 Src.PCtor nameRegion maybePrefix name patterns ->
173 let
174 toCanonicalArg index ptrn tipe =
175 Can.PatternCtorArg index tipe
176 <$> canonicalize env (Can.DIndex index destructor) ptrn
177 in
178 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
179 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
180 case verifiedList of
181 Index.LengthMatch cargs ->
182 Result.ok $ Can.PCtor home tipe vars name cargs
184 Index.LengthMismatch actualLength expectedLength ->
185 Result.throw region (error "TODO" actualLength expectedLength)
187 Src.PList patterns ->
188 Can.PList <$> canonicalizeList env destructor patterns
190 Src.PCons first rest ->
191 Can.PCons
192 <$> canonicalize env (Can.DIndex Index.first destructor) first
193 <*> canonicalize env (Can.DIndex Index.second destructor) rest
195 Src.PAlias ptrn (A.A reg name) ->
196 do cpattern <- canonicalize env destructor ptrn
197 let info = Dups.info name reg () (A.A reg destructor)
198 Result.accumulate (Bag.one info) (Can.PAlias cpattern name)
200 Src.PChr chr ->
201 Result.ok (Can.PChr chr)
203 Src.PStr str ->
204 Result.ok (Can.PStr str)
206 Src.PInt int ->
207 Result.ok (Can.PInt int)
210canonicalizeTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)
211canonicalizeTuple tupleRegion env destructor extras =
212 case extras of
213 [] ->
214 Result.ok Nothing
216 [three] ->
217 Just <$> canonicalize env (Can.DIndex Index.third destructor) three
219 _ : others ->
220 let (A.A r1 _, A.A r2 _) = (head others, last others) in
221 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
224canonicalizeList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]
225canonicalizeList env destructor list =
226 case list of
227 [] ->
228 Result.ok []
230 pattern : otherPatterns ->
231 (:)
232 <$> canonicalize env (Can.DIndex Index.first destructor) pattern
233 <*> canonicalizeList env (Can.DIndex Index.second destructor) otherPatterns