{-# 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
(Int -> GhciInput -> ShowS)
-> (GhciInput -> String)
-> ([GhciInput] -> ShowS)
-> Show GhciInput
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
(Int -> GhciOutput -> ShowS)
-> (GhciOutput -> String)
-> ([GhciOutput] -> ShowS)
-> Show GhciOutput
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
(Int -> GhciLine -> ShowS)
-> (GhciLine -> String) -> ([GhciLine] -> ShowS) -> Show GhciLine
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
_) <- ReaderT ProcessInfo IO ProcessInfo
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let script :: String
script = String
"putStrLn " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
magic String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
expr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"putStrLn " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
magic String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String
out <- IO String -> ReaderT ProcessInfo IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ReaderT ProcessInfo IO String)
-> IO String -> ReaderT ProcessInfo IO String
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 -> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (GhciOutput -> ReaderT ProcessInfo IO GhciOutput)
-> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
forall a b. (a -> b) -> a -> b
$ String -> GhciOutput
OK String
out'
    Just String
e
      | String
out' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
e -> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (GhciOutput -> ReaderT ProcessInfo IO GhciOutput)
-> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
forall a b. (a -> b) -> a -> b
$ String -> GhciOutput
OK String
out'
      | Bool
otherwise -> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (GhciOutput -> ReaderT ProcessInfo IO GhciOutput)
-> GhciOutput -> ReaderT ProcessInfo IO GhciOutput
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 :: 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
  String -> String -> (String -> IO a) -> IO a
forall a. String -> String -> (String -> IO a) -> IO a
withLiterateHashWorkaround String
f String
src ((String -> IO a) -> IO a) -> (String -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
f' -> do
    ProcessInfo
h     <- String -> IO ProcessInfo
runInteractiveCommand (String -> IO ProcessInfo) -> String -> IO ProcessInfo
forall a b. (a -> b) -> a -> b
$ String
"ghci -v0 -ignore-dot-ghci "
                                     String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if Bool
isLit then String
f' else String
"")
    a
res   <- ReaderT ProcessInfo IO a -> ProcessInfo -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ProcessInfo IO a
m ProcessInfo
h
    ProcessInfo -> IO ()
stopGhci ProcessInfo
h
    a -> IO a
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 :: String -> String -> (String -> IO a) -> IO a
withLiterateHashWorkaround String
f String
src String -> IO a
k = do
  let bad :: String -> Bool
bad = (String
"#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
      b :: Bool
b   = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
bad ([String] -> Bool) -> (String -> [String]) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ String
src
  case Bool
b of
    Bool
False -> String -> IO a
k String
f
    Bool
True  -> String -> String -> (String -> Handle -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> String -> (String -> Handle -> m a) -> m a
withTempFile String
"" (ShowS
takeFileName String
f) ((String -> Handle -> IO a) -> IO a)
-> (String -> Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \String
f' Handle
h -> do
               Handle -> String -> IO ()
hPutStr Handle
h ([String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
bad) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
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 = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
"> " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> Bool) -> (String -> [String]) -> String -> Bool
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
  () -> IO ()
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 = ([String] -> String) -> IO [String] -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
extract ShowS -> ([String] -> String) -> [String] -> String
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 = [String] -> IO [String]
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' | (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> ShowS -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> (String -> (String, String)) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> String -> (String, String)
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
magic)) String
l = Int
n
             | Bool
otherwise                                  = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
lString -> [String] -> [String]
forall 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)              =  (String -> Bool) -> String -> (String, String)
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (String -> String -> Bool
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                 =  ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
t
          prelength :: Int
prelength           =  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pre then Int
0 else String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pre Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
          -- pre contains the prefix of magic on the same line
          u' :: String
u'                  =  Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
magic Int -> Int -> Int
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
_)              =  (String -> Bool) -> String -> (String, String)
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breaks (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf (String
pre String -> ShowS
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 :: ([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               =  ([a] -> [a]) -> ([a], [a]) -> ([a], [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) (([a], [a]) -> ([a], [a])) -> ([a], [a]) -> ([a], [a])
forall a b. (a -> b) -> a -> b
$ ([a] -> Bool) -> [a] -> ([a], [a])
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 = String -> ReaderT ProcessInfo IO Pandoc -> IO Pandoc
forall a. String -> ReaderT ProcessInfo IO a -> IO a
withGhciProcess String
f (ReaderT ProcessInfo IO Pandoc -> IO Pandoc)
-> (Pandoc -> ReaderT ProcessInfo IO Pandoc) -> Pandoc -> IO Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> ReaderT ProcessInfo IO Block)
-> Pandoc -> ReaderT ProcessInfo IO Pandoc
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' = Text
-> (Attr -> Text -> ReaderT ProcessInfo IO Block)
-> (Block -> ReaderT ProcessInfo IO Block)
-> Block
-> ReaderT ProcessInfo IO Block
forall a. Text -> (Attr -> Text -> a) -> (Block -> a) -> Block -> a
onTag (String -> Text
T.pack String
"ghci") Attr -> Text -> ReaderT ProcessInfo IO Block
formatGhciBlock Block -> ReaderT ProcessInfo IO Block
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 <- (GhciInput -> GhciOutput -> GhciLine)
-> [GhciInput] -> [GhciOutput] -> [GhciLine]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith GhciInput -> GhciOutput -> GhciLine
GhciLine [GhciInput]
inputs ([GhciOutput] -> [GhciLine])
-> ReaderT ProcessInfo IO [GhciOutput]
-> ReaderT ProcessInfo IO [GhciLine]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GhciInput -> ReaderT ProcessInfo IO GhciOutput)
-> [GhciInput] -> ReaderT ProcessInfo IO [GhciOutput]
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
      Block -> ReaderT ProcessInfo IO Block
forall (m :: * -> *) a. Monad m => a -> m a
return (Block -> ReaderT ProcessInfo IO Block)
-> Block -> ReaderT ProcessInfo IO Block
forall a b. (a -> b) -> a -> b
$ Attr -> Text -> Block
CodeBlock Attr
attr (Text -> [Text] -> Text
T.intercalate (String -> Text
T.pack String
"\n") ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (GhciLine -> Text) -> [GhciLine] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Text
T.pack (String -> Text) -> (GhciLine -> String) -> GhciLine -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GhciLine -> String
formatGhciResult) [GhciLine]
results)

parseGhciInputs :: Text -> [GhciInput]
parseGhciInputs :: Text -> [GhciInput]
parseGhciInputs = ([String] -> GhciInput) -> [[String]] -> [GhciInput]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> GhciInput
mkGhciInput
                ([[String]] -> [GhciInput])
-> (Text -> [[String]]) -> Text -> [GhciInput]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter String -> [String] -> [[String]]
forall a. Splitter a -> [a] -> [[a]]
split
                  ( Splitter String -> Splitter String
forall a. Splitter a -> Splitter a
dropInitBlank
                  (Splitter String -> Splitter String)
-> (Splitter String -> Splitter String)
-> Splitter String
-> Splitter String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter String -> Splitter String
forall a. Splitter a -> Splitter a
dropFinalBlank
                  (Splitter String -> Splitter String)
-> (Splitter String -> Splitter String)
-> Splitter String
-> Splitter String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Splitter String -> Splitter String
forall a. Splitter a -> Splitter a
keepDelimsL
                  (Splitter String -> Splitter String)
-> Splitter String -> Splitter String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Splitter String
forall a. (a -> Bool) -> Splitter a
whenElt (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
" " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                  )
                ([String] -> [[String]])
-> (Text -> [String]) -> Text -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
                (String -> [String]) -> (Text -> String) -> Text -> [String]
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
"" Maybe String
forall a. Maybe a
Nothing
mkGhciInput [String
i]      = String -> Maybe String -> GhciInput
GhciInput String
i Maybe String
forall a. Maybe a
Nothing
mkGhciInput (String
i:[String]
expr) = String -> Maybe String -> GhciInput
GhciInput String
i (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ([String] -> String) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines' ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
unindent ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String]
expr)

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

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

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

indent :: Int -> String -> String
indent :: Int -> ShowS
indent Int
n = [String] -> String
unlines' ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' 'String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
color String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
";\">" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
txt String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"</span>"
coloredBlock :: String -> ShowS
coloredBlock String
color = [String] -> String
unlines' ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
colored String
color) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
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))
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
output
    = String
ghciPrompt String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input
  | Bool
otherwise
    = String
ghciPrompt String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (ShowS
esc String
output) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
formatGhciResult (GhciLine (GhciInput String
input Maybe String
_) (Unexpected String
output String
expr))
  = String
ghciPrompt String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
esc String
input String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (String -> ShowS
coloredBlock String
"red" (ShowS
esc String
output))
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
indent Int
2 (String -> ShowS
coloredBlock String
"blue" (ShowS
esc String
expr))
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"

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

esc :: String -> String
esc :: ShowS
esc = (Char -> String) -> ShowS
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]