From 9110064fe62f98dd3ecc5fb4c3915a843492b8fb Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 23 Oct 2023 23:18:34 +0200
Subject: a year went by

This does many meta-things, but changes no functionality:
 - get rid of stack, and use just cabal with a stackage snapshot instead
   (why did I ever think stack was a good idea?)
 - update the stackage snapshot to something halfway recent
 - thus making builds work on nixpkgs-23.05 (current stable)
 - separating out packages into their own cabal files
 - use the GHC2021 set of extensions as default
 - very slight code changes to make things build again
 - update readme accordingly
 - stylish-haskell run
---
 lib/LintWriter.hs | 198 ------------------------------------------------------
 1 file changed, 198 deletions(-)
 delete mode 100644 lib/LintWriter.hs

(limited to 'lib/LintWriter.hs')

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
-- 
cgit v1.2.3