Skip to content
Snippets Groups Projects
Select Git revision
  • 24a0763b4b0a87b5abd488ebca67f4c5ff9b966d
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

LintWriter.hs

Blame
  • LintWriter.hs 4.38 KiB
    {-# LANGUAGE DeriveAnyClass    #-}
    {-# LANGUAGE DeriveGeneric     #-}
    {-# LANGUAGE FlexibleContexts  #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE LambdaCase        #-}
    {-# LANGUAGE NamedFieldPuns    #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RankNTypes        #-}
    {-# LANGUAGE TupleSections     #-}
    
    -- | a monad that collects warnings, outputs, etc,
    module LintWriter where
    
    import           Data.Aeson                 (ToJSON (toJSON))
    import           Data.Text                  (Text)
    
    import           Control.Monad.State        (StateT, modify)
    import           Control.Monad.Trans.Reader (Reader, asks, runReader)
    import           Control.Monad.Trans.State  (runStateT)
    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           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)}
    
    
    -- | a monad to collect hints, with some context (usually the containing layer/etc.)
    type LintWriter ctxt = LintWriter' ctxt ()
    type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt)) 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)
    
    
    invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
    invertLintResult (LintResult (ctxt, lints)) =
      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