{-# 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.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 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 e | out' == e -> return $ OK out' | otherwise -> return $ Unexpected out' 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 f m = do src <- Strict.readFile f let isLit = isLiterate src withLiterateHashWorkaround f src $ \f' -> do h <- runInteractiveCommand $ "ghci -v0 -ignore-dot-ghci " ++ (if isLit then f' else "") res <- runReaderT m h stopGhci h return 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 f src k = do let bad = ("#" `isPrefixOf`) b = any bad . lines $ src case b of False -> k f True -> withTempFile "" (takeFileName f) $ \f' h -> do hPutStr h (unlines . filter (not . bad) . lines $ src) hClose h k f' -- | Poor man's check to see whether we have a literate Haskell file. isLiterate :: String -> Bool isLiterate = any ("> " `isPrefixOf`) . lines -- | 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 _ [] = ([], []) 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 [] = 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 = "" ++ txt ++ "" 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" -- XXX the styles above should be configurable... esc :: String -> String esc = concatMap escapeOne where escapeOne '<' = "<" escapeOne '>' = ">" escapeOne c = [c]