Aelve Codesearch

grep over package repositories
BlogLiterately-0.8.6.3
src/Text/BlogLiterately/Ghci.hs
{-# 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           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 = "<span style=\"color: " ++ color ++ ";\">" ++ txt ++ "</span>"
coloredBlock color = unlines' . map (colored color) . lines

ghciPrompt :: String
ghciPrompt = colored "gray" "ghci&gt; "

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 '<' = "&lt;"
    escapeOne '>' = "&gt;"
    escapeOne  c  = [c]