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

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

import           Control.Monad.Trans.Maybe  ()
import           Control.Monad.Writer       (MonadWriter (tell), WriterT,
                                             runWriterT)
import           Data.Aeson                 (ToJSON (toJSON))
import           Data.Text                  (Text)

import           Control.Monad.Trans.Reader (Reader, asks, runReader)
import           Control.Monad.Writer.Lazy  (lift)
import           Data.Maybe                 (mapMaybe)
import qualified Data.Text                  as T
import           Types
import           Util                       (PrettyPrint (..))


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

-- | a monad to collect hints, with some context
type LintWriter ctxt = LintWriter' ctxt ()
type LintWriter' ctxt res = WriterT [Lint] (Reader (Context, ctxt)) 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)


-- 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

-- | run a linter
runLintWriter :: ctxt -> Context -> LintWriter ctxt -> LintResult ctxt
runLintWriter c c' linter =  LintResult (c, lints)
  where lints = snd $ flip runReader (c',c) $ runWriterT linter

-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter a
lint level = tell . (: []) . hint level

dependsOn :: Dep -> LintWriter a
dependsOn dep = tell . (: []) $ Depends dep

offersEntrypoint :: Text -> LintWriter a
offersEntrypoint = tell . (: []) . Offers



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

askContext :: LintWriter' a a
askContext = lift $ asks snd

askFileDepth :: LintWriter' a Int
askFileDepth = lift $ asks fst