{-# LANGUAGE PatternGuards #-} ----------------------------------------------------------------------------- -- | -- Module : Text.BlogLiterately.Ghci -- Copyright : (c) 1997-2005 Ralf Hinze , Andres Loeh , 2012 Brent Yorgey -- License : GPL (see LICENSE) -- Maintainer : Brent Yorgey -- -- 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 System.IO 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 { expr :: String, expected :: Maybe String } deriving 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 Show -- | A @GhciLine@ is a @GhciInput@ paired with its corresponding @GhciOutput@. data GhciLine = GhciLine GhciInput GhciOutput deriving Show -- | Evaluate an expression using an external @ghci@ process. 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 exp | out' == exp -> return $ OK out' | otherwise -> return $ Unexpected out' exp -- | 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 f m = do isLit <- isLiterate f pi <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci " ++ (if isLit then f else "") res <- runReaderT m pi stopGhci pi return res -- | Poor man's check to see whether we have a literate Haskell file. isLiterate :: FilePath -> IO Bool isLiterate f = (any ("> " `isPrefixOf`) . lines) <$> readFile f -- | Stop a ghci process by passing it @:q@ and waiting for it to exit. stopGhci :: ProcessInfo -> IO () stopGhci (pin,_,_,pid) = do hPutStrLn pin ":q" hFlush pin _ <- waitForProcess pid -- ignore exit code 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 = "!@#$^&*" 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 -- t contains everything up to magic, u starts with magic -- |u' = tail (dropWhile (/='\n') u)| pre = reverse . takeWhile (/='\n') . reverse $ t prelength = if null pre then 0 else length pre + 1 -- pre contains the prefix of magic on the same line u' = drop (length magic + prelength) u -- we drop the magic string, plus the newline, plus the prefix (v, _) = breaks (isPrefixOf (pre ++ magic)) u' -- we look for the next occurrence of prefix plus magic breaks :: ([a] -> Bool) -> [a] -> ([a], [a]) breaks p [] = ([], []) breaks p as@(a : as') | p as = ([], as) | otherwise = first (a:) $ breaks p 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 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 [i] = GhciInput i Nothing mkGhciInput (i:exp) = GhciInput i (Just . unlines' . unindent $ exp) unlines' :: [String] -> String unlines' = intercalate "\n" strip :: String -> String strip = f . f where f = dropWhile isSpace . reverse unindent :: [String] -> [String] 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 color txt = "" ++ txt ++ "" coloredBlock color = unlines' . map (colored color) . lines ghciPrompt = colored "gray" "ghci> " 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 exp)) = ghciPrompt ++ esc input ++ "\n" ++ indent 2 (coloredBlock "red" (esc output)) ++ "\n" ++ indent 2 (coloredBlock "blue" (esc exp)) ++ "\n" -- XXX the styles above should be configurable... esc :: String -> String esc = concatMap escapeOne where escapeOne '<' = "<" escapeOne '>' = ">" escapeOne c = [c]