module Control.Biegunka.Options
( options
, parser
, constructorOptions
, constructorOption
, constructorName
, transformConstructor
) where
import Control.Lens
import Control.Monad ((>=>))
import Data.Char (isUpper, toLower)
import Data.Foldable (asum)
import Data.Map (Map)
import Data.Monoid (Monoid, mempty)
import Data.Traversable (mapAccumL)
import Data.Tuple (swap)
import Data.Data (Data, toConstr)
import Options.Applicative hiding ((&))
import System.Exit (exitWith)
import Control.Biegunka.Biegunka (biegunka, confirm)
import Control.Biegunka.Settings (Settings, Mode(Offline), mode)
import Control.Biegunka.Execute (run, dryRun)
import Control.Biegunka.Language (Scope(Sources))
import Control.Biegunka.Check (check)
import Control.Biegunka.Script (Script)
type Runner a = (Settings () -> Settings ()) -> Script Sources () -> IO a
options :: Data a => [a] -> IO (a, Runner b)
options xs = execParser (info (helper <*> parser xs) fullDesc)
parser :: Data a => [a] -> Parser (a, Runner b)
parser xs = (\os i f -> (os, \g -> biegunka (g . f) i >=> exitWith))
<$> constructorOptions xs
<*> interpreters
<*> modes
where
interpreters = asum
[ flag' dryRun (long "changes" <> help "List script changes")
, flag' safeRun (long "run" <> help "Run script")
, flag' check (long "problems" <> help "List problematic filepaths")
, flag' run (long "force" <> help "Run script without confirmation")
, flag' allRun (long "all" <> help "A combination of --dry-run, --run, and --problems")
, pure allRun
]
allRun = dryRun <> safeRun <> check
safeRun = confirm <> run
modes = asum
[ flag' (set mode Offline) (long "offline" <> help "Run script offline")
, flag' id (long "online" <> help "Run script online")
, pure id
]
constructorOptions :: Data a => [a] -> Parser a
constructorOptions = asum . mapAccumL_ constructorOption where
mapAccumL_ :: (Traversable t, Monoid m) => (m -> a -> (m, b)) -> t a -> t b
mapAccumL_ f = snd . mapAccumL f mempty
constructorOption :: Data a => Map String Int -> a -> (Map String Int, Parser a)
constructorOption acc x = flag' x . long <$> constructorNameSuffixed acc x
constructorNameSuffixed :: Data a => Map String Int -> a -> (Map String Int, String)
constructorNameSuffixed acc x =
let
n = constructorName x
incr = at n.non 0 <<%~ succ
in
acc & incr & swap <&> \p -> if p == 0 then n else concat [n, "-", show p]
constructorName :: Data a => a -> String
constructorName = transformConstructor . show . toConstr
transformConstructor :: String -> String
transformConstructor (x:xs) = toLower x : concatMap transformChar xs
where
transformChar :: Char -> String
transformChar y
| isUpper y = ['-', toLower y]
| otherwise = [y]
transformConstructor [] = []