Add Show/Render for Data.Comp.Multi

Author: tomberek

.gitignore

@@ -10,3 +10,4 @@ dummy.cabal
 *.mix
 hpcreport
 *.DS_Store
+.stack-work

compdata.cabal

@@ -165,6 +165,7 @@ library
                         Data.Comp.Multi.Generic
                         Data.Comp.Multi.Desugar
                         Data.Comp.Multi.Projection
+                        Data.Comp.Multi.Render
 
   Other-Modules:        Data.Comp.SubsumeCommon
                         Data.Comp.Derive.Equality
@@ -200,7 +201,7 @@ Test-Suite test
   hs-source-dirs:	testsuite/tests examples src
   Build-Depends:        base >= 4.7, base < 5, template-haskell, containers, mtl >= 2.2.1, QuickCheck >= 2 && < 2.9, 
                         HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2 >= 0.3, derive,
-                        th-expand-syns, deepseq, transformers
+                        th-expand-syns, deepseq, transformers, tree-view
 
 Benchmark algebra
   Type:                 exitcode-stdio-1.0

src/Data/Comp/Multi/Derive/Show.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators   #-}
+{-# LANGUAGE FlexibleInstances   #-}
 --------------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Comp.Multi.Derive.Show
@@ -17,13 +18,17 @@ module Data.Comp.Multi.Derive.Show
     (
      ShowHF(..),
      KShow(..),
-     makeShowHF
+     makeShowHF,
+     ShowConstr(..),
+     makeShowConstr
     ) where
 
 import Data.Comp.Derive.Utils
 import Data.Comp.Multi.Algebra
 import Data.Comp.Multi.HFunctor
 import Language.Haskell.TH
+import Data.Tree
+import Data.Tree.View
 
 {-| Signature printing. An instance @ShowHF f@ gives rise to an instance
   @KShow (HTerm f)@. -}
@@ -36,9 +41,9 @@ class ShowHF f where
 class KShow a where
     kshow :: a i -> K String i
 
-showConstr :: String -> [String] -> String
-showConstr con [] = con
-showConstr con args = "(" ++ con ++ " " ++ unwords args ++ ")"
+showConstr' :: String -> [String] -> String
+showConstr' con [] = con
+showConstr' con args = "(" ++ con ++ " " ++ unwords args ++ ")"
 
 {-| Derive an instance of 'ShowHF' for a type constructor of any higher-order
   kind taking at least two arguments. -}
@@ -66,5 +71,46 @@ makeShowHF fname = do
                   allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs
                   shows = listE $ map mkShow allVars
                   conName = nameBase constr
-              body <- [|K $ showConstr conName $shows|]
+              body <- [|K $ showConstr' conName $shows|]
               return $ Clause [pat] (NormalB body) []
+
+{-| Constructor printing. -}
+class ShowConstr f where
+    showConstr :: KShow a => f a i -> String
+
+instance KShow (K (Tree String)) where
+    kshow (K a) = K $ showTree a
+    
+showCon' :: String -> [String] -> String
+showCon' con args = unwords $ con : filter (not.null) args
+
+{-| Derive an instance of 'showConstr' for a type constructor of any first-order kind
+  taking at least one argument. -}
+makeShowConstr :: Name -> Q [Dec] 
+makeShowConstr fname = do
+  Just (DataInfo _cxt name args' constrs _deriving) <- abstractNewtypeQ $ reify fname
+  let args = init args'
+      fArg = VarT . tyVarBndrName $ last args
+      argNames = map (VarT . tyVarBndrName) (init args)
+      complType = foldl AppT (ConT name) argNames
+      preCond = map (mkClassP ''KShow . (: [])) argNames
+      classType = AppT (ConT ''ShowConstr) complType
+  constrs' <- mapM normalConExp constrs
+  showConstrDecl <- funD 'showConstr (showConstrClauses fArg constrs')
+  return [InstanceD Nothing preCond classType [showConstrDecl]]
+      where showConstrClauses fArg = map (genShowConstrClause fArg)
+            filterFarg fArg ty@(AppT ty' _) x = (fArg == ty', varE x)
+            filterFarg fArg ty@(_) x = (fArg == ty, varE x)
+            mkShow :: (Bool, ExpQ) -> ExpQ
+            mkShow (isFArg, var)
+                | isFArg = [| "" |]
+                | otherwise = [| unK $ kshow $var |]
+            genShowConstrClause fArg (constr, args, ty) = do
+              let n = length args
+              varNs <- newNames n "x"
+              let pat = ConP constr $ map VarP varNs
+                  allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs
+                  shows = listE $ map mkShow allVars
+                  conName = nameBase constr
+              body <- [| showCon' conName $shows|]
+              return $ Clause [pat] (NormalB body) []

src/Data/Comp/Multi/Render.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
+module Data.Comp.Multi.Render where
+
+import Data.Comp.Multi
+import Data.Comp.Multi.Derive
+import Data.Comp.Multi.HFoldable
+import Data.Comp.Multi.Show()
+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 (HFunctor f, HFoldable f,ShowHF f,ShowConstr f) => Render f where
+    stringTreeAlg :: Alg f (K (Tree String))
+    stringTreeAlg f = K $ Node (showConstr f) $ fmap (\(E (K a)) -> a) $ htoList f
+
+-- | Convert a term to a 'Tree'
+stringTree :: Render f => Term f :-> K (Tree String)
+stringTree = cata stringTreeAlg
+
+-- | Show a term using ASCII art
+showTerm :: Render f => Term f :=> String
+showTerm = showTree . unK . stringTree
+
+-- | Print a term using ASCII art
+drawTerm :: Render f => Term f :=> IO ()
+drawTerm = putStrLn . showTerm
+
+-- | Write a term to an HTML file with foldable nodes
+writeHtmlTerm :: Render f => FilePath -> Term f :=> IO ()
+writeHtmlTerm file = writeHtmlTree file . fmap (\n -> NodeInfo n "") . unK . stringTree
+
+$(derive [liftSum] [''Render])

src/Data/Comp/Multi/Show.hs

@@ -26,6 +26,7 @@ module Data.Comp.Multi.Show
 import Data.Comp.Multi.Algebra
 import Data.Comp.Multi.Annotation
 import Data.Comp.Multi.Derive
+import Data.Comp.Derive.Utils (derive)
 import Data.Comp.Multi.HFunctor
 import Data.Comp.Multi.Term
 
@@ -49,3 +50,8 @@ instance (ShowHF f, Show p) => ShowHF (f :&: p) where
     showHF (v :&: p) =  K $ unK (showHF v) ++ " :&: " ++ show p
 
 $(derive [liftSum] [''ShowHF])
+
+instance (ShowConstr f, Show p) => ShowConstr (f :&: p) where
+    showConstr (v :&: p) = showConstr v ++ " :&: " ++ show p
+    
+$(derive [liftSum] [''ShowConstr])