git.iko.soy/elk
on 1238607 help sign in
elk/compiler/src/Canonicalize/Pattern.hs
180 lines 4.8 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
12import qualified Data.Name as Name
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 Data.Index as Index
19import qualified Elm.ModuleName as ModuleName
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
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 Name.Name A.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 A.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 -> A.Region -> Name.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 if tipe == Name.bool && home == ModuleName.basics then
127 Result.ok (Can.PBool union (name == Name.true))
128 else
129 Result.ok (Can.PCtor home tipe union name index cargs)
131 Index.LengthMismatch actualLength expectedLength ->
132 Result.throw (Error.BadArity region Error.PatternArity name expectedLength actualLength)
134 Env.RecordCtor _ _ _ ->
135 Result.throw (Error.PatternHasRecordCtor region name)
138canonicalizeTuple :: A.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
139canonicalizeTuple tupleRegion env extras =
140 case extras of
141 [] ->
142 Result.ok Nothing
144 [three] ->
145 Just <$> canonicalize env three
147 _ ->
148 Result.throw $ Error.TupleLargerThanThree tupleRegion
151canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
152canonicalizeList env list =
153 case list of
154 [] ->
155 Result.ok []
157 pattern : otherPatterns ->
158 (:)
159 <$> canonicalize env pattern
160 <*> canonicalizeList env otherPatterns
164-- LOG BINDINGS
167logVar :: Name.Name -> A.Region -> a -> Result DupsDict w a
168logVar name region value =
169 Result.Result $ \bindings warnings _ ok ->
170 ok (Dups.insert name region region bindings) warnings value
173logFields :: [A.Located Name.Name] -> a -> Result DupsDict w a
174logFields fields value =
175 let
176 addField (A.At region name) dict =
177 Dups.insert name region region dict
178 in
179 Result.Result $ \bindings warnings _ ok ->
180 ok (foldr addField bindings fields) warnings value