git.iko.soy/elk
on 232f7dc help sign in
elk/src/Canonicalize/Pattern.hs
220 lines 6.9 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 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 zipWithM (canonicalizeArg env) patterns [ 0 .. length 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 -> Src.Pattern -> Int -> Result Bag Can.Arg
55canonicalizeArg env pattern index =
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 0) 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 Type.Raw)
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 0) 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 0 destructor) a
168 <*> canonicalize env (Can.DIndex 1 destructor) b
169 <*> canonicalizeTuple region env destructor cs
171 Src.PCtor nameRegion maybePrefix name patterns ->
172 let
173 canArgs ptrn tipe index =
174 (,,) index tipe <$> canonicalize env (Can.DIndex index destructor) ptrn
175 in
176 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
177 Can.PCtor home tipe vars name
178 <$> sequenceA (zipWith3 canArgs patterns args [ 0 .. length patterns ])
180 Src.PList patterns ->
181 Can.PList <$> canonicalizeList env destructor patterns
183 Src.PCons first rest ->
184 Can.PCons
185 <$> canonicalize env (Can.DIndex 0 destructor) first
186 <*> canonicalize env (Can.DIndex 1 destructor) rest
188 Src.PAlias ptrn (A.A reg name) ->
189 do cpattern <- canonicalize env destructor ptrn
190 let info = Dups.info name reg () (A.A reg destructor)
191 Result.accumulate (Bag.one info) (Can.PAlias cpattern name)
193 Src.PLiteral lit ->
194 Result.ok (Can.PLiteral lit)
197canonicalizeTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)
198canonicalizeTuple tupleRegion env destructor extras =
199 case extras of
200 [] ->
201 Result.ok Nothing
203 [three] ->
204 Just <$> canonicalize env (Can.DIndex 2 destructor) three
206 _ : others ->
207 let (A.A r1 _, A.A r2 _) = (head others, last others) in
208 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
211canonicalizeList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]
212canonicalizeList env destructor list =
213 case list of
214 [] ->
215 Result.ok []
217 pattern : otherPatterns ->
218 (:)
219 <$> canonicalize env (Can.DIndex 0 destructor) pattern
220 <*> canonicalizeList env (Can.DIndex 1 destructor) otherPatterns