From 3e5330c7353d8e94ae30ccc50cf8001d8be44fd8 Mon Sep 17 00:00:00 2001 From: Francis Russell Date: Thu, 18 Apr 2013 16:32:26 +0100 Subject: [PATCH] Intial implementation of expression pretty printing. --- LTA/Precedence.hs | 11 +++-- LTA/Symbolic.hs | 115 +++++++++++++++++++++++++++++++++++++++------- src/Main.hs | 4 +- 3 files changed, 107 insertions(+), 23 deletions(-) diff --git a/LTA/Precedence.hs b/LTA/Precedence.hs index 9d0ce27..2550496 100644 --- 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 deecffa..5273123 100644 --- 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 9200824..1f1da19 100644 --- 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 -- 2.47.3