{-# LANGUAGE DeriveDataTypeable #-}

module Up.Options (
    UpOptions(..),
    PathType(..),
    Separator(..),
    BasePath(..),
    parseOptions,
) where


import Control.Monad.State.Strict
import Data.List
import Data.Typeable
import Text.LambdaOptions


--------------------------------------------------------------------------------


data Separator = ForwardSlash | BackSlash
    deriving (Typeable)


data PathType
    = AbsolutePath
    | RelativePath


data BasePath
    = CurrPath
    | GivenPath FilePath


data UpOptions = UpOptions {
    optionHelp :: Maybe String,
    optionBasePath :: BasePath,
    optionUpBy :: Maybe (PathType, Int),
    optionUpTo :: Maybe (PathType, FilePath),
    optionSeparator :: Separator,
    optionPathType :: Maybe PathType,
    optionIgnoreCase :: Bool,
    optionActionCount :: Int
} deriving ()


--------------------------------------------------------------------------------


newtype DotInt = DotInt { unDotInt :: Int }
    deriving (Typeable)


instance Parseable DotInt where
    parse args = case args of
        arg : _ -> case span (== '.') arg of
            (dots@('.' : _), []) -> (Just $ DotInt $ length dots - 1, 1)
            _ -> case parse args of
                (Just num, n) -> (Just $ DotInt num, n)
                _ -> (Nothing, 0)
        [] -> (Nothing, 0)


instance Parseable Separator where
    parse args = case args of
        arg : _ -> case arg of
            "forward" -> (Just ForwardSlash, 1)
            "backward" -> (Just BackSlash, 1)
            _ -> (Nothing, 0)


--------------------------------------------------------------------------------


incActionCount :: State UpOptions ()
incActionCount = modify $ \st -> st { optionActionCount = optionActionCount st + 1 }


options :: Options (State UpOptions) ()
options = do
    addOption (kw ["--help", "-h"] `text` "Display this help message.") $ \(HelpDescription desc) -> do
        modify $ \st -> st { optionHelp = Just $ usage desc }
    addOption (kw ["--relative", "-r"] `text` "Emit the path as a relative path.") $ do
        modify $ \st -> st { optionPathType = Just RelativePath }
    addOption (kw ["--absolute", "-a"] `text` "Emit the path as an absolute path.") $ do
        modify $ \st -> st { optionPathType = Just AbsolutePath }
    addOption (kw ["--separator", "-s"] `argText` "(forward|back)" `text` "The type of file separator to emit. If this option is not supplied, the emitted separator will be compliant with the program's operating system.") $ \sep -> do
        modify $ \st -> st { optionSeparator = sep }
    addOption (kw ["--ignore-case", "-i"] `text` "Ignore case when matching strings.") $ do
        modify $ \st -> st { optionIgnoreCase = True }
    addOption (kw ["--from-by", "-m"] `argText` "DIR AMOUNT" `text` "Goes up DIR by AMOUNT. Emits an absolute path by default.") $ \dir n -> do
        modify $ \st -> st { optionBasePath = GivenPath dir, optionUpBy = Just (AbsolutePath, unDotInt n) }
        incActionCount
    addOption (kw ["--by", "-n"] `argText` "AMOUNT" `text` "Goes up the current directory by AMOUNT. Emits a relative path by default.") $ \n -> do
        modify $ \st -> st { optionBasePath = CurrPath, optionUpBy = Just (RelativePath, unDotInt n) }
        incActionCount
    addOption (kw ["--from-to", "-f"] `argText` "DIR PATHPART" `text` "Goes up DIR until PATHPART is hit. Emits an absolute path by default.") $ \dir part -> do
        modify $ \st -> st { optionBasePath = GivenPath dir, optionUpTo = Just (AbsolutePath, part) }
        incActionCount
    addOption (kw ["--to", "-t"] `argText` "PATHPART" `text` "Goes up the current directory until PATHPART is hit. Emits a relative path by default.") $ \dir part -> do
        modify $ \st -> st { optionBasePath = GivenPath dir, optionUpTo = Just (RelativePath, part) }
        incActionCount


usage :: String -> String
usage helpDesc = intercalate "\n" [
    fit "Usage: up [OPTION]",
    fit "Emits a path to go up a certain amount of directories based on [OPTION].",
    fit line,
    helpDesc,
    fit line,
    fit "In the above options, AMOUNT can be of two forms. (1) a non-negative integer. (2) a series of consecutive '.' (dot) characters. Case (2) is the same as (1) if AMOUNT were the number of dots minus one.",
    fit line,
    fit "The following flags do not need to be explicitly written and can be implied: --by, --to. If AMOUNT is supplied, --by is chosen. In all other cases, --to is chosen." ]
    where
        line = replicate 80 '-'
        fit = fitToOptions options


--------------------------------------------------------------------------------


initialState :: Separator -> UpOptions
initialState sep = UpOptions {
    optionHelp = Nothing,
    optionBasePath = CurrPath,
    optionUpBy = Nothing,
    optionUpTo = Nothing,
    optionSeparator = sep,
    optionPathType = Nothing,
    optionIgnoreCase = False,
    optionActionCount = 0 }


parseOptions :: Separator -> [String] -> Either String UpOptions
parseOptions sep args = case runOptions options args of
    Left (ParseFailed msg _ _) -> Left $ msg ++ "\n" ++ help
    Right m -> case execState m $ initialState sep of
        st -> case optionHelp st of
            Just _ -> Right st
            Nothing -> case optionActionCount st of
                1 -> Right st
                0 -> Left help
                _ -> Left $ "Please only supply one mode at a time.\n" ++ help
    where
        help = usage $ getHelpDescription options