git.iko.soy/elk
on master help sign in
Get canonicalization of binop sequences working again
8b88494Evan Czaplicki
src/AST/Binop.hs+1
compare with master
unifiedsplit
@@ -16,6 +16,7 @@ import Data.Binary
16
16
17
17
18newtype Precedence = Precedence Int
18newtype Precedence = Precedence Int
19+ deriving (Eq, Ord)
19
20
20
21
21data Associativity
22data Associativity
src/Canonicalize/Binops.hsdeleted−118
@@ -1,118 +0,0 @@
1−{-# OPTIONS_GHC -Wall #-}
2−module Canonicalize.Binops ( Op(..), canonicalize, flatten ) where
3−
4−import Prelude hiding (last)
5−import qualified Data.Map as Map
6−import Data.Text (Text)
7−
8−import qualified AST.Declaration as Decl
9−import qualified AST.Expression.Canonical as C
10−import qualified AST.Variable as Var
11−import qualified Canonicalize.Environment as Env
12−import qualified Canonicalize.Variable as Var
13−import qualified Reporting.Annotation as A
14−import qualified Reporting.Error.Canonicalize as Error
15−import qualified Reporting.Region as Region
16−import qualified Reporting.Result as R
17−
18−
19−
20−-- CANONICALIZE
21−
22−
23−data Op =
24− Op
25− { _name :: Var.Canonical
26− , _assoc :: Decl.Assoc
27− , _prec :: Int
28− , _region :: Region.Region
29− }
30−
31−
32−canonicalize :: Env.Env -> A.Located Text -> Var.Result Op
33−canonicalize env (A.A region op) =
34− do name <- Var.variable region env op
35− let (assoc, prec) = Map.findWithDefault defaults name (Env._infixes env)
36− return $ Op name assoc prec region
37−
38−
39−defaults :: ( Decl.Assoc, Int )
40−defaults =
41− ( Decl.defaultAssociativity, Decl.defaultPrecedence )
42−
43−
44−
45−-- FLATTEN
46−
47−
48−flatten :: (Monoid i) => Region.Region -> [(C.Expr, Op)] -> C.Expr -> R.Result i w Error.Error C.Expr
49−flatten overallRegion ops last =
50− runStepper overallRegion (More ops last)
51−
52−
53−data Step
54− = Done C.Expr
55− | More [(C.Expr, Op)] C.Expr
56− | Error Op Op
57−
58−
59−runStepper :: (Monoid i) => Region.Region -> Step -> R.Result i w Error.Error C.Expr
60−runStepper overallRegion step =
61− case step of
62− Done expr ->
63− R.ok expr
64−
65− More [] expr ->
66− R.ok expr
67−
68− More ( (expr, op@(Op name _ _ _)) : rest ) last ->
69− runStepper overallRegion $
70− flattenHelp (binop name expr) op rest last
71−
72− Error (Op name1 assoc1 prec _) (Op name2 assoc2 _ region) ->
73− R.throw overallRegion (Error.BadInfix region prec name1 assoc1 name2 assoc2)
74−
75−
76−flattenHelp :: (C.Expr -> C.Expr) -> Op -> [(C.Expr, Op)] -> C.Expr -> Step
77−flattenHelp makeBinop rootOp@(Op _ rootAssoc rootPrec _) middle last =
78− case middle of
79− [] ->
80− Done (makeBinop last)
81−
82− ( expr, op@(Op name assoc prec _) ) : rest ->
83− if prec < rootPrec then
84−
85− More ((makeBinop expr, op) : rest) last
86−
87− else if prec > rootPrec then
88−
89− case flattenHelp (binop name expr) op rest last of
90− Done newLast ->
91− Done (makeBinop newLast)
92−
93− More newMiddle newLast ->
94− flattenHelp makeBinop rootOp newMiddle newLast
95−
96− Error a b ->
97− Error a b
98−
99− else
100−
101− case (rootAssoc, assoc) of
102− (Decl.Left, Decl.Left) ->
103− flattenHelp (\right -> binop name (makeBinop expr) right) op rest last
104−
105− (Decl.Right, Decl.Right) ->
106− flattenHelp (\right -> makeBinop (binop name expr right)) op rest last
107−
108− (_, _) ->
109− Error rootOp op
110−
111−
112−
113−-- BINOP HELPERS
114−
115−
116−binop :: Var.Canonical -> C.Expr -> C.Expr -> C.Expr
117−binop name left right =
118− A.merge left right (C.Binop name left right)
src/Canonicalize/Environment/Foreign.hs+5−5
@@ -103,7 +103,7 @@ importToEnv (Import home (I.Interface _ types unions aliases binops) prefix expo
103 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
103 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)
104 )
104 )
105 (Map.map (toOpenHomes home prefix (,)) patterns)
105 (Map.map (toOpenHomes home prefix (,)) patterns)
106− (Map.map (toBinopHomes home) binops)
106+ (Map.mapWithKey (toBinopHomes home) binops)
107
107
108 Explicit explicits ->
108 Explicit explicits ->
109 Env
109 Env
@@ -113,12 +113,12 @@ importToEnv (Import home (I.Interface _ types unions aliases binops) prefix expo
113 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
113 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)
114 )
114 )
115 (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)
115 (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)
116− (Map.map (toBinopHomes home) binops)
116+ (Map.mapWithKey (toBinopHomes home) binops)
117
117
118
118
119−toBinopHomes :: ModuleName.Canonical -> Can.Binop -> OneOrMore.OneOrMore Env.Binop
119+toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop
120−toBinopHomes home (Can.Binop_ associativity precedence name) =
120+toBinopHomes home op (Can.Binop_ associativity precedence name) =
121− OneOrMore.one (Env.Binop home name associativity precedence)
121+ OneOrMore.one (Env.Binop op home name associativity precedence)
122
122
123
123
124toOpenHomes
124toOpenHomes
src/Canonicalize/Environment/Internals.hs+2−1
@@ -84,7 +84,8 @@ data Type
84
84
85data Binop =
85data Binop =
86 Binop
86 Binop
87+ { _op_name :: N.Name
87− { _op_home :: ModuleName.Canonical
88+ , _op_home :: ModuleName.Canonical
88 , _op_func :: N.Name
89 , _op_func :: N.Name
89 , _associativity :: Binop.Associativity
90 , _associativity :: Binop.Associativity
90 , _precedence :: Binop.Precedence
91 , _precedence :: Binop.Precedence
src/Canonicalize/Environment/Local.hs+1−1
@@ -102,7 +102,7 @@ addBinops :: Valid.Module -> Env.Env -> Result Env.Env
102addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =
102addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =
103 let
103 let
104 toInfo (Valid.Binop (A.A region op) assoc prec name) =
104 toInfo (Valid.Binop (A.A region op) assoc prec name) =
105− Dups.info op region () (OneOrMore.one (Env.Binop home name assoc prec))
105+ Dups.info op region () (OneOrMore.one (Env.Binop op home name assoc prec))
106
106
107 toError op () () =
107 toError op () () =
108 Error.DuplicateBinop op
108 Error.DuplicateBinop op
src/Canonicalize/Expression.hs+88−4
@@ -10,6 +10,7 @@ import qualified Data.Graph as Graph
10import qualified Data.Map.Strict as Map
10import qualified Data.Map.Strict as Map
11import qualified Data.Set as Set
11import qualified Data.Set as Set
12
12
13+import qualified AST.Binop as Binop
13import qualified AST.Expression.Canonical as Can
14import qualified AST.Expression.Canonical as Can
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Expression.Valid as Valid
15import qualified Canonicalize.Environment as Env
16import qualified Canonicalize.Environment as Env
@@ -53,15 +54,15 @@ canonicalize env (A.A region expression) =
53 Valid.List exprs ->
54 Valid.List exprs ->
54 Can.List <$> traverse (canonicalize env) exprs
55 Can.List <$> traverse (canonicalize env) exprs
55
56
56− Valid.Op name ->
57+ Valid.Op op ->
57− do (Env.Binop home func _ _) <- Env.findBinop region env name
58+ do (Env.Binop _ home name _ _) <- Env.findBinop region env op
58− return (Can.VarOperator name home func)
59+ return (Can.VarOperator op home name)
59
60
60 Valid.Negate expr ->
61 Valid.Negate expr ->
61 Can.Negate <$> canonicalize env expr
62 Can.Negate <$> canonicalize env expr
62
63
63 Valid.Binops ops final ->
64 Valid.Binops ops final ->
64− error "TODO"
65+ A.drop <$> canonicalizeBinops region env ops final
65
66
66 Valid.Lambda args body ->
67 Valid.Lambda args body ->
67 addLocals $
68 addLocals $
@@ -145,6 +146,89 @@ canonicalizeBranch env (condition, branch) =
145
146
146
147
147
148
149+-- CANONICALIZE BINOPS
150+
151+
152+canonicalizeBinops :: R.Region -> Env.Env -> [(Valid.Expr, A.Located N.Name)] -> Valid.Expr -> Result FreeLocals Can.Expr
153+canonicalizeBinops overallRegion env ops final =
154+ let
155+ canonicalizeHelp (expr, A.A region op) =
156+ (,)
157+ <$> canonicalize env expr
158+ <*> Env.findBinop region env op
159+ in
160+ runBinopStepper overallRegion =<< (
161+ More
162+ <$> traverse canonicalizeHelp ops
163+ <*> canonicalize env final
164+ )
165+
166+
167+data Step
168+ = Done Can.Expr
169+ | More [(Can.Expr, Env.Binop)] Can.Expr
170+ | Error Env.Binop Env.Binop
171+
172+
173+runBinopStepper :: R.Region -> Step -> Result FreeLocals Can.Expr
174+runBinopStepper overallRegion step =
175+ case step of
176+ Done expr ->
177+ Result.ok expr
178+
179+ More [] expr ->
180+ Result.ok expr
181+
182+ More ( (expr, op) : rest ) final ->
183+ runBinopStepper overallRegion $
184+ toBinopStep (toBinop op expr) op rest final
185+
186+ Error (Env.Binop op1 _ _ _ _) (Env.Binop op2 _ _ _ _) ->
187+ Result.throw overallRegion (Error.Binop op1 op2)
188+
189+
190+toBinopStep :: (Can.Expr -> Can.Expr) -> Env.Binop -> [(Can.Expr, Env.Binop)] -> Can.Expr -> Step
191+toBinopStep makeBinop rootOp@(Env.Binop _ _ _ rootAssociativity rootPrecedence) middle final =
192+ case middle of
193+ [] ->
194+ Done (makeBinop final)
195+
196+ ( expr, op@(Env.Binop _ _ _ associativity precedence) ) : rest ->
197+ if precedence < rootPrecedence then
198+
199+ More ((makeBinop expr, op) : rest) final
200+
201+ else if precedence > rootPrecedence then
202+
203+ case toBinopStep (toBinop op expr) op rest final of
204+ Done newLast ->
205+ Done (makeBinop newLast)
206+
207+ More newMiddle newLast ->
208+ toBinopStep makeBinop rootOp newMiddle newLast
209+
210+ Error a b ->
211+ Error a b
212+
213+ else
214+
215+ case (rootAssociativity, associativity) of
216+ (Binop.Left, Binop.Left) ->
217+ toBinopStep (\right -> toBinop op (makeBinop expr) right) op rest final
218+
219+ (Binop.Right, Binop.Right) ->
220+ toBinopStep (\right -> makeBinop (toBinop op expr right)) op rest final
221+
222+ (_, _) ->
223+ Error rootOp op
224+
225+
226+toBinop :: Env.Binop -> Can.Expr -> Can.Expr -> Can.Expr
227+toBinop (Env.Binop op home name _ _) left right =
228+ A.merge left right (Can.Binop op home name left right)
229+
230+
231+
148-- CANONICALIZE LET
232-- CANONICALIZE LET
149
233
150
234