diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,11 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) + +## [1.1.1.0] - 2017-09-26 +### Changed + * Improve and colourise the pretty-printer + ## [1.1.0.0] - 2017-09-21 ### Added * Additional EKG monitoring hooks ([#340]) @@ -86,7 +91,8 @@ * Initial release of the CUDA backend -[1.1.0.0]: https://github.com/AccelerateHS/accelerate/compare/1.0.0.0...1.1.0.0 +[1.1.1.0]: https://github.com/AccelerateHS/accelerate/compare/v1.1.0.0...v1.1.1.0 +[1.1.0.0]: https://github.com/AccelerateHS/accelerate/compare/1.0.0.0...v1.1.0.0 [1.0.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.15.1.0...1.0.0.0 [0.15.1.0]: https://github.com/AccelerateHS/accelerate/compare/0.15.0.0...0.15.1.0 [0.15.0.0]: https://github.com/AccelerateHS/accelerate/compare/0.14.0.0...0.15.0.0 diff --git a/Data/Array/Accelerate/Debug/Flags.hs b/Data/Array/Accelerate/Debug/Flags.hs --- a/Data/Array/Accelerate/Debug/Flags.hs +++ b/Data/Array/Accelerate/Debug/Flags.hs @@ -45,14 +45,14 @@ import Data.List import System.Environment import System.IO.Unsafe -import Text.PrettyPrint hiding ( Mode ) -import qualified Control.Monad as M ( when, unless ) +import Text.PrettyPrint.ANSI.Leijen +import qualified Control.Monad as M ( when, unless ) import Foreign.C import Foreign.Marshal import Foreign.Ptr -import GHC.Foreign as GHC -import GHC.IO.Encoding ( getFileSystemEncoding ) +import GHC.Foreign as GHC +import GHC.IO.Encoding ( getFileSystemEncoding ) import Debug.Trace @@ -239,9 +239,9 @@ (prefix,rest) = break (== '=') this suffix = if null rest then [] else tail rest - unknown = render $ text "Unknown option:" <+> quotes (text this) - ambiguous alts = render $ - vcat [ text "Ambiguous option:" <+> quotes (text this) + unknown = show $ text "Unknown option:" <+> squotes (text this) + ambiguous alts = show $ + vcat [ text "Ambiguous option:" <+> squotes (text this) , text "" , text "Did you mean one of these?" , nest 4 $ vcat (map (\(Option s _) -> text s) alts) diff --git a/Data/Array/Accelerate/Debug/Stats.hs b/Data/Array/Accelerate/Debug/Stats.hs --- a/Data/Array/Accelerate/Debug/Stats.hs +++ b/Data/Array/Accelerate/Debug/Stats.hs @@ -29,7 +29,7 @@ import Data.List ( groupBy, sortBy ) import Data.Ord ( comparing ) import Data.Map ( Map ) -import Text.PrettyPrint +import Text.PrettyPrint.ANSI.Leijen import System.IO.Unsafe import qualified Data.Map as Map @@ -80,7 +80,7 @@ } instance Show SimplStats where - show = render . pprSimplCount + show = show . pprSimplCount -- Stores the current statistics counters @@ -170,13 +170,13 @@ sameTag = (==) `on` tickToTag . fst pprTickGroup :: [(Tick,Int)] -> Doc -pprTickGroup [] = error "pprTickGroup" -pprTickGroup group = - hang (int groupTotal <+> text groupName) - 2 (vcat [ int n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) group ]) +pprTickGroup [] = error "pprTickGroup" +pprTickGroup grp = + hang 2 (vcat $ (int groupTotal <+> text groupName) + : [ int n <+> pprTickCtx t | (t,n) <- sortBy (flip (comparing snd)) grp ]) where - groupName = tickToStr (fst (head group)) - groupTotal = sum [n | (_,n) <- group] + groupName = tickToStr (fst (head grp)) + groupTotal = sum [n | (_,n) <- grp] tickToTag :: Tick -> Int tickToTag Inline{} = 0 diff --git a/Data/Array/Accelerate/Pretty.hs b/Data/Array/Accelerate/Pretty.hs --- a/Data/Array/Accelerate/Pretty.hs +++ b/Data/Array/Accelerate/Pretty.hs @@ -26,7 +26,7 @@ ) where -- standard libraries -import Text.PrettyPrint +import Text.PrettyPrint.ANSI.Leijen -- friends import Data.Array.Accelerate.AST @@ -34,11 +34,9 @@ import Data.Array.Accelerate.Pretty.Print import Data.Array.Accelerate.Pretty.Graphviz --- |Show instances --- --------------- -wide :: Style -wide = style { lineLength = 150 } +-- Show +-- ---- -- Explicitly enumerate Show instances for the Accelerate array AST types. If we -- instead use a generic instance of the form: @@ -49,10 +47,10 @@ -- interacting with other packages. See Issue #108. -- instance PrettyEnv aenv => Show (OpenAcc aenv a) where - show c = renderStyle wide $ prettyAcc noParens prettyEnv c + showsPrec _ = displayS . renderStyle . pretty instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where - show c = renderStyle wide $ prettyAcc noParens prettyEnv c + showsPrec _ = displayS . renderStyle . pretty -- These parameterised instances are fine because there is a concrete kind -- @@ -61,14 +59,35 @@ -- tuples, but our type parameter 'env' doesn't capture that. -- instance (Kit acc, PrettyEnv aenv) => Show (PreOpenAfun acc aenv f) where - show f = renderStyle wide $ prettyPreOpenAfun prettyAcc prettyEnv f + showsPrec _ = displayS . renderStyle . pretty instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun acc env aenv f) where - show f = renderStyle wide $ prettyPreOpenFun prettyAcc prettyEnv prettyEnv f + showsPrec _ = displayS . renderStyle . pretty instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp acc env aenv t) where - show e = renderStyle wide $ prettyPreOpenExp prettyAcc noParens prettyEnv prettyEnv e + showsPrec _ = displayS . renderStyle . pretty -- instance Kit acc => Show (PreOpenSeq acc aenv senv t) where -- show s = renderStyle wide $ sep $ punctuate (text ";") $ prettySeq prettyAcc 0 0 noParens s + +renderStyle :: Doc -> SimpleDoc +renderStyle = renderSmart 0.7 120 + +-- Pretty +-- ------ + +instance PrettyEnv aenv => Pretty (OpenAcc aenv a) where + pretty c = prettyAcc noParens prettyEnv c + +instance PrettyEnv aenv => Pretty (DelayedOpenAcc aenv a) where + pretty c = prettyAcc noParens prettyEnv c + +instance (Kit acc, PrettyEnv aenv) => Pretty (PreOpenAfun acc aenv f) where + pretty f = prettyPreOpenAfun prettyAcc prettyEnv f + +instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenFun acc env aenv f) where + pretty f = prettyPreOpenFun prettyAcc prettyEnv prettyEnv f + +instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Pretty (PreOpenExp acc env aenv t) where + pretty e = prettyPreOpenExp prettyAcc noParens prettyEnv prettyEnv e diff --git a/Data/Array/Accelerate/Pretty/Graphviz.hs b/Data/Array/Accelerate/Pretty/Graphviz.hs --- a/Data/Array/Accelerate/Pretty/Graphviz.hs +++ b/Data/Array/Accelerate/Pretty/Graphviz.hs @@ -29,17 +29,18 @@ ) where -- standard libraries +import Control.Applicative hiding ( Const, empty ) +import Control.Arrow ( (&&&) ) +import Control.Monad.State ( modify, gets, state ) +import Data.HashSet ( HashSet ) import Data.List import Data.Maybe -import Data.HashSet ( HashSet ) -import Text.PrettyPrint -import Control.Monad.State ( modify, gets, state ) -import Control.Arrow ( (&&&) ) import System.IO.Unsafe ( unsafePerformIO ) -import Control.Applicative hiding ( Const, empty ) +import Text.PrettyPrint.ANSI.Leijen hiding ( (<$>), parens ) import Prelude hiding ( exp ) import qualified Data.Sequence as Seq import qualified Data.HashSet as Set +import qualified Text.PrettyPrint.ANSI.Leijen as PP -- friends import Data.Array.Accelerate.AST ( PreOpenAcc(..), PreOpenAfun(..), PreOpenFun(..), PreOpenExp(..), PreBoundary(..), Idx(..) ) @@ -218,14 +219,14 @@ f' <- prettyDelayedAfun detail aenv f -- let PNode _ (Leaf (Nothing,xb)) fvs = x' - loop = wrap $ hang "awhile" 2 (sep [ text p', text f', xb ]) + loop = wrap $ hang 2 (sep ["awhile", text p', text f', xb ]) return $ PNode ident (Leaf (Nothing,loop)) fvs Atuple atup -> prettyDelayedAtuple detail wrap aenv atup Aprj ix atup -> do ident <- mkNodeId atop PNode _ (Leaf (p,d)) deps <- replant =<< prettyDelayedOpenAcc detail parens aenv atup - return $ PNode ident (Leaf (p, wrap (char '#' <> prettyTupleIdx ix <+> nest 2 d))) deps + return $ PNode ident (Leaf (p, wrap (prettyTupleIdx ix <+> nest 2 d))) deps Use arrs -> "use" .$ [ return $ PDoc (prettyArrays (arrays (undefined::arrs)) arrs) [] ] Unit e -> "unit" .$ [ ppE e ] @@ -263,7 +264,7 @@ docs' <- sequence docs let args = [ x | PDoc x _ <- docs' ] fvs = [ x | PDoc _ x <- docs' ] - return $ PDoc (wrap $ hang (text name) 2 (if simple detail then empty else sep args)) + return $ PDoc (wrap $ hang 2 (sep [text name, if simple detail then empty else sep args])) (concat fvs) pnode :: PDoc -> Dot PNode @@ -313,11 +314,11 @@ ppB :: forall sh e. (Shape sh, Elt e) => PreBoundary DelayedOpenAcc aenv (Array sh e) -> Dot PDoc - ppB Clamp = return (PDoc "Clamp" []) - ppB Mirror = return (PDoc "Mirror" []) - ppB Wrap = return (PDoc "Wrap" []) - ppB (Constant e) = return (PDoc (parens $ "Constant" <+> text (show (toElt e :: e))) []) - ppB (Function f) = "Function" `fmt` [ ppF f ] + ppB Clamp = return (PDoc "clamp" []) + ppB Mirror = return (PDoc "mirror" []) + ppB Wrap = return (PDoc "wrap" []) + ppB (Constant e) = return (PDoc (parens $ "constant" <+> text (show (toElt e :: e))) []) + ppB (Function f) = ppF f ppF :: DelayedFun aenv t -> Dot PDoc ppF = return . uncurry PDoc . (parens . prettyDelayedFun aenv' &&& fvF) @@ -344,7 +345,10 @@ in PNode ident x' vs + parens :: Doc -> Doc + parens = PP.parens . align + -- Pretty print array functions as separate sub-graphs, and return the name of -- the sub-graph as if it can be called like a function. We will add additional -- nodes at the top of the graph to represent the bound variables. @@ -424,7 +428,7 @@ -- simply tuple-up all of the elements. -- forest :: [Tree (Maybe Port, Doc)] -> Tree (Maybe Port, Doc) - forest leaves = Leaf (Nothing, tuple [ d | Leaf (Nothing,d) <- leaves ]) + forest leaves = Leaf (Nothing, tupled [ align d | Leaf (Nothing,d) <- leaves ]) -- Lift out anything that isn't a Leaf node and output it to the graph diff --git a/Data/Array/Accelerate/Pretty/Graphviz/Type.hs b/Data/Array/Accelerate/Pretty/Graphviz/Type.hs --- a/Data/Array/Accelerate/Pretty/Graphviz/Type.hs +++ b/Data/Array/Accelerate/Pretty/Graphviz/Type.hs @@ -17,9 +17,8 @@ import Data.Maybe import Data.Hashable -import Data.List import Text.Printf -import Text.PrettyPrint +import Text.PrettyPrint.ANSI.Leijen -- Rose tree, with all information at the leaves. @@ -103,8 +102,8 @@ , brackets $ hcat $ punctuate comma - $ catMaybes [ fmap ((text "xlabel" <> equals <>) . doubleQuotes . text) label - , Just ( text "label" <> equals <> doubleQuotes (ppNodeTree body)) + $ catMaybes [ fmap ((\x -> text "xlabel" <> equals <> x) . dquotes . text) label + , Just ( text "label" <> equals <> dquotes (ppNodeTree body)) ] ] @@ -116,18 +115,31 @@ -- escape some special characters. If the text takes up more than one line, -- then newlines '\n' need be be replaced with '\l', to ensure that the text -- is left justified rather than centred. The last line also needs a final - -- '\l'. Single lines of text are left centred, which provides better + -- '\l'. Single lines of text remain centred, which provides better -- formatting for short statements and port labels. -- pp :: Doc -> Doc - pp (lines . concatMap escape . renderStyle wide -> doc) = - case doc of - [] -> empty - [x] -> text x - xs -> text (intercalate "\\l" xs) <> text "\\l" -- [1] left justify + pp = encode . renderSmart 0.7 120 - wide :: Style - wide = style { lineLength = 200 } + encode :: SimpleDoc -> Doc + encode doc = + let + go SFail = error "unexpected failure rendering SimpleDoc" + go SEmpty = (empty, False) + go (SChar c x) = let (x',m) = go x in (text (escape c) <> x', m) + go (SText _ t x) = let (x',m) = go x in (text (concatMap escape t) <> x', m) + go (SLine i x) = let (x',_) = go x in (text "\\l" <> spaces i <> x', True) -- [1] left justify + go (SSGR _ x) = go x + + (doc',multiline) = go doc + in + doc' <> if multiline + then text "\\l" + else empty + + spaces :: Int -> Doc + spaces i | i <= 0 = empty + | otherwise = text (concat (replicate i "\\ ")) escape :: Char -> String escape ' ' = "\\ " -- don't collapse multiple spaces diff --git a/Data/Array/Accelerate/Pretty/Print.hs b/Data/Array/Accelerate/Pretty/Print.hs --- a/Data/Array/Accelerate/Pretty/Print.hs +++ b/Data/Array/Accelerate/Pretty/Print.hs @@ -40,18 +40,18 @@ -- ** Utilities Val(..), PrettyEnv(..), prj, sizeEnv, noParens, - tuple, ) where -- standard libraries -import Prelude hiding ( exp, seq ) -import Data.List -import Text.PrettyPrint +import Prelude hiding ( (<$>), exp, seq ) +import Data.List ( isPrefixOf ) +import Text.PrettyPrint.ANSI.Leijen hiding ( parens, tupled ) +import qualified Text.PrettyPrint.ANSI.Leijen as PP -- friends import Data.Array.Accelerate.AST hiding ( Val(..), prj ) -import Data.Array.Accelerate.Array.Sugar hiding ( tuple ) +import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Product @@ -103,7 +103,14 @@ ppE = prettyPreExp prettyAcc parens aenv ppSh :: PreExp acc aenv sh -> Doc - ppSh = parens . prettyPreExp prettyAcc noParens aenv + ppSh x = encase (prettyPreExp prettyAcc noParens aenv x) + where + encase = case x of + Var{} -> id + IndexNil -> id + IndexAny -> id + Const{} -> id + _ -> parens ppF :: PreFun acc aenv f -> Doc ppF = parens . prettyPreFun prettyAcc aenv @@ -124,19 +131,23 @@ ppB (Function f) = ppF f -- pretty print a named array operation with its arguments - name .$ docs = wrap $ hang (text name) 2 (sep docs) + name .$ docs = wrap $ hang 2 (sep (manifest (text name) : docs)) -- The main pretty-printer -- ----------------------- -- pp :: PreOpenAcc acc aenv arrs -> Doc pp (Alet acc1 acc2) - | not (isAlet acc1') && isAlet acc2' - = wrap $ vcat [ text "let" <+> a <+> equals <+> acc1' <+> text "in", acc2' ] + | isAlet acc2' + = if isAlet acc1' + then wrap $ vsep [ let_ <+> a <+> equals <$> indent 2 acc1' <+> in_, acc2' ] + else wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']) <+> in_, acc2' ] + | otherwise - = wrap $ vcat [ hang (text "let" <+> a <+> equals) 2 acc1', text "in" <+> acc2' ] + = wrap $ vsep [ hang 2 (sep [let_ <+> a <+> equals, acc1']), in_ acc2' ] where -- TLM: derp, can't unwrap into a PreOpenAcc to pattern match on Alet + render doc = displayS (renderCompact (plain doc)) "" isAlet doc = "let" `isPrefixOf` render doc acc1' = prettyAcc noParens aenv acc1 acc2' = prettyAcc noParens (aenv `Push` a) acc2 @@ -145,10 +156,10 @@ pp (Awhile p afun acc) = "awhile" .$ [ppAF p, ppAF afun, ppA acc] pp (Atuple tup) = prettyAtuple prettyAcc aenv tup pp (Avar idx) = prj idx aenv - pp (Aprj ix arrs) = wrap $ char '#' <> prettyTupleIdx ix <+> ppA arrs + pp (Aprj ix arrs) = wrap $ prettyTupleIdx ix <+> ppA arrs pp (Apply afun acc) = wrap $ sep [ ppAF afun, ppA acc ] - pp (Acond e acc1 acc2) = wrap $ sep [ ppE e, text "?|", tuple [ppA acc1, ppA acc2] ] - pp (Slice _ty acc ix) = wrap $ sep [ ppA acc, char '!', prettyPreExp prettyAcc noParens aenv ix ] + pp (Acond e acc1 acc2) = wrap $ hang 3 (vsep [if_ <+> ppE e, then_ <+> ppA acc1, else_ <+> ppA acc2]) + pp (Slice _ty acc ix) = "slice" .$ [ ppA acc, ppE ix ] pp (Use arrs) = "use" .$ [ prettyArrays (arrays (undefined :: arrs)) arrs ] pp (Unit e) = "unit" .$ [ ppE e ] pp (Generate sh f) = "generate" .$ [ ppSh sh, ppF f ] @@ -217,8 +228,8 @@ ppSlix :: SliceIndex slix sl co sh -> Doc ppSlix SliceNil = text "Z" - ppSlix (SliceAll s) = ppSlix s <+> text ":." <+> text "All" - ppSlix (SliceFixed s) = ppSlix s <+> text ":." <+> text "Split" + ppSlix (SliceAll s) = sep [ ppSlix s, text ":.", text "All" ] + ppSlix (SliceFixed s) = sep [ ppSlix s, text ":.", text "Split" ] prettyP :: forall a. Producer acc aenv senv a -> Doc prettyP p = @@ -235,7 +246,7 @@ case c of FoldSeq f e x -> "foldSeq" ..$ [ ppF f , ppE e , ppX x ] FoldSeqFlatten f a x -> "foldSeqFlatten" ..$ [ ppAF f , ppA a , ppX x ] - Stuple t -> tuple (prettyT t) + Stuple t -> tupled (prettyT t) prettyT :: forall t. Atuple (Consumer acc aenv senv) t -> [Doc] prettyT NilAtup = [] @@ -254,7 +265,7 @@ prettyPreOpenAfun pp aenv afun = char '\\' <> next aenv afun where next :: Val aenv' -> PreOpenAfun acc aenv' f' -> Doc - next aenv' (Abody body) = text "->" <+> pp noParens aenv' body + next aenv' (Abody body) = text "->" <+> align (pp noParens aenv' body) next aenv' (Alam afun') = let a = char 'a' <> int (sizeEnv aenv') in a <+> next (aenv' `Push` a) afun' @@ -275,7 +286,7 @@ prettyPreOpenFun pp env aenv fun = char '\\' <> next env fun where next :: Val env' -> PreOpenFun acc env' aenv f' -> Doc - next env' (Body body) = text "->" <+> prettyPreOpenExp pp noParens env' aenv body + next env' (Body body) = text "->" <+> align (prettyPreOpenExp pp noParens env' aenv body) next env' (Lam fun') = let x = char 'x' <> int (sizeEnv env') in x <+> next (env' `Push` x) fun' @@ -300,8 +311,15 @@ ppE = prettyPreOpenExp prettyAcc parens env aenv ppE' = prettyPreOpenExp prettyAcc noParens env aenv - ppSh :: PreOpenExp acc env aenv sh -> Doc - ppSh = parens . ppE' + ppE'' :: PreOpenExp acc env aenv sh -> Doc + ppE'' x = encase (ppE' x) + where + encase = case x of + Var{} -> id + IndexNil -> id + IndexAny -> id + Const{} -> id + _ -> parens ppF :: PreOpenFun acc env aenv f -> Doc ppF = parens . prettyPreOpenFun prettyAcc env aenv @@ -310,29 +328,33 @@ ppA = prettyAcc parens aenv -- pretty print a named array operation with its arguments - name .$ docs = wrap $ text name <+> sep docs + name .$ docs = wrap $ hang 2 (sep (text name : docs)) -- The main pretty-printer -- ----------------------- -- pp :: PreOpenExp acc env aenv t -> Doc pp (Let e1 e2) - | not (isLet e1) && isLet e2 - = wrap $ vcat [ text "let" <+> x <+> equals <+> e1' <+> text "in", e2' ] + | isLet e2 + = if isLet e1 + then wrap $ vsep [ let_ <+> x <+> equals <$> indent 2 e1' <+> in_, e2' ] + else wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']) <+> in_, e2' ] | otherwise - = wrap $ vcat [ hang (text "let" <+> x <+> equals) 2 e1', text "in" <+> e2' ] + = wrap $ vsep [ hang 2 (sep [let_ <+> x <+> equals, e1']), in_ e2' ] where isLet (Let _ _) = True isLet _ = False - e1' = prettyPreOpenExp prettyAcc noParens env aenv e1 - e2' = prettyPreOpenExp prettyAcc noParens (env `Push` x) aenv e2 + e1' = align $ prettyPreOpenExp prettyAcc noParens env aenv e1 + e2' = align $ prettyPreOpenExp prettyAcc noParens (env `Push` x) aenv e2 x = char 'x' <> int (sizeEnv env) pp (PrimApp p a) - | infixOp, Tuple (NilTup `SnocTup` x `SnocTup` y) <- a - = wrap $ sep [ppE x, f, ppE y] + | Tuple (NilTup `SnocTup` x `SnocTup` y) <- a + = if infixOp + then wrap $ sep [ppE x, f, ppE y] + else hang 2 (sep [f, ppE'' x, ppE'' y]) | otherwise - = wrap $ f' <+> ppE a + = wrap $ hang 2 (sep [f', ppE a]) where -- sometimes the infix function arguments are obstructed. If so, add -- parentheses and print prefix. @@ -344,25 +366,25 @@ pp (Tuple tup) = prettyTuple prettyAcc env aenv tup pp (Var idx) = prj idx env pp (Const v) = text $ show (toElt v :: t) - pp (Prj idx e) = wrap $ char '#' <> prettyTupleIdx idx <+> ppE e - pp (Cond c t e) = wrap $ sep [ ppE c, char '?' , tuple [ ppE' t, ppE' e ]] + pp (Prj idx e) = wrap $ prettyTupleIdx idx <+> ppE e + pp (Cond c t e) = wrap $ hang 3 (vsep [ if_ <+> ppE' c, then_ <+> ppE' t, else_ <+> ppE' e ]) pp IndexNil = char 'Z' pp IndexAny = text "indexAny" - pp (IndexCons t h) = ppE' t <+> text ":." <+> ppE' h + pp (IndexCons t h) = sep [ ppE' t, text ":.", ppE' h ] pp (IndexHead ix) = "indexHead" .$ [ ppE ix ] pp (IndexTail ix) = "indexTail" .$ [ ppE ix ] pp (IndexSlice _ slix sh) = "indexSlice" .$ [ ppE slix, ppE sh ] pp (IndexFull _ slix sl) = "indexFull" .$ [ ppE slix, ppE sl ] - pp (ToIndex sh ix) = "toIndex" .$ [ ppSh sh, ppSh ix ] - pp (FromIndex sh ix) = "fromIndex" .$ [ ppSh sh, ppE ix ] + pp (ToIndex sh ix) = "toIndex" .$ [ ppE'' sh, ppE'' ix ] + pp (FromIndex sh ix) = "fromIndex" .$ [ ppE'' sh, ppE ix ] pp (While p f x) = "while" .$ [ ppF p, ppF f, ppE x ] pp (Foreign ff _f e) = "foreign" .$ [ text (strForeign ff), {- ppF f, -} ppE e ] pp (Shape idx) = "shape" .$ [ ppA idx ] - pp (ShapeSize idx) = "shapeSize" .$ [ ppSh idx ] - pp (Intersect sh1 sh2) = "intersect" .$ [ ppSh sh1, ppSh sh2 ] - pp (Union sh1 sh2) = "union" .$ [ ppSh sh1, ppSh sh2 ] - pp (Index idx i) = wrap $ cat [ ppA idx, char '!', ppE i ] - pp (LinearIndex idx i) = wrap $ cat [ ppA idx, text "!!", ppE i ] + pp (ShapeSize idx) = "shapeSize" .$ [ ppE'' idx ] + pp (Intersect sh1 sh2) = "intersect" .$ [ ppE'' sh1, ppE'' sh2 ] + pp (Union sh1 sh2) = "union" .$ [ ppE'' sh1, ppE'' sh2 ] + pp (Index idx i) = wrap $ cat [ ppA idx, char '!', ppE'' i ] + pp (LinearIndex idx i) = wrap $ cat [ ppA idx, text "!!", ppE'' i ] -- Pretty print nested pairs as a proper tuple. @@ -373,7 +395,7 @@ -> Val aenv -> Atuple (acc aenv) t -> Doc -prettyAtuple pp aenv = tuple . collect +prettyAtuple pp aenv = tupled . collect where collect :: Atuple (acc aenv) t' -> [Doc] collect NilAtup = [] @@ -386,7 +408,7 @@ -> Val aenv -> Tuple (PreOpenExp acc env aenv) t -> Doc -prettyTuple pp env aenv = tuple . collect +prettyTuple pp env aenv = tupled . collect where collect :: Tuple (PreOpenExp acc env aenv) t' -> [Doc] collect NilTup = [] @@ -396,7 +418,7 @@ -- Pretty print an index for a tuple projection -- prettyTupleIdx :: TupleIdx t e -> Doc -prettyTupleIdx = int . toInt +prettyTupleIdx ix = char '#' <> int (toInt ix) where toInt :: TupleIdx t e -> Int toInt ZeroTupIdx = 0 @@ -490,7 +512,7 @@ -- TLM: seems to flatten the nesting structure -- prettyArrays :: ArraysR arrs -> arrs -> Doc -prettyArrays arrs = tuple . collect arrs +prettyArrays arrs = tupled . collect arrs where collect :: ArraysR arrs -> arrs -> [Doc] collect ArraysRunit _ = [] @@ -499,9 +521,9 @@ prettyArray :: forall dim e. Array dim e -> Doc prettyArray arr@(Array sh _) - = hang (text "Array") 2 - $ sep [ parens . text $ showShape (toElt sh :: dim) - , dataDoc] + = hang 2 $ sep [ text "Array" + , parens . text $ showShape (toElt sh :: dim) + , dataDoc ] where showDoc :: forall a. Show a => a -> Doc showDoc = text . show @@ -514,18 +536,36 @@ -- Auxiliary pretty printing combinators -- +parens :: Doc -> Doc +parens = PP.parens . align + noParens :: Doc -> Doc noParens = id -tuple :: [Doc] -> Doc -tuple = encloseSep lparen rparen comma +tupled :: [Doc] -> Doc +tupled = PP.tupled . map align -encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc -encloseSep left right p ds = - case ds of - [] -> left <> right - [d] -> left <> d <> right - _ -> cat (zipWith (<>) (left : repeat p) ds) <> right + +-- ANSI colourisation +-- + +control :: Doc -> Doc +control = dullyellow + +manifest :: Doc -> Doc +manifest = blue + +-- delayed :: Doc -> Doc +-- delayed = green + +let_, in_ :: Doc +let_ = control (text "let") +in_ = control (text "in") + +if_, then_, else_ :: Doc +if_ = control (text "if") +then_ = control (text "then") +else_ = control (text "else") -- Environments diff --git a/Data/Array/Accelerate/Trafo/Algebra.hs b/Data/Array/Accelerate/Trafo/Algebra.hs --- a/Data/Array/Accelerate/Trafo/Algebra.hs +++ b/Data/Array/Accelerate/Trafo/Algebra.hs @@ -30,7 +30,7 @@ import Data.Char import Data.Monoid import GHC.Float ( float2Double, double2Float ) -import Text.PrettyPrint +import Text.PrettyPrint.ANSI.Leijen import Unsafe.Coerce import qualified Prelude as P diff --git a/Data/Array/Accelerate/Trafo/Base.hs b/Data/Array/Accelerate/Trafo/Base.hs --- a/Data/Array/Accelerate/Trafo/Base.hs +++ b/Data/Array/Accelerate/Trafo/Base.hs @@ -53,7 +53,7 @@ import Control.DeepSeq import Data.Hashable import Data.Type.Equality -import Text.PrettyPrint +import Text.PrettyPrint.ANSI.Leijen hiding ( (<$>) ) import Prelude hiding ( until ) -- friends @@ -253,11 +253,10 @@ -> prettyDelayedOpenAcc wrap aenv a | otherwise - -> wrap $ hang (text "Delayed") 2 - $ sep [ prettyPreExp prettyDelayedOpenAcc parens aenv sh - , parens (prettyPreFun prettyDelayedOpenAcc aenv f) - ] - + -> wrap $ hang 2 (sep [ green (text "delayed") + , parens (align (prettyPreExp prettyDelayedOpenAcc (parens . align) aenv sh)) + , parens (align (prettyPreFun prettyDelayedOpenAcc aenv f)) + ]) {-- -- Pretty print delayed sequences diff --git a/accelerate.cabal b/accelerate.cabal --- a/accelerate.cabal +++ b/accelerate.cabal @@ -1,5 +1,5 @@ Name: accelerate -Version: 1.1.0.0 +Version: 1.1.1.0 Cabal-version: >= 1.8 Tested-with: GHC >= 7.8 Build-type: Simple @@ -263,7 +263,7 @@ , hashable >= 1.1 , hashtables >= 1.0 , mtl >= 2.0 - , pretty >= 1.0 + , ansi-wl-pprint >= 0.6 , template-haskell , time >= 1.4 , transformers >= 0.3 @@ -406,7 +406,7 @@ source-repository this Type: git - Tag: 1.1.0.0 + Tag: 1.1.1.0 Location: git://github.com/AccelerateHS/accelerate.git -- vim: nospell