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 System.IO
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 Show
data GhciOutput = OK String
| Unexpected String String
deriving Show
data GhciLine = GhciLine GhciInput GhciOutput
deriving Show
ghciEval :: GhciInput -> ReaderT ProcessInfo IO GhciOutput
ghciEval (GhciInput expr expected) = do
(pin, pout, _, _) <- ask
let script = "putStrLn " ++ show magic ++ "\n"
++ expr ++ "\n"
++ "putStrLn " ++ show magic ++ "\n"
out <- liftIO $ do
hPutStr pin script
hFlush pin
extract' pout
let out' = strip out
case expected of
Nothing -> return $ OK out'
Just e
| out' == e -> return $ OK out'
| otherwise -> return $ Unexpected out' e
withGhciProcess :: FilePath -> ReaderT ProcessInfo IO a -> IO a
withGhciProcess f m = do
isLit <- isLiterate f
h <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci "
++ (if isLit then f else "")
res <- runReaderT m h
stopGhci h
return res
isLiterate :: FilePath -> IO Bool
isLiterate f = (any ("> " `isPrefixOf`) . lines) <$> readFile f
stopGhci :: ProcessInfo -> IO ()
stopGhci (pin,_,_,pid) = do
hPutStrLn pin ":q"
hFlush pin
_ <- waitForProcess pid
return ()
magic :: String
magic = "!@#$^&*"
extract' :: Handle -> IO String
extract' h = fmap (extract . unlines) (readMagic 2)
where
readMagic :: Int -> IO [String]
readMagic 0 = return []
readMagic n = do
l <- hGetLine h
let n' | (null . snd . breaks (isPrefixOf magic)) l = n
| otherwise = n 1
fmap (l:) (readMagic n')
extract :: String -> String
extract s = v
where (t, u) = breaks (isPrefixOf magic) s
pre = reverse . takeWhile (/='\n') . reverse $ t
prelength = if null pre then 0 else length pre + 1
u' = drop (length magic + prelength) u
(v, _) = breaks (isPrefixOf (pre ++ magic)) u'
breaks :: ([a] -> Bool) -> [a] -> ([a], [a])
breaks _ [] = ([], [])
breaks p as@(a : as')
| p as = ([], as)
| otherwise = first (a:) $ breaks p as'
formatInlineGhci :: FilePath -> Pandoc -> IO Pandoc
formatInlineGhci f = withGhciProcess f . bottomUpM formatInlineGhci'
where
formatInlineGhci' :: Block -> ReaderT ProcessInfo IO Block
formatInlineGhci' = onTag "ghci" formatGhciBlock return
formatGhciBlock attr src = do
let inputs = parseGhciInputs src
results <- zipWith GhciLine inputs <$> mapM ghciEval inputs
return $ CodeBlock attr (intercalate "\n" $ map formatGhciResult results)
parseGhciInputs :: String -> [GhciInput]
parseGhciInputs = map mkGhciInput
. split
( dropInitBlank
. dropFinalBlank
. keepDelimsL
$ whenElt (not . (" " `isPrefixOf`))
)
. lines
mkGhciInput :: [String] -> GhciInput
mkGhciInput [] = GhciInput "" Nothing
mkGhciInput [i] = GhciInput i Nothing
mkGhciInput (i:expr) = GhciInput i (Just . unlines' . unindent $ expr)
unlines' :: [String] -> String
unlines' = intercalate "\n"
strip :: String -> String
strip = f . f
where f = dropWhile isSpace . reverse
unindent :: [String] -> [String]
unindent [] = []
unindent (x:xs) = map (drop indentAmt) (x:xs)
where indentAmt = length . takeWhile (==' ') $ x
indent :: Int -> String -> String
indent n = unlines' . map (replicate n ' '++) . lines
colored, coloredBlock :: String -> String -> String
colored color txt = "<span style=\"color: " ++ color ++ ";\">" ++ txt ++ "</span>"
coloredBlock color = unlines' . map (colored color) . lines
ghciPrompt :: String
ghciPrompt = colored "gray" "ghci> "
formatGhciResult :: GhciLine -> String
formatGhciResult (GhciLine (GhciInput input _) (OK output))
| all isSpace output
= ghciPrompt ++ esc input
| otherwise
= ghciPrompt ++ esc input ++ "\n" ++ indent 2 (esc output) ++ "\n"
formatGhciResult (GhciLine (GhciInput input _) (Unexpected output expr))
= ghciPrompt ++ esc input ++ "\n" ++ indent 2 (coloredBlock "red" (esc output))
++ "\n" ++ indent 2 (coloredBlock "blue" (esc expr))
++ "\n"
esc :: String -> String
esc = concatMap escapeOne
where
escapeOne '<' = "<"
escapeOne '>' = ">"
escapeOne c = [c]