git.iko.soy/elk
on 0bdfd73 help sign in
elk/src/Canonicalize/Pattern.hs
177 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( verify
4 , Bindings
5 , DupsDict
6 , canonicalize
7 )
8 where
11import qualified Data.Map.Strict as Map
13import qualified AST.Canonical as Can
14import qualified AST.Source as Src
15import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment.Dups as Dups
17import qualified Data.Index as Index
18import qualified Elm.Name as N
19import qualified Reporting.Annotation as A
20import qualified Reporting.Error.Canonicalize as Error
21import qualified Reporting.Region as R
22import qualified Reporting.Result as Result
26-- RESULTS
29type Result i w a =
30 Result.Result i w Error.Error a
33type Bindings =
34 Map.Map N.Name R.Region
38-- VERIFY
41verify :: Error.DuplicatePatternContext -> Result DupsDict w a -> Result i w (a, Bindings)
42verify context (Result.Result k) =
43 Result.Result $ \info warnings bad good ->
44 k Dups.none warnings
45 (\_ warnings1 errors ->
46 bad info warnings1 errors
47 )
48 (\bindings warnings1 value ->
49 case Dups.detect (Error.DuplicatePattern context) bindings of
50 Result.Result k1 ->
51 k1 () ()
52 (\() () errs -> bad info warnings1 errs)
53 (\() () dict -> good info warnings1 (value, dict))
54 )
58-- CANONICALIZE
61type DupsDict =
62 Dups.Dict R.Region
65canonicalize :: Env.Env -> Src.Pattern -> Result DupsDict w Can.Pattern
66canonicalize env (A.At region pattern) =
67 A.At region <$>
68 case pattern of
69 Src.PAnything ->
70 Result.ok Can.PAnything
72 Src.PVar name ->
73 logVar name region (Can.PVar name)
75 Src.PRecord fields ->
76 logFields fields (Can.PRecord (map A.toValue fields))
78 Src.PUnit ->
79 Result.ok Can.PUnit
81 Src.PTuple a b cs ->
82 Can.PTuple
83 <$> canonicalize env a
84 <*> canonicalize env b
85 <*> canonicalizeTuple region env cs
87 Src.PCtor nameRegion name patterns ->
88 canonicalizeCtor env region name patterns =<< Env.findCtor nameRegion env name
90 Src.PCtorQual nameRegion home name patterns ->
91 canonicalizeCtor env region name patterns =<< Env.findCtorQual nameRegion env home name
93 Src.PList patterns ->
94 Can.PList <$> canonicalizeList env patterns
96 Src.PCons first rest ->
97 Can.PCons
98 <$> canonicalize env first
99 <*> canonicalize env rest
101 Src.PAlias ptrn (A.At reg name) ->
102 do cpattern <- canonicalize env ptrn
103 logVar name reg (Can.PAlias cpattern name)
105 Src.PChr chr ->
106 Result.ok (Can.PChr chr)
108 Src.PStr str ->
109 Result.ok (Can.PStr str)
111 Src.PInt int ->
112 Result.ok (Can.PInt int)
115canonicalizeCtor :: Env.Env -> R.Region -> N.Name -> [Src.Pattern] -> Env.Ctor -> Result DupsDict w Can.Pattern_
116canonicalizeCtor env region name patterns ctor =
117 case ctor of
118 Env.Ctor home tipe union index args ->
119 let
120 toCanonicalArg argIndex argPattern argTipe =
121 Can.PatternCtorArg argIndex argTipe <$> canonicalize env argPattern
122 in
123 do verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
124 case verifiedList of
125 Index.LengthMatch cargs ->
126 Result.ok (Can.PCtor home tipe union name index cargs)
128 Index.LengthMismatch actualLength expectedLength ->
129 Result.throw (Error.BadArity region Error.PatternArity name actualLength expectedLength)
131 Env.RecordCtor _ _ _ ->
132 Result.throw (Error.PatternHasRecordCtor region name)
135canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
136canonicalizeTuple tupleRegion env extras =
137 case extras of
138 [] ->
139 Result.ok Nothing
141 [three] ->
142 Just <$> canonicalize env three
144 _ ->
145 Result.throw $ Error.TupleLargerThanThree tupleRegion
148canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
149canonicalizeList env list =
150 case list of
151 [] ->
152 Result.ok []
154 pattern : otherPatterns ->
155 (:)
156 <$> canonicalize env pattern
157 <*> canonicalizeList env otherPatterns
161-- LOG BINDINGS
164logVar :: N.Name -> R.Region -> a -> Result DupsDict w a
165logVar name region value =
166 Result.Result $ \bindings warnings _ ok ->
167 ok (Dups.insert name region region bindings) warnings value
170logFields :: [A.Located N.Name] -> a -> Result DupsDict w a
171logFields fields value =
172 let
173 addField (A.At region name) dict =
174 Dups.insert name region region dict
175 in
176 Result.Result $ \bindings warnings _ ok ->
177 ok (foldr addField bindings fields) warnings value