From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Thu, 18 Apr 2013 18:12:27 +0000 (+0100)
Subject: Clean-up precedence printing code.
X-Git-Url: https://git.unchartedbackwaters.co.uk/w/?a=commitdiff_plain;h=HEAD;p=francis%2Flta.git

Clean-up precedence printing code.
---

diff --git a/LTA/Symbolic.hs b/LTA/Symbolic.hs
index 5273123..549c70b 100644
--- a/LTA/Symbolic.hs
+++ b/LTA/Symbolic.hs
@@ -34,6 +34,30 @@ import qualified Data.Set as Set
 data SumTag
 data ProductTag
 
+powerOp :: (Assoc, Integer, String)
+powerOp = (AssocRight, 8, "^")
+
+mulOp :: (Assoc, Integer, String)
+mulOp = (AssocLeft, 7, "*")
+
+divOpFloat :: (Assoc, Integer, String)
+divOpFloat = (AssocLeft, 7, "/")
+
+divOpInt :: (Assoc, Integer, String)
+divOpInt = (AssocLeft, 7, "//")
+
+modOp :: (Assoc, Integer, String)
+modOp = (AssocLeft, 7, "%")
+
+addOp :: (Assoc, Integer, String)
+addOp = (AssocLeft, 6, "+")
+
+andOp :: (Assoc, Integer, String)
+andOp = (AssocRight, 3, "&&")
+
+orOp :: (Assoc, Integer, String)
+orOp = (AssocRight, 2, "||")
+
 class PairSeqLike e where
   empty :: e
   rebuild :: e -> Expr
@@ -99,23 +123,17 @@ instance PairSeqLike (PairSeq ProductTag Expr) where
                Nothing -> addPair oldSeq (a, b)
 
 instance PrecedenceExpression (PairSeq SumTag Literal) where
-  toPrecExpr pairSeq = buildPrecExprFromPairSeq pairSeq nullOverall addOp mulOp where
-    nullOverall = 0
-    addOp = (AssocLeft, 6, "+") 
-    mulOp = (AssocLeft, 7, "*")
+  toPrecExpr pairSeq = buildPrecExprFromPairSeq pairSeq 0 addOp mulOp where
 
 instance PrecedenceExpression (PairSeq ProductTag Expr) where
-  toPrecExpr pairSeq = buildPrecExprFromPairSeq pairSeq nullOverall mulOp powerOp where
-    nullOverall = 1
-    mulOp = (AssocLeft, 7, "*")
-    powerOp = (AssocRight, 8, "^") 
+  toPrecExpr pairSeq = buildPrecExprFromPairSeq pairSeq 1 mulOp powerOp where
 
 instance PrecedenceExpression Literal where
   toPrecExpr (FloatLiteral d) = buildAtom $ toDoc d
   toPrecExpr (RationalLiteral r) = if denominator r == 1
     then numToAtom $ numerator r
-    else buildInfix (AssocLeft, 7, "/") (numToAtom $ numerator r) (numToAtom $ denominator r)
-    where numToAtom = buildAtom . toDoc 
+    else buildInfix divOpFloat (numToAtom $ numerator r) (numToAtom $ denominator r)
+    where numToAtom = buildAtom . toDoc
 
 data Expr
   = IntegerSymbol String
@@ -219,8 +237,8 @@ instance PrecedenceExpression Expr where
     Product pairSeq -> toPrecExpr pairSeq
     Sum pairSeq -> toPrecExpr pairSeq
     Literal l -> toPrecExpr l
-    Div a b -> buildInfix (AssocLeft, 7, "/") (toPrecExpr a) (toPrecExpr b)
-    Mod a b -> buildInfix (AssocLeft, 7, "%") (toPrecExpr a) (toPrecExpr b)
+    Div a b -> buildInfix divOpInt (toPrecExpr a) (toPrecExpr b)
+    Mod a b -> buildInfix modOp (toPrecExpr a) (toPrecExpr b)
     UnaryFunction f x -> buildAtom $ case toPrecExpr x of
       (PrecExpr _ _ s) -> (toDoc f) <> (parens s)
     Conditional c a b -> PrecExpr AssocNone conditionalPrec val where
@@ -237,9 +255,9 @@ instance PrecedenceExpression Cond where
     Compare op left right ->
       buildInfix (AssocNone, 4, render $ toDoc op) (toPrecExpr left) (toPrecExpr right)
     And left right ->
-      buildInfix (AssocRight, 3, "&&") (toPrecExpr left) (toPrecExpr right)
+      buildInfix andOp (toPrecExpr left) (toPrecExpr right)
     Or left right ->
-      buildInfix (AssocRight, 2, "||") (toPrecExpr left) (toPrecExpr right)
+      buildInfix orOp (toPrecExpr left) (toPrecExpr right)
     Not e -> PrecExpr AssocNone 8 $ (text "!") <> (value $ toPrecExpr e)