module DepGraph.Cli

import Data.List1
import Data.String
import System

%default total

public export
record ModOpts where
  constructor MkModOpts
  withExternal : Bool

public export
record PkgOpts where
  constructor MkPkgOpts
  localOnly : Bool

||| CLOpt - possible command line options
public export
data CLOpt
  =
  ||| Module import graph
  Module ModOpts |
  ||| Package dependency graph
  Package PkgOpts |
  ||| The input Idris file
  InputFile String |
  ||| Display help text
  Help |
  ||| Display app version
  Version

data OptType
  = Required String
  | Optional String
  | Flag String

public export
data SubCmd =
  ||| Module import graph
  SubCmdMod ModOpts |
  ||| Package dependency graph
  SubCmdPkg PkgOpts

Show OptType where
  show (Required a) = "<" ++ a ++ ">"
  show (Optional a) = "[" ++ a ++ "]"
  show (Flag a) = "[--" ++ a ++ "]"

ActType : List OptType -> Type
ActType [] = List CLOpt
ActType (Required a :: as) = String -> ActType as
ActType (Optional a :: as) = Maybe String -> ActType as
ActType (Flag a :: as) = Bool -> ActType as

record OptDesc where
  constructor MkOpt
  flags : List String
  argdescs : List OptType
  action : ActType argdescs
  help : Maybe String

optSeparator : OptDesc
optSeparator = MkOpt [] [] [] Nothing

showDefault : Show a => a -> String
showDefault x = "(default " ++ show x ++ ")"

options : List OptDesc
options =
  [ MkOpt ["package", "pkg", "p"] [Flag "local-only"]
      (\localOnly => [Package $ MkPkgOpts {localOnly}])
      (Just "(default) Generate a package dependency graph")
  , MkOpt ["module", "mod", "m"] [Flag "with-external"]
      (\withExternal => [Module $ MkModOpts {withExternal}])
      (Just "Generate a module import graph")
  , MkOpt ["--help", "-h", "-?"] [] [Help]
      (Just "Display help text")
  , MkOpt ["--version", "-v"] [] [Version]
      (Just "Display version string")
  ]

optShow : OptDesc -> (String, Maybe String)
optShow (MkOpt [] _ _ _) = ("", Just "")
optShow (MkOpt flags argdescs action help) =
  (showSep ", " flags ++ " " ++ showSep " " (map show argdescs), help)
  where
    showSep : String -> List String -> String
    showSep sep [] = ""
    showSep sep [x] = x
    showSep sep (x :: xs) = x ++ sep ++ showSep sep xs

firstColumnWidth : Nat
firstColumnWidth = foldr max 0 $ map (length . fst . optShow) options

makeTextFromOptionsOrEnvs : List (String, Maybe String) -> String
makeTextFromOptionsOrEnvs rows = concatMap (optUsage firstColumnWidth) rows
  where
    optUsage : Nat -> (String, Maybe String) -> String
    optUsage maxOpt (optshow, help) =
      maybe
        ""  -- Don't show anything if there's no help string (that means
            -- it's an internal option)
        (\h =>
          "  " ++ optshow ++
          pack (List.replicate (minus (maxOpt + 2) (length optshow)) ' ') ++
          h ++ "\n")
        help

optsUsage : String
optsUsage = makeTextFromOptionsOrEnvs $ map optShow options

-- TODO get version from .ipkg
export
versionMsg : String
versionMsg = "Dep-graph version 0.1.0"

export
usage : String
usage = """
  \{ versionMsg }
  Usage: dep-graph [options] [ipkg file...]

  Available options:
  \{ optsUsage }
  """

processArgs : String -> (args : List OptType) -> List String -> ActType args ->
              Either String (List CLOpt, List String)
processArgs flag [] xs f = Right (f, xs)
-- Missing required arguments
processArgs flag (opt@(Required _) :: as) [] f =
  Left $ "Missing required argument " ++ show opt ++ " for flag " ++ flag
processArgs flag (Optional a :: as) [] f =
  processArgs flag as [] (f Nothing)
processArgs flag (Flag a :: as) [] f =
  processArgs flag as [] (f False)
-- Happy cases
processArgs flag (Required a :: as) (x :: xs) f =
  processArgs flag as xs (f x)
processArgs flag (Optional a :: as) (x :: xs) f =
  if isPrefixOf "-" x
    then processArgs flag as (x :: xs) (f Nothing)
    else processArgs flag as xs (f $ Just x)
processArgs flag (Flag a :: as) (x :: xs) f =
  if x == "--" ++ a
    then processArgs flag as xs (f True)
    else processArgs flag as (x :: xs) (f False)

matchFlag : (d : OptDesc) -> List String ->
            Either String (Maybe (List CLOpt, List String))
matchFlag d [] = Right Nothing -- Nothing left to match
matchFlag d (x :: xs) =
  if x `elem` flags d
    then do
      args <- processArgs x (argdescs d) xs (action d)
      Right (Just args)
    else Right Nothing

findMatch : List OptDesc -> List String ->
            Either String (List CLOpt, List String)
findMatch [] [] = Right ([], [])
findMatch [] (f :: args) =
  case unpack f of
    '-' :: '-' :: _ => Left "Unknown flag \{f}"
    _ => Right ([InputFile f], args)
findMatch (d :: ds) args =
  case !(matchFlag d args) of
    Nothing => findMatch ds args
    Just res => Right res

parseOpts : List OptDesc -> List String -> Either String (List CLOpt)
parseOpts opts [] = Right []
parseOpts opts args = do
  (cl, rest) <- findMatch opts args
  cls <- assert_total (parseOpts opts rest) -- 'rest' smaller than 'args'
  pure (cl ++ cls)

export
getCmdOpts : IO (Either String (List CLOpt))
getCmdOpts = do
  (_ :: opts) <- getArgs
    | _ => pure (Left "Invalid command line")
  pure $ parseOpts options opts

export
findInputs : List CLOpt -> List String
findInputs [] = []
findInputs (InputFile f :: fs) = f :: findInputs fs
findInputs (_ :: fs) = findInputs fs

export
quitOpts : List CLOpt -> IO Bool
quitOpts [] = pure True
quitOpts (Version :: _) = do
  putStrLn versionMsg
  pure False
quitOpts (Help :: _) = do
  putStrLn usage
  pure False
quitOpts (_ :: opts) = quitOpts opts

export
subCmd : List CLOpt -> SubCmd
subCmd [] = SubCmdPkg $ MkPkgOpts {localOnly = False} -- default
subCmd (Module opts :: _) = SubCmdMod opts
subCmd (Package opts :: _) = SubCmdPkg opts
subCmd (f :: fs) = subCmd fs