{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags (
IHaskellMode(..),
Argument(..),
Args(..),
LhsStyle(..),
NotebookFormat(..),
lhsStyleBird,
parseFlags,
help,
) where
import IHaskellPrelude hiding (Arg(..))
import qualified Data.Text as T
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import Data.List (findIndex)
data Args = Args IHaskellMode [Argument]
deriving Int -> Args -> ShowS
[Args] -> ShowS
Args -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Args] -> ShowS
$cshowList :: [Args] -> ShowS
show :: Args -> String
$cshow :: Args -> String
showsPrec :: Int -> Args -> ShowS
$cshowsPrec :: Int -> Args -> ShowS
Show
data Argument = ConfFile String
| OverwriteFiles
| GhcLibDir String
| RTSFlags [String]
| KernelDebug
| Help
| Version
| CodeMirror String
| ConvertFrom String
| ConvertTo String
| ConvertFromFormat NotebookFormat
| ConvertToFormat NotebookFormat
| ConvertLhsStyle (LhsStyle String)
| KernelspecInstallPrefix String
| KernelspecUseStack
| KernelspecEnvFile FilePath
deriving (Argument -> Argument -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Argument -> Argument -> Bool
$c/= :: Argument -> Argument -> Bool
== :: Argument -> Argument -> Bool
$c== :: Argument -> Argument -> Bool
Eq, Int -> Argument -> ShowS
[Argument] -> ShowS
Argument -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Argument] -> ShowS
$cshowList :: [Argument] -> ShowS
show :: Argument -> String
$cshow :: Argument -> String
showsPrec :: Int -> Argument -> ShowS
$cshowsPrec :: Int -> 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
, forall string. LhsStyle string -> string
lhsEndCode :: string
, forall string. LhsStyle string -> string
lhsBeginOutput :: string
, forall string. LhsStyle string -> string
lhsEndOutput :: string
}
deriving (LhsStyle string -> LhsStyle string -> Bool
forall string.
Eq string =>
LhsStyle string -> LhsStyle string -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LhsStyle string -> LhsStyle string -> Bool
$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
Eq, 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
<$ :: forall a b. a -> LhsStyle b -> LhsStyle a
$c<$ :: forall a b. a -> LhsStyle b -> LhsStyle a
fmap :: forall a b. (a -> b) -> LhsStyle a -> LhsStyle b
$cfmap :: forall a b. (a -> b) -> LhsStyle a -> LhsStyle b
Functor, Int -> LhsStyle string -> ShowS
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
showList :: [LhsStyle string] -> ShowS
$cshowList :: forall string. Show string => [LhsStyle string] -> ShowS
show :: LhsStyle string -> String
$cshow :: forall string. Show string => LhsStyle string -> String
showsPrec :: Int -> LhsStyle string -> ShowS
$cshowsPrec :: forall string. Show string => Int -> LhsStyle string -> ShowS
Show)
data NotebookFormat = LhsMarkdown
| IpynbFile
deriving (NotebookFormat -> NotebookFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotebookFormat -> NotebookFormat -> Bool
$c/= :: NotebookFormat -> NotebookFormat -> Bool
== :: NotebookFormat -> NotebookFormat -> Bool
$c== :: NotebookFormat -> NotebookFormat -> Bool
Eq, Int -> NotebookFormat -> ShowS
[NotebookFormat] -> ShowS
NotebookFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotebookFormat] -> ShowS
$cshowList :: [NotebookFormat] -> ShowS
show :: NotebookFormat -> String
$cshow :: NotebookFormat -> String
showsPrec :: Int -> NotebookFormat -> ShowS
$cshowsPrec :: Int -> NotebookFormat -> ShowS
Show)
data IHaskellMode = ShowDefault String
| InstallKernelSpec
| ConvertLhs
| Kernel (Maybe String)
deriving (IHaskellMode -> IHaskellMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IHaskellMode -> IHaskellMode -> Bool
$c/= :: IHaskellMode -> IHaskellMode -> Bool
== :: IHaskellMode -> IHaskellMode -> Bool
$c== :: IHaskellMode -> IHaskellMode -> Bool
Eq, Int -> IHaskellMode -> ShowS
[IHaskellMode] -> ShowS
IHaskellMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IHaskellMode] -> ShowS
$cshowList :: [IHaskellMode] -> ShowS
show :: IHaskellMode -> String
$cshow :: IHaskellMode -> String
showsPrec :: Int -> IHaskellMode -> ShowS
$cshowsPrec :: Int -> IHaskellMode -> ShowS
Show)
parseFlags :: [String] -> Either String Args
parseFlags :: [String] -> Either String Args
parseFlags [String]
flags =
let modeIndex :: Maybe Int
modeIndex = forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (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 ->
forall a. Mode a -> [String] -> Either String a
process Mode Args
ihaskellArgs [String]
flags
Just Int
0 -> forall a. Mode a -> [String] -> Either String a
process Mode Args
ihaskellArgs [String]
flags
Just Int
idx ->
let ([String]
start, String
first:[String]
end) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
idx [String]
flags
in forall a. Mode a -> [String] -> Either String a
process Mode Args
ihaskellArgs forall a b. (a -> b) -> a -> b
$ String
first forall a. a -> [a] -> [a]
: [String]
start forall a. [a] -> [a] -> [a]
++ [String]
end
where
modeFlgs :: [String]
modeFlgs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap 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]
help :: IHaskellMode -> String
help :: IHaskellMode -> String
help IHaskellMode
md = TextFormat -> [Text] -> String
showText (Int -> TextFormat
Wrap Int
100) forall a b. (a -> b) -> a -> b
$ forall a. [String] -> HelpFormat -> Mode a -> [Text]
helpText [] HelpFormat
HelpFormatAll 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
_) = forall a. HasCallStack => String -> a
error String
"IHaskell.Flags.help: Should never happen."
ghcLibFlag :: Flag Args
ghcLibFlag :: Flag Args
ghcLibFlag = forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"ghclib", String
"l"] ((String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
GhcLibDir) String
"<path>" String
"Library directory for GHC."
ghcRTSFlag :: Flag Args
ghcRTSFlag :: Flag Args
ghcRTSFlag = forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"use-rtsopts"] 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)
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[Argument]
prev) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Argument
RTSFlags)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {a}.
(Eq a, IsString a, IsString a) =>
[a] -> Either a [a]
parseRTS forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'"') String
allRTSFlags
parseRTS :: [a] -> Either a [a]
parseRTS (a
"+RTS":[a]
fs)
= [a] -> Either a [a]
parseRTS [a]
fs
parseRTS [a
"-RTS"] = forall a b. b -> Either a b
Right []
parseRTS (a
"-RTS":[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
fforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> Either a [a]
parseRTS [a]
fs
parseRTS [] = forall a b. b -> Either a b
Right []
kernelDebugFlag :: Flag Args
kernelDebugFlag :: Flag Args
kernelDebugFlag = 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 forall a. a -> [a] -> [a]
: [Argument]
prev)
kernelCodeMirrorFlag :: Flag Args
kernelCodeMirrorFlag :: Flag Args
kernelCodeMirrorFlag = forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"codemirror"] ((String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
CodeMirror) String
"<codemirror>"
String
"Specify codemirror mode that is used for syntax highlighting (default: ihaskell)."
kernelStackFlag :: Flag Args
kernelStackFlag :: Flag Args
kernelStackFlag = 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 forall a. a -> [a] -> [a]
: [Argument]
prev)
kernelEnvFileFlag :: Flag Args
kernelEnvFileFlag :: Flag Args
kernelEnvFileFlag =
forall a. [String] -> Update a -> String -> String -> Flag a
flagReq
[String
"env-file"]
((String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
KernelspecEnvFile)
String
"<file>"
String
"Load environment from this file when kernel is installed"
confFlag :: Flag Args
confFlag :: Flag Args
confFlag = forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"conf", String
"c"] ((String -> Argument) -> String -> Args -> Either String 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 = forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"prefix"] ((String -> Argument) -> String -> Args -> Either String 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 = 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 forall a b. (a -> b) -> a -> b
$ Argument
flag forall a. a -> [a] -> [a]
: [Argument]
flags
store :: (String -> Argument) -> String -> Args -> Either String Args
store :: (String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
constructor String
str (Args IHaskellMode
md [Argument]
prev) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md forall a b. (a -> b) -> a -> b
$ String -> Argument
constructor String
str forall a. a -> [a] -> [a]
: [Argument]
prev
installKernelSpec :: Mode Args
installKernelSpec :: Mode Args
installKernelSpec =
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." forall a. Arg a
noArgs
[Flag Args
ghcLibFlag, Flag Args
ghcRTSFlag, Flag Args
kernelDebugFlag, Flag Args
confFlag, Flag Args
installPrefixFlag, Flag Args
helpFlag, Flag Args
kernelStackFlag, Flag Args
kernelEnvFileFlag]
kernel :: Mode Args
kernel :: Mode Args
kernel = forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
"kernel" (IHaskellMode -> [Argument] -> Args
Args (Maybe String -> IHaskellMode
Kernel 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
kernelEnvFileFlag, Flag Args
kernelCodeMirrorFlag]
where
kernelArg :: Arg Args
kernelArg = forall a. Update a -> String -> Arg a
flagArg 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) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args (Maybe String -> IHaskellMode
Kernel forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
filename) [Argument]
flags
convert :: Mode Args
convert :: Mode Args
convert = 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 = [ forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"input", String
"i"] ((String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
ConvertFrom) String
"<file>" String
"File to read."
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"output", String
"o"] ((String -> Argument) -> String -> Args -> Either String Args
store String -> Argument
ConvertTo) String
"<file>" String
"File to write."
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"from", String
"f"] ((NotebookFormat -> Argument)
-> String -> Args -> Either String Args
storeFormat NotebookFormat -> Argument
ConvertFromFormat) String
"lhs|ipynb"
String
"Format of the file to read."
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"to", String
"t"] ((NotebookFormat -> Argument)
-> String -> Args -> Either String Args
storeFormat NotebookFormat -> Argument
ConvertToFormat) String
"lhs|ipynb"
String
"Format of the file to write."
, forall a. [String] -> (a -> a) -> String -> Flag a
flagNone [String
"force"] Args -> Args
consForce String
"Overwrite existing files with output."
, forall a. [String] -> Update a -> String -> String -> Flag a
flagReq [String
"style", String
"s"] String -> Args -> Either String Args
storeLhs String
"bird|tex"
String
"Type of markup used for the literate haskell file"
, forall a. [String] -> (a -> a) -> String -> Flag a
flagNone [String
"bird"] (LhsStyle String -> Args -> Args
consStyle LhsStyle String
lhsStyleBird) String
"Literate haskell uses >"
, 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 forall a. a -> [a] -> [a]
: [Argument]
prev)
unnamedArg :: Arg Args
unnamedArg = forall a. Update a -> String -> Bool -> Arg a
Arg ((String -> Argument) -> String -> Args -> Either String 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 forall a. a -> [a] -> [a]
: [Argument]
prev)
storeFormat :: (NotebookFormat -> Argument)
-> String -> Args -> Either String 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" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md forall a b. (a -> b) -> a -> b
$ NotebookFormat -> Argument
constructor NotebookFormat
LhsMarkdown forall a. a -> [a] -> [a]
: [Argument]
prev
Text
"ipynb" -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ IHaskellMode -> [Argument] -> Args
Args IHaskellMode
md forall a b. (a -> b) -> a -> b
$ NotebookFormat -> Argument
constructor NotebookFormat
IpynbFile forall a. a -> [a] -> [a]
: [Argument]
prev
Text
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Unknown format requested: " forall a. [a] -> [a] -> [a]
++ String
str
storeLhs :: String -> Args -> Either String Args
storeLhs String
str Args
previousArgs =
case Text -> Text
T.toLower (String -> Text
T.pack String
str) of
Text
"bird" -> forall {a}. LhsStyle String -> Either a Args
success LhsStyle String
lhsStyleBird
Text
"tex" -> forall {a}. LhsStyle String -> Either a Args
success LhsStyle String
lhsStyleTex
Text
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Unknown lhs style: " forall a. [a] -> [a] -> [a]
++ String
str
where
success :: LhsStyle String -> Either a Args
success LhsStyle String
lhsStyle = forall a b. b -> Either a b
Right 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 = forall string.
string
-> string
-> string
-> string
-> string
-> string
-> LhsStyle string
LhsStyle String
"> " String
"\n<< " String
"" String
"" String
"" String
""
lhsStyleTex :: LhsStyle String
lhsStyleTex = 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 = forall a. String -> a -> String -> Arg a -> [Flag a] -> Mode a
mode String
"IHaskell" Args
defaultReport String
descr 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 = 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) forall a b. (a -> b) -> a -> b
$ forall a. [String] -> HelpFormat -> Mode a -> [Text]
helpText [] HelpFormat
HelpFormatAll Mode Args
ihaskellArgs
in Mode Args
noMode { modeGroupModes :: Group (Mode Args)
modeGroupModes = forall a. [a] -> Group a
toGroup [Mode Args]
allModes }
noArgs :: Arg a
noArgs :: forall a. Arg a
noArgs = forall a. Update a -> String -> Arg a
flagArg forall {a}. String -> a
unexpected String
""
where
unexpected :: String -> a
unexpected String
a = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unexpected argument: " forall a. [a] -> [a] -> [a]
++ String
a