git.iko.soy/elk
on 63fb3d0 help sign in
elk/src/Canonicalize/Pattern.hs
231 lines 7.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( canonicalize
4 , canonicalizeArgs
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
41canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result () (Can.Pattern, Can.Destructors)
42canonicalize env index pattern =
43 case process env (Can.DRoot index) pattern of
44 Result.Result bag warnings (Result.Ok cpattern) ->
45 do let toError name () () = Error.DuplicateArg name
46 destructors <- Dups.detect toError (Bag.toList bag)
47 Result.Result () warnings $ Result.Ok (cpattern, destructors)
49 Result.Result _ warnings (Result.Err err) ->
50 Result.Result () warnings (Result.Err err)
54-- CANONICALIZE ARGS
57canonicalizeArgs :: Env.Env -> [Src.Pattern] -> Result () Can.Args
58canonicalizeArgs env patterns =
59 case Index.indexedTraverse (canonicalizeArg env) patterns of
60 Result.Result bag warnings (Result.Ok args) ->
61 do let toError name () () = Error.DuplicateArg name
62 destructors <- Dups.detect toError (Bag.toList bag)
63 Result.Result () warnings $ Result.Ok $
64 Can.Args args destructors
66 Result.Result _ warnings (Result.Err err) ->
67 Result.Result () warnings (Result.Err err)
70canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bag Can.Arg
71canonicalizeArg env index pattern =
72 Can.Arg index <$> process env (Can.DRoot index) pattern
76-- CANONICALIZE BINDINGS
79data Binding
80 = Define R.Region Int (A.Located N.Name) [Src.Pattern] Valid.Expr (Maybe Src.Type)
81 | Destruct R.Region Int Can.Pattern Can.Destructors Valid.Expr
84canonicalizeBindings :: Env.Env -> [Valid.Def] -> Result () ( [Binding], Map.Map N.Name (A.Located Int) )
85canonicalizeBindings env defs =
86 case zipWithM (canonicalizeBinding env) defs [ 0 .. length defs ] of
87 Result.Result bag warnings (Result.Ok cdefs) ->
88 do let toError name () () = Error.DuplicateBindingName name
89 nodes <- Dups.detect toError (Bag.toList bag)
90 Result.Result () warnings (Result.Ok (cdefs, nodes))
92 Result.Result _ warnings (Result.Err err) ->
93 Result.Result () warnings (Result.Err err)
96type KeyBag =
97 Bag.Bag ( N.Name, [Dups.Info () (A.Located Int)] )
100canonicalizeBinding :: Env.Env -> Valid.Def -> Int -> Result KeyBag Binding
101canonicalizeBinding env def index =
102 case def of
103 Valid.Define region aname@(A.A reg name) args body maybeType ->
104 let info = Dups.info name reg () (A.A region index) in
105 Result.accumulate (Bag.one info) $
106 Define region index aname args body maybeType
108 Valid.Destruct region pattern body ->
109 case process env (Can.DRoot Index.first) pattern of
110 Result.Result bag warnings (Result.Ok cpattern) ->
111 do let toError name () () = Error.DuplicateBindingName name
112 destructors <- Result.untracked (Dups.detect toError (Bag.toList bag))
113 Result.Result (toKeyBag index bag) warnings $ Result.Ok $
114 Destruct region index cpattern destructors body
116 Result.Result bag warnings (Result.Err err) ->
117 Result.Result (toKeyBag index bag) warnings (Result.Err err)
120toKeyBag :: Int -> Bag -> KeyBag
121toKeyBag index bag =
122 let
123 redoInfo (Dups.Info region () _) =
124 Dups.Info region () (A.A region index)
126 replaceWithIndex ( name, infos ) =
127 ( name, map redoInfo infos )
128 in
129 Bag.map replaceWithIndex bag
133-- CANONICALIZE
136type Bag =
137 Bag.Bag (N.Name, [Dups.Info () (A.Located Can.Destructor)])
140process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bag Can.Pattern
141process env destructor (A.A region pattern) =
142 A.A region <$>
143 case pattern of
144 Src.PAnything ->
145 Result.ok Can.PAnything
147 Src.PVar name ->
148 Result.accumulate
149 (Bag.one (Dups.info name region () (A.A region destructor)))
150 (Can.PVar name)
152 Src.PRecord fields ->
153 let
154 fieldToInfo (A.A reg name) =
155 Dups.info name reg () (A.A reg (Can.DField name destructor))
156 in
157 Result.accumulate
158 (Bag.fromList fieldToInfo fields)
159 (Can.PRecord (map A.drop fields))
161 Src.PUnit ->
162 Result.ok Can.PUnit
164 Src.PTuple a b cs ->
165 Can.PTuple
166 <$> process env (Can.DIndex Index.first destructor) a
167 <*> process env (Can.DIndex Index.second destructor) b
168 <*> processTuple region env destructor cs
170 Src.PCtor nameRegion maybePrefix name patterns ->
171 let
172 toCanonicalArg index ptrn tipe =
173 Can.PatternCtorArg index tipe
174 <$> process env (Can.DIndex index destructor) ptrn
175 in
176 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
177 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
178 case verifiedList of
179 Index.LengthMatch cargs ->
180 Result.ok $ Can.PCtor home tipe vars name cargs
182 Index.LengthMismatch actualLength expectedLength ->
183 Result.throw region (error "TODO" actualLength expectedLength)
185 Src.PList patterns ->
186 Can.PList <$> processList env destructor patterns
188 Src.PCons first rest ->
189 Can.PCons
190 <$> process env (Can.DIndex Index.first destructor) first
191 <*> process env (Can.DIndex Index.second destructor) rest
193 Src.PAlias ptrn (A.A reg name) ->
194 do cpattern <- process env destructor ptrn
195 let info = Dups.info name reg () (A.A reg destructor)
196 Result.accumulate (Bag.one info) (Can.PAlias cpattern name)
198 Src.PChr chr ->
199 Result.ok (Can.PChr chr)
201 Src.PStr str ->
202 Result.ok (Can.PStr str)
204 Src.PInt int ->
205 Result.ok (Can.PInt int)
208processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag (Maybe Can.Pattern)
209processTuple tupleRegion env destructor extras =
210 case extras of
211 [] ->
212 Result.ok Nothing
214 [three] ->
215 Just <$> process env (Can.DIndex Index.third destructor) three
217 _ : others ->
218 let (A.A r1 _, A.A r2 _) = (head others, last others) in
219 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
222processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bag [Can.Pattern]
223processList env destructor list =
224 case list of
225 [] ->
226 Result.ok []
228 pattern : otherPatterns ->
229 (:)
230 <$> process env (Can.DIndex Index.first destructor) pattern
231 <*> processList env (Can.DIndex Index.second destructor) otherPatterns