{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Pretty
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Pretty (

  -- ** Pretty printing
  PrettyAcc, ExtractAcc,
  prettyPreOpenAcc,
  prettyPreOpenAfun,
  prettyOpenExp,
  prettyOpenFun,

  -- ** Graphviz
  Graph,
  PrettyGraph(..), Detail(..),
  graphDelayedAcc, graphDelayedAfun,

) where

import Data.Array.Accelerate.AST                                    hiding ( Acc, Exp )
import Data.Array.Accelerate.Error
import Data.Array.Accelerate.Pretty.Graphviz
import Data.Array.Accelerate.Pretty.Print                           hiding ( Keyword(..) )
import Data.Array.Accelerate.Smart                                  ( Acc, Exp )
import Data.Array.Accelerate.Sugar.Array
import Data.Array.Accelerate.Sugar.Elt
import Data.Array.Accelerate.Trafo
import Data.Array.Accelerate.Trafo.Delayed

import Data.Maybe
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.String
import Data.Text.Prettyprint.Doc.Render.Terminal
import System.Environment
import System.IO
import System.IO.Unsafe
import qualified Data.Text.Lazy                                     as T
import qualified System.Console.ANSI                                as Term
import qualified System.Console.Terminal.Size                       as Term

#if ACCELERATE_DEBUG
import Control.DeepSeq
import Data.Array.Accelerate.Debug.Flags
import Data.Array.Accelerate.Debug.Stats
#endif


instance Arrays arrs => Show (Acc arrs) where
  show :: Acc arrs -> String
show = ShowS
withSimplStats ShowS -> (Acc arrs -> String) -> Acc arrs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DelayedAcc (ArraysR arrs) -> String
forall a. Show a => a -> String
show (DelayedAcc (ArraysR arrs) -> String)
-> (Acc arrs -> DelayedAcc (ArraysR arrs)) -> Acc arrs -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Acc arrs -> DelayedAcc (ArraysR arrs)
forall arrs. Acc arrs -> DelayedAcc (ArraysR arrs)
convertAcc

instance Afunction (Acc a -> f) => Show (Acc a -> f) where
  show :: (Acc a -> f) -> String
show = ShowS
withSimplStats ShowS -> ((Acc a -> f) -> String) -> (Acc a -> f) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DelayedAfun (ArraysR a -> ArraysFunctionR f) -> String
forall a. Show a => a -> String
show (DelayedAfun (ArraysR a -> ArraysFunctionR f) -> String)
-> ((Acc a -> f) -> DelayedAfun (ArraysR a -> ArraysFunctionR f))
-> (Acc a -> f)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Acc a -> f) -> DelayedAfun (ArraysR a -> ArraysFunctionR f)
forall f. Afunction f => f -> DelayedAfun (ArraysFunctionR f)
convertAfun

instance Elt e => Show (Exp e) where
  show :: Exp e -> String
show = ShowS
withSimplStats ShowS -> (Exp e -> String) -> Exp e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp () (EltR e) -> String
forall a. Show a => a -> String
show (Exp () (EltR e) -> String)
-> (Exp e -> Exp () (EltR e)) -> Exp e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp e -> Exp () (EltR e)
forall e. Exp e -> Exp () (EltR e)
convertExp

instance Function (Exp a -> f) => Show (Exp a -> f) where
  show :: (Exp a -> f) -> String
show = ShowS
withSimplStats ShowS -> ((Exp a -> f) -> String) -> (Exp a -> f) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fun () (EltR a -> EltFunctionR f) -> String
forall a. Show a => a -> String
show (Fun () (EltR a -> EltFunctionR f) -> String)
-> ((Exp a -> f) -> Fun () (EltR a -> EltFunctionR f))
-> (Exp a -> f)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp a -> f) -> Fun () (EltR a -> EltFunctionR f)
forall f. Function f => f -> Fun () (EltFunctionR f)
convertFun

-- instance Typeable a => Show (Seq a) where
--   show = withSimplStats . show . convertSeq


-- Note: [Show instances]
--
-- Explicitly enumerate Show instances for the Accelerate array AST types.
-- If we instead use a generic instance of the form:
--
--   instance Kit acc => Show (acc aenv a) where
--
-- This matches any type of kind (* -> * -> *), which can cause problems
-- interacting with other packages. See Issue #108.
--

instance PrettyEnv aenv => Show (OpenAcc aenv a) where
  show :: OpenAcc aenv a -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (OpenAcc aenv a -> Adoc) -> OpenAcc aenv a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Val aenv -> OpenAcc aenv a -> Adoc
PrettyAcc OpenAcc
prettyOpenAcc Context
context0 (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))

instance PrettyEnv aenv => Show (OpenAfun aenv f) where
  show :: OpenAfun aenv f -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (OpenAfun aenv f -> Adoc) -> OpenAfun aenv f -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyAcc OpenAcc -> Val aenv -> OpenAfun aenv f -> Adoc
forall (acc :: * -> * -> *) aenv f.
PrettyAcc acc -> Val aenv -> PreOpenAfun acc aenv f -> Adoc
prettyPreOpenAfun PrettyAcc OpenAcc
prettyOpenAcc (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))

instance PrettyEnv aenv => Show (DelayedOpenAcc aenv a) where
  show :: DelayedOpenAcc aenv a -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (DelayedOpenAcc aenv a -> Adoc)
-> DelayedOpenAcc aenv a
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PrettyAcc DelayedOpenAcc
Context -> Val aenv -> DelayedOpenAcc aenv a -> Adoc
prettyDelayedOpenAcc Context
context0 (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))

instance PrettyEnv aenv => Show (DelayedOpenAfun aenv f) where
  show :: DelayedOpenAfun aenv f -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (DelayedOpenAfun aenv f -> Adoc)
-> DelayedOpenAfun aenv f
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrettyAcc DelayedOpenAcc
-> Val aenv -> DelayedOpenAfun aenv f -> Adoc
forall (acc :: * -> * -> *) aenv f.
PrettyAcc acc -> Val aenv -> PreOpenAfun acc aenv f -> Adoc
prettyPreOpenAfun HasCallStack => PrettyAcc DelayedOpenAcc
PrettyAcc DelayedOpenAcc
prettyDelayedOpenAcc (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))

instance (PrettyEnv env, PrettyEnv aenv) => Show (OpenExp env aenv e) where
  show :: OpenExp env aenv e -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (OpenExp env aenv e -> Adoc) -> OpenExp env aenv e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Val env -> Val aenv -> OpenExp env aenv e -> Adoc
forall env aenv t.
Context -> Val env -> Val aenv -> OpenExp env aenv t -> Adoc
prettyOpenExp Context
context0 (Adoc -> Val env
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'x')) (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))

instance (PrettyEnv env, PrettyEnv aenv) => Show (OpenFun env aenv e) where
  show :: OpenFun env aenv e -> String
show = Adoc -> String
renderForTerminal (Adoc -> String)
-> (OpenFun env aenv e -> Adoc) -> OpenFun env aenv e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Val env -> Val aenv -> OpenFun env aenv e -> Adoc
forall env aenv f.
Val env -> Val aenv -> OpenFun env aenv f -> Adoc
prettyOpenFun (Adoc -> Val env
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'x')) (Adoc -> Val aenv
forall env. PrettyEnv env => Adoc -> Val env
prettyEnv (Char -> Adoc
forall a ann. Pretty a => a -> Doc ann
pretty Char
'a'))


-- Internals
-- ---------

renderForTerminal :: Adoc  -> String
renderForTerminal :: Adoc -> String
renderForTerminal = SimpleDocStream Keyword -> String
render (SimpleDocStream Keyword -> String)
-> (Adoc -> SimpleDocStream Keyword) -> Adoc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Adoc -> SimpleDocStream Keyword
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
terminalLayoutOptions
  where
    fancy :: Bool
fancy = Bool
terminalSupportsANSI Bool -> Bool -> Bool
&& Bool
terminalColourAllowed
    render :: SimpleDocStream Keyword -> String
render
      | Bool
fancy     = Text -> String
T.unpack (Text -> String)
-> (SimpleDocStream Keyword -> Text)
-> SimpleDocStream Keyword
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream AnsiStyle -> Text
renderLazy (SimpleDocStream AnsiStyle -> Text)
-> (SimpleDocStream Keyword -> SimpleDocStream AnsiStyle)
-> SimpleDocStream Keyword
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Keyword -> AnsiStyle)
-> SimpleDocStream Keyword -> SimpleDocStream AnsiStyle
forall ann ann'.
(ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
reAnnotateS Keyword -> AnsiStyle
ansiKeyword
      | Bool
otherwise = SimpleDocStream Keyword -> String
forall ann. SimpleDocStream ann -> String
renderString

{-# NOINLINE terminalColourAllowed #-}
terminalColourAllowed :: Bool
terminalColourAllowed :: Bool
terminalColourAllowed = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"

{-# NOINLINE terminalSupportsANSI #-}
terminalSupportsANSI :: Bool
terminalSupportsANSI :: Bool
terminalSupportsANSI = IO Bool -> Bool
forall a. IO a -> a
unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Handle -> IO Bool
Term.hSupportsANSI Handle
stdout

{-# NOINLINE terminalLayoutOptions #-}
terminalLayoutOptions :: LayoutOptions
terminalLayoutOptions :: LayoutOptions
terminalLayoutOptions
  = IO LayoutOptions -> LayoutOptions
forall a. IO a -> a
unsafePerformIO
  (IO LayoutOptions -> LayoutOptions)
-> IO LayoutOptions -> LayoutOptions
forall a b. (a -> b) -> a -> b
$ do Maybe (Window Int)
term <- IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Term.size
       LayoutOptions -> IO LayoutOptions
forall (m :: * -> *) a. Monad m => a -> m a
return (LayoutOptions -> IO LayoutOptions)
-> LayoutOptions -> IO LayoutOptions
forall a b. (a -> b) -> a -> b
$ case Maybe (Window Int)
term of
                  Maybe (Window Int)
Nothing -> LayoutOptions
defaultLayoutOptions
                  Just Window Int
t  -> LayoutOptions :: PageWidth -> LayoutOptions
LayoutOptions { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
w Int
120) Double
f }
                    where
                      w :: Int
w = Window Int -> Int
forall a. Window a -> a
Term.width Window Int
t
                      f :: Double
f | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
80   = Double
1
                        | Int
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
100  = Double
0.9
                        | Bool
otherwise = Double
0.8

prettyOpenAcc :: PrettyAcc OpenAcc
prettyOpenAcc :: Context -> Val aenv -> OpenAcc aenv a -> Adoc
prettyOpenAcc Context
context Val aenv
aenv (OpenAcc PreOpenAcc OpenAcc aenv a
pacc) =
  Context
-> PrettyAcc OpenAcc
-> ExtractAcc OpenAcc
-> Val aenv
-> PreOpenAcc OpenAcc aenv a
-> Adoc
forall (acc :: * -> * -> *) aenv arrs.
Context
-> PrettyAcc acc
-> ExtractAcc acc
-> Val aenv
-> PreOpenAcc acc aenv arrs
-> Adoc
prettyPreOpenAcc Context
context PrettyAcc OpenAcc
prettyOpenAcc ExtractAcc OpenAcc
extractOpenAcc Val aenv
aenv PreOpenAcc OpenAcc aenv a
pacc

extractOpenAcc :: OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a
extractOpenAcc :: OpenAcc aenv a -> PreOpenAcc OpenAcc aenv a
extractOpenAcc (OpenAcc PreOpenAcc OpenAcc aenv a
pacc) = PreOpenAcc OpenAcc aenv a
pacc


prettyDelayedOpenAcc :: HasCallStack => PrettyAcc DelayedOpenAcc
prettyDelayedOpenAcc :: PrettyAcc DelayedOpenAcc
prettyDelayedOpenAcc Context
context Val aenv
aenv (Manifest PreOpenAcc DelayedOpenAcc aenv a
pacc)
  = Context
-> PrettyAcc DelayedOpenAcc
-> ExtractAcc DelayedOpenAcc
-> Val aenv
-> PreOpenAcc DelayedOpenAcc aenv a
-> Adoc
forall (acc :: * -> * -> *) aenv arrs.
Context
-> PrettyAcc acc
-> ExtractAcc acc
-> Val aenv
-> PreOpenAcc acc aenv arrs
-> Adoc
prettyPreOpenAcc Context
context HasCallStack => PrettyAcc DelayedOpenAcc
PrettyAcc DelayedOpenAcc
prettyDelayedOpenAcc forall aenv a.
HasCallStack =>
DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a
ExtractAcc DelayedOpenAcc
extractDelayedOpenAcc Val aenv
aenv PreOpenAcc DelayedOpenAcc aenv a
pacc
prettyDelayedOpenAcc Context
_       Val aenv
aenv (Delayed ArrayR (Array sh e)
_ Exp aenv sh
sh Fun aenv (sh -> e)
f Fun aenv (Int -> e)
_)
  = Adoc -> Adoc
forall ann. Doc ann -> Doc ann
parens
  (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ Int -> Adoc -> Adoc
forall ann. Int -> Doc ann -> Doc ann
nest Int
shiftwidth
  (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ [Adoc] -> Adoc
forall ann. [Doc ann] -> Doc ann
sep [ Operator -> Adoc
delayed Operator
"delayed"
        ,          Context -> Val () -> Val aenv -> Exp aenv sh -> Adoc
forall env aenv t.
Context -> Val env -> Val aenv -> OpenExp env aenv t -> Adoc
prettyOpenExp Context
app Val ()
Empty Val aenv
aenv Exp aenv sh
sh
        , Adoc -> Adoc
forall ann. Doc ann -> Doc ann
parens (Adoc -> Adoc) -> Adoc -> Adoc
forall a b. (a -> b) -> a -> b
$ Val () -> Val aenv -> Fun aenv (sh -> e) -> Adoc
forall env aenv f.
Val env -> Val aenv -> OpenFun env aenv f -> Adoc
prettyOpenFun     Val ()
Empty Val aenv
aenv Fun aenv (sh -> e)
f
        ]

extractDelayedOpenAcc :: HasCallStack => DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a
extractDelayedOpenAcc :: DelayedOpenAcc aenv a -> PreOpenAcc DelayedOpenAcc aenv a
extractDelayedOpenAcc (Manifest PreOpenAcc DelayedOpenAcc aenv a
pacc) = PreOpenAcc DelayedOpenAcc aenv a
pacc
extractDelayedOpenAcc Delayed{}       = String -> PreOpenAcc DelayedOpenAcc aenv a
forall a. HasCallStack => String -> a
internalError String
"expected manifest array"


-- Debugging
-- ---------

-- Attach simplifier statistics to the tail of the given string. Since the
-- statistics rely on fully evaluating the expression this is difficult to do
-- generally (without an additional deepseq), but easy enough for our show
-- instances.
--
-- For now, we just reset the statistics at the beginning of a conversion, and
-- leave it to a backend to choose an appropriate moment to dump the summary.
--
withSimplStats :: String -> String
#ifdef ACCELERATE_DEBUG
withSimplStats x = unsafePerformIO $ do
  when dump_simpl_stats $ x `deepseq` dumpSimplStats
  return x
#else
withSimplStats :: ShowS
withSimplStats String
x = String
x
#endif