Select Git revision
LintWriter.hs
LintWriter.hs 4.38 KiB
{-# 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 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)) 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