{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
module Data.Array.Accelerate.Pretty (
module Data.Array.Accelerate.Pretty.Print,
module Data.Array.Accelerate.Pretty.Graphviz,
) where
import System.IO
import System.IO.Unsafe
import Text.PrettyPrint.ANSI.Leijen
import qualified System.Console.ANSI as Term
import qualified System.Console.Terminal.Size as Term
import Data.Array.Accelerate.AST
import Data.Array.Accelerate.Trafo.Base
import Data.Array.Accelerate.Pretty.Print
import Data.Array.Accelerate.Pretty.Graphviz
instance PrettyEnv aenv => Show (OpenAcc aenv a) where
showsPrec _ = renderForTerminal . pretty
instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where
showsPrec _ = renderForTerminal . pretty
instance (Kit acc, PrettyEnv aenv) => Show (PreOpenAfun acc aenv f) where
showsPrec _ = renderForTerminal . pretty
instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenFun acc env aenv f) where
showsPrec _ = renderForTerminal . pretty
instance (Kit acc, PrettyEnv env, PrettyEnv aenv) => Show (PreOpenExp acc env aenv t) where
showsPrec _ = renderForTerminal . pretty
renderForTerminal :: Doc -> ShowS
renderForTerminal doc next =
unsafePerformIO $ do
term <- Term.size
ansi <- Term.hSupportsANSI stdout
let
w = maybe 120 Term.width term
d | ansi = doc
| otherwise = plain doc
f | w <= 100 = 0.7
| w <= 120 = 0.6
| otherwise = 0.5
return $ displayS (renderSmart f w d) next
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