Add code and output style options

app/Main.hs

@@ -1,7 +1,6 @@
 module Main where
 
 import Control.Monad (unless, when)
-import Data.List (isPrefixOf)
 import Data.Maybe (isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as TIO
@@ -25,20 +24,8 @@ import ScriptHs.Version (
     tagStyleFor,
     tagVersion,
  )
-
--- | Parsed command-line options.
-data Args = Args
-    { argScript :: Maybe FilePath
-    , argOutput :: Maybe FilePath
-    , argPackages :: [FilePath]
-    , argNoLocalProject :: Bool
-    , argInPlace :: Bool
-    , argHelp :: Bool
-    , argVersion :: Bool
-    }
-
-emptyArgs :: Args
-emptyArgs = Args Nothing Nothing [] False False False False
+import ScriptHs.CLI.Types
+import ScriptHs.Markdown
 
 main :: IO ()
 main = do
@@ -61,7 +48,7 @@ main = do
                                 { roPackages = pkgs
                                 , roEnclosingProject = not (argNoLocalProject a)
                                 }
-                    dispatch opts path outPath
+                    dispatch (argOutputStyle a) (argCodeStyle a) opts path outPath
 
 {- | Resolve the output destination, honouring @--in-place@: write back over the
 notebook itself. In-place is only meaningful for notebooks (the @.ghci@\/@.hs@
@@ -80,43 +67,16 @@ resolveOutput a path
 isNotebook :: FilePath -> Bool
 isNotebook path = takeExtension path `elem` [".md", ".markdown"]
 
-dispatch :: RunOptions -> FilePath -> Maybe FilePath -> IO ()
-dispatch opts path outputPath =
+dispatch :: OutputStyle ->  CodeStyle -> RunOptions -> FilePath -> Maybe FilePath -> IO ()
+dispatch outputStyle codeStyle opts path outputPath =
     case takeExtension path of
-        ".md" -> runNotebook opts path outputPath
-        ".markdown" -> runNotebook opts path outputPath
+        ".md" -> runNotebook outputStyle codeStyle opts path outputPath
+        ".markdown" -> runNotebook outputStyle codeStyle opts path outputPath
         _ -> do
             contents <- TIO.readFile path
             let sf = parseScript contents
             runScript opts path sf
 
-{- | Parse args: @[-o FILE | --output=FILE] [-i | --in-place] [--package DIR |
--p DIR | --package=DIR]... [--no-local-project] [-h | --help] <script>@. The
-script is the sole non-flag argument.
--}
-parseArgs :: [String] -> Either String Args
-parseArgs = go emptyArgs
-  where
-    go a [] = Right a
-    go a ("-o" : f : rest) = go a{argOutput = Just f} rest
-    go _ ["-o"] = Left "-o requires a filename"
-    go a (tok : rest)
-        | tok == "-p" || tok == "--package" = case rest of
-            (d : rest') -> go a{argPackages = argPackages a ++ [d]} rest'
-            [] -> Left (tok ++ " requires a directory")
-        | Just f <- stripFlag "--output=" tok = go a{argOutput = Just f} rest
-        | Just d <- stripFlag "--package=" tok =
-            go a{argPackages = argPackages a ++ [d]} rest
-        | tok == "--no-local-project" = go a{argNoLocalProject = True} rest
-        | tok == "-i" || tok == "--in-place" = go a{argInPlace = True} rest
-        | tok == "-h" || tok == "--help" = go a{argHelp = True} rest
-        | tok == "-v" || tok == "--version" = go a{argVersion = True} rest
-        | "-" `isPrefixOf` tok = Left ("unknown flag: " ++ tok)
-        | otherwise = case argScript a of
-            Nothing -> go a{argScript = Just tok} rest
-            Just _ -> Left ("unexpected extra argument: " ++ tok)
-    stripFlag p s = if p `isPrefixOf` s then Just (drop (length p) s) else Nothing
-
 -- | Resolve a @--package@ dir to absolute, requiring a package root (a @.cabal@).
 resolvePackageDir :: FilePath -> IO FilePath
 resolvePackageDir dir = do
@@ -171,6 +131,8 @@ helpText prog =
         , "  --no-local-project        do not auto-include the enclosing cabal project"
         , "  -h, --help                show this help"
         , "  -v, --version             show the scripths version"
+        , "  --code-style=display|remove    control how code fences should appear after processing (default: display)"
+        , "  --output-style=quoted|raw      control how evaluted code is outputed (default: quoted)"
         , ""
         , "Files may carry a first-line version tag recording the scripths that wrote"
         , "them ('-- scripths: X' in scripts, '<!-- scripths: X -->' in notebooks); a"

scripths.cabal

@@ -23,11 +23,12 @@ common warnings
 
 library
     import:           warnings
-    exposed-modules:  ScriptHs.Parser,
+    exposed-modules:  ScriptHs.CLI.Types,
                       ScriptHs.Compiled,
-                      ScriptHs.Render,
                       ScriptHs.Markdown,
                       ScriptHs.Notebook,
+                      ScriptHs.Parser,
+                      ScriptHs.Render,
                       ScriptHs.Repl,
                       ScriptHs.Run,
                       ScriptHs.Version

src/ScriptHs/CLI/Types.hs

@@ -0,0 +1,72 @@
+module ScriptHs.CLI.Types (
+    Args (..),
+    emptyArgs,
+    parseArgs,
+) where
+
+import Data.List (isPrefixOf)
+import ScriptHs.Markdown
+
+-- | Parsed command-line options.
+data Args = Args
+    { argScript :: Maybe FilePath
+    , argOutput :: Maybe FilePath
+    , argPackages :: [FilePath]
+    , argNoLocalProject :: Bool
+    , argInPlace :: Bool
+    , argHelp :: Bool
+    , argVersion :: Bool
+    , argCodeStyle :: CodeStyle
+    , argOutputStyle :: OutputStyle
+    }
+
+emptyArgs :: Args
+emptyArgs =
+    Args
+        { argScript = Nothing
+        , argOutput = Nothing
+        , argPackages = []
+        , argNoLocalProject = False
+        , argInPlace = False
+        , argHelp = False
+        , argVersion = False
+        , argCodeStyle = DisplayCode
+        , argOutputStyle = OutputQuoted
+        }
+
+{- | Parse args: @[-o FILE | --output=FILE] [-i | --in-place] [--package DIR |
+-p DIR | --package=DIR]... [--no-local-project] [-h | --help] <script>@. The
+script is the sole non-flag argument.
+-}
+parseArgs :: [String] -> Either String Args
+parseArgs = go emptyArgs
+  where
+    go a [] = Right a
+    go a ("-o" : f : rest) = go a{argOutput = Just f} rest
+    go _ ["-o"] = Left "-o requires a filename"
+    go a (tok : rest)
+        | tok == "-p" || tok == "--package" = case rest of
+            (d : rest') -> go a{argPackages = argPackages a ++ [d]} rest'
+            [] -> Left (tok ++ " requires a directory")
+        | Just f <- stripFlag "--output=" tok = go a{argOutput = Just f} rest
+        | Just d <- stripFlag "--package=" tok =
+            go a{argPackages = argPackages a ++ [d]} rest
+        | tok == "--no-local-project" = go a{argNoLocalProject = True} rest
+        | tok == "-i" || tok == "--in-place" = go a{argInPlace = True} rest
+        | tok == "-h" || tok == "--help" = go a{argHelp = True} rest
+        | tok == "-v" || tok == "--version" = go a{argVersion = True} rest
+        | tok == "--code-style" = case rest of
+            (d : rest') -> case parseCodeStyle d of
+                Just codeStyle -> go a{argCodeStyle = codeStyle} rest'
+                Nothing -> Left ("Could not parse code style: " ++ tok)
+            [] -> Left (tok ++ " requires a code style")
+        | tok == "--output-style" = case rest of
+            (d : rest') -> case parseOutputStyle d of
+                Just codeStyle -> go a{argOutputStyle = codeStyle} rest'
+                Nothing -> Left ("Could not parse output style: " ++ tok)
+            [] -> Left (tok ++ " requires a output style")
+        | "-" `isPrefixOf` tok = Left ("unknown flag: " ++ tok)
+        | otherwise = case argScript a of
+            Nothing -> go a{argScript = Just tok} rest
+            Just _ -> Left ("unexpected extra argument: " ++ tok)
+    stripFlag p s = if p `isPrefixOf` s then Just (drop (length p) s) else Nothing

src/ScriptHs/Markdown.hs

@@ -4,11 +4,46 @@ module ScriptHs.Markdown (
     reassemble,
     MimeType (..),
     CodeOutput (..),
+    CodeStyle (..),
+    parseCodeStyle,
+    defaultCodeStyle,
+    OutputStyle (..),
+    parseOutputStyle,
+    defaultOutputStyle,
 ) where
 
 import Data.Text (Text)
 import qualified Data.Text as T
 
+{- |  Directs how the original code fences are styled
+  in the processed output.
+-}
+data CodeStyle
+    = DisplayCode
+    | RemoveCode
+    deriving (Eq, Ord, Show)
+
+parseCodeStyle :: String -> Maybe CodeStyle
+parseCodeStyle "display" = Just DisplayCode
+parseCodeStyle "remove" = Just RemoveCode
+parseCodeStyle _ = Nothing
+
+defaultCodeStyle :: CodeStyle
+defaultCodeStyle = DisplayCode
+
+data OutputStyle
+    = OutputQuoted
+    | OutputRaw
+    deriving (Eq, Ord, Show)
+
+parseOutputStyle :: String -> Maybe OutputStyle
+parseOutputStyle "quoted" = Just OutputQuoted
+parseOutputStyle "raw" = Just OutputRaw
+parseOutputStyle _ = Nothing
+
+defaultOutputStyle :: OutputStyle
+defaultOutputStyle = OutputQuoted
+
 data MimeType
     = MimeHtml
     | MimeMarkdown
@@ -19,7 +54,8 @@ data MimeType
     | MimePlain
     deriving (Show, Eq)
 
-data CodeOutput = CodeOutput MimeType Text deriving (Show, Eq)
+data CodeOutput = CodeOutput OutputStyle MimeType Text
+    deriving (Show, Eq)
 
 data Segment
     = Prose Text
@@ -48,7 +84,8 @@ parseMarkdown' acc (line : rest) = case fenceLang line of
                                 (cOutput, afterOutput) = span (T.isPrefixOf "> ") xs
                                 mType = mimeFromTag x
                              in
-                                ( Just (CodeOutput mType (T.unlines (map (T.drop (T.length "> ")) cOutput)))
+                                ( Just
+                                    (CodeOutput OutputQuoted mType (T.unlines (map (T.drop (T.length "> ")) cOutput)))
                                 , afterOutput
                                 )
                 [] -> (Nothing, rest')
@@ -91,8 +128,8 @@ fenceCodeSegment lang output
 seam between segments collapses to one blank line and the document's leading/
 trailing blanks are trimmed, so re-running (e.g. @--in-place@) adds no new lines.
 -}
-reassemble :: [Segment] -> Text
-reassemble = finalize . foldr (joinSeam . renderSegment) ""
+reassemble :: CodeStyle -> [Segment] -> Text
+reassemble codeStyle = finalize . foldr (joinSeam . renderSegment codeStyle) ""
   where
     joinSeam "" acc = acc
     joinSeam piece "" = piece
@@ -106,19 +143,26 @@ reassemble = finalize . foldr (joinSeam . renderSegment) ""
         let stripped = T.dropWhileEnd (== '\n') (T.dropWhile (== '\n') t)
          in if T.null stripped then "" else stripped <> "\n"
 
-renderSegment :: Segment -> Text
-renderSegment (Prose t) = t
-renderSegment (CodeBlock lang code Nothing) = fenceCodeSegment lang code
-renderSegment (CodeBlock lang code (Just output)) = fenceCodeSegment lang code <> blockQuote output
+renderSegment :: CodeStyle -> Segment -> Text
+renderSegment _ (Prose t) = t
+renderSegment _ (CodeBlock lang code Nothing) = fenceCodeSegment lang code
+renderSegment codeStyle (CodeBlock lang code (Just output)) =
+    let codeFence = case codeStyle of
+            DisplayCode -> fenceCodeSegment lang code
+            RemoveCode -> mempty
+     in codeFence <> blockQuote output
 
 blockQuote :: CodeOutput -> Text
-blockQuote (CodeOutput mimeType t) =
+blockQuote (CodeOutput outputStyle mimeType t) =
     let
         ls = (mimeMarker <> mimeIndicator mimeType <> " -->") : T.lines t
         trimmed = reverse $ dropWhile T.null $ reverse ls
-        quoted = T.unlines $ map (\l -> if T.null l then "> " else "> " <> l) trimmed
+        styling = case outputStyle of
+            OutputQuoted -> "> "
+            OutputRaw -> ""
+        output = T.unlines $ map (\l -> if T.null l then styling else styling <> l) trimmed
      in
-        quoted <> "\n"
+        output <> "\n"
 
 mimeIndicator :: MimeType -> Text
 mimeIndicator m = case m of

src/ScriptHs/Notebook.hs

@@ -13,7 +13,9 @@ import System.CPUTime (getCPUTime)
 
 import ScriptHs.Markdown (
     CodeOutput (..),
+    CodeStyle,
     MimeType (..),
+    OutputStyle,
     Segment (..),
     parseMarkdown,
     reassemble,
@@ -37,10 +39,11 @@ type IndexedBlocks = [(Int, [Line])]
 clean; output written to a file (@-o@ or @--in-place@) is stamped with the
 current scripths version tag at the top.
 -}
-runNotebook :: RunOptions -> FilePath -> Maybe FilePath -> IO ()
-runNotebook opts path outputPath = do
+runNotebook ::
+    OutputStyle -> CodeStyle -> RunOptions -> FilePath -> Maybe FilePath -> IO ()
+runNotebook outputStyle codeStyle opts path outputPath = do
     contents <- stripBom <$> TIO.readFile path
-    outputMd <- processNotebook opts path contents
+    outputMd <- processNotebook outputStyle codeStyle opts path contents
     case outputPath of
         Nothing -> TIO.putStr outputMd
         Just output -> TIO.writeFile output (stampVersion NotebookTag outputMd)
@@ -49,22 +52,33 @@ runNotebook opts path outputPath = do
 stripBom :: Text -> Text
 stripBom t = fromMaybe t (T.stripPrefix "\65279" t)
 
-processNotebook :: RunOptions -> FilePath -> Text -> IO Text
-processNotebook opts notebookPath contents = do
+processNotebook ::
+    OutputStyle -> CodeStyle -> RunOptions -> FilePath -> Text -> IO Text
+processNotebook outputStyle codeStyle opts notebookPath contents = do
     let indexedSegments = zip [0 ..] (parseMarkdown contents)
         (metas, indexedCodeBlocks) = parseBlocks indexedSegments
     if null indexedCodeBlocks
         then pure contents
-        else executeCodeCells opts notebookPath metas indexedSegments indexedCodeBlocks
+        else
+            executeCodeCells
+                outputStyle
+                codeStyle
+                opts
+                notebookPath
+                metas
+                indexedSegments
+                indexedCodeBlocks
 
 executeCodeCells ::
+    OutputStyle ->
+    CodeStyle ->
     RunOptions ->
     FilePath ->
     CabalMeta ->
     IndexedSegments ->
     IndexedBlocks ->
     IO Text
-executeCodeCells opts notebookPath meta allSegments codeBlocks = do
+executeCodeCells outputStyle codeStyle opts notebookPath meta allSegments codeBlocks = do
     let ghciScript0 = generatedMarkedScript "" codeBlocks
     nonce <- makeNonce ghciScript0
     let ghciScript = generatedMarkedScript nonce codeBlocks
@@ -76,8 +90,8 @@ executeCodeCells opts notebookPath meta allSegments codeBlocks = do
             map
                 (fmap (scrubCellOutput nonce indices))
                 (splitByMarkers nonce rawOutput indices)
-        blocksWithOutput = addOutputToSegments outputs allSegments
-    pure $ reassemble blocksWithOutput
+        blocksWithOutput = addOutputToSegments outputStyle outputs allSegments
+    pure $ reassemble codeStyle blocksWithOutput
 
 {- | A per-run hex nonce woven into every cell-end marker so a cell's own output
 cannot spoof a marker and misattribute another cell's output. Mixes the process
@@ -104,11 +118,16 @@ scrubCellOutput nonce indices =
   where
     stripMarkers t = foldr (\i acc -> T.replace (mkMarker nonce i) "" acc) t indices
 
-addOutputToSegments :: [(Int, Text)] -> IndexedSegments -> [Segment]
-addOutputToSegments outputs = map addOutput
+addOutputToSegments ::
+    OutputStyle -> [(Int, Text)] -> IndexedSegments -> [Segment]
+addOutputToSegments outputStyle outputs = map addOutput
   where
     addOutput :: (Int, Segment) -> Segment
-    addOutput (i, CodeBlock lang code _) = CodeBlock lang code (fmap (CodeOutput MimePlain) (lookup i outputs))
+    addOutput (i, CodeBlock lang code _) =
+        CodeBlock
+            lang
+            code
+            (fmap (CodeOutput outputStyle MimePlain) (lookup i outputs))
     addOutput (_, seg) = seg
 
 mkIndexedCodeSegments :: IndexedSegments -> IndexedSegments