{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.Comp.Render where

import Data.Comp
import Data.Comp.Derive
import Data.Comp.Show ()
import Data.Foldable (toList)
import Data.Tree (Tree (..))
import Data.Tree.View

-- | The 'stringTree' algebra of a functor. The default instance creates a tree
-- with the same structure as the term.
class (Functor f, Foldable f, ShowConstr f) => Render f where
    stringTreeAlg :: Alg f (Tree String)
    stringTreeAlg f (Tree String)
f = String -> Forest String -> Tree String
forall a. a -> Forest a -> Tree a
Node (f (Tree String) -> String
forall (f :: * -> *) a. ShowConstr f => f a -> String
showConstr f (Tree String)
f) (Forest String -> Tree String) -> Forest String -> Tree String
forall a b. (a -> b) -> a -> b
$ f (Tree String) -> Forest String
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Tree String)
f

-- | Convert a term to a 'Tree'
stringTree :: Render f => Term f -> Tree String
stringTree :: Term f -> Tree String
stringTree = Alg f (Tree String) -> Term f -> Tree String
forall (f :: * -> *) a. Functor f => Alg f a -> Term f -> a
cata Alg f (Tree String)
forall (f :: * -> *). Render f => Alg f (Tree String)
stringTreeAlg

-- | Show a term using ASCII art
showTerm :: Render f => Term f -> String
showTerm :: Term f -> String
showTerm = Tree String -> String
showTree (Tree String -> String)
-> (Term f -> Tree String) -> Term f -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term f -> Tree String
forall (f :: * -> *). Render f => Term f -> Tree String
stringTree

-- | Print a term using ASCII art
drawTerm :: Render f => Term f -> IO ()
drawTerm :: Term f -> IO ()
drawTerm = String -> IO ()
putStrLn (String -> IO ()) -> (Term f -> String) -> Term f -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term f -> String
forall (f :: * -> *). Render f => Term f -> String
showTerm

-- | Write a term to an HTML file with foldable nodes
writeHtmlTerm :: Render f => FilePath -> Term f -> IO ()
writeHtmlTerm :: String -> Term f -> IO ()
writeHtmlTerm String
file
    = Maybe String -> String -> Tree NodeInfo -> IO ()
writeHtmlTree Maybe String
forall a. Maybe a
Nothing String
file
    (Tree NodeInfo -> IO ())
-> (Term f -> Tree NodeInfo) -> Term f -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> NodeInfo) -> Tree String -> Tree NodeInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\String
n -> Behavior -> String -> String -> NodeInfo
NodeInfo Behavior
InitiallyExpanded String
n String
"") (Tree String -> Tree NodeInfo)
-> (Term f -> Tree String) -> Term f -> Tree NodeInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term f -> Tree String
forall (f :: * -> *). Render f => Term f -> Tree String
stringTree

$(derive [liftSum] [''Render])