Intial implementation of expression pretty printing.

diff --git a/LTA/Precedence.hs b/LTA/Precedence.hs
index 9d0ce276f20f7e804d0255dc77e944402d438143..2550496ebae918b99447653cd7b6ac2692af9dac 100644 (file)
--- a/LTA/Precedence.hs
+++ b/LTA/Precedence.hs
@@ -1,13 +1,16 @@
 module LTA.Precedence
   ( Assoc(..)
   , PrecExpr(..)
+  , bracket
   , buildAtom
   , buildFunction
   , buildInfix
+  , precedence
+  , value
   ) where
 
 import Control.Applicative ((<$>))
-import Text.PrettyPrint (Doc, comma, hcat, parens, punctuate, text)
+import Text.PrettyPrint ((<>), Doc, comma, hcat, parens, punctuate, space, text)
 
 data Assoc
   = AssocLeft
@@ -33,10 +36,10 @@ buildAtom = PrecExpr AssocNone 9
 buildFunction :: String -> [PrecExpr] -> PrecExpr
 buildFunction name params = PrecExpr AssocNone 9 call where
   call = hcat [text name, parens flatParams]
-  flatParams = hcat . punctuate comma $ value <$> params
+  flatParams = hcat . punctuate (comma <> space) $ value <$> params
 
-buildInfix :: String -> Assoc -> Integer -> PrecExpr -> PrecExpr -> PrecExpr
-buildInfix name assoc prec left right = PrecExpr assoc prec val where
+buildInfix :: (Assoc, Integer, String) -> PrecExpr -> PrecExpr -> PrecExpr
+buildInfix (assoc, prec, name) left right = PrecExpr assoc prec val where
   valueLeft = bracket bracketLeft $ value left
   valueRight = bracket bracketRight $ value right
   val = hcat [valueLeft, text " ", text name, text " ", valueRight]

diff --git a/LTA/Symbolic.hs b/LTA/Symbolic.hs
index deecffab504417d9cb142c655917627fe05a0dbe..52731236d080413a51bd327f603912351dafadd5 100644 (file)
--- a/LTA/Symbolic.hs
+++ b/LTA/Symbolic.hs
@@ -25,8 +25,9 @@ import Data.List (foldl')
 import Data.Map (Map)
 import Data.Set (Set)
 import LTA.Common (PrettyPrintable(..))
-import LTA.Precedence (PrecExpr(..), buildAtom, buildFunction, buildInfix)
-import Text.PrettyPrint (text)
+import LTA.Precedence (Assoc(..), PrecExpr(..), bracket, buildAtom, buildFunction
+  , buildInfix, precedence, value)
+import Text.PrettyPrint ((<>), hsep, parens, render, text)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -43,6 +44,9 @@ class ContainsSymbols e where
   rename :: String -> String -> e -> e
   findSymbols :: e -> Set String
 
+class PrecedenceExpression e where
+  toPrecExpr :: e -> PrecExpr
+
 instance PairSeqLike (PairSeq SumTag Literal) where
   empty = PairSeq 0 Map.empty
   rebuild (PairSeq overall pairs) = case (overall, Map.toList pairs) of
@@ -94,6 +98,25 @@ instance PairSeqLike (PairSeq ProductTag Expr) where
                Just n -> transformOverall oldSeq (* n)
                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, "*")
+
+instance PrecedenceExpression (PairSeq ProductTag Expr) where
+  toPrecExpr pairSeq = buildPrecExprFromPairSeq pairSeq nullOverall mulOp powerOp where
+    nullOverall = 1
+    mulOp = (AssocLeft, 7, "*")
+    powerOp = (AssocRight, 8, "^") 
+
+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 
+
 data Expr
   = IntegerSymbol String
   | FloatSymbol String
@@ -109,12 +132,12 @@ data Expr
   deriving (Eq, Ord, Show)
 
 data CompareOp
- = Equal
- | LessThan
- | LessThanEqual
- | GreaterThan
- | GreaterThanEqual
- deriving (Eq, Ord, Show)
+  = Equal
+  | LessThan
+  | LessThanEqual
+  | GreaterThan
+  | GreaterThanEqual
+  deriving (Eq, Ord, Show)
 
 data Cond
   = TrueC
@@ -166,17 +189,60 @@ buildConditional base ((cond, expr) : cases) =
 (~>) = Compare GreaterThan
 
 instance PrettyPrintable Expr where
-  toDoc expr = case buildPrecedence expr of
+  toDoc expr = case toPrecExpr expr of
     (PrecExpr _ _ doc) -> doc
-    where
-    buildPrecedence e = case e of
-      IntegerSymbol s -> buildAtom $ text s
-      FloatSymbol s -> buildAtom $ text s
-      Constant c -> buildAtom . text $ show c
-      Summation var low high summand -> buildFunction "sum" params where
-        params = buildPrecedence <$> [summand, IntegerSymbol var, low, high]
-      v -> error $ "Unimplemented: " ++ show v
 
+instance PrettyPrintable UnaryFunction where
+  toDoc Abs = text "abs"
+  toDoc Signum = text "signum"
+
+instance PrettyPrintable Constant where
+  toDoc Euler = text "e"
+  toDoc Pi = text "pi"
+  toDoc ImaginaryUnit = text "i"
+
+instance PrettyPrintable CompareOp where
+  toDoc op = text $ case op of
+    Equal -> "=="
+    LessThan -> "<"
+    LessThanEqual -> "<="
+    GreaterThan -> ">"
+    GreaterThanEqual -> ">=" 
+
+instance PrecedenceExpression Expr where
+  toPrecExpr e = case e of
+    IntegerSymbol s -> buildAtom $ text s
+    FloatSymbol s -> buildAtom $ text s
+    Constant c -> buildAtom $ toDoc c
+    Summation var low high summand -> buildFunction "sum" params where
+      params = toPrecExpr <$> [summand, IntegerSymbol var, low, high]
+    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)
+    UnaryFunction f x -> buildAtom $ case toPrecExpr x of
+      (PrecExpr _ _ s) -> (toDoc f) <> (parens s)
+    Conditional c a b -> PrecExpr AssocNone conditionalPrec val where
+      val = hsep [text "if", doBracket c, text "then", doBracket a, text "else", doBracket b] 
+      conditionalPrec = 1
+      doBracket expr = bracket (precedence expr' <= conditionalPrec) (value expr') where
+        expr' = toPrecExpr expr
+      
+
+instance PrecedenceExpression Cond where
+  toPrecExpr cond = case cond of
+    TrueC -> buildAtom $ text "true"
+    FalseC -> buildAtom $ text "false"
+    Compare op left right ->
+      buildInfix (AssocNone, 4, render $ toDoc op) (toPrecExpr left) (toPrecExpr right)
+    And left right ->
+      buildInfix (AssocRight, 3, "&&") (toPrecExpr left) (toPrecExpr right)
+    Or left right ->
+      buildInfix (AssocRight, 2, "||") (toPrecExpr left) (toPrecExpr right)
+    Not e -> PrecExpr AssocNone 8 $ (text "!") <> (value $ toPrecExpr e)
+
+      
 instance ContainsSymbols Expr where
   rename from to e = case e of
     IntegerSymbol name -> if name == from
@@ -294,6 +360,21 @@ evalPow (Literal a) (Literal b) = evalPow' a b where
   evalPow' _ _ = Nothing
 evalPow _ _ = Nothing
 
+buildPrecExprFromPairSeq :: (Eq c, Num c, PrecedenceExpression c) => 
+  PairSeq t c -> Literal -> (Assoc, Integer, String) -> (Assoc, Integer, String) -> 
+  PrecExpr
+buildPrecExprFromPairSeq (PairSeq overall terms) nullOverall combineOp pairOp = 
+  case (overall, Map.toList terms) of
+    (_, []) -> toPrecExpr overall
+    (_, _) -> if overall == nullOverall
+      then termsPrec
+      else buildInfix combineOp termsPrec $ toPrecExpr overall
+      where
+        termsPrec = foldr1 (buildInfix combineOp) (buildPairPrec <$> Map.toList terms)
+        buildPairPrec (a, b) = if b == 1 
+          then toPrecExpr a 
+          else buildInfix pairOp (toPrecExpr a) (toPrecExpr b)
+
 instance Num Literal where
   (+) (RationalLiteral a) (RationalLiteral b) = RationalLiteral $ a + b
   (+) (FloatLiteral a) (FloatLiteral b) = FloatLiteral $ a + b

diff --git a/src/Main.hs b/src/Main.hs
index 920082436a69687c96c69278d9308a0b1d099a85..1f1da19ed7c06f677be3c38156ee85763768bbbd 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -2,7 +2,7 @@ module Main (main) where
 
 import LTA.Symbolic
 import LTA.Common
-import Text.PrettyPrint (comma, hcat, parens, punctuate, text)
+import Text.PrettyPrint ((<>), comma, hcat, parens, punctuate, space, text)
 
 data Matrix
  = Matrix Expr Expr Expr
@@ -10,7 +10,7 @@ data Matrix
 
 instance PrettyPrintable Matrix where
   toDoc (Matrix rows cols expr) =
-    hcat $ [text "matrix", parens . hcat . punctuate comma $ params] where
+    hcat $ [text "matrix", parens . hcat . punctuate (comma <> space) $ params] where
       params = [toDoc rows, toDoc cols, toDoc expr]
 
 multiply :: Matrix -> Matrix -> Matrix