git.iko.soy/elk
on 5fcbf86 help sign in
elk/src/Canonicalize/Pattern.hs
161 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Canonicalize.Pattern
3 ( verify
4 , Bindings
5 , canonicalize
6 , canonicalizeArg
7 )
8 where
11import qualified AST.Canonical as Can
12import qualified AST.Source as Src
13import qualified Canonicalize.Environment as Env
14import qualified Canonicalize.Environment.Dups as Dups
15import qualified Data.Index as Index
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Canonicalize as Error
18import qualified Reporting.Region as R
19import qualified Reporting.Result as Result
20import qualified Reporting.Warning as Warning
24-- RESULTS
27type Result i =
28 Result.Result i Warning.Warning Error.Error
32-- VERIFY NAMES
35verify :: Error.DuplicatePatternContext -> Result Bindings a -> Result () (a, Can.Destructors)
36verify context (Result.Result bindings warnings answer) =
37 case answer of
38 Result.Ok value ->
39 do let toError name () () = Error.DuplicatePattern context name
40 destructors <- Dups.detect toError bindings
41 Result.Result () warnings $ Result.Ok (value, destructors)
43 Result.Err err ->
44 Result.Result () warnings (Result.Err err)
48-- CANONICALIZE ARG
51canonicalizeArg :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Arg
52canonicalizeArg env index pattern =
53 Can.Arg index <$> canonicalize env index pattern
57-- CANONICALIZE
60type Bindings =
61 Dups.Dict () (A.Located Can.Destructor)
64canonicalize :: Env.Env -> Index.ZeroBased -> Src.Pattern -> Result Bindings Can.Pattern
65canonicalize env index pattern =
66 process env (Can.DRoot index) pattern
69process :: Env.Env -> Can.Destructor -> Src.Pattern -> Result Bindings Can.Pattern
70process env destructor (A.A region pattern) =
71 A.A region <$>
72 case pattern of
73 Src.PAnything ->
74 Result.ok Can.PAnything
76 Src.PVar name ->
77 Result.accumulate
78 (Dups.one name region () (A.A region destructor))
79 (Can.PVar name)
81 Src.PRecord fields ->
82 let
83 addField (A.A reg name) dict =
84 Dups.insert name reg () (A.A reg (Can.DField name destructor)) dict
85 in
86 Result.accumulate
87 (foldr addField Dups.none fields)
88 (Can.PRecord (map A.drop fields))
90 Src.PUnit ->
91 Result.ok Can.PUnit
93 Src.PTuple a b cs ->
94 Can.PTuple
95 <$> process env (Can.DIndex Index.first destructor) a
96 <*> process env (Can.DIndex Index.second destructor) b
97 <*> processTuple region env destructor cs
99 Src.PCtor nameRegion maybePrefix name patterns ->
100 let
101 toCanonicalArg index ptrn tipe =
102 Can.PatternCtorArg index tipe
103 <$> process env (Can.DIndex index destructor) ptrn
104 in
105 do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name
106 verifiedList <- Index.indexedZipWithA toCanonicalArg patterns args
107 case verifiedList of
108 Index.LengthMatch cargs ->
109 Result.ok $ Can.PCtor home tipe vars name cargs
111 Index.LengthMismatch actualLength expectedLength ->
112 Result.throw region (error "TODO" actualLength expectedLength)
114 Src.PList patterns ->
115 Can.PList <$> processList env destructor patterns
117 Src.PCons first rest ->
118 Can.PCons
119 <$> process env (Can.DIndex Index.first destructor) first
120 <*> process env (Can.DIndex Index.second destructor) rest
122 Src.PAlias ptrn (A.A reg name) ->
123 do cpattern <- process env destructor ptrn
124 Result.accumulate
125 (Dups.one name reg () (A.A reg destructor))
126 (Can.PAlias cpattern name)
128 Src.PChr chr ->
129 Result.ok (Can.PChr chr)
131 Src.PStr str ->
132 Result.ok (Can.PStr str)
134 Src.PInt int ->
135 Result.ok (Can.PInt int)
138processTuple :: R.Region -> Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings (Maybe Can.Pattern)
139processTuple tupleRegion env destructor extras =
140 case extras of
141 [] ->
142 Result.ok Nothing
144 [three] ->
145 Just <$> process env (Can.DIndex Index.third destructor) three
147 _ : others ->
148 let (A.A r1 _, A.A r2 _) = (head others, last others) in
149 Result.throw tupleRegion (Error.TupleLargerThanThree (R.merge r1 r2))
152processList :: Env.Env -> Can.Destructor -> [Src.Pattern] -> Result Bindings [Can.Pattern]
153processList env destructor list =
154 case list of
155 [] ->
156 Result.ok []
158 pattern : otherPatterns ->
159 (:)
160 <$> process env (Can.DIndex Index.first destructor) pattern
161 <*> processList env (Can.DIndex Index.second destructor) otherPatterns