{-# LANGUAGE GADTs, Rank2Types #-}
module Terminal.Chomp
  ( chomp
  )
  where


import qualified Data.List as List

import Terminal.Error
import Terminal.Internal



-- CHOMP INTERFACE


chomp :: Maybe Int -> [String] -> Args args -> Flags flags -> ( IO [String], Either Error (args, flags) )
chomp maybeIndex strings args flags =
  let
    (Chomper flagChomper) =
      chompFlags flags

    ok suggest chunks flagValue =
      fmap (flip (,) flagValue) <$> chompArgs suggest chunks args

    err suggest flagError =
      ( addSuggest (return []) suggest, Left (BadFlag flagError) )
  in
  flagChomper (toSuggest maybeIndex) (toChunks strings) ok err


toChunks :: [String] -> [Chunk]
toChunks strings =
  zipWith Chunk [ 1 .. length strings ] strings


toSuggest :: Maybe Int -> Suggest
toSuggest maybeIndex =
  case maybeIndex of
    Nothing ->
      NoSuggestion

    Just index ->
      Suggest index



-- CHOMPER


newtype Chomper x a =
  Chomper (
    forall result.
      Suggest
      -> [Chunk]
      -> (Suggest -> [Chunk] -> a -> result)
      -> (Suggest -> x -> result)
      -> result
  )


data Chunk =
  Chunk
    { _index :: Int
    , _chunk :: String
    }


data Suggest
  = NoSuggestion
  | Suggest Int
  | Suggestions (IO [String])


makeSuggestion :: Suggest -> (Int -> Maybe (IO [String])) -> Suggest
makeSuggestion suggest maybeUpdate =
  case suggest of
    NoSuggestion ->
      suggest

    Suggestions _ ->
      suggest

    Suggest index ->
      maybe suggest Suggestions (maybeUpdate index)



-- ARGS


chompArgs :: Suggest -> [Chunk] -> Args a -> (IO [String], Either Error a)
chompArgs suggest chunks (Args completeArgsList) =
  chompArgsHelp suggest chunks completeArgsList [] []


chompArgsHelp :: Suggest -> [Chunk] -> [CompleteArgs a] -> [Suggest] -> [(CompleteArgs a, ArgError)] -> (IO [String], Either Error a)
chompArgsHelp suggest chunks completeArgsList revSuggest revArgErrors =
  case completeArgsList of
    [] ->
      ( foldl addSuggest (return []) revSuggest
      , Left (BadArgs (reverse revArgErrors))
      )

    completeArgs : others ->
      case chompCompleteArgs suggest chunks completeArgs of
        (s1, Left argError) ->
          chompArgsHelp suggest chunks others (s1:revSuggest) ((completeArgs,argError):revArgErrors)

        (s1, Right value) ->
          ( addSuggest (return []) s1
          , Right value
          )


addSuggest :: IO [String] -> Suggest -> IO [String]
addSuggest everything suggest =
  case suggest of
    NoSuggestion ->
      everything

    Suggest _ ->
      everything

    Suggestions newStuff ->
      (++) <$> newStuff <*> everything



-- COMPLETE ARGS


chompCompleteArgs :: Suggest -> [Chunk] -> CompleteArgs a -> (Suggest, Either ArgError a)
chompCompleteArgs suggest chunks completeArgs =
  let
    numChunks = length chunks
  in
  case completeArgs of
    Exactly requiredArgs ->
      chompExactly suggest chunks (chompRequiredArgs numChunks requiredArgs)

    Optional requiredArgs parser ->
      chompOptional suggest chunks (chompRequiredArgs numChunks requiredArgs) parser

    Multiple requiredArgs parser ->
      chompMultiple suggest chunks (chompRequiredArgs numChunks requiredArgs) parser


chompExactly :: Suggest -> [Chunk] -> Chomper ArgError a -> (Suggest, Either ArgError a)
chompExactly suggest chunks (Chomper chomper) =
  let
    ok s cs value =
      case map _chunk cs of
        [] -> (s, Right value)
        es -> (s, Left (ArgExtras es))

    err s argError =
      (s, Left argError)
  in
  chomper suggest chunks ok err


chompOptional :: Suggest -> [Chunk] -> Chomper ArgError (Maybe a -> b) -> Parser a -> (Suggest, Either ArgError b)
chompOptional suggest chunks (Chomper chomper) parser =
  let
    ok s1 cs func =
      case cs of
        [] ->
          (s1, Right (func Nothing))

        Chunk index string : others ->
          case tryToParse s1 parser index string of
            (s2, Left expectation) ->
              (s2, Left (ArgBad string expectation))

            (s2, Right value) ->
              case map _chunk others of
                [] -> (s2, Right (func (Just value)))
                es -> (s2, Left (ArgExtras es))

    err s1 argError =
      (s1, Left argError)
  in
  chomper suggest chunks ok err


chompMultiple :: Suggest -> [Chunk] -> Chomper ArgError ([a] -> b) -> Parser a -> (Suggest, Either ArgError b)
chompMultiple suggest chunks (Chomper chomper) parser =
  let
    err s1 argError =
      (s1, Left argError)
  in
  chomper suggest chunks (chompMultipleHelp parser []) err


chompMultipleHelp :: Parser a -> [a] -> Suggest -> [Chunk] -> ([a] -> b) -> (Suggest, Either ArgError b)
chompMultipleHelp parser revArgs suggest chunks func =
  case chunks of
    [] ->
      (suggest, Right (func (reverse revArgs)))

    Chunk index string : otherChunks ->
      case tryToParse suggest parser index string of
        (s1, Left expectation) ->
          (s1, Left (ArgBad string expectation))

        (s1, Right arg) ->
          chompMultipleHelp parser (arg:revArgs) s1 otherChunks func



-- REQUIRED ARGS


chompRequiredArgs :: Int -> RequiredArgs a -> Chomper ArgError a
chompRequiredArgs numChunks args =
  case args of
    Done value ->
      return value

    Required funcArgs argParser ->
      do  func <- chompRequiredArgs numChunks funcArgs
          arg <- chompArg numChunks argParser
          return (func arg)


chompArg :: Int -> Parser a -> Chomper ArgError a
chompArg numChunks parser@(Parser singular _ _ _ toExamples) =
  Chomper $ \suggest chunks ok err ->
    case chunks of
      [] ->
        let
          newSuggest = makeSuggestion suggest (suggestArg parser numChunks)
          theError = ArgMissing (Expectation singular (toExamples ""))
        in
        err newSuggest theError

      Chunk index string : otherChunks ->
        case tryToParse suggest parser index string of
          (newSuggest, Left expectation) ->
            err newSuggest (ArgBad string expectation)

          (newSuggest, Right arg) ->
            ok newSuggest otherChunks arg


suggestArg :: Parser a -> Int -> Int -> Maybe (IO [String])
suggestArg (Parser _ _ _ toSuggestions _) numChunks targetIndex =
  if numChunks <= targetIndex then
    Just (toSuggestions "")
  else
    Nothing



-- PARSER


tryToParse :: Suggest -> Parser a -> Int -> String -> (Suggest, Either Expectation a)
tryToParse suggest (Parser singular _ parse toSuggestions toExamples) index string =
  let
    newSuggest =
      makeSuggestion suggest $ \targetIndex ->
        if index == targetIndex then Just (toSuggestions string) else Nothing

    outcome =
      case parse string of
        Nothing ->
          Left (Expectation singular (toExamples string))

        Just value ->
          Right value
  in
  (newSuggest, outcome)



-- FLAGS


chompFlags :: Flags a -> Chomper FlagError a
chompFlags flags =
  do  value <- chompFlagsHelp flags
      checkForUnknownFlags flags
      return value


chompFlagsHelp :: Flags a -> Chomper FlagError a
chompFlagsHelp flags =
  case flags of
    FDone value ->
      return value

    FMore funcFlags argFlag ->
      do  func <- chompFlagsHelp funcFlags
          arg <- chompFlag argFlag
          return (func arg)



-- FLAG


chompFlag :: Flag a -> Chomper FlagError a
chompFlag flag =
  case flag of
    OnOff flagName _ ->
      chompOnOffFlag flagName

    Flag flagName parser _ ->
      chompNormalFlag flagName parser


chompOnOffFlag :: String -> Chomper FlagError Bool
chompOnOffFlag flagName =
  Chomper $ \suggest chunks ok err ->
    case findFlag flagName chunks of
      Nothing ->
        ok suggest chunks False

      Just (FoundFlag before value after) ->
        case value of
          DefNope ->
            ok suggest (before ++ after) True

          Possibly chunk ->
            ok suggest (before ++ chunk : after) True

          Definitely _ string ->
            err suggest (FlagWithValue flagName string)


chompNormalFlag :: String -> Parser a -> Chomper FlagError (Maybe a)
chompNormalFlag flagName parser@(Parser singular _ _ _ toExamples) =
  Chomper $ \suggest chunks ok err ->
    case findFlag flagName chunks of
      Nothing ->
        ok suggest chunks Nothing

      Just (FoundFlag before value after) ->
        let
          attempt index string =
            case tryToParse suggest parser index string of
              (newSuggest, Left expectation) ->
                err newSuggest (FlagWithBadValue flagName string expectation)

              (newSuggest, Right flagValue) ->
                ok newSuggest (before ++ after) (Just flagValue)
        in
        case value of
          Definitely index string ->
            attempt index string

          Possibly (Chunk index string) ->
            attempt index string

          DefNope ->
            err suggest (FlagWithNoValue flagName (Expectation singular (toExamples "")))



-- FIND FLAG


data FoundFlag =
  FoundFlag
    { _before :: [Chunk]
    , _value :: Value
    , _after :: [Chunk]
    }


data Value
  = Definitely Int String
  | Possibly Chunk
  | DefNope


findFlag :: String -> [Chunk] -> Maybe FoundFlag
findFlag flagName chunks =
  findFlagHelp [] ("--" ++ flagName) ("--" ++ flagName ++ "=") chunks


findFlagHelp :: [Chunk] -> String -> String -> [Chunk] -> Maybe FoundFlag
findFlagHelp revPrev loneFlag flagPrefix chunks =
  let
    succeed value after =
      Just (FoundFlag (reverse revPrev) value after)

    deprefix string =
      drop (length flagPrefix) string
  in
  case chunks of
    [] ->
      Nothing

    chunk@(Chunk index string) : rest ->
      if List.isPrefixOf flagPrefix string then
        succeed (Definitely index (deprefix string)) rest

      else if string /= loneFlag then
        findFlagHelp (chunk:revPrev) loneFlag flagPrefix rest

      else
        case rest of
          [] ->
            succeed DefNope []

          argChunk@(Chunk _ potentialArg) : restOfRest ->
            if List.isPrefixOf "-" potentialArg then
              succeed DefNope rest
            else
              succeed (Possibly argChunk) restOfRest



-- CHECK FOR UNKNOWN FLAGS


checkForUnknownFlags :: Flags a -> Chomper FlagError ()
checkForUnknownFlags flags =
  Chomper $ \suggest chunks ok err ->
    case filter startsWithDash chunks of
      [] ->
        ok suggest chunks ()

      unknownFlags@(Chunk _ unknownFlag : _) ->
        err
          (makeSuggestion suggest (suggestFlag unknownFlags flags))
          (FlagUnknown unknownFlag flags)


suggestFlag :: [Chunk] -> Flags a -> Int -> Maybe (IO [String])
suggestFlag unknownFlags flags targetIndex =
  case unknownFlags of
    [] ->
      Nothing

    Chunk index string : otherUnknownFlags ->
      if index == targetIndex then
        Just (return (filter (List.isPrefixOf string) (getFlagNames flags [])))
      else
        suggestFlag otherUnknownFlags flags targetIndex


startsWithDash :: Chunk -> Bool
startsWithDash (Chunk _ string) =
  List.isPrefixOf "-" string


getFlagNames :: Flags a -> [String] -> [String]
getFlagNames flags names =
  case flags of
    FDone _ ->
      "--help" : names

    FMore subFlags flag ->
      getFlagNames subFlags (getFlagName flag : names)


getFlagName :: Flag a -> String
getFlagName flag =
  case flag of
    Flag name _ _ ->
      "--" ++ name

    OnOff name _ ->
      "--" ++ name



-- CHOMPER INSTANCES


instance Functor (Chomper x) where
  fmap func (Chomper chomper) =
    Chomper $ \i w ok err ->
      let
        ok1 s1 cs1 value =
          ok s1 cs1 (func value)
      in
      chomper i w ok1 err


instance Applicative (Chomper x) where
  pure value =
    Chomper $ \ss cs ok _ ->
      ok ss cs value

  (<*>) (Chomper funcChomper) (Chomper argChomper) =
    Chomper $ \s cs ok err ->
      let
        ok1 s1 cs1 func =
          let
            ok2 s2 cs2 value =
              ok s2 cs2 (func value)
          in
          argChomper s1 cs1 ok2 err
      in
      funcChomper s cs ok1 err


instance Monad (Chomper x) where
  return = pure

  (>>=) (Chomper aChomper) callback =
    Chomper $ \s cs ok err ->
      let
        ok1 s1 cs1 a =
          case callback a of
            Chomper bChomper -> bChomper s1 cs1 ok err
      in
      aChomper s cs ok1 err