From 1172bfd2a04a78eb3d4cd11637ce7e63b0a64c9b Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Mon, 17 Sep 2007 10:38:30 +0000 Subject: [PATCH] Added the pshowCode function that uses the ShowOccam and ShowRain classes to print out applicable parts of an AST --- common/PrettyShow.hs | 61 ++++++++++++++++++++++++++++---------------- common/ShowCode.hs | 9 +++++++ 2 files changed, 48 insertions(+), 22 deletions(-) diff --git a/common/PrettyShow.hs b/common/PrettyShow.hs index 87697c1..84713b5 100644 --- a/common/PrettyShow.hs +++ b/common/PrettyShow.hs @@ -20,16 +20,19 @@ with this program. If not, see . -- This ought to use a class (like show does), so that it can be extended -- properly without me needing to have Tock-specific cases in here -- see the -- appropriate SYB paper. -module PrettyShow (pshow) where +module PrettyShow (pshow, pshowCode) where +import Control.Monad.State import Data.Generics import qualified Data.Map as Map import qualified Data.Set as Set import Text.PrettyPrint.HughesPJ import qualified AST as A +import CompState import Metadata import Pattern +import ShowCode -- This is ugly -- but it looks like you can't easily define a generic function -- even for a single tuple type, since it has to parameterise over multiple Data @@ -42,8 +45,8 @@ isTupleCtr ('(':cs) = checkRest cs checkRest _ = False isTupleCtr _ = False -doGeneral :: Data a => a -> Doc -doGeneral t = +doGeneral :: Data a => GenericQ Doc -> a -> Doc +doGeneral anyFunc t = if isTupleCtr cn then parens $ sep $ punctuate (text ",") l else case l of @@ -52,10 +55,10 @@ doGeneral t = where cn = showConstr (toConstr t) con = text $ cn - l = gmapQ doAny t + l = gmapQ anyFunc t -doList :: Data a => [a] -> Doc -doList t = brackets $ sep $ punctuate (text ",") (map doAny t) +doList :: Data a => GenericQ Doc -> [a] -> Doc +doList anyFunc t = brackets $ sep $ punctuate (text ",") (map anyFunc t) doString :: String -> Doc doString s = text $ show s @@ -63,12 +66,12 @@ doString s = text $ show s doMeta :: Meta -> Doc doMeta m = text $ show m -doMap :: (Data a, Data b) => Map.Map a b -> Doc -doMap map = braces $ sep $ punctuate (text ",") [doAny k <+> text ":" <+> doAny v - | (k, v) <- Map.toAscList map] +doMap :: (Data a, Data b) => GenericQ Doc -> Map.Map a b -> Doc +doMap anyFunc map = braces $ sep $ punctuate (text ",") [anyFunc k <+> text ":" <+> anyFunc v + | (k, v) <- Map.toAscList map] -doSet :: Data a => Set.Set a -> Doc -doSet set = brackets $ sep $ punctuate (text ",") (map doAny $ Set.toList set) +doSet :: Data a => GenericQ Doc -> Set.Set a -> Doc +doSet anyFunc set = brackets $ sep $ punctuate (text ",") (map anyFunc $ Set.toList set) foldPatternList :: Pattern -> [Pattern] foldPatternList (Match con patList) @@ -113,25 +116,39 @@ doPattern p@(Match c ps) = --It's a string: then doString (showStringPattern folded) --It's some other kind of list: - else doList folded + else doList (mkQ empty doPattern) folded --It's neither a list nor a tuple: else parens $ (text (showConstr c)) $+$ (sep items) where items = map doPattern ps folded = foldPatternList p - -doAny :: Data a => a -> Doc -doAny = doGeneral `ext1Q` doList `extQ` doString `extQ` doMeta `extQ` doPattern - `extQ` (doMap :: Map.Map String String -> Doc) - `extQ` (doMap :: Map.Map String A.NameDef -> Doc) - `extQ` (doMap :: Map.Map String [A.Type] -> Doc) - `extQ` (doMap :: Map.Map String [A.Actual] -> Doc) - `extQ` (doSet :: Set.Set String -> Doc) - `extQ` (doSet :: Set.Set A.Name -> Doc) +doAny :: (forall a. Typeable a => (a -> Doc) -> (a -> Doc)) -> GenericQ Doc +doAny extFunc = extFunc ( + (doGeneral anyFunc) `ext1Q` (doList anyFunc) `extQ` doString `extQ` doMeta `extQ` doPattern + `extQ` (doMap anyFunc :: Map.Map String String -> Doc) + `extQ` (doMap anyFunc :: Map.Map String A.NameDef -> Doc) + `extQ` (doMap anyFunc :: Map.Map String [A.Type] -> Doc) + `extQ` (doMap anyFunc :: Map.Map String [A.Actual] -> Doc) + `extQ` (doSet anyFunc :: Set.Set String -> Doc) + `extQ` (doSet anyFunc :: Set.Set A.Name -> Doc) + ) + where + anyFunc :: GenericQ Doc + anyFunc = doAny extFunc -- | Convert an arbitrary data structure to a string in a reasonably pretty way. -- This is currently rather slow. pshow :: Data a => a -> String -pshow x = render $ doAny x +pshow x = render $ doAny id x +pshowCode :: (Data a, CSM m) => a -> m String +pshowCode c = do st <- get + case csFrontend st of + FrontendOccam -> return $ render $ (extOccam $ doAny extOccam) c + FrontendRain -> return $ render $ (extRain $ doAny extRain) c + where + extOccam :: forall a. Typeable a => (a -> Doc) -> (a -> Doc) + extOccam f = extCode f showOccam + extRain :: forall a. Typeable a => (a -> Doc) -> (a -> Doc) + extRain f = extCode f showRain diff --git a/common/ShowCode.hs b/common/ShowCode.hs index efbc183..9ad109b 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -22,6 +22,9 @@ with this program. If not, see . module ShowCode where import Control.Monad.State +import Data.Generics +import Data.List +import Text.PrettyPrint.HughesPJ import Text.Regex import qualified AST as A import CompState @@ -171,3 +174,9 @@ instance ShowRain A.Variable where showRain (A.DirectedVariable _ A.DirInput v) = "?" ++ showRain v showRain (A.DirectedVariable _ A.DirOutput v) = "!" ++ showRain v showRain x = "" + +-- | Extends an existing (probably generic) function with cases for everything that has a specific ShowOccam and ShowRain instance +extCode :: Typeable b => (b -> Doc) -> (forall a. (ShowOccam a, ShowRain a) => a -> String) -> (b -> Doc) +extCode q f = q `extQ` (text . (f :: A.Type -> String)) + `extQ` (text . (f :: A.DyadicOp -> String)) + `extQ` (text . (f :: A.Variable -> String))