git.iko.soy/elk
on 2799bc0 help sign in
elk/src/Canonicalize/Pattern.hs
167 lines 4.2 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 Canonicalize.Result as Result
18import qualified Data.Index as Index
19import qualified Elm.Name as N
20import qualified Reporting.Annotation as A
21import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Region as R
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 _ : others ->
134 let (A.At r1 _, A.At r2 _) = (head others, last others) in
135 Result.throw (Error.TupleLargerThanThree tupleRegion (R.merge r1 r2))
138canonicalizeList :: Env.Env -> [Src.Pattern] -> Result DupsDict w [Can.Pattern]
139canonicalizeList env list =
140 case list of
141 [] ->
142 Result.ok []
144 pattern : otherPatterns ->
145 (:)
146 <$> canonicalize env pattern
147 <*> canonicalizeList env otherPatterns
151-- LOG BINDINGS
154logVar :: N.Name -> R.Region -> a -> Result DupsDict w a
155logVar name region value =
156 Result.Result $ \bindings warnings _ ok ->
157 ok (Dups.insert name region () region bindings) warnings value
160logFields :: [A.Located N.Name] -> a -> Result DupsDict w a
161logFields fields value =
162 let
163 addField (A.At region name) dict =
164 Dups.insert name region () region dict
165 in
166 Result.Result $ \bindings warnings _ ok ->
167 ok (foldr addField bindings fields) warnings value