accelerate 1.1.0.0 → 1.1.1.0
raw patch · 10 files changed
+196/−116 lines, 10 filesdep +ansi-wl-pprintdep −pretty
Dependencies added: ansi-wl-pprint
Dependencies removed: pretty
Files
- CHANGELOG.md +7/−1
- Data/Array/Accelerate/Debug/Flags.hs +7/−7
- Data/Array/Accelerate/Debug/Stats.hs +8/−8
- Data/Array/Accelerate/Pretty.hs +29/−10
- Data/Array/Accelerate/Pretty/Graphviz.hs +18/−14
- Data/Array/Accelerate/Pretty/Graphviz/Type.hs +24/−12
- Data/Array/Accelerate/Pretty/Print.hs +94/−54
- Data/Array/Accelerate/Trafo/Algebra.hs +1/−1
- Data/Array/Accelerate/Trafo/Base.hs +5/−6
- accelerate.cabal +3/−3
CHANGELOG.md view
@@ -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
Data/Array/Accelerate/Debug/Flags.hs view
@@ -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)
Data/Array/Accelerate/Debug/Stats.hs view
@@ -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
Data/Array/Accelerate/Pretty.hs view
@@ -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
Data/Array/Accelerate/Pretty/Graphviz.hs view
@@ -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
Data/Array/Accelerate/Pretty/Graphviz/Type.hs view
@@ -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
Data/Array/Accelerate/Pretty/Print.hs view
@@ -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
Data/Array/Accelerate/Trafo/Algebra.hs view
@@ -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
Data/Array/Accelerate/Trafo/Base.hs view
@@ -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
accelerate.cabal view
@@ -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