{-# LANGUAGE PatternGuards #-}
module Text.BlogLiterately.Ghci
(
ProcessInfo
, ghciEval
, withGhciProcess
, isLiterate
, stopGhci
, magic
, extract'
, extract
, breaks
, 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)
type ProcessInfo = (Handle, Handle, Handle, ProcessHandle)
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
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
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
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
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
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'
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
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
forall (m :: * -> *) a. Monad m => a -> m a
return ()
magic :: String
magic :: String
magic = String
"!@#$^&*"
extract' :: Handle -> IO String
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
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
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
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
(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'
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'
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> "
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"
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
"<"
escapeOne Char
'>' = String
">"
escapeOne Char
c = [Char
c]