{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE TupleSections     #-}

-- | a monad that collects warnings, outputs, etc,
module LintWriter where

import           Data.Aeson                 (ToJSON (toJSON))
import           Data.Text                  (Text)

import           Control.Monad.State        (StateT, modify)
import           Control.Monad.Trans.Reader (Reader, asks, runReader)
import           Control.Monad.Trans.State  (runStateT)
import           Control.Monad.Writer.Lazy  (lift)
import           Data.Bifunctor             (Bifunctor (second))
import           Data.Map                   (Map, fromListWith)
import           Data.Maybe                 (mapMaybe)
import qualified Data.Text                  as T
import           Util                       (PrettyPrint (..))

import           Badges                     (Badge)
import           LintConfig                 (LintConfig')
import           Tiled2                     (HasName)
import           Types

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

newtype LinterState ctxt = LinterState
  { fromLinterState :: ([Lint], ctxt)}


-- | a monad to collect hints, with some context (usually the containing layer/etc.)
type LintWriter ctxt = LintWriter' ctxt ()
type LintWriter' ctxt res =
  StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res

-- wrapped to allow for manual writing of Aeson instances
type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
newtype LintResult ctxt = LintResult (LintResult' ctxt)


invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
invertLintResult (LintResult (ctxt, lints)) =
  fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints

-- better, less confusing serialisation of an Either Hint (a, [Hint]).
-- Note that Left hint is also serialised as a list to make the resulting
-- json schema more regular.
instance ToJSON (LintResult a) where
  toJSON (LintResult res) = toJSON $ snd res

instance PrettyPrint ctxt => PrettyPrint (Level, LintResult ctxt) where
  prettyprint (level, LintResult (ctxt, res)) =
    T.concat $ map ((<> context) . prettyprint) (filterLintLevel level res)
    where context = " (" <> prettyprint ctxt <> ")\n"

lintToDep :: Lint -> Maybe Dep
lintToDep = \case
  Depends dep -> Just dep
  _           -> Nothing

lintToOffer :: Lint -> Maybe Text
lintToOffer = \case
  Offers frag -> Just frag
  _           -> Nothing

filterLintLevel :: Level -> [Lint] -> [Lint]
filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l
  then Just l
  else Nothing

resultToDeps :: LintResult a -> [Dep]
resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a

resultToOffers :: LintResult a -> [Text]
resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a

-- | convert a lint result into a flat list of lints
-- (throwing away information on if a single error was fatal)
resultToLints :: LintResult a -> [Lint]
resultToLints (LintResult res) = snd res

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

resultToAdjusted :: LintResult a -> a
resultToAdjusted (LintResult res) = fst res

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

tell' :: Lint -> LintWriter ctxt
tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt)


-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter a
lint level text = tell' $ hint  level text

dependsOn :: Dep -> LintWriter a
dependsOn dep = tell' $ Depends dep

offersEntrypoint :: Text -> LintWriter a
offersEntrypoint text = tell' $ Offers text

offersBadge :: Badge -> LintWriter a
offersBadge badge = tell' $ Badge badge

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


info = lint Info
suggest = lint Suggestion
warn = lint Warning
forbid = lint Forbidden
complain = lint Error


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

askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks (\(a,_,_) -> a)

lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a
lintConfig get = lift $ asks (\(_,_,config) -> get config)