diff options
Diffstat (limited to 'lib/LintWriter.hs')
| -rw-r--r-- | lib/LintWriter.hs | 198 |
1 files changed, 0 insertions, 198 deletions
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs deleted file mode 100644 index afcec65..0000000 --- a/lib/LintWriter.hs +++ /dev/null @@ -1,198 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} -{-# 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 - , zoom - -- * 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 - ,offersCWs,resultToCWs,offersJitsi,resultToJitsis) where - -import Universum - - -import Badges (Badge) -import Data.Map (fromListWith) -import Data.Tiled.Abstract (HasName (getName)) -import LintConfig (LintConfig') -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)} - deriving Functor - --- | 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)) - - -zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a -zoom embed extract operation = do - config <- lintConfig id - depth <- askFileDepth - let result ctxt = runLintWriter config ctxt depth operation - LinterState (lints,a) <- get - let res = result . extract $ a - put $ LinterState - . (resultToLints res <> lints,) - . embed - . resultToAdjusted - $ res - pure $ resultToAdjusted res - - --- | "invert" a linter's result, grouping lints by their messages -invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [Text] -invertLintResult (LinterState (lints, ctxt)) = - fmap (sortNub . map getName) . 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 - -resultToCWs :: LintResult a -> [Text] -resultToCWs (LinterState a) = fold $ mapMaybe lintToCW $ fst a - where lintToCW = \case (CW cw) -> Just cw; _ -> Nothing - -resultToJitsis :: LintResult a -> [Text] -resultToJitsis (LinterState a) = mapMaybe lintToJitsi $ fst a - where lintToJitsi = \case (Jitsi room) -> Just room; _ -> 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 - -offersCWs :: [Text] -> LintWriter a -offersCWs = tell' . CW - -offersJitsi :: Text -> LintWriter a -offersJitsi = tell' . Jitsi - - --- | 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 |