{-# 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 Int -> Args -> ShowS
[Args] -> ShowS
Args -> String
(Int -> Args -> ShowS)
-> (Args -> String) -> ([Args] -> ShowS) -> Show Args
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Args -> ShowS
showsPrec :: Int -> Args -> ShowS
$cshow :: Args -> String
show :: Args -> String
$cshowList :: [Args] -> ShowS
showList :: [Args] -> ShowS
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 (Argument -> Argument -> Bool
(Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool) -> Eq Argument
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Argument -> Argument -> Bool
== :: Argument -> Argument -> Bool
$c/= :: Argument -> Argument -> Bool
/= :: Argument -> Argument -> Bool
Eq, Int -> Argument -> ShowS
[Argument] -> ShowS
Argument -> String
(Int -> Argument -> ShowS)
-> (Argument -> String) -> ([Argument] -> ShowS) -> Show Argument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Argument -> ShowS
showsPrec :: Int -> Argument -> ShowS
$cshow :: Argument -> String
show :: Argument -> String
$cshowList :: [Argument] -> ShowS
showList :: [Argument] -> ShowS
Show)

data LhsStyle string =
       LhsStyle
         { forall string. LhsStyle string -> string
lhsCodePrefix :: string  -- ^ @>@
         , forall string. LhsStyle string -> string
lhsOutputPrefix :: string  -- ^ @<<@
         , forall string. LhsStyle string -> string
lhsBeginCode :: string  -- ^ @\\begin{code}@
         , forall string. LhsStyle string -> string
lhsEndCode :: string  -- ^ @\\end{code}@
         , forall string. LhsStyle string -> string
lhsBeginOutput :: string  -- ^ @\\begin{verbatim}@
         , forall string. LhsStyle string -> string
lhsEndOutput :: string  -- ^ @\\end{verbatim}@
         }
  deriving (LhsStyle string -> LhsStyle string -> Bool
(LhsStyle string -> LhsStyle string -> Bool)
-> (LhsStyle string -> LhsStyle string -> Bool)
-> Eq (LhsStyle string)
forall string.
Eq string =>
LhsStyle string -> LhsStyle string -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall string.
Eq string =>
LhsStyle string -> LhsStyle string -> Bool
== :: LhsStyle string -> LhsStyle string -> Bool
$c/= :: forall string.
Eq string =>
LhsStyle string -> LhsStyle string -> Bool
/= :: LhsStyle string -> LhsStyle string -> Bool
Eq, (forall a b. (a -> b) -> LhsStyle a -> LhsStyle b)
-> (forall a b. a -> LhsStyle b -> LhsStyle a) -> Functor LhsStyle
forall a b. a -> LhsStyle b -> LhsStyle a
forall a b. (a -> b) -> LhsStyle a -> LhsStyle b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> LhsStyle a -> LhsStyle b
fmap :: forall a b. (a -> b) -> LhsStyle a -> LhsStyle b
$c<$ :: forall a b. a -> LhsStyle b -> LhsStyle a
<$ :: forall a b. a -> LhsStyle b -> LhsStyle a
Functor, Int -> LhsStyle string -> ShowS
[LhsStyle string] -> ShowS
LhsStyle string -> String
(Int -> LhsStyle string -> ShowS)
-> (LhsStyle string -> String)
-> ([LhsStyle string] -> ShowS)
-> Show (LhsStyle string)
forall string. Show string => Int -> LhsStyle string -> ShowS
forall string. Show string => [LhsStyle string] -> ShowS
forall string. Show string => LhsStyle string -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall string. Show string => Int -> LhsStyle string -> ShowS
showsPrec :: Int -> LhsStyle string -> ShowS
$cshow :: forall string. Show string => LhsStyle string -> String
show :: LhsStyle string -> String
$cshowList :: forall string. Show string => [LhsStyle string] -> ShowS
showList :: [LhsStyle string] -> ShowS
Show)

data NotebookFormat = LhsMarkdown
                    | IpynbFile
  deriving (NotebookFormat -> NotebookFormat -> Bool
(NotebookFormat -> NotebookFormat -> Bool)
-> (NotebookFormat -> NotebookFormat -> Bool) -> Eq NotebookFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NotebookFormat -> NotebookFormat -> Bool
== :: NotebookFormat -> NotebookFormat -> Bool
$c/= :: NotebookFormat -> NotebookFormat -> Bool
/= :: NotebookFormat -> NotebookFormat -> Bool
Eq, Int -> NotebookFormat -> ShowS
[NotebookFormat] -> ShowS
NotebookFormat -> String
(Int -> NotebookFormat -> ShowS)
-> (NotebookFormat -> String)
-> ([NotebookFormat] -> ShowS)
-> Show NotebookFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NotebookFormat -> ShowS
showsPrec :: Int -> NotebookFormat -> ShowS
$cshow :: NotebookFormat -> String
show :: NotebookFormat -> String
$cshowList :: [NotebookFormat] -> ShowS
showList :: [NotebookFormat] -> ShowS
Show)

-- Which mode IHaskell is being invoked in.
data IHaskellMode = ShowDefault String
                  | InstallKernelSpec
                  | ConvertLhs
                  | Kernel (Maybe String)
  deriving (IHaskellMode -> IHaskellMode -> Bool
(IHaskellMode -> IHaskellMode -> Bool)
-> (IHaskellMode -> IHaskellMode -> Bool) -> Eq IHaskellMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IHaskellMode -> IHaskellMode -> Bool
== :: IHaskellMode -> IHaskellMode -> Bool
$c/= :: IHaskellMode -> IHaskellMode -> Bool
/= :: IHaskellMode -> IHaskellMode -> Bool
Eq, Int -> IHaskellMode -> ShowS
[IHaskellMode] -> ShowS
IHaskellMode -> String
(Int -> IHaskellMode -> ShowS)
-> (IHaskellMode -> String)
-> ([IHaskellMode] -> ShowS)
-> Show IHaskellMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IHaskellMode -> ShowS
showsPrec :: Int -> IHaskellMode -> ShowS
$cshow :: IHaskellMode -> String
show :: IHaskellMode -> String
$cshowList :: [IHaskellMode] -> ShowS
showList :: [IHaskellMode] -> ShowS
Show)

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

    Just Int
idx ->
      -- If mode not first, move it to be first.
      let ([String]
start, String
first:[String]
end) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [String]
flags
      in Mode Args -> [String] -> Either String Args
forall a. Mode a -> [String] -> Either String a
process Mode Args
ihaskellArgs ([String] -> Either String Args) -> [String] -> Either String Args
forall a b. (a -> b) -> a -> b
$ String
first String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
start [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
end
  where
    modeFlgs :: [String]
modeFlgs = (Mode Args -> [String]) -> [Mode Args] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Mode Args -> [String]
forall a. Mode a -> [String]
modeNames [Mode Args]
allModes

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

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

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

ghcRTSFlag :: Flag Args
ghcRTSFlag :: Flag Args
ghcRTSFlag = [String] -> Update Args -> String -> String -> Flag Args
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"use-rtsopts"] Update Args
forall {a}. IsString a => String -> Args -> Either a Args
storeRTS String
"\"<flags>\""
                  String
"Runtime options (multithreading etc.). See `ghc +RTS -?`."
 where storeRTS :: String -> Args -> Either a Args
storeRTS String
allRTSFlags (Args IHaskellMode
md [Argument]
prev)
          = ([String] -> Args) -> Either a [String] -> Either a Args
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md ([Argument] -> Args)
-> ([String] -> [Argument]) -> [String] -> Args
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
:[Argument]
prev) (Argument -> [Argument])
-> ([String] -> Argument) -> [String] -> [Argument]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Argument
RTSFlags)
              (Either a [String] -> Either a Args)
-> (String -> Either a [String]) -> String -> Either a Args
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Either a [String]
forall {a} {a}.
(Eq a, IsString a, IsString a) =>
[a] -> Either a [a]
parseRTS ([String] -> Either a [String])
-> (String -> [String]) -> String -> Either a [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words (String -> Either a Args) -> String -> Either a Args
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'"') String
allRTSFlags
       parseRTS :: [a] -> Either a [a]
parseRTS (a
"+RTS":[a]
fs)  -- Ignore if this is included (we already wrap
           = [a] -> Either a [a]
parseRTS [a]
fs     -- the ihaskell-kernel call in +RTS <flags> -RTS anyway)
       parseRTS [a
"-RTS"] = [a] -> Either a [a]
forall a b. b -> Either a b
Right []
       parseRTS (a
"-RTS":[a]
_)  -- Evil injection of extra arguments? Unlikely, but...
           = a -> Either a [a]
forall a b. a -> Either a b
Left a
"Adding non-RTS options to --use-rtsopts not permitted."
       parseRTS (a
f:[a]
fs) = (a
fa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Either a [a] -> Either a [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Either a [a]
parseRTS [a]
fs
       parseRTS [] = [a] -> Either a [a]
forall a b. b -> Either a b
Right []

kernelDebugFlag :: Flag Args
kernelDebugFlag :: Flag Args
kernelDebugFlag = [String] -> (Args -> Args) -> String -> Flag Args
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone [String
"debug"] Args -> Args
addDebug String
"Print debugging output from the kernel."
  where
    addDebug :: Args -> Args
addDebug (Args IHaskellMode
md [Argument]
prev) = IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md (Argument
KernelDebug Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev)

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

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

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

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

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

kernelStackFlag :: Flag Args
kernelStackFlag :: Flag Args
kernelStackFlag = [String] -> (Args -> Args) -> String -> Flag Args
forall a. [String] -> (a -> a) -> String -> Flag a
flagNone [String
"stack"] Args -> Args
addStack
                    String
"Inherit environment from `stack` when it is installed"
  where
    addStack :: Args -> Args
addStack (Args IHaskellMode
md [Argument]
prev) = IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md (Argument
KernelspecUseStack Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev)

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

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

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

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

helpFlag :: Flag Args
helpFlag :: Flag Args
helpFlag = (Args -> Args) -> Flag Args
forall a. (a -> a) -> Flag a
flagHelpSimple (Argument -> Args -> Args
add Argument
Help)

add :: Argument -> Args -> Args
add :: Argument -> Args -> Args
add Argument
flag (Args IHaskellMode
md [Argument]
flags) = IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md ([Argument] -> Args) -> [Argument] -> Args
forall a b. (a -> b) -> a -> b
$ Argument
flag Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
flags

store :: (String -> Argument) -> String -> Args -> Either String Args
store :: (String -> Argument) -> Update Args
store String -> Argument
constructor String
str (Args IHaskellMode
md [Argument]
prev) = Args -> Either String Args
forall a b. b -> Either a b
Right (Args -> Either String Args) -> Args -> Either String Args
forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md ([Argument] -> Args) -> [Argument] -> Args
forall a b. (a -> b) -> a -> b
$ String -> Argument
constructor String
str Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev

installKernelSpec :: Mode Args
installKernelSpec :: Mode Args
installKernelSpec =
  String -> Args -> String -> Arg Args -> [Flag Args] -> Mode Args
forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
"install" (IHaskellMode -> [Argument] -> Args
Args IHaskellMode
InstallKernelSpec []) String
"Install the Jupyter kernelspec." Arg Args
forall a. Arg a
noArgs
    [Flag Args
ghcLibFlag, Flag Args
ghcRTSFlag, Flag Args
kernelDebugFlag, Flag Args
kernelNameFlag, Flag Args
displayNameFlag, Flag Args
confFlag, Flag Args
installPrefixFlag, Flag Args
helpFlag, Flag Args
kernelStackFlag, Flag Args
kernelStackExtraFlags, Flag Args
kernelEnvFileFlag]

kernel :: Mode Args
kernel :: Mode Args
kernel = String -> Args -> String -> Arg Args -> [Flag Args] -> Mode Args
forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
"kernel" (IHaskellMode -> [Argument] -> Args
Args (Maybe String -> IHaskellMode
Kernel Maybe String
forall a. Maybe a
Nothing) []) String
"Invoke the IHaskell kernel." Arg Args
kernelArg
           [Flag Args
ghcLibFlag
           , Flag Args
kernelDebugFlag
           , Flag Args
confFlag
           , Flag Args
kernelStackFlag
           , Flag Args
kernelStackExtraFlags
           , Flag Args
kernelEnvFileFlag
           , Flag Args
kernelCodeMirrorFlag
           , Flag Args
kernelHtmlCodeWrapperClassFlag
           , Flag Args
kernelHtmlCodeTokenPrefixFlag
           ]
  where
    kernelArg :: Arg Args
kernelArg = Update Args -> String -> Arg Args
forall a. Update a -> String -> Arg a
flagArg Update Args
forall {a}. String -> Args -> Either a Args
update String
"<json-kernel-file>"
    update :: String -> Args -> Either a Args
update String
filename (Args IHaskellMode
_ [Argument]
flags) = Args -> Either a Args
forall a b. b -> Either a b
Right (Args -> Either a Args) -> Args -> Either a Args
forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args (Maybe String -> IHaskellMode
Kernel (Maybe String -> IHaskellMode) -> Maybe String -> IHaskellMode
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
filename) [Argument]
flags

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

    consForce :: Args -> Args
consForce (Args IHaskellMode
md [Argument]
prev) = IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md (Argument
OverwriteFiles Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev)
    unnamedArg :: Arg Args
unnamedArg = Update Args -> String -> Bool -> Arg Args
forall a. Update a -> String -> Bool -> Arg a
Arg ((String -> Argument) -> Update Args
store String -> Argument
ConvertFrom) String
"<file>" Bool
False
    consStyle :: LhsStyle String -> Args -> Args
consStyle LhsStyle String
style (Args IHaskellMode
md [Argument]
prev) = IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md (LhsStyle String -> Argument
ConvertLhsStyle LhsStyle String
style Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev)

    storeFormat :: (NotebookFormat -> Argument) -> Update Args
storeFormat NotebookFormat -> Argument
constructor String
str (Args IHaskellMode
md [Argument]
prev) =
      case Text -> Text
T.toLower (String -> Text
T.pack String
str) of
        Text
"lhs"   -> Args -> Either String Args
forall a b. b -> Either a b
Right (Args -> Either String Args) -> Args -> Either String Args
forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md ([Argument] -> Args) -> [Argument] -> Args
forall a b. (a -> b) -> a -> b
$ NotebookFormat -> Argument
constructor NotebookFormat
LhsMarkdown Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev
        Text
"ipynb" -> Args -> Either String Args
forall a b. b -> Either a b
Right (Args -> Either String Args) -> Args -> Either String Args
forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md ([Argument] -> Args) -> [Argument] -> Args
forall a b. (a -> b) -> a -> b
$ NotebookFormat -> Argument
constructor NotebookFormat
IpynbFile Argument -> [Argument] -> [Argument]
forall a. a -> [a] -> [a]
: [Argument]
prev
        Text
_       -> String -> Either String Args
forall a b. a -> Either a b
Left (String -> Either String Args) -> String -> Either String Args
forall a b. (a -> b) -> a -> b
$ String
"Unknown format requested: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str

    storeLhs :: Update Args
storeLhs String
str Args
previousArgs =
      case Text -> Text
T.toLower (String -> Text
T.pack String
str) of
        Text
"bird" -> LhsStyle String -> Either String Args
forall {a}. LhsStyle String -> Either a Args
success LhsStyle String
lhsStyleBird
        Text
"tex"  -> LhsStyle String -> Either String Args
forall {a}. LhsStyle String -> Either a Args
success LhsStyle String
lhsStyleTex
        Text
_      -> String -> Either String Args
forall a b. a -> Either a b
Left (String -> Either String Args) -> String -> Either String Args
forall a b. (a -> b) -> a -> b
$ String
"Unknown lhs style: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
str
      where
        success :: LhsStyle String -> Either a Args
success LhsStyle String
lhsStyle = Args -> Either a Args
forall a b. b -> Either a b
Right (Args -> Either a Args) -> Args -> Either a Args
forall a b. (a -> b) -> a -> b
$ LhsStyle String -> Args -> Args
consStyle LhsStyle String
lhsStyle Args
previousArgs

lhsStyleBird, lhsStyleTex :: LhsStyle String
lhsStyleBird :: LhsStyle String
lhsStyleBird = String
-> String
-> String
-> String
-> String
-> String
-> LhsStyle String
forall string.
string
-> string
-> string
-> string
-> string
-> string
-> LhsStyle string
LhsStyle String
"> " String
"\n<< " String
"" String
"" String
"" String
""

lhsStyleTex :: LhsStyle String
lhsStyleTex = String
-> String
-> String
-> String
-> String
-> String
-> LhsStyle String
forall string.
string
-> string
-> string
-> string
-> string
-> string
-> LhsStyle string
LhsStyle String
"" String
"" String
"\\begin{code}" String
"\\end{code}" String
"\\begin{verbatim}" String
"\\end{verbatim}"

ihaskellArgs :: Mode Args
ihaskellArgs :: Mode Args
ihaskellArgs =
  let noMode :: Mode Args
noMode = String -> Args -> String -> Arg Args -> [Flag Args] -> Mode Args
forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
"IHaskell" Args
defaultReport String
descr Arg Args
forall a. Arg a
noArgs [Flag Args
helpFlag, Flag Args
versionFlag]
      defaultReport :: Args
defaultReport = IHaskellMode -> [Argument] -> Args
Args (String -> IHaskellMode
ShowDefault String
helpStr) []
      descr :: String
descr = String
"Haskell for Interactive Computing."
      versionFlag :: Flag Args
versionFlag = (Args -> Args) -> Flag Args
forall a. (a -> a) -> Flag a
flagVersion (Argument -> Args -> Args
add Argument
Version)
      helpStr :: String
helpStr = TextFormat -> [Text] -> String
showText (Int -> TextFormat
Wrap Int
100) ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> HelpFormat -> Mode Args -> [Text]
forall a. [String] -> HelpFormat -> Mode a -> [Text]
helpText [] HelpFormat
HelpFormatAll Mode Args
ihaskellArgs
  in Mode Args
noMode { modeGroupModes = toGroup allModes }

noArgs :: Arg a
noArgs :: forall a. Arg a
noArgs = Update a -> String -> Arg a
forall a. Update a -> String -> Arg a
flagArg Update a
forall {a}. String -> a
unexpected String
""
  where
    unexpected :: String -> a
unexpected String
a = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Unexpected argument: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
a