content: --
  -- Copyright © 2013-2015 Anchor Systems, Pty Ltd and Others
  --
  -- The code in this file, and the program it is a part of, is
  -- made available to you by its authors as open source software:
  -- you can redistribute it and/or modify it under the terms of
  -- the 3-clause BSD licence.
  --
  
  -- | Common helpers for git vogue plugins
  module Git.Vogue.PluginCommon
  (
      -- * Output
      outputGood,
      outputUnfortunate,
      outputBad,
      lineWrap,
  
      -- * FilePath handling
      hsProjects,
      forProjects,
  
      -- * Command line parsing
      getPluginCommand,
      pureSubCommand,
      PluginCommand(..),
  
      -- * Utility
      forWithKey_,
      forWithKey,
  ) where
  
  import           Control.Applicative
  import           Control.Monad.IO.Class
  import           Data.Char
  import           Data.Functor
  import           Data.List
  import           Data.Map.Strict        (Map)
  import qualified Data.Map.Strict        as M
  import           Data.Maybe
  import           Data.Monoid
  import           Data.Ord
  import           Options.Applicative
  import           System.Directory
  import           System.FilePath
  
  -- | The check went or is going well, this should make the developer happy
  outputGood :: MonadIO m => String -> m ()
  outputGood = outputWithIcon "  \x1b[32m[+]\x1b[0m "
  
  -- | A non-fatal warning of some sort. The developer should be able to ignore
  -- this.
  outputUnfortunate :: MonadIO m => String -> m ()
  outputUnfortunate = outputWithIcon "  \x1b[33m[*]\x1b[0m "
  
  -- | If any of these appear, you should probably be exploding and the developer
  -- will be sad.
  outputBad :: MonadIO m => String -> m ()
  outputBad = outputWithIcon "  \x1b[31m[-]\x1b[0m "
  
  outputWithIcon :: MonadIO m => String -> String -> m ()
  outputWithIcon icon = liftIO . putStrLn . (icon <>) . prependWS
  
  -- | Prepend some whitespace to every line but the first so that subsequent
  -- lines line up below a [+] or [-].
  prependWS :: String -> String
  prependWS "" = ""
  prependWS input =
      let (x:xs) = lines input
      in intercalate "\n" $ x : fmap ("      " <>) xs
  
  -- | Convenience for line wrapping long lines.
  lineWrap :: Int -> String -> String
  lineWrap line_len =
      intercalate "\n" . fmap (intercalate "\n" . unfoldr f) . lines
    where
      f [] = Nothing
      f xs = Just . fmap lstrip $ splitAt line_len xs
      lstrip = dropWhile isSpace
  
  -- | Helper for traversing a Map with keys
  forWithKey_ :: Applicative f => Map k v -> (k -> v -> f ()) -> f ()
  forWithKey_ m a = void $ M.traverseWithKey a m
  
  forWithKey :: Applicative f => Map k v -> (k -> v -> f a) -> f (Map k a)
  forWithKey = flip M.traverseWithKey
  
  -- | Find .cabal files in hsFiles and arrange children underneath these
  -- "headings".
  hsProjects
      :: [FilePath] -- ^ Files to be checked
      -> [FilePath] -- ^ All files
      -> Map FilePath [FilePath]
  hsProjects check_fs all_fs =
      -- We want to stick the subset of files to be checked under the same
      -- project headings as we would if we were checking all files. So we mush
      -- them together.
      --
      -- Discard the remainder, the user probably doesn't know what to do with
      -- it.
      let (complete_proj_map, _) = findProjects (isSuffixOf ".cabal") all_fs
      -- Now do the awesome quadratic thing and traverse lists.
          proj_map =  fmap (filter (`elem` check_fs)) complete_proj_map
      -- And finally strip the prefixes of the dirs, so that this looks a bit
      -- like a one level trie.
          bug = error "BUG: hsProjects: A key was not a prefix of its elements"
      in M.mapWithKey (\k -> fmap (fromMaybe bug . stripPrefix k)) proj_map
  
  -- | For the given projects, perform the supplied action on each given relative
  -- URLS and having set the current directory to the project.
  --
  -- This will also take care of printing out a "Checking project in: " message.
  forProjects
      :: (MonadIO m, Applicative m)
      => Map FilePath [FilePath]
      -> ([FilePath] -> m a)
      -> m (Map FilePath a)
  forProjects projs f = do
      cwd <- liftIO $ getCurrentDirectory >>= canonicalizePath
      forWithKey projs $ \dir fs -> do
          let pdir = "." </> dir
          liftIO $ do
              putStrLn $ "Checking project in: " <> pdir
              setCurrentDirectory pdir
          x <- f fs
          liftIO $ setCurrentDirectory cwd
          return x
  
  -- | Given a predicate to identify a file as being in the "root" of a
  -- directory and a bunch of FilePaths, figure out which file paths belong under
  -- these roots and "compartmentalize" them. The remainder of possibly
  -- un-accounted-for files are the second element returned.
  --
  -- This is useful for finding files belonging to distinct projects within a
  -- repository.
  findProjects
      :: (FilePath -> Bool)
      -> [FilePath]
      -> (Map FilePath [FilePath], [FilePath])
  findProjects p xs =
          -- We start out by putting all of the files in a nested list, splitting
          -- up the path.
      let all_paths = fmap (splitPath . ('/':)) xs
  
          -- Now we find all of the project roots. Again tacking on the root so
          -- that init is safe and everything lines up.
          roots = sortBy (comparing length) . fmap (init . splitPath . ('/':)) $
                      filter p xs
  
          -- Now iterate over the project roots, taking the bits of the whole
          -- list as we go.
          f current_root (result, remaining) =
              let included = isPrefixOf current_root
                  to_take  = filter included remaining
                  to_leave = filter (not . included) remaining
              in ( M.insert (joinPath $ tail current_root) to_take result
                 , to_leave)
  
          (projects, remainder) = foldr f (mempty, all_paths) roots
  
      -- Now put the broken up paths back together and take the roots off.
      in ((fmap . fmap) (joinPath . tail) projects
         , fmap (joinPath . tail) remainder)
  
  -- | Parser for plugin arguments
  pluginCommandParser :: Parser PluginCommand
  pluginCommandParser = subparser
      (  pureSubCommand "name" CmdName "Get name of plugin"
      <> fpCommand "check" CmdCheck "Check for problems"
      <> fpCommand "fix" CmdFix "Try to fix problems"
      )
  
  -- Helper for plugin commands that take [FilePath]s
  fpCommand
      :: String
      -> (FilePath -> FilePath -> a)
      -> String
      -> Mod CommandFields a
  fpCommand name ctor desc = command name (info parser (progDesc desc))
    where
      parser = ctor <$> argument str (metavar "CHECKABLE_FILES_LIST")
                    <*> argument str (metavar "ALL_FILES_LIST")
  
  -- | Sub-command helper
  pureSubCommand :: String -> a -> String -> Mod CommandFields a
  pureSubCommand name ctor desc = command name (info (pure ctor) (progDesc desc))
  
  -- | Get the plugin command requested given a header and a description
  getPluginCommand :: String -> String -> IO PluginCommand
  getPluginCommand hdr desc = execParser parser
    where
      parser = info (helper <*> pluginCommandParser)
          ( fullDesc
          <> progDesc desc
          <> header hdr)
  
  -- | Arguments to the plugin
  data PluginCommand
      -- | Check the project for problems.
      = CmdCheck FilePath FilePath
      -- | Fix problems in the project.
      | CmdFix FilePath FilePath
      -- | Report details.
      | CmdName
  
  
  