{-# LANGUAGE UnicodeSyntax, PatternGuards #-}

-- | Module for parsing command line options and build queries. These functions
-- are used by default, but user can supply his own functions.
module Todos.Default.CmdLine
  (parseCmdLine',
   glob,
   buildQuery,
   compose,
   usage)
  where

import Prelude hiding (putStrLn,readFile,getContents,print)
import Prelude.Unicode
import System.Console.GetOpt
import System.FilePath.Glob hiding (glob)
import Data.Maybe
import Data.List (sort)

import Todos.IO
import Todos.Types
import Todos.Tree
import Todos.Default.Config
import Todos.Dates (parseDate)

-- | Compose predicate from Composed
compose โˆท DateTime       -- ^ Current date/time
        โ†’ Composed       -- ^ Composed query
        โ†’ (TodoItem โ†’ ๐”น)
compose _ Empty             = const True
compose _ (Pred NoFilter)   = const True
compose _ (Pred (Tag s))    = tagPred s
compose _ (Pred (Name s))   = grepPred s
compose _ (Pred (Description s))   = descPred s
compose _ (Pred (Status s)) = statusPred s
compose _ (Pred (IdIs s)) = idPred s
compose dt (Pred (StartDateIs d)) = datePred startDate dt d
compose dt (Pred (EndDateIs d)) = datePred endDate dt d
compose dt (Pred (DeadlineIs d)) = datePred deadline dt d
compose dt (Not p)           = not โˆ˜ (compose dt p)
compose dt (And (Pred NoFilter) p) = compose dt p
compose dt (And p (Pred NoFilter)) = compose dt p
compose dt (And p1 p2)      = \item โ†’ (compose dt p1 item) โˆง (compose dt p2 item)
compose dt (Or (Pred NoFilter) p) = compose dt p
compose dt (Or p (Pred NoFilter)) = compose dt p
compose dt (Or p1 p2)       = \item โ†’ (compose dt p1 item) โˆจ (compose dt p2 item)
compose _ x = error $ show x

appendC โˆท Composed โ†’ QueryFlag โ†’ Composed
appendC (Not (Pred NoFilter))   f = Not (Pred f)
appendC Empty OrCons              = (Pred NoFilter) `Or` (Pred NoFilter)
appendC Empty AndCons             = (Pred NoFilter) `And` (Pred NoFilter)
appendC Empty NotCons             = Not (Pred NoFilter)
appendC Empty f                   = Pred f
appendC c NoFilter                = c
appendC c AndCons                 = c `And` (Pred NoFilter)
appendC c OrCons                  = c `Or`  (Pred NoFilter)
appendC c NotCons                 = c `And` (Pred NoFilter)
appendC (And c (Pred NoFilter)) f = c `And` (Pred f) 
appendC (And (Pred NoFilter) c) f = c `And` (Pred f) 
appendC c@(And _ _)             f = c `And` (Pred f)
appendC (Or c (Pred NoFilter))  f = c `Or`  (Pred f)
appendC (Or (Pred NoFilter) c)  f = c `Or`  (Pred f)
appendC c@(Or _ _)              f = c `Or`  (Pred f)
appendC c@(Pred _)              f = c `And` (Pred f)
appendC c                       f = c `And` (Pred f)

appendF โˆท Options โ†’ CmdLineFlag โ†’ Options
appendF (O q m o l) (QF f) = O (f:q) m o l
appendF (O q m o l) (MF f) = O q (f:m) o l
appendF (O q m o l) (OF f) = O q m (f:o) l
appendF (O q m o l) (LF f) = O q m o (f:l)
appendF _ HelpF = Help
appendF Help _  = Help

parseFlags โˆท [CmdLineFlag] โ†’ Options
parseFlags lst | HelpF โˆˆ lst = Help
parseFlags [] = O [] [] [] []
parseFlags (f:fs) = (parseFlags fs) `appendF` f

-- | Build DefaultConfig (with query etc) from Options
buildQuery โˆท BaseConfig    -- ^ Default config
           โ†’ Options       -- ^ Cmdline options
           โ†’ DefaultConfig
buildQuery _ Help = error "Internal error: buildQuery does no sense for Help!"
buildQuery dc (O qflags mflags oflags lflags) =
    DConfig {
      baseConfig = BConfig {
          outOnlyFirst = update outOnlyFirst onlyFirst,
          outColors    = update outColors    colors,
          outIds       = update outIds       showIds,
          outHighlight = update outHighlight highlight,
          sorting      = update sorting      srt,
          pruneL       = update pruneL       limitP,
          minL         = update minL         limitM,
          commandToRun = update commandToRun command,
          prefix       = update prefix       aprefix,
          outputFormat = update outputFormat dformat,
          indentString = update indentString indent,
          skipStatus   = update skipStatus   noStatus,
          groupByFile  = update groupByFile  doGroupByFile,
          groupByTag   = update groupByTag   doGroupByTag,
          groupByStatus = update groupByStatus doGroupByStatus,
          forcedStatus = update forcedStatus setStatus,
          topStatus    = update topStatus    setTopStatus },
      query        = fromMaybe Empty composedFlags }
  where
    update fn Nothing  = fn dc
    update _  (Just x) = x

    x ? lst | x โˆˆ lst   = Just True
            | otherwise = Nothing

    composedFlags | null qflags = Nothing
                  | otherwise   = Just $ parseQuery qflags
    (limitP,limitM) | null lflags = (Nothing, Nothing)
                    | otherwise   = parseLimits (unLimit $ pruneL dc) (unLimit $ minL dc) lflags

    onlyFirst = OnlyFirst ? oflags
    colors    = Colors    ? oflags
    highlight = Highlight ? oflags
    showIds   = Ids       ? oflags

    srtFlags = filter isSort oflags
    srt | null srtFlags = Nothing
        | otherwise     = Just $ getSorting (last srtFlags)

    doGroupByFile   = GroupByFile   ? mflags
    doGroupByTag    = GroupByTag    ? mflags
    doGroupByStatus = GroupByStatus ? mflags

    cmdFlags  = filter isCommand mflags
    command | DotExport โˆˆ oflags = Just $ ShowAsDot
            | null cmdFlags      = Nothing
            | otherwise          = Just $ SystemCommand $ unExecute (last cmdFlags)

    prefixFlags = filter isPrefix mflags
    aprefix | null prefixFlags = Nothing
            | otherwise        = Just $ Just $ unPrefix (last prefixFlags)

    dflags = filter isFormat mflags
    dformat | null dflags = Nothing
            | otherwise   = Just $ getFormat $ last dflags

    iflags = filter isIndent oflags
    indent | null iflags = Nothing
           | otherwise   = Just $ getIndentString $ last iflags

    noStatus = DoNotReadStatus ? mflags
    newStatusFlags = filter isSetStatus mflags
    setStatus | null newStatusFlags = Nothing
              | otherwise           = Just $ Just $ newStatus $ last newStatusFlags

    topStatusFlags = filter isTopStatus mflags
    setTopStatus | null topStatusFlags = Nothing
                 | otherwise           = Just $ Just $ newTopStatus $ last topStatusFlags

    isSort (Sort _) = True
    isSort _        = False
    isFormat (Format _) = True
    isFormat _          = False
    isIndent (IndentWith _) = True
    isIndent _              = False
    isCommand (Execute _) = True
    isCommand _           = False
    isPrefix (Prefix _) = True
    isPrefix _          = False
    isSetStatus (SetStatus _)  = True
    isSetStatus _              = False
    isTopStatus (SetTopStatus _) = True
    isTopStatus _                = False

parseLimits โˆท โ„ค โ†’ โ„ค โ†’ [LimitFlag] โ†’ (Maybe Limit,Maybe Limit)
parseLimits dlp dlm flags = (Just limitP, Just limitM)
  where
    pruneFlags = filter isPrune flags
    minFlags   = filter isMin flags

    limitP'       = foldl min Unlimited $ map (Limit โˆ˜ unPrune) pruneFlags
    limitP | Unlimited โ† limitP' = Limit dlp
           | otherwise           = limitP'

    limitM'       = foldl max (Limit 0) $ map (Limit โˆ˜ unMin) minFlags
    limitM | Unlimited โ† limitM' = Limit dlm
           | otherwise           = limitM'

    isPrune (Prune _) = True
    isPrune _         = False

    isMin   (Start _) = True
    isMin   _         = False

parseQuery โˆท [QueryFlag] โ†’ Composed
parseQuery flags = foldl appendC Empty flags

-- | Parse command line
parseCmdLine' โˆท DateTime             -- ^ Current date/time
             โ†’ [String]              -- ^ Command line args
             โ†’ Either String (Options, [FilePath]) -- ^ Error message or (Options, list of files)
parseCmdLine' currDate args = 
  case getOpt Permute (options currDate) (map decodeString args) of
        (flags, [],      [])     โ†’ Right (parseFlags flags, ["TODO"])
        (flags, nonOpts, [])     โ†’ Right (parseFlags flags, nonOpts)
        (_,     _,       msgs)   โ†’ Left $ concat msgs โงบ usage

isPattern โˆท String โ†’ ๐”น
isPattern s = ('*' โˆˆ s) || ('?' โˆˆ s)

-- | For given list of glob masks, return list of matching files
glob โˆท [FilePath] โ†’ IO [FilePath]
glob list = do
  let patterns = filter isPattern list
      files = filter (not โˆ˜ isPattern) list
  (matches, _) โ† globDir (map compile patterns) "." 
  return $ sort $ files โงบ concat matches

-- | Usage help for default command line options
usage โˆท  String
usage = usageInfo header (options undefined)
  where 
    header = "Usage: todos [OPTION...] [INPUT FILES]"

options โˆท DateTime โ†’ [OptDescr CmdLineFlag]
options currDate = [
    Option "1" ["only-first"] (NoArg (OF OnlyFirst))                 "show only first matching entry",
    Option "c" ["color"]      (NoArg (OF Colors))                    "show colored output",
    Option "H" ["highlight"]  (NoArg (OF Highlight))                 "instead of filtering TODOs, just highlight matching the query",
    Option "I" ["show-ids"]   (NoArg (OF Ids))                       "show IDs of todos",
    Option "A" ["prefix"]     (OptArg mkPrefix "PREFIX")             "use alternate parser: read only lines starting with PREFIX",
    Option ""  ["dot"]        (NoArg (OF DotExport))                 "output entries in DOT (graphviz) format",
    Option "D" ["format"]     (ReqArg mkFormat "FORMAT")             "use FORMAT to format items",
    Option "k" ["indent-with"] (OptArg mkIndent "STRING")            "use STRING instead of two spaces for items indentation",
    Option "w" ["no-status"]  (NoArg (MF DoNotReadStatus))           "do not read status field from TODOs",
    Option ""  ["set-status"] (ReqArg mkSetStatus "STRING")          "force all TODOs status to be equal to STRING",
    Option ""  ["set-root-status"] (ReqArg mkTopStatus "STRING")     "force statuses of root TODOs to be equal to STRING",
    Option "F" ["by-file"]    (NoArg (MF GroupByFile))               "group TODOs by source file",
    Option "T" ["by-tag"]     (NoArg (MF GroupByTag))                "group TODOs by tag",
    Option "Z" ["by-status"]  (NoArg (MF GroupByStatus))             "group TODOs by status",
    Option "p" ["prune"]      (ReqArg mkPrune "N")                   "limit tree height to N",
    Option "m" ["min-depth"]  (ReqArg mkMin "N")                     "show first N levels of tree unconditionally",
    Option "t" ["tag"]        (ReqArg mkTag "TAG")                   "find items marked with TAG",
    Option "g" ["grep"]       (ReqArg mkName "PATTERN")              "find items with PATTERN in name",
    Option "G" ["description"] (ReqArg mkDescr "PATTERN")            "find items with PATTERN in description",
    Option "s" ["status"]     (ReqArg mkStatus "STRING")             "find items with status equal to STRING",
    Option "i" ["id"]         (ReqArg mkIdQ "STRING")                "find items with ID equal to STRING",
    Option "a" ["and"]        (NoArg (QF AndCons))                   "logical AND",
    Option "o" ["or"]         (NoArg (QF OrCons))                    "logical OR",
    Option "n" ["not"]        (NoArg (QF NotCons))                   "logical NOT",
    Option ""  ["sort"]       (ReqArg mkSort "FIELD")                "specify sorting",
    Option "e" ["exec"]       (OptArg mkExecute "COMMAND")           "run COMMAND on each matching entry",
    Option "S" ["start-date"] (ReqArg (mkStartDate currDate) "DATE") "find items with start date bounded with DATE",
    Option "E" ["end-date"]   (ReqArg (mkEndDate currDate) "DATE")   "find items with end date bounded with DATE",
    Option "d" ["deadline"]   (ReqArg (mkDeadline currDate) "DATE")  "find items with deadline bounded with DATE",
    Option "h" ["help"]       (NoArg HelpF)                          "display this help"
  ]

mkSort โˆท  String โ†’ CmdLineFlag
mkSort s = OF $ Sort $ readSort s

mkTag โˆท  String โ†’ CmdLineFlag
mkTag t = QF $ Tag t

mkName โˆท  String โ†’ CmdLineFlag
mkName n = QF $ Name n

mkStatus โˆท  String โ†’ CmdLineFlag
mkStatus s = QF $ Status s

mkIdQ โˆท  String โ†’ CmdLineFlag
mkIdQ s = QF $ IdIs s

mkDescr โˆท  String โ†’ CmdLineFlag
mkDescr s = QF $ Description s

forceEither โˆท  (Show t) โ‡’ Either t b โ†’ b
forceEither (Right x) = x
forceEither (Left x) = error $ show x

mkStartDate โˆท  DateTime โ†’ String โ†’ CmdLineFlag
mkStartDate dt s = QF $ StartDateIs $ forceEither $ parseDate dt s

mkEndDate โˆท  DateTime โ†’ String โ†’ CmdLineFlag
mkEndDate dt s = QF $ EndDateIs $ forceEither $ parseDate dt s

mkDeadline โˆท  DateTime โ†’ String โ†’ CmdLineFlag
mkDeadline dt s = QF $ DeadlineIs $ forceEither $ parseDate dt s

mkFormat โˆท  String โ†’ CmdLineFlag
mkFormat f = MF $ Format f

mkIndent โˆท Maybe String โ†’ CmdLineFlag
mkIndent Nothing  = OF $ IndentWith ""
mkIndent (Just s) = OF $ IndentWith s

mkSetStatus โˆท String โ†’ CmdLineFlag
mkSetStatus st = MF $ SetStatus st

mkTopStatus โˆท String โ†’ CmdLineFlag
mkTopStatus st = MF $ SetTopStatus st

mkPrune โˆท  String โ†’ CmdLineFlag
mkPrune s = LF $ Prune (read s)

mkMin โˆท  String โ†’ CmdLineFlag
mkMin s = LF $ Start (read s)

mkPrefix โˆท  Maybe [Char] โ†’ CmdLineFlag
mkPrefix = MF โˆ˜ Prefix โˆ˜ fromMaybe "TODO:"

mkExecute โˆท  Maybe [Char] โ†’ CmdLineFlag
mkExecute = MF โˆ˜ Execute โˆ˜ fromMaybe "echo %n %d"