{-# LANGUAGE PatternGuards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.BlogLiterately.Ghci
-- Copyright   :  (c) 1997-2005 Ralf Hinze <ralf.hinze@comlab.ox.ac.uk>, Andres Loeh <lhs2tex@andres-loeh.de>, 2012 Brent Yorgey
-- License     :  GPL (see LICENSE)
-- Maintainer  :  Brent Yorgey <byorgey@gmail.com>
--
-- Format specially marked blocks as interactive ghci sessions.  Uses
-- some ugly but effective code for interacting with an external ghci
-- process taken from lhs2TeX.
--
-----------------------------------------------------------------------------

module Text.BlogLiterately.Ghci
    (
    -- * Running ghci
      ProcessInfo
    , ghciEval
    , withGhciProcess
    , isLiterate
    , stopGhci

    -- * Extracting output
    -- $extract

    , magic
    , extract'
    , extract
    , breaks

    -- * Formatting
    , formatInlineGhci

    ) where

import           Control.Arrow              (first)
import           Control.Monad.IO.Class     (liftIO)
import           Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import           Data.Char                  (isSpace)
import           Data.Functor               ((<$>))
import           Data.List                  (intercalate, isPrefixOf)
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import           System.FilePath            (takeFileName)
import           System.IO
import qualified System.IO.Strict           as Strict
import           System.IO.Temp
import           System.Process             (ProcessHandle,
                                             runInteractiveCommand,
                                             waitForProcess)

import           Data.List.Split
import           Text.Pandoc                (Block (CodeBlock), Pandoc,
                                             bottomUpM)

import           Text.BlogLiterately.Block  (onTag)

-- | Information about a running process: stdin, stdout, stderr, and a
--   handle.
type ProcessInfo = (Handle, Handle, Handle, ProcessHandle)

-- | An input to ghci consists of an expression/command, possibly
--   paired with an expected output.
data GhciInput  = GhciInput String (Maybe String)
  deriving Int -> GhciInput -> ShowS
[GhciInput] -> ShowS
GhciInput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciInput] -> ShowS
$cshowList :: [GhciInput] -> ShowS
show :: GhciInput -> String
$cshow :: GhciInput -> String
showsPrec :: Int -> GhciInput -> ShowS
$cshowsPrec :: Int -> GhciInput -> ShowS
Show

-- | An output from ghci is either a correct output, or an incorrect
--   (unexpected) output paired with the expected output.
data GhciOutput = OK String
                | Unexpected String String
  deriving Int -> GhciOutput -> ShowS
[GhciOutput] -> ShowS
GhciOutput -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciOutput] -> ShowS
$cshowList :: [GhciOutput] -> ShowS
show :: GhciOutput -> String
$cshow :: GhciOutput -> String
showsPrec :: Int -> GhciOutput -> ShowS
$cshowsPrec :: Int -> GhciOutput -> ShowS
Show

-- | A @GhciLine@ is a @GhciInput@ paired with its corresponding @GhciOutput@.
data GhciLine = GhciLine GhciInput GhciOutput
  deriving Int -> GhciLine -> ShowS
[GhciLine] -> ShowS
GhciLine -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhciLine] -> ShowS
$cshowList :: [GhciLine] -> ShowS
show :: GhciLine -> String
$cshow :: GhciLine -> String
showsPrec :: Int -> GhciLine -> ShowS
$cshowsPrec :: Int -> GhciLine -> ShowS
Show

-- | Evaluate an expression using an external @ghci@ process.
ghciEval :: GhciInput -> ReaderT ProcessInfo IO GhciOutput
ghciEval :: GhciInput -> ReaderT ProcessInfo IO GhciOutput
ghciEval (GhciInput String
expr Maybe String
expected) =  do
  (Handle
pin, Handle
pout, Handle
_, ProcessHandle
_) <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let script :: String
script = String
"putStrLn " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
magic forall a. [a] -> [a] -> [a]
++ String
"\n"
                 forall a. [a] -> [a] -> [a]
++ String
expr forall a. [a] -> [a] -> [a]
++ String
"\n"
                 forall a. [a] -> [a] -> [a]
++ String
"putStrLn " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
magic forall a. [a] -> [a] -> [a]
++ String
"\n"
  String
out <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Handle -> String -> IO ()
hPutStr Handle
pin String
script
    Handle -> IO ()
hFlush Handle
pin
    Handle -> IO String
extract' Handle
pout
  let out' :: String
out' = ShowS
strip String
out
  case Maybe String
expected of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> GhciOutput
OK String
out'
    Just String
e
      | String
out' forall a. Eq a => a -> a -> Bool
== String
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> GhciOutput
OK String
out'
      | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> String -> GhciOutput
Unexpected String
out' String
e

-- | Start an external ghci process, run a computation with access to
--   it, and finally stop the process.
withGhciProcess :: FilePath -> ReaderT ProcessInfo IO a -> IO a
withGhciProcess :: forall a. String -> ReaderT ProcessInfo IO a -> IO a
withGhciProcess String
f ReaderT ProcessInfo IO a
m = do
  String
src <- String -> IO String
Strict.readFile String
f
  let isLit :: Bool
isLit = String -> Bool
isLiterate String
src
  forall a. String -> String -> (String -> IO a) -> IO a
withLiterateHashWorkaround String
f String
src forall a b. (a -> b) -> a -> b
$ \String
f' -> do
    ProcessInfo
h     <- String -> IO ProcessInfo
runInteractiveCommand forall a b. (a -> b) -> a -> b
$ String
"ghci -v0 -ignore-dot-ghci "
                                     forall a. [a] -> [a] -> [a]
++ (if Bool
isLit then String
f' else String
"")
    a
res   <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ProcessInfo IO a
m ProcessInfo
h
    ProcessInfo -> IO ()
stopGhci ProcessInfo
h
    forall (m :: * -> *) a. Monad m => a -> m a
return a
res

-- | Workaround for https://ghc.haskell.org/trac/ghc/ticket/4836; see
--   also https://github.com/byorgey/BlogLiterately/issues/11.  If the
--   file contains any lines beginning with #, create a temporary file
--   with those lines filtered out, and pass that instead.[
withLiterateHashWorkaround :: FilePath -> String -> (FilePath -> IO a) -> IO a
withLiterateHashWorkaround :: forall a. String -> String -> (String -> IO a) -> IO a
withLiterateHashWorkaround String
f String
src String -> IO a
k = do
  let bad :: String -> Bool
bad = (String
"#" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
      b :: Bool
b   = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
bad forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
src
  case Bool
b of
    Bool
False -> String -> IO a
k String
f
    Bool
True  -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile String
"" (ShowS
takeFileName String
f) forall a b. (a -> b) -> a -> b
$ \String
f' Handle
h -> do
               Handle -> String -> IO ()
hPutStr Handle
h ([String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
bad) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
src)
               Handle -> IO ()
hClose Handle
h
               String -> IO a
k String
f'

-- | Poor man's check to see whether we have a literate Haskell file.
isLiterate :: String -> Bool
isLiterate :: String -> Bool
isLiterate = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
"> " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- | Stop a ghci process by passing it @:q@ and waiting for it to exit.
stopGhci :: ProcessInfo -> IO ()
stopGhci :: ProcessInfo -> IO ()
stopGhci (Handle
pin,Handle
_,Handle
_,ProcessHandle
pid) = do
  Handle -> String -> IO ()
hPutStrLn Handle
pin String
":q"
  Handle -> IO ()
hFlush Handle
pin
  ExitCode
_ <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pid   -- ignore exit code
  forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- $extract
-- To extract the answer from @ghci@'s output we use a simple technique
-- which should work in most cases: we print the string @magic@ before
-- and after the expression we are interested in. We assume that
-- everything that appears before the first occurrence of @magic@ on the
-- same line is the prompt, and everything between the first @magic@ and
-- the second @magic@ plus prompt is the result we look for.

-- | There is nothing magic about the magic string.
magic :: String
magic :: String
magic =  String
"!@#$^&*"

extract' :: Handle -> IO String
extract' :: Handle -> IO String
extract' Handle
h = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
extract forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines) (Int -> IO [String]
readMagic Int
2)
  where
    readMagic :: Int -> IO [String]
    readMagic :: Int -> IO [String]
readMagic Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return []
    readMagic Int
n = do
      String
l <- Handle -> IO String
hGetLine Handle
h
      let n' :: Int
n' | (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
magic)) String
l = Int
n
             | Bool
otherwise                                  = Int
n forall a. Num a => a -> a -> a
- Int
1
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
lforall a. a -> [a] -> [a]
:) (Int -> IO [String]
readMagic Int
n')

extract                       :: String -> String
extract :: ShowS
extract String
s                     =  String
v
    where (String
t, String
u)              =  forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
magic) String
s
          -- t contains everything up to magic, u starts with magic
          -- |u'                      =  tail (dropWhile (/='\n') u)|
          pre :: String
pre                 =  forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/=Char
'\n') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ String
t
          prelength :: Int
prelength           =  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pre then Int
0 else forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre forall a. Num a => a -> a -> a
+ Int
1
          -- pre contains the prefix of magic on the same line
          u' :: String
u'                  =  forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
magic forall a. Num a => a -> a -> a
+ Int
prelength) String
u
          -- we drop the magic string, plus the newline, plus the prefix
          (String
v, String
_)              =  forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String
pre forall a. [a] -> [a] -> [a]
++ String
magic)) String
u'
          -- we look for the next occurrence of prefix plus magic

breaks                        :: ([a] -> Bool) -> [a] -> ([a], [a])
breaks :: forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks [a] -> Bool
_ []                   =  ([], [])
breaks [a] -> Bool
p as :: [a]
as@(a
a : [a]
as')
    | [a] -> Bool
p [a]
as                    =  ([], [a]
as)
    | Bool
otherwise               =  forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a
aforall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks [a] -> Bool
p [a]
as'

-- | Given the path to the @.lhs@ source and its representation as a
--   @Pandoc@ document, @formatInlineGhci@ finds any @[ghci]@ blocks
--   in it, runs them through @ghci@, and formats the results as an
--   interactive @ghci@ session.
--
--   Lines beginning in the first column of the block are interpreted
--   as inputs.  Lines indented by one or more space are interpreted
--   as /expected outputs/.  Consecutive indented lines are
--   interpreted as one multi-line expected output, with a number of
--   spaces removed from the beginning of each line equal to the
--   number of spaces at the start of the first indented line.
--
--   If the output for a given input is the same as the expected
--   output (or if no expected output is given), the result is typeset
--   normally.  If the actual and expected outputs differ, the actual
--   output is typeset first in red, then the expected output in blue.
formatInlineGhci :: FilePath -> Pandoc -> IO Pandoc
formatInlineGhci :: String -> Pandoc -> IO Pandoc
formatInlineGhci String
f = forall a. String -> ReaderT ProcessInfo IO a -> IO a
withGhciProcess String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b.
(Monad m, Data a, Data b) =>
(a -> m a) -> b -> m b
bottomUpM Block -> ReaderT ProcessInfo IO Block
formatInlineGhci'
  where
    formatInlineGhci' :: Block -> ReaderT ProcessInfo IO Block
    formatInlineGhci' :: Block -> ReaderT ProcessInfo IO Block
formatInlineGhci' = forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag (String -> Text
T.pack String
"ghci") Attr -> Text -> ReaderT ProcessInfo IO Block
formatGhciBlock forall (m :: * -> *) a. Monad m => a -> m a
return

    formatGhciBlock :: Attr -> Text -> ReaderT ProcessInfo IO Block
formatGhciBlock Attr
attr Text
src = do
      let inputs :: [GhciInput]
inputs = Text -> [GhciInput]
parseGhciInputs Text
src
      [GhciLine]
results <- forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith GhciInput -> GhciOutput -> GhciLine
GhciLine [GhciInput]
inputs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GhciInput -> ReaderT ProcessInfo IO GhciOutput
ghciEval [GhciInput]
inputs
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Block
CodeBlock Attr
attr (Text -> [Text] -> Text
T.intercalate (String -> Text
T.pack String
"\n") forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciLine -> String
formatGhciResult) [GhciLine]
results)

parseGhciInputs :: Text -> [GhciInput]
parseGhciInputs :: Text -> [GhciInput]
parseGhciInputs = forall a b. (a -> b) -> [a] -> [b]
map [String] -> GhciInput
mkGhciInput
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> [a] -> [[a]]
split
                  ( forall a. Splitter a -> Splitter a
dropInitBlank
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
dropFinalBlank
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> Splitter a
keepDelimsL
                  forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> Splitter a
whenElt (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                  )
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

mkGhciInput :: [String] -> GhciInput
mkGhciInput :: [String] -> GhciInput
mkGhciInput []       = String -> Maybe String -> GhciInput
GhciInput String
"" forall a. Maybe a
Nothing
mkGhciInput [String
i]      = String -> Maybe String -> GhciInput
GhciInput String
i forall a. Maybe a
Nothing
mkGhciInput (String
i:[String]
expr) = String -> Maybe String -> GhciInput
GhciInput String
i (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
unindent forall a b. (a -> b) -> a -> b
$ [String]
expr)

unlines' :: [String] -> String
unlines' :: [String] -> String
unlines' = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"

strip :: String -> String
strip :: ShowS
strip = ShowS
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
f
  where f :: ShowS
f = forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse

unindent :: [String] -> [String]
unindent :: [String] -> [String]
unindent [] = []
unindent (String
x:[String]
xs) = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop Int
indentAmt) (String
xforall a. a -> [a] -> [a]
:[String]
xs)
  where indentAmt :: Int
indentAmt = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') forall a b. (a -> b) -> a -> b
$ String
x

indent :: Int -> String -> String
indent :: Int -> ShowS
indent Int
n = [String] -> String
unlines' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> a -> [a]
replicate Int
n Char
' 'forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

colored, coloredBlock :: String -> String -> String
colored :: String -> ShowS
colored String
color String
txt = String
"<span style=\"color: " forall a. [a] -> [a] -> [a]
++ String
color forall a. [a] -> [a] -> [a]
++ String
";\">" forall a. [a] -> [a] -> [a]
++ String
txt forall a. [a] -> [a] -> [a]
++ String
"</span>"
coloredBlock :: String -> ShowS
coloredBlock String
color = [String] -> String
unlines' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
colored String
color) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

ghciPrompt :: String
ghciPrompt :: String
ghciPrompt = String -> ShowS
colored String
"gray" String
"ghci&gt; "

formatGhciResult :: GhciLine -> String
formatGhciResult :: GhciLine -> String
formatGhciResult (GhciLine (GhciInput String
input Maybe String
_) (OK String
output))
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
output
    = String
ghciPrompt forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input
  | Bool
otherwise
    = String
ghciPrompt forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (ShowS
esc String
output) forall a. [a] -> [a] -> [a]
++ String
"\n"
formatGhciResult (GhciLine (GhciInput String
input Maybe String
_) (Unexpected String
output String
expr))
  = String
ghciPrompt forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (String -> ShowS
coloredBlock String
"red" (ShowS
esc String
output))
                            forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (String -> ShowS
coloredBlock String
"blue" (ShowS
esc String
expr))
                            forall a. [a] -> [a] -> [a]
++ String
"\n"

    -- XXX the styles above should be configurable...

esc :: String -> String
esc :: ShowS
esc = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escapeOne
  where
    escapeOne :: Char -> String
escapeOne Char
'<' = String
"&lt;"
    escapeOne Char
'>' = String
"&gt;"
    escapeOne  Char
c  = [Char
c]