lots of code reorganising and some deduplication

it was kinda getting messy in places.

Also found some accidental isomorphisms between types, so these are now
only one type because the consequences were getting silly.

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