Add Show/Render for Data.Comp.Multi

.gitignore

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

compdata.cabal

@@ -1,5 +1,5 @@
 Name:			compdata
-Version:		0.10
+Version:		0.11
 Synopsis:            	Compositional Data Types
 Description:
 
@@ -165,6 +165,9 @@ library
                         Data.Comp.Multi.Generic
                         Data.Comp.Multi.Desugar
                         Data.Comp.Multi.Projection
+                        Data.Comp.Multi.Render
+                        -- Data.Comp.Multi.Matching
+                        -- Data.Comp.Multi.TermRewriting
 
   Other-Modules:        Data.Comp.SubsumeCommon
                         Data.Comp.Derive.Equality
@@ -193,12 +196,11 @@ library
   hs-source-dirs:	src
   ghc-options:          -W
 
-
 Test-Suite test
   Type:                 exitcode-stdio-1.0
-  Main-is:		Data_Test.hs
-  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, 
+  Main-is:              Data_Test.hs
+  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
 

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,15 +41,15 @@ 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. -}
 makeShowHF :: Name -> Q [Dec]
 makeShowHF fname = do
-  Just (DataInfo _cxt name args constrs _deriving) <- abstractNewtypeQ $ reify fname
+  TyConI (DataD _cxt name args mkind constrs _deriving) <- abstractNewtypeQ $ reify fname
   let args' = init args
       fArg = VarT . tyVarBndrName $ last args'
       argNames = map (VarT . tyVarBndrName) (init args')
@@ -53,18 +58,58 @@ makeShowHF fname = do
       classType = AppT (ConT ''ShowHF) complType
   constrs' <- mapM normalConExp constrs
   showFDecl <- funD 'showHF (showFClauses fArg constrs')
-  return [mkInstanceD preCond classType [showFDecl]]
+  return [InstanceD Nothing preCond classType [showFDecl]]
       where showFClauses fArg = map (genShowFClause fArg)
             filterFarg fArg ty x = (containsType ty fArg, varE x)
             mkShow (isFArg, var)
                 | isFArg = [|unK $var|]
                 | otherwise = [| show $var |]
-            genShowFClause fArg (constr, args, ty) = do
+            genShowFClause fArg (constr, args) = do
               let n = length args
               varNs <- newNames n "x"
               let pat = ConP constr $ map VarP varNs
-                  allVars = zipWith (filterFarg (getBinaryFArg fArg ty)) args varNs
+                  allVars = zipWith (filterFarg fArg) 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
+  TyConI (DataD _cxt name args' mkind 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) = do
+              let n = length args
+              varNs <- newNames n "x"
+              let pat = ConP constr $ map VarP varNs
+                  allVars = zipWith (filterFarg fArg) 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,38 @@
+{-# 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.HFunctor
+import Data.Comp.Multi.HFoldable
+import Data.Comp.Multi.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 (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

@@ -25,7 +25,9 @@ module Data.Comp.Multi.Show
 
 import Data.Comp.Multi.Algebra
 import Data.Comp.Multi.Annotation
-import Data.Comp.Multi.Derive
+import Data.Comp.Multi.Derive (liftSum)
+import Data.Comp.Derive.Utils (derive)
+import Data.Comp.Multi.Derive.Show
 import Data.Comp.Multi.HFunctor
 import Data.Comp.Multi.Term
 
@@ -49,3 +51,9 @@ 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])
+