git.iko.soy/elk
on 2deedfb help sign in
elk/src/Canonicalize/Pattern.hs
166 lines 4.1 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 maybePrefix name patterns ->
88 let
89 toCanonicalArg index ptrn tipe =
90 Can.PatternCtorArg index tipe
91 <$> canonicalize env ptrn
92 in
93 do (Env.Pattern home tipe vars alts index args) <- Env.findPattern nameRegion env maybePrefix name
94 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
95 case verifiedList of
96 Index.LengthMatch cargs ->
97 Result.ok (Can.PCtor home tipe vars alts name index cargs)
99 Index.LengthMismatch actualLength expectedLength ->
100 Result.throw (error "TODO" region actualLength expectedLength)
102 Src.PList patterns ->
103 Can.PList <$> canonicalizeList env patterns
105 Src.PCons first rest ->
106 Can.PCons
107 <$> canonicalize env first
108 <*> canonicalize env rest
110 Src.PAlias ptrn (A.At reg name) ->
111 do cpattern <- canonicalize env ptrn
112 logVar name reg (Can.PAlias cpattern name)
114 Src.PChr chr ->
115 Result.ok (Can.PChr chr)
117 Src.PStr str ->
118 Result.ok (Can.PStr str)
120 Src.PInt int ->
121 Result.ok (Can.PInt int)
124canonicalizeTuple :: R.Region -> Env.Env -> [Src.Pattern] -> Result DupsDict w (Maybe Can.Pattern)
125canonicalizeTuple tupleRegion env extras =
126 case extras of
127 [] ->
128 Result.ok Nothing
130 [three] ->
131 Just <$> canonicalize env three
133 _ ->
134 Result.throw $ Error.TupleLargerThanThree tupleRegion
137canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
138canonicalizeList env list =
139 case list of
140 [] ->
141 Result.ok []
143 pattern : otherPatterns ->
144 (:)
145 <$> canonicalize env pattern
146 <*> canonicalizeList env otherPatterns
150-- LOG BINDINGS
153logVar :: N.Name -> R.Region -> a -> Result DupsDict w a
154logVar name region value =
155 Result.Result $ \bindings warnings _ ok ->
156 ok (Dups.insert name region region bindings) warnings value
159logFields :: [A.Located N.Name] -> a -> Result DupsDict w a
160logFields fields value =
161 let
162 addField (A.At region name) dict =
163 Dups.insert name region region dict
164 in
165 Result.Result $ \bindings warnings _ ok ->
166 ok (foldr addField bindings fields) warnings value