diff options
Diffstat (limited to 'lib/LintWriter.hs')
| -rw-r--r-- | lib/LintWriter.hs | 180 |
1 files changed, 104 insertions, 76 deletions
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index e235fca..12c4311 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -7,11 +7,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | a monad that collects warnings, outputs, etc, -module LintWriter where +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.Aeson (ToJSON (toJSON)) import Data.Text (Text) import Control.Monad.State (StateT, modify) @@ -21,123 +49,123 @@ 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)} +import TiledAbstract (HasName) +import Types (Dep, Hint, Level (..), Lint (..), + hint, lintsToHints) --- | a monad to collect hints, with some context (usually the containing layer/etc.) +-- | 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 --- wrapped to allow for manual writing of Aeson instances -type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint]) -newtype LintResult ctxt = LintResult (LintResult' ctxt) +-- | 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 (LintResult (ctxt, lints)) = +invertLintResult (LinterState (lints, ctxt)) = 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 +resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints + where lintToDep = \case + Depends dep -> Just dep + _ -> Nothing 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 +resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a + where lintToOffer = \case + Offers frag -> Just frag + _ -> Nothing resultToBadges :: LintResult a -> [Badge] -resultToBadges (LintResult a) = mapMaybe lintToBadge $ snd a +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 (LintResult res) = fst res +resultToAdjusted (LinterState res) = snd 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 +-- | 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 --- | 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 +-- | 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 |