Flags.hs

{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}

module IHaskell.Flags (
    IHaskellMode(..),
    Argument(..),
    Args(..),
    LhsStyle(..),
    NotebookFormat(..),
    lhsStyleBird,
    parseFlags,
    help,
    ) where

import qualified Data.Text as T
import           IHaskellPrelude hiding (Arg(..))

import           System.Console.CmdArgs.Explicit
import           System.Console.CmdArgs.Text
import           Data.List (findIndex)

-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
data Args = Args IHaskellMode [Argument]
  deriving Show

data Argument = ConfFile String               -- ^ A file with commands to load at startup.
              | OverwriteFiles                -- ^ Present when output should overwrite existing files.
              | GhcLibDir String              -- ^ Where to find the GHC libraries.
              | RTSFlags [String]             -- ^ Options for the GHC runtime (e.g. heap-size limit
                                              --     or number of threads).
              | KernelDebug                   -- ^ Spew debugging output from the kernel.
              | KernelName String             -- ^ The IPython kernel directory name.
              | DisplayName String            -- ^ The IPython display name.
              | Help                          -- ^ Display help text.
              | Version                       -- ^ Display version text.
              | CodeMirror String             -- ^ change codemirror mode (default=ihaskell)
              | HtmlCodeWrapperClass String   -- ^ set the wrapper class for HTML output
              | HtmlCodeTokenPrefix String    -- ^ set a prefix on each token of HTML output
              | ConvertFrom String
              | ConvertTo String
              | ConvertFromFormat NotebookFormat
              | ConvertToFormat NotebookFormat
              | ConvertLhsStyle (LhsStyle String)
              | KernelspecInstallPrefix String
              | KernelspecUseStack
              | KernelspecStackFlag String
              | KernelspecEnvFile FilePath
  deriving (Eq, Show)

data LhsStyle string =
       LhsStyle
         { lhsCodePrefix :: string  -- ^ @>@
         , lhsOutputPrefix :: string  -- ^ @<<@
         , lhsBeginCode :: string  -- ^ @\\begin{code}@
         , lhsEndCode :: string  -- ^ @\\end{code}@
         , lhsBeginOutput :: string  -- ^ @\\begin{verbatim}@
         , lhsEndOutput :: string  -- ^ @\\end{verbatim}@
         }
  deriving (Eq, Functor, Show)

data NotebookFormat = LhsMarkdown
                    | IpynbFile
  deriving (Eq, Show)

-- Which mode IHaskell is being invoked in.
data IHaskellMode = ShowDefault String
                  | InstallKernelSpec
                  | ConvertLhs
                  | Kernel (Maybe String)
  deriving (Eq, Show)

-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags flags =
  let modeIndex = findIndex (`elem` modeFlgs) flags
  in case modeIndex of
    Nothing ->
      -- Treat no mode as 'console'.
      process ihaskellArgs flags
    Just 0 -> process ihaskellArgs flags

    Just idx ->
      -- If mode not first, move it to be first.
      let (start, first:end) = splitAt idx flags
      in process ihaskellArgs $ first : start ++ end
  where
    modeFlgs = concatMap modeNames allModes

allModes :: [Mode Args]
allModes = [installKernelSpec, kernel, convert]

-- | Get help text for a given IHaskell ode.
help :: IHaskellMode -> String
help md = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode md
  where
    chooseMode InstallKernelSpec = installKernelSpec
    chooseMode (Kernel _) = kernel
    chooseMode ConvertLhs = convert
    chooseMode (ShowDefault _) = error "IHaskell.Flags.help: Should never happen."

ghcLibFlag :: Flag Args
ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directory for GHC."

ghcRTSFlag :: Flag Args
ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"<flags>\""
                  "Runtime options (multithreading etc.). See `ghc +RTS -?`."
 where storeRTS allRTSFlags (Args md prev)
          = fmap (Args md . (:prev) . RTSFlags)
              . parseRTS . words $ filter (/='"') allRTSFlags
       parseRTS ("+RTS":fs)  -- Ignore if this is included (we already wrap
           = parseRTS fs     -- the ihaskell-kernel call in +RTS <flags> -RTS anyway)
       parseRTS ["-RTS"] = Right []
       parseRTS ("-RTS":_)  -- Evil injection of extra arguments? Unlikely, but...
           = Left "Adding non-RTS options to --use-rtsopts not permitted."
       parseRTS (f:fs) = (f:) <$> parseRTS fs
       parseRTS [] = Right []

kernelDebugFlag :: Flag Args
kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel."
  where
    addDebug (Args md prev) = Args md (KernelDebug : prev)

kernelNameFlag :: Flag Args
kernelNameFlag =
  flagReq
    ["kernel-name"]
    (store KernelName)
    "<name>"
    "The directory name of the kernel."

displayNameFlag :: Flag Args
displayNameFlag =
  flagReq
    ["display-name"]
    (store DisplayName)
    "<name>"
    "The display name of the kernel."

kernelCodeMirrorFlag :: Flag Args
kernelCodeMirrorFlag = flagReq ["codemirror"] (store CodeMirror) "<codemirror>"
        "Specify codemirror mode that is used for syntax highlighting (default: ihaskell)."

kernelHtmlCodeWrapperClassFlag :: Flag Args
kernelHtmlCodeWrapperClassFlag = flagReq ["html-code-wrapper-class"] (store HtmlCodeWrapperClass) "CodeMirror cm-s-jupyter cm-s-ipython"
        "Specify class name for wrapper div around HTML output (default: 'CodeMirror cm-s-jupyter cm-s-ipython')"

kernelHtmlCodeTokenPrefixFlag :: Flag Args
kernelHtmlCodeTokenPrefixFlag = flagReq ["html-code-token-prefix"] (store HtmlCodeTokenPrefix) "cm-"
        "Specify class name prefix for each token in HTML output (default: cm-)"

kernelStackFlag :: Flag Args
kernelStackFlag = flagNone ["stack"] addStack
                    "Inherit environment from `stack` when it is installed"
  where
    addStack (Args md prev) = Args md (KernelspecUseStack : prev)

kernelStackExtraFlags :: Flag Args
kernelStackExtraFlags = flagReq ["stack-flag"] (store KernelspecStackFlag) ""
        "Extra flag to pass to `stack` when --stack is used. Can be specified multiple times."

kernelEnvFileFlag :: Flag Args
kernelEnvFileFlag =
  flagReq
    ["env-file"]
    (store KernelspecEnvFile)
    "<file>"
    "Load environment from this file when kernel is installed"

confFlag :: Flag Args
confFlag = flagReq ["conf", "c"] (store ConfFile) "<rc.hs>"
             "File with commands to execute at start; replaces ~/.ihaskell/rc.hs."

installPrefixFlag :: Flag Args
installPrefixFlag = flagReq ["prefix"] (store KernelspecInstallPrefix) "<install-dir>"
                      "Installation prefix for kernelspec (see Jupyter's --prefix option)"

helpFlag :: Flag Args
helpFlag = flagHelpSimple (add Help)

add :: Argument -> Args -> Args
add flag (Args md flags) = Args md $ flag : flags

store :: (String -> Argument) -> String -> Args -> Either String Args
store constructor str (Args md prev) = Right $ Args md $ constructor str : prev

installKernelSpec :: Mode Args
installKernelSpec =
  mode "install" (Args InstallKernelSpec []) "Install the Jupyter kernelspec." noArgs
    [ghcLibFlag, ghcRTSFlag, kernelDebugFlag, kernelNameFlag, displayNameFlag, confFlag, installPrefixFlag, helpFlag, kernelStackFlag, kernelStackExtraFlags, kernelEnvFileFlag]

kernel :: Mode Args
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg
           [ghcLibFlag
           , kernelDebugFlag
           , confFlag
           , kernelStackFlag
           , kernelStackExtraFlags
           , kernelEnvFileFlag
           , kernelCodeMirrorFlag
           , kernelHtmlCodeWrapperClassFlag
           , kernelHtmlCodeTokenPrefixFlag
           ]
  where
    kernelArg = flagArg update "<json-kernel-file>"
    update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags

convert :: Mode Args
convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlags
  where
    description = "Convert between Literate Haskell (*.lhs) and Ipython notebooks (*.ipynb)."
    convertFlags = [ flagReq ["input", "i"] (store ConvertFrom) "<file>" "File to read."
                   , flagReq ["output", "o"] (store ConvertTo) "<file>" "File to write."
                   , flagReq ["from", "f"] (storeFormat ConvertFromFormat) "lhs|ipynb"
                       "Format of the file to read."
                   , flagReq ["to", "t"] (storeFormat ConvertToFormat) "lhs|ipynb"
                       "Format of the file to write."
                   , flagNone ["force"] consForce "Overwrite existing files with output."
                   , flagReq ["style", "s"] storeLhs "bird|tex"
                       "Type of markup used for the literate haskell file"
                   , flagNone ["bird"] (consStyle lhsStyleBird) "Literate haskell uses >"
                   , flagNone ["tex"] (consStyle lhsStyleTex) "Literate haskell uses \\begin{code}"
                   , helpFlag
                   ]

    consForce (Args md prev) = Args md (OverwriteFiles : prev)
    unnamedArg = Arg (store ConvertFrom) "<file>" False
    consStyle style (Args md prev) = Args md (ConvertLhsStyle style : prev)

    storeFormat constructor str (Args md prev) =
      case T.toLower (T.pack str) of
        "lhs"   -> Right $ Args md $ constructor LhsMarkdown : prev
        "ipynb" -> Right $ Args md $ constructor IpynbFile : prev
        _       -> Left $ "Unknown format requested: " ++ str

    storeLhs str previousArgs =
      case T.toLower (T.pack str) of
        "bird" -> success lhsStyleBird
        "tex"  -> success lhsStyleTex
        _      -> Left $ "Unknown lhs style: " ++ str
      where
        success lhsStyle = Right $ consStyle lhsStyle previousArgs

lhsStyleBird, lhsStyleTex :: LhsStyle String
lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" ""

lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"

ihaskellArgs :: Mode Args
ihaskellArgs =
  let noMode = mode "IHaskell" defaultReport descr noArgs [helpFlag, versionFlag]
      defaultReport = Args (ShowDefault helpStr) []
      descr = "Haskell for Interactive Computing."
      versionFlag = flagVersion (add Version)
      helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
  in noMode { modeGroupModes = toGroup allModes }

noArgs :: Arg a
noArgs = flagArg unexpected ""
  where
    unexpected a = error $ "Unexpected argument: " ++ a