{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TupleSections     #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}

-- | a monad that collects warnings, outputs, etc,
module LintWriter
  ( runLintWriter
  , LintWriter
  , LintWriter'
  , LintResult
  , invertLintResult
  , zoom
  -- * working with lint results
  , resultToDeps
  , resultToOffers
  , resultToBadges
  , resultToLints
  , resultToAdjusted
  -- * Add lints to a linter
  , info
  , suggest
  , warn
  , forbid
  , complain
  -- * add other information to the linter
  , offersEntrypoint
  , offersBadge
  , dependsOn
  -- * get information about the linter's context
  , askContext
  , askFileDepth
  , lintConfig
  -- * adjust the linter's context
  , adjust
  ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where

import           Universum


import           Badges              (Badge)
import           Data.Map            (fromListWith)
import           Data.Tiled.Abstract (HasName (getName))
import           LintConfig          (LintConfig')
import           Types               (Dep, Hint, Level (..), Lint (..), hint,
                                      lintsToHints)


-- | A monad modelling the main linter features
type LintWriter ctxt = LintWriter' ctxt ()
-- | A linter that can use pure / return things monadically
type LintWriter' ctxt res =
  StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res

-- | A Linter's state: some context (which it may adjust), and a list of lints
-- | it already collected.
newtype LinterState ctxt = LinterState
  { fromLinterState :: ([Lint], ctxt)}
  deriving Functor

-- | The result of running a linter: an adjusted context, and a list of lints.
-- | This is actually just a type synonym of LinterState, but kept seperately
-- | for largely historic reasons since I don't think I'll change it again
type LintResult ctxt = LinterState ctxt

-- | for now, all context we have is how "deep" in the directory tree
-- we currently are
type Context = Int

-- | run a linter. Returns the adjusted context, and a list of lints
runLintWriter
  :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
runLintWriter config context depth linter = LinterState
  . fromLinterState
  . snd
  . runReader runstate
  $ (depth, context, config)
  where runstate = runStateT linter (LinterState ([], context))


zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a
zoom embed extract operation = do
  config <- lintConfig id
  depth <- askFileDepth
  let result ctxt = runLintWriter config ctxt depth operation
  LinterState (lints,a) <- get
  let res = result . extract $ a
  put $ LinterState
    . (resultToLints res <> lints,)
    . embed
    . resultToAdjusted
    $ res
  pure $ resultToAdjusted res


-- | "invert" a linter's result, grouping lints by their messages
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text]
invertLintResult (LinterState (lints, ctxt)) =
  fmap (sortNub . map getName) . fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints

resultToDeps :: LintResult a -> [Dep]
resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints
  where lintToDep = \case
          Depends dep -> Just dep
          _           -> Nothing

resultToOffers :: LintResult a -> [Text]
resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a
 where lintToOffer = \case
         Offers frag -> Just frag
         _           -> Nothing

resultToBadges :: LintResult a -> [Badge]
resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a
  where lintToBadge (Badge badge) = Just badge
        lintToBadge _             = Nothing

resultToCWs :: LintResult a -> [Text]
resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a
  where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing

resultToJitsis :: LintResult a -> [Text]
resultToJitsis (LinterState a) = mapMaybe lintToJitsi $ fst a
  where lintToJitsi = \case (Jitsi room) -> Just room; _ -> Nothing

-- | convert a lint result into a flat list of lints
resultToLints :: LintResult a -> [Lint]
resultToLints (LinterState res) = fst res

-- | extract the adjusted context from a lint result
resultToAdjusted :: LintResult a -> a
resultToAdjusted (LinterState res) = snd res




-- | fundamental linter operations: add a lint of some severity
info = lint Info
suggest = lint Suggestion
warn = lint Warning
forbid = lint Forbidden
complain = lint Error

-- | add a dependency to the linter
dependsOn :: Dep -> LintWriter a
dependsOn dep = tell' $ Depends dep

-- | add an offer for an entrypoint to the linter
offersEntrypoint :: Text -> LintWriter a
offersEntrypoint text = tell' $ Offers text

-- | add an offer for a badge to the linter
offersBadge :: Badge -> LintWriter a
offersBadge badge = tell' $ Badge badge

offersCWs :: [Text] -> LintWriter a
offersCWs = tell' . CW

offersJitsi :: Text -> LintWriter a
offersJitsi = tell' . Jitsi


-- | get the context as it was initially, without any modifications
askContext :: LintWriter' a a
askContext = lift $ asks (\(_,a,_) -> a)

-- | ask for the file depth within the repository tree of the current map.
-- | This function brings in a lot more conceptual baggage than I'd like, but
-- | it's needed to check if relative paths lie outside the repository
askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks (\(a,_,_) -> a)

-- | ask for a specific part of the linter's global config
lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a
lintConfig get = lift $ asks (\(_,_,config) -> get config)




-- | tell, but for a singular lint. Leaves the context unchanged
tell' :: Lint -> LintWriter ctxt
tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt)

-- | small helper to tell a singlular proper lint
lint :: Level -> Text -> LintWriter a
lint level text = tell' $ hint level text

-- | adjusts the context. Gets a copy of the /current/ context,
-- | i.e. one which might have already been changed by other adjustments
adjust :: (a -> a) -> LintWriter a
adjust f = modify $ LinterState . second f . fromLinterState