content: {-# LANGUAGE Arrows                    #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE NoImplicitPrelude         #-}
  {-# LANGUAGE OverloadedStrings         #-}
  {-# LANGUAGE TemplateHaskell           #-}
  -- | Parsers and pretty printers for the `lint-results.xml` file format.
  module AndroidLintSummary (
    supportedLintFormatVersion
  , AppEnv(..)
  , AppOpts(..)
  , LintSeverity(..)
  , LintFormatter(..)
  , LintLocation()
  , LintIssue()
  , Verbosity(..)
  , readLintIssues
  , openXMLFile
  , indentWrap
  , formatLintIssues
  , filename
  , line
  , column
  , severity
  , summary
  , priority
  , explanation
  , location
  , formatter
  , glob
  , targets
  , verbose
  ) where
  
  import           BasicPrelude                 hiding (fromString)
  
  import           Rainbow
  import           Text.XML.HXT.Core
  
  import           Control.Lens                 hiding (deep)
  import           Control.Monad.Reader         (Reader (), ask)
  import           Data.Default                 (Default (), def)
  import           Data.Stringable              (Stringable (..))
  import           System.FilePath.GlobPattern  (GlobPattern)
  import           System.IO                    (Handle (), IOMode (ReadMode),
                                                 openFile, stdin)
  
  import qualified Data.Text                    as T
  import qualified Data.Text.IO                 as TIO
  import qualified System.Console.Terminal.Size as Terminal
  
  supportedLintFormatVersion :: String
  supportedLintFormatVersion = "4"
  
  defaultLintResultsGlob :: GlobPattern
  defaultLintResultsGlob = "**/build/outputs/lint-results.xml"
  
  data LintSeverity = FatalSeverity
                    | ErrorSeverity
                    | WarningSeverity
                    | InformationalSeverity
      deriving (Eq, Ord, Show, Bounded, Enum)
  
  data LintLocation = LintLocation { _filename :: FilePath
                                   , _line     :: Maybe Int
                                   , _column   :: Maybe Int
                                   }
      deriving (Eq, Show)
  
  makeLenses ''LintLocation
  
  data LintIssue = LintIssue { _severity    :: LintSeverity
                             , _summary     :: T.Text
                             , _priority    :: Int
                             , _explanation :: T.Text
                             , _location    :: LintLocation
                             }
      deriving (Eq, Show)
  
  makeLenses ''LintIssue
  
  data LintFormatter =
      NullLintFormatter -- ^ A formatter that doesn't output
                        --   anything.
    | SimpleLintFormatter -- ^ A formatter that displays the errors
                          --   in descending errors with simple color
                          --   coding.
    deriving (Eq, Show, Bounded, Enum)
  
  data Verbosity = Normal | Verbose
      deriving (Show, Eq)
  
  data AppOpts = AppOpts { _targets   :: Maybe [FilePath]
                         , _glob      :: GlobPattern
                         , _formatter :: LintFormatter
                         , _verbose   :: Verbosity
                         }
      deriving (Show, Eq)
  
  makeLenses ''AppOpts
  
  data AppEnv = AppEnv { _opts         :: AppOpts
                       , _terminalSize :: Maybe (Terminal.Window Int)
                       }
  
  makeLenses ''AppEnv
  
  instance Default AppOpts where
      def = AppOpts { _targets = mempty
                    , _glob = defaultLintResultsGlob
                    , _formatter = SimpleLintFormatter
                    , _verbose = Normal
                    }
  
  instance Stringable LintSeverity where
      toString = formatSeverity
      fromString s
          | s == "Fatal" = FatalSeverity
          | s == "Error" = ErrorSeverity
          | s == "Warning" = WarningSeverity
          | s == "Information" = InformationalSeverity
          | otherwise = error $ "Invalid severity " <> s
      length _ = 0
  
  
  instance Stringable LintFormatter where
      toString NullLintFormatter = "null"
      toString SimpleLintFormatter = "simple"
      fromString s
        | s == "null" = NullLintFormatter
        | s == "simple" = SimpleLintFormatter
        | otherwise = error "Invalid LintFormatter specification"
      length _ = 0
  
  formatSeverity :: LintSeverity -> String
  formatSeverity FatalSeverity         = "Fatal"
  formatSeverity ErrorSeverity         = "Error"
  formatSeverity WarningSeverity       = "Warning"
  formatSeverity InformationalSeverity = "Information"
  
  colorSeverity :: LintSeverity -> Chunk a -> Chunk a
  colorSeverity FatalSeverity         a = a & fore red & bold
  colorSeverity ErrorSeverity         a = a & fore red
  colorSeverity WarningSeverity       a = a & fore yellow
  colorSeverity InformationalSeverity a = a & fore white
  
  
  formatLintIssues :: LintFormatter -> [LintIssue] -> Reader AppEnv [Chunk T.Text]
  formatLintIssues NullLintFormatter _ = pure mempty
  formatLintIssues SimpleLintFormatter issues = concat <$> mapM fmt sortedIssues
      where
          sortedIssues = sortOn (((-1) *) . view priority) issues
  
          fmt :: LintIssue -> Reader AppEnv [Chunk T.Text]
          fmt i =
            sequence [ pure $ label i
                     , pure $ chunk (" " <> i ^. summary <> "\n") & bold
                     , pure $ chunk $ concat $ replicate 4 " "
                     , pure $ chunk ( T.pack (i ^. location . filename)
                                     <> fmtLine (i ^. location . line)
                                     <> "\n"
                                      ) & underline & fore blue
                     , fmtExplanation i
                     ]
  
          fmtExplanation :: LintIssue -> Reader AppEnv (Chunk T.Text)
          fmtExplanation i = ask >>= \env -> return $ case env ^. opts . verbose of
            Normal -> mempty
            Verbose -> chunk
              ( maybe
                (i ^. explanation <> "\n")
                (\size -> indentWrap size 4 $ i ^. explanation)
                (env ^. terminalSize)
              ) & faint
  
          fmtLine :: Show a => Maybe a -> T.Text
          fmtLine = maybe mempty ((":" <>) . T.pack . show)
  
          label i = dye i ( "["
                         <> T.take 1 (toText $ i ^. severity)
                         <> "]" )
  
          dye i j = colorSeverity (i ^. severity) (chunk j)
  
  atTag :: ArrowXml a => String -> a XmlTree XmlTree
  atTag tag = deep (isElem >>> hasName tag)
  
  sread :: Read a => String -> a
  sread = read . T.pack
  
  sreadMay :: Read a => String -> Maybe a
  sreadMay = readMay . T.pack
  
  indentWrap :: Terminal.Window Int -> Int -> T.Text -> T.Text
  indentWrap size indentation text = foldMap wrap lines'
    where
      indent :: T.Text
      indent = concat $ replicate indentation " "
  
      lines' = filter (/= mempty) $ lines text
      wrap t
        | t == mempty = mempty
        | otherwise = let (as, bs) = T.splitAt (Terminal.width size - indentation) t
                      in indent <> as <> "\n" <> wrap bs
  
  openXMLFile :: forall s b. FilePath -> IO (IOStateArrow s b XmlTree)
  openXMLFile = (readXMLFileHandle =<<) . getHandle
    where
      getHandle filepath
        | filepath == "-" = return stdin
        | otherwise       = openFile filepath ReadMode
  
  
  readXMLFileHandle :: forall s b. Handle -> IO (IOStateArrow s b XmlTree)
  readXMLFileHandle h = do
      contents <- TIO.hGetContents h
      return $ readString [withWarnings yes] $ T.unpack contents
  
  readLintIssues :: IOSLA (XIOState ()) XmlTree XmlTree -> IO [LintIssue]
  readLintIssues doc =
      runX $ doc >>> selectIssues >>> parseIssues
      where
          parseIssues :: ArrowXml a => a XmlTree LintIssue
          parseIssues = proc i -> do
              severity' <- arr fromString <<< getAttrValue "severity" -< i
              summary' <- arr T.pack <<< getAttrValue "summary" -< i
              priority' <- arr sread <<< getAttrValue "priority" -< i
              explanation' <- arr T.pack <<< getAttrValue "explanation" -< i
              location' <- parseLocation -< i
              returnA -< LintIssue { _severity = severity'
                                   , _summary = summary'
                                   , _explanation = explanation'
                                   , _priority = priority'
                                   , _location = location'
                                   }
  
          parseLocation :: ArrowXml a => a XmlTree LintLocation
          parseLocation = atTag "location" >>> proc l -> do
              filename' <- getAttrValue "file" -< l
              line' <- arr sreadMay <<< getAttrValue "line" -< l
              column' <- arr sreadMay <<< getAttrValue "column" -< l
              returnA -< LintLocation { _filename = filename'
                                      , _line = line'
                                      , _column = column'
                                      }
  
          selectIssues :: ArrowXml a => a XmlTree XmlTree
          selectIssues = getChildren
              >>>
              isElem >>> hasName "issues"
              >>>
              hasAttrValue "format" (== supportedLintFormatVersion)
              >>>
              atTag "issue"
  