A module for converting any data type with a Generic instance into a pretty tree

GenericToTree.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}
module GenericToTree where

import GHC.Generics
import Data.Tree
import GHC.TypeLits (symbolVal, KnownSymbol)
import Data.Proxy (Proxy(Proxy))
import Data.List (intercalate)
import qualified Data.Map as Map
import qualified Data.Array as Array
import qualified Data.Foldable as Foldable
import qualified Data.Set as Set


-- class Show a => ToTree a where
class ToTree a where
    toTree :: a -> Tree String
    toTreeList :: [a] -> Tree String
    toTreeList = toTreeList__

    default toTree :: (Generic a, ToTree (Rep a ()) ) => a -> Tree String
    toTree = toTree . from @a @()

-- class Show a => ToForest a where
class ToForest a where
    toForest :: a -> Forest String

data SillyTree = SLeaf | SNode SillyTree SillyTree
  deriving (Show, Eq, Generic)

instance ToTree SillyTree where
    toTree = toTree . from

exampleTree :: Tree String
exampleTree = toTree $ SNode (SNode SLeaf SLeaf) SLeaf

showAsTree :: ToTree a => a -> String
showAsTree = drawTree . simplfiyTree . toTree

printAsTree :: ToTree a => a -> IO ()
printAsTree = putStrLn . showAsTree

showExampleTree :: String
showExampleTree = drawTree exampleTree



-- | Simplifier

simplfiyTree :: Tree String -> Tree String
simplfiyTree = cataTree simplifySingle

simplifySingle :: String -> Forest String -> Tree String
-- simplifySingle a (Node "" []:xs) = simplifySingle (a ++ "+") xs
simplifySingle a (Node "" []:xs) = simplifySingle a xs
simplifySingle "[]" [Node b []] = Node ("[" ++ b ++ "]") []
simplifySingle a [Node b []] | not (elem ' ' b) = Node (a ++ " " ++ b) []
simplifySingle a [Node b []] = Node (a ++ " $ " ++ b) []
simplifySingle a [Node b bs] = Node (a ++ " . " ++ b) bs
simplifySingle a [] = Node a []
simplifySingle a xs | all (null . subForest) xs, length simpl < 90 = pure simpl
  where
    simpl
        | a == "(,)" = "(" ++ intercalate ", " (map rootLabel xs) ++ ")"
        | a == "[]" = "[" ++ intercalate ", " (map rootLabel xs) ++ "]"
        | otherwise = a ++ concatMap ((' ':) . parenthize . rootLabel) xs
-- simplifySingle a xs = Node (show (length xs) ++ a) xs
simplifySingle a xs = Node a xs

parenthize :: String -> String
parenthize s | not (elem ' ' s) = s
parenthize s@('[':_) = s
parenthize s = "(" ++ s ++ ")"

-- cataTree :: (a -> Forest b -> Tree b) -> Tree a -> Tree b
cataTree :: (a -> [b] -> b) -> Tree a -> b
cataTree f (Node x xs) = f x $ cataTree f <$> xs

transformTree :: (Tree a -> Tree a) -> Tree a -> Tree a
transformTree f (Node x ts) = f (Node x $ transformTree f <$> ts)

-- * Instances

class GetName (meta :: Meta) where
    getName :: String

instance KnownSymbol name => GetName ('MetaCons name fixity selectors) where
    getName = symbolVal @name Proxy

instance KnownSymbol name => GetName ('MetaSel ('Just name) fixity selectors strictness) where
    getName = symbolVal @name Proxy ++ " = "

instance GetName ('MetaSel 'Nothing fixity selectors strictness) where
    getName = ""

instance ToTree (f p) => ToTree (M1 D t f p) where
    toTree (M1 x) = toTree x

-- Constructor, get name
instance (GetName meta, ToForest (f p)) => ToTree (M1 C meta f p) where
    toTree (M1 x) = Node (getName @meta) $ toForest x

instance (ToForest (f p), ToForest (g p)) => ToForest ((f :*: g) p) where
    toForest (x :*: y) = toForest x ++ toForest y

-- Selector, get name
instance (GetName meta, ToTree (f p)) => ToForest (M1 S meta f p) where
    toForest (M1 x) = pure $ mapHead (getName @meta ++)  $ toTree x

-- instance (ToForest (f p)) => ToForest (M1 S meta f p) where
--     toForest (M1 x) = toForest x

instance (ToTree f) => ToTree (K1 R f p) where
    toTree (K1 x) = toTree x

instance (ToTree f) => ToForest (K1 R f p) where
    toForest (K1 x) = [toTree x]

instance ToForest (U1 p) where
    toForest U1 = []

-- instance ToTree (f p) => ToTree (M1 i t f p) where
--     toTree (M1 x) = toTree x

instance (ToTree (f p), ToTree (g p)) => ToTree ((f :+: g) p) where
    toTree (L1 x) = toTree x
    toTree (R1 x) = toTree x


-- * Specific instances

instance ToTree a => ToTree [a] where
  toTree = toTreeList

toTreeList__ :: ToTree a => [a] -> Tree [Char]
toTreeList__ xs = Node "[]" $ toTree <$> xs

instance ToTree a => ToTree (Maybe a)
instance (ToTree a, ToTree b) => ToTree (a, b)
instance (ToTree a, ToTree b, ToTree c) => ToTree (a, b, c)
instance (ToTree a, ToTree b, ToTree c, ToTree d) => ToTree (a,b,c,d)

instance (ToTree a, ToTree b) => ToTree (Map.Map a b) where
    toTree a = mapHead ("Map.fromList . " ++) . toTree $ Map.toList a

instance ToTree a => ToTree (Set.Set a) where
    toTree a = mapHead ("Set.fromList . " ++) . toTree $ Set.toList a

instance (ToTree a, ToTree b) => ToTree (Array.Array a b) where
    toTree a = mapHead ("Array.fromList . " ++) . toTree $ Foldable.toList a

wrapText :: [a] -> Tree [a] -> Tree [a]
wrapText s = mapHead (s ++)

instance ToTree Char where
  toTree = toTreeShow
  toTreeList = toTreeShow

instance ToTree Bool
instance ToTree Double where toTree = toTreeShow
instance ToTree Int where toTree = toTreeShow
instance ToTree Integer where toTree = toTreeShow

toTreeShow :: Show a => a -> Tree String
toTreeShow a = Node (show a) []

mapHead :: (a -> a) -> Tree a -> Tree a
mapHead f (Node a xs) = Node (f a) xs