git.iko.soy/elk
on ddb7c79 help sign in
elk/src/Canonicalize/Pattern.hs
185 lines 5.1 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( verify
4 , Bindings
5 , DupsDict
6 , canonicalize
7 , canonicalizeArg
8 )
9 where
12import qualified Data.Map.Strict as Map
14import qualified AST.Canonical as Can
15import qualified AST.Source as Src
16import qualified Canonicalize.Environment as Env
17import qualified Canonicalize.Environment.Dups as Dups
18import qualified Canonicalize.Result as Result
19import qualified Data.Index as Index
20import qualified Elm.Name as N
21import qualified Reporting.Annotation as A
22import qualified Reporting.Error.Canonicalize as Error
23import qualified Reporting.Region as R
27-- RESULTS
30type Result i w a =
31 Result.Result i w Error.Error a
34type Bindings =
35 Map.Map N.Name (A.Located Can.Destructor)
39-- VERIFY NAMES
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 () (A.Located Can.Destructor)
66canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result DupsDict w Can.Arg
67canonicalizeArg env index pattern =
68 Can.Arg index <$> canonicalize env index pattern
71canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result DupsDict w Can.Pattern
72canonicalize env index pattern =
73 process env (Can.DRoot index) pattern
77-- PROCESS PATTERNS
80process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result DupsDict w Can.Pattern
81process env destructor (A.At region pattern) =
82 A.At region <$>
83 case pattern of
84 Src.PAnything ->
85 Result.ok Can.PAnything
87 Src.PVar name ->
88 logVar name region destructor (Can.PVar name)
90 Src.PRecord fields ->
91 logFields fields destructor (Can.PRecord (map A.drop fields))
93 Src.PUnit ->
94 Result.ok Can.PUnit
96 Src.PTuple a b cs ->
97 Can.PTuple
98 <$> process env (Can.DIndex Index.first destructor) a
99 <*> process env (Can.DIndex Index.second destructor) b
100 <*> processTuple region env destructor cs
102 Src.PCtor nameRegion maybePrefix name patterns ->
103 let
104 toCanonicalArg index ptrn tipe =
105 Can.PatternCtorArg index tipe
106 <$> process env (Can.DIndex index destructor) ptrn
107 in
108 do (Env.Pattern home tipe vars alts args) <- Env.findPattern nameRegion env maybePrefix name
109 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
110 case verifiedList of
111 Index.LengthMatch cargs ->
112 Result.ok (Can.PCtor home tipe vars alts name cargs)
114 Index.LengthMismatch actualLength expectedLength ->
115 Result.throw (error "TODO" region actualLength expectedLength)
117 Src.PList patterns ->
118 Can.PList <$> processList env destructor patterns
120 Src.PCons first rest ->
121 Can.PCons
122 <$> process env (Can.DIndex Index.first destructor) first
123 <*> process env (Can.DIndex Index.second destructor) rest
125 Src.PAlias ptrn (A.At reg name) ->
126 do cpattern <- process env destructor ptrn
127 logVar name reg destructor (Can.PAlias cpattern name)
129 Src.PChr chr ->
130 Result.ok (Can.PChr chr)
132 Src.PStr str ->
133 Result.ok (Can.PStr str)
135 Src.PInt int ->
136 Result.ok (Can.PInt int)
139processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
140processTuple tupleRegion env destructor extras =
141 case extras of
142 [] ->
143 Result.ok Nothing
145 [three] ->
146 Just <$> process env (Can.DIndex Index.third destructor) three
148 _ : others ->
149 let (A.At r1 _, A.At r2 _) = (head others, last others) in
150 Result.throw (Error.TupleLargerThanThree tupleRegion (R.merge r1 r2))
153processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
154processList env destructor list =
155 case list of
156 [] ->
157 Result.ok []
159 pattern : otherPatterns ->
160 (:)
161 <$> process env (Can.DIndex Index.first destructor) pattern
162 <*> processList env (Can.DIndex Index.second destructor) otherPatterns
166-- LOG BINDINGS
169logVar :: N.Name -> R.Region -> Can.Destructor -> a -> Result DupsDict w a
170logVar name region destructor value =
171 Result.Result $ \bindings warnings _ ok ->
172 ok
173 (Dups.insert name region () (A.At region destructor) bindings)
174 warnings
175 value
178logFields :: [A.Located N.Name] -> Can.Destructor -> a -> Result DupsDict w a
179logFields fields destructor value =
180 let
181 addField (A.At region name) dict =
182 Dups.insert name region () (A.At region (Can.DField name destructor)) dict
183 in
184 Result.Result $ \bindings warnings _ ok ->
185 ok (foldr addField bindings fields) warnings value