diff options
Diffstat (limited to 'walint/LintWriter.hs')
| -rw-r--r-- | walint/LintWriter.hs | 192 |
1 files changed, 192 insertions, 0 deletions
diff --git a/walint/LintWriter.hs b/walint/LintWriter.hs new file mode 100644 index 0000000..40d54bb --- /dev/null +++ b/walint/LintWriter.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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 |