Changed Show to Ppr

prototype2.hs

 {-# LANGUAGE ViewPatterns, PatternSynonyms, LambdaCase #-}
 import Data.Bifunctor
+class Ppr a where
+  ppr :: a -> String
+instance Ppr String where
+  ppr :: String -> String
+  ppr = id
+
 data Tree a o = Leaf a | Fork o (Tree a o) (Tree a o) deriving (Eq, Show)
 instance Bifunctor Tree where
   first = mapLeafes
@@ -17,25 +23,31 @@ mapOps f = foldTree Leaf (Fork . f)
 maxDepth :: Tree a o -> Int
 maxDepth = foldTree (const 1) (\_ l r -> 1 + max l r)
 
-prettyPrintTree :: Tree String String -> String
-prettyPrintTree t = go t 0 where
+instance (Ppr a, Ppr o) => Ppr (Tree a o) where
+  ppr :: (Ppr a, Ppr o) => Tree a o -> String
+  ppr t = go t 0 where
     showDepth :: Int -> String
     showDepth n = (take (2*n) $ cycle "--") ++ "|"
-  go :: Tree String String -> Int -> String
+    go :: Tree a o -> Int -> String
     go = foldTree fLeaf fFork
-  fLeaf :: String -> Int -> String
-  fLeaf s i = showDepth i ++ s ++ "\n"
-  fFork o l r i = showDepth i ++ o ++ "\n" ++ l (i+1) ++ r (i+1)
+    fLeaf :: a -> Int -> String
+    fLeaf s i = showDepth i ++ ppr s ++ "\n"
+    fFork o l r i = showDepth i ++ ppr o ++ "\n" ++ l (i+1) ++ r (i+1)
 
 data TreeZipper a o = TreeZipper (Tree a o) [(o, Direction, Tree a o)] deriving Show
-prettyPrintZipper :: (Show a, Show o) => TreeZipper a o -> String
-prettyPrintZipper = prettyPrintTree . unzipp . markCurrentPos
+
+markCurrentPos :: (a -> a -> a) -> a -> TreeZipper a a -> TreeZipper a a
+markCurrentPos fmark marker = modify (\case
+  Leaf a -> Leaf $ fmark a marker
+  Fork o l r -> Fork (fmark o marker) l r)
+
+instance (Ppr a, Ppr o) => Ppr (TreeZipper a o) where
+  ppr = ppr . unzipp . markCurrentPos (++) "<<<---" . mapZipper ppr ppr
 mapZipper :: (a1 -> a2) -> (o1 -> o2) -> TreeZipper a1 o1 -> TreeZipper a2 o2
 mapZipper fLeaf fOp (TreeZipper t bs) = TreeZipper t' bs' where
   t' = bimap fLeaf fOp t
   bs' = map (\(o,d,u) -> (fOp o, d, bimap fLeaf fOp u)) bs
 
-
 data Direction = DLeft | DRight deriving Show
 
 zipp :: Tree a o -> TreeZipper a o
@@ -65,10 +77,10 @@ data Leafes o = I' | Z' | U' -- U == Underflow
             | FILE' | FONT'
             | VAR' String
             | NAME'
-            | QUOTE' (Tree (Leafes o) o) deriving (Eq)
+            | QUOTE' (Tree (Leafes o) o) deriving (Eq, Show)
 
-instance Show o => Show (Leafes o) where
-  show = \case
+instance Ppr o => Ppr (Leafes o) where
+  ppr = \case
     I' -> "I"
     Z' -> "Z"
     U' -> "U"
@@ -81,7 +93,7 @@ instance Show o => Show (Leafes o) where
     FONT' -> "FONT"
     VAR' s -> "VAR " ++ s
     NAME' -> "NAME"
-    QUOTE' t -> "QUOTE " ++ show t
+    QUOTE' t -> "QUOTE " ++ ppr t
 pattern I = Leaf I'
 pattern Z = Leaf Z'
 pattern U = Leaf U'
@@ -98,9 +110,9 @@ pattern QUOTE t = Leaf (QUOTE' t)
 data Operators =
     OSUM
   | OPRODUCT
-  | OARROW deriving (Eq)
-instance Show Operators where
-  show = \case
+  | OARROW deriving (Eq, Show)
+instance Ppr Operators where
+  ppr = \case
     OSUM -> "+"
     OPRODUCT -> "*"
     OARROW -> "->"
@@ -115,11 +127,6 @@ pattern PRODUCT l r = Fork OPRODUCT l r
 pattern ARROW :: PTypes -> PTypes -> PTypes
 pattern ARROW l r = Fork OARROW l r
 
-markCurrentPos :: (Show a, Show o) => TreeZipper a o -> TreeZipper String String
-markCurrentPos = modify (\case
-  Leaf a -> Leaf $ a ++ "<<<---"
-  Fork o l r -> Fork (o ++ "<<<---") l r) . mapZipper show show
-
 
 type Edit = PTypes -> PTypes
 assoziative :: Edit
@@ -190,7 +197,7 @@ exampleTree :: PTypes
 exampleTree = (VAR "T" #* (VAR "X" #> VAR "X"#* VAR "X")) #+ Z --- (SUM (SUM (VAR "middle left") (VAR "X") )  (VAR "right"))
 
 loop tree = do
-   putStrLn $ prettyPrintZipper tree
+   putStrLn $ ppr tree
    putStrLn $ show tree
    l <- getLine
    case l of