8b88494 · elk · git.iko.soy

git.iko.soy/elk

Get canonicalization of binop sequences working again

commit8b8849429565938bdfa40f40bb45d973090fee03 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 30 Oct 2017, 23:14 (9 years ago) parentbfb8eca

6 files changed+97−129

compare with master

unifiedsplit

src/AST/Binop.hs+1 src/Canonicalize/Binops.hs−118 src/Canonicalize/Environment/Foreign.hs+5−5 src/Canonicalize/Environment/Internals.hs+2−1 src/Canonicalize/Environment/Local.hs+1−1 src/Canonicalize/Expression.hs+88−4

src/AST/Binop.hs+1

@@ -16,6 +16,7 @@ import Data.Binary

1616

1717

1818newtype Precedence = Precedence Int

19+ deriving (Eq, Ord)

1920

2021

2122data 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

103103 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)

104104 )

105105 (Map.map (toOpenHomes home prefix (,)) patterns)

106− (Map.map (toBinopHomes home) binops)

106+ (Map.mapWithKey (toBinopHomes home) binops)

107107

108108 Explicit explicits ->

109109 Env

@@ -113,12 +113,12 @@ importToEnv (Import home (I.Interface _ types unions aliases binops) prefix expo

113113 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)

114114 )

115115 (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)

116− (Map.map (toBinopHomes home) binops)

116+ (Map.mapWithKey (toBinopHomes home) binops)

117117

118118

119−toBinopHomes :: ModuleName.Canonical -> Can.Binop -> OneOrMore.OneOrMore Env.Binop

120−toBinopHomes home (Can.Binop_ associativity precedence name) =

121− OneOrMore.one (Env.Binop home name associativity precedence)

119+toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop

120+toBinopHomes home op (Can.Binop_ associativity precedence name) =

121+ OneOrMore.one (Env.Binop op home name associativity precedence)

122122

123123

124124toOpenHomes

src/Canonicalize/Environment/Internals.hs+2−1

@@ -84,7 +84,8 @@ data Type

8484

8585data Binop =

8686 Binop

87− { _op_home :: ModuleName.Canonical

87+ { _op_name :: N.Name

88+ , _op_home :: ModuleName.Canonical

8889 , _op_func :: N.Name

8990 , _associativity :: Binop.Associativity

9091 , _precedence :: Binop.Precedence

src/Canonicalize/Environment/Local.hs+1−1

@@ -102,7 +102,7 @@ addBinops :: Valid.Module -> Env.Env -> Result Env.Env

102102addBinops (Valid.Module _ _ _ _ _ _ _ _ ops _) (Env.Env home vars types patterns binops) =

103103 let

104104 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))

106106

107107 toError op () () =

108108 Error.DuplicateBinop op

src/Canonicalize/Expression.hs+88−4

@@ -10,6 +10,7 @@ import qualified Data.Graph as Graph

1010import qualified Data.Map.Strict as Map

1111import qualified Data.Set as Set

1212

13+import qualified AST.Binop as Binop

1314import qualified AST.Expression.Canonical as Can

1415import qualified AST.Expression.Valid as Valid

1516import qualified Canonicalize.Environment as Env

@@ -53,15 +54,15 @@ canonicalize env (A.A region expression) =

5354 Valid.List exprs ->

5455 Can.List <$> traverse (canonicalize env) exprs

5556

56− Valid.Op name ->

57− do (Env.Binop home func _ _) <- Env.findBinop region env name

58− return (Can.VarOperator name home func)

57+ Valid.Op op ->

58+ do (Env.Binop _ home name _ _) <- Env.findBinop region env op

59+ return (Can.VarOperator op home name)

5960

6061 Valid.Negate expr ->

6162 Can.Negate <$> canonicalize env expr

6263

6364 Valid.Binops ops final ->

64− error "TODO"

65+ A.drop <$> canonicalizeBinops region env ops final

6566

6667 Valid.Lambda args body ->

6768 addLocals $

@@ -145,6 +146,89 @@ canonicalizeBranch env (condition, branch) =

145146

146147

147148

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+

148232-- CANONICALIZE LET

149233

150234