diff --git a/prototype2.hs b/prototype2.hs index ee189b8e95caa79b08ac1e2b9ad45299ed5ac3d5..ece1b0bbee531427e8587b1d9a3220aed0a54b7d 100644 --- a/prototype2.hs +++ b/prototype2.hs @@ -1,5 +1,11 @@ {-# 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 - showDepth :: Int -> String - showDepth n = (take (2*n) $ cycle "--") ++ "|" - go :: Tree String String -> 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) +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 a o -> Int -> String + go = foldTree fLeaf fFork + 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