LintWriter.hs

{-# LANGUAGE DeriveAnyClass    #-}
{-# 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
  -- * 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
  ) where

import           Data.Text                  (Text)

import           Badges                     (Badge)
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           LintConfig                 (LintConfig')
import           TiledAbstract              (HasName)
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)}

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

-- | "invert" a linter's result, grouping lints by their messages
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
invertLintResult (LinterState (lints, ctxt)) =
  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

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



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