From: Francis Russell <francis@unchartedbackwaters.co.uk>
Date: Thu, 18 Apr 2013 10:40:17 +0000 (+0100)
Subject: Inital work on pretty printing.
X-Git-Url: https://git.unchartedbackwaters.co.uk/w/?a=commitdiff_plain;h=490bf33dd304f48f0bb13e10725e0404e6cd3144;p=francis%2Flta.git

Inital work on pretty printing.
---

diff --git a/LTA/Common.hs b/LTA/Common.hs
new file mode 100644
index 0000000..e2038ba
--- /dev/null
+++ b/LTA/Common.hs
@@ -0,0 +1,23 @@
+module LTA.Common
+  ( PrettyPrintable(..)
+  ) where
+
+import Text.PrettyPrint
+  (Doc, renderStyle, Style(..), Mode(..), double, float , integer, int)
+
+class PrettyPrintable a where
+  toDoc :: a -> Doc
+  prettyPrint :: a -> String
+  prettyPrint = renderStyle Style {mode = PageMode, lineLength=72, ribbonsPerLine=1.5 } . toDoc
+
+instance PrettyPrintable Double where
+  toDoc = double
+
+instance PrettyPrintable Float where
+  toDoc = float
+
+instance PrettyPrintable Integer where
+  toDoc = integer
+
+instance PrettyPrintable Int where
+  toDoc = int
diff --git a/LTA/Precedence.hs b/LTA/Precedence.hs
new file mode 100644
index 0000000..9d0ce27
--- /dev/null
+++ b/LTA/Precedence.hs
@@ -0,0 +1,52 @@
+module LTA.Precedence
+  ( Assoc(..)
+  , PrecExpr(..)
+  , buildAtom
+  , buildFunction
+  , buildInfix
+  ) where
+
+import Control.Applicative ((<$>))
+import Text.PrettyPrint (Doc, comma, hcat, parens, punctuate, text)
+
+data Assoc
+  = AssocLeft
+  | AssocRight
+  | AssocNone
+  deriving Eq
+
+data PrecExpr
+  = PrecExpr Assoc Integer Doc
+
+precedence :: PrecExpr -> Integer
+precedence (PrecExpr _ p _) = p
+
+associativity :: PrecExpr -> Assoc
+associativity (PrecExpr a _ _) = a
+
+value :: PrecExpr -> Doc
+value (PrecExpr _ _ v) = v
+
+buildAtom :: Doc -> PrecExpr
+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
+
+buildInfix :: String -> Assoc -> Integer -> PrecExpr -> PrecExpr -> PrecExpr
+buildInfix name assoc prec 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]
+  bracketLeft =
+    prec > (precedence left) ||
+    (prec == precedence left && assoc /= associativity left)
+  bracketRight =
+    prec > (precedence right) ||
+    (prec == precedence right && assoc /= associativity right)
+
+bracket :: Bool -> Doc -> Doc
+bracket True = parens
+bracket False = id
diff --git a/LTA/Symbolic.hs b/LTA/Symbolic.hs
index 80939ee..deecffa 100644
--- a/LTA/Symbolic.hs
+++ b/LTA/Symbolic.hs
@@ -24,6 +24,9 @@ import Data.Ratio (numerator, denominator)
 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 qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -162,6 +165,18 @@ buildConditional base ((cond, expr) : cases) =
 (~>) :: Expr -> Expr -> Cond
 (~>) = Compare GreaterThan
 
+instance PrettyPrintable Expr where
+  toDoc expr = case buildPrecedence 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 ContainsSymbols Expr where
   rename from to e = case e of
     IntegerSymbol name -> if name == from
@@ -225,7 +240,7 @@ instance ContainsSymbols Cond where
     Not e -> findSymbols e
 
 findUniqueSymbol :: (ContainsSymbols e) => String -> e -> String
-findUniqueSymbol prefix expr = 
+findUniqueSymbol prefix expr =
   head [n | n <- generateNames, Set.notMember n syms ] where
     syms = findSymbols expr
     generateNames = [prefix ++ "_" ++ show n | n <- [0::Integer ..]]
diff --git a/lta.cabal b/lta.cabal
index 93a4fe8..972641e 100644
--- a/lta.cabal
+++ b/lta.cabal
@@ -9,11 +9,13 @@ Cabal-Version:       >=1.8.0.2
 Library
   Hs-Source-Dirs:    .
   GHC-Options:       -Wall
-  Build-Depends:     base, containers
-  Exposed-Modules:   LTA.Symbolic
+  Build-Depends:     base, containers, pretty
+  Exposed-Modules:   LTA.Common
+                     LTA.Precedence
+                     LTA.Symbolic
 
 Executable lta
   Main-is:           Main.hs
   Hs-Source-Dirs:    src
   GHC-Options:       -Wall
-  Build-Depends:     base, lta
+  Build-Depends:     base, lta, pretty
diff --git a/src/Main.hs b/src/Main.hs
index b39cd82..9200824 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,20 +1,27 @@
 module Main (main) where
 
 import LTA.Symbolic
+import LTA.Common
+import Text.PrettyPrint (comma, hcat, parens, punctuate, text)
 
-data Matrix 
+data Matrix
  = Matrix Expr Expr Expr
  deriving(Eq, Ord, Show)
 
+instance PrettyPrintable Matrix where
+  toDoc (Matrix rows cols expr) =
+    hcat $ [text "matrix", parens . hcat . punctuate comma $ params] where
+      params = [toDoc rows, toDoc cols, toDoc expr]
+
 multiply :: Matrix -> Matrix -> Matrix
-multiply (Matrix aRows aCols aExpr) (Matrix bRows bCols bExpr) = 
+multiply (Matrix aRows aCols aExpr) (Matrix bRows bCols bExpr) =
   Matrix aRows bCols $ Summation sumVar 0 aCols (aExpr' * bExpr') where
     sumVar = findUniqueSymbol "sum" (aExpr * bExpr)
     aExpr' = rename "col" sumVar aExpr
     bExpr' = rename "row" sumVar bExpr
 
 main :: IO()
-main = putStrLn . show $ (pad size) `multiply` (dft size) where
+main = putStrLn . prettyPrint $ (pad size) `multiply` (dft size) where
   size = IntegerSymbol "N"
 
 row :: Expr
@@ -39,7 +46,7 @@ isEven :: Expr -> Cond
 isEven n = (n `Mod` 2) ~== 0
 
 pad :: Expr -> Matrix
-pad size = 
+pad size =
   Matrix (2*size) size $ Conditional (isEven size) (evenPad size) (oddPad size)
 
 evenPad :: Expr -> Expr