From 9a8d793f8f08fd5674bc6a917278ee7251bac56f Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 20 Sep 2021 21:41:50 +0200
Subject: rebuilding the core LintWriter monad

it is no longer an Either since that wasn't used anyways, but is now
also a Reader.
---
 lib/LintWriter.hs | 80 ++++++++++++++++++++-----------------------------------
 1 file changed, 29 insertions(+), 51 deletions(-)

(limited to 'lib/LintWriter.hs')

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index dd5ae7d..a6fa17e 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -3,88 +3,66 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 -- | a monad that collects warnings, outputs, etc,
 module LintWriter where
 
-import           Control.Monad.Trans.Maybe ()
-import           Control.Monad.Writer      (MonadTrans (lift),
-                                            MonadWriter (tell), WriterT,
-                                            runWriterT)
-import           Data.Aeson                (ToJSON (toJSON))
-import           Data.Text                 (Text)
+import           Control.Monad.Trans.Maybe  ()
+import           Control.Monad.Writer       (MonadWriter (tell), WriterT,
+                                             runWriterT)
+import           Data.Aeson                 (ToJSON (toJSON))
+import           Data.Text                  (Text)
 
-import           Data.Maybe                (mapMaybe)
+import           Control.Monad.Trans.Reader (Reader, runReader)
+import           Data.Maybe                 (mapMaybe)
 import           Types
+import GHC.Generics (Generic)
 
--- | a monad to collect hints. If it yields Left, then the
--- map is flawed in some fundamental way which prevented us
--- from getting any hints at all except whatever broke it
-type LintWriter a = WriterT [Lint] (Either Lint) a
+-- | a monad to collect hints, with some context
+type LintWriter ctxt = WriterT [Lint] (Reader ctxt) ()
 
--- this is wrapped in a newtype because Aeson is silly and wants
--- to serialise Either as { "Right" : … } or { "Left" : … } ...
-type LintResult' a = Either Lint (a, [Lint])
-newtype LintResult a = LintResult (LintResult' a)
+-- wrapped to allow for manual writing of Aeson instances
+type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint])
+newtype LintResult ctxt = LintResult (LintResult' ctxt)
+
+data LayerContext = LayerContext ()
+  deriving (Generic, ToJSON)
 
 -- 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 a => ToJSON (LintResult a) where
-  toJSON (LintResult r) = toJson' r
-    where toJson' (Left hint)        = toJSON [hint]
-          toJson' (Right (_, hints)) = toJSON hints
+  toJSON (LintResult res) = toJSON $ snd res
 
 lintToDep :: Lint -> Maybe Dep
 lintToDep = \case
   Depends dep -> Just dep
   _           -> Nothing
 
-lintResultToDeps :: LintResult a -> [Dep]
-lintResultToDeps (LintResult a) = case a of
-  Left (Depends dep) -> [dep]
-  Left _             -> []
-  Right (_, lints)   -> mapMaybe lintToDep lints
+resultToDeps :: LintResult a -> [Dep]
+resultToDeps (LintResult a) = mapMaybe lintToDep $ 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) = case res of
-  Left l           -> [l]
-  Right (_, lints) -> lints
+resultToLints (LintResult res) = snd res
 
--- | Confusingly, this returns lints, not a …
-runLintWriter :: LintWriter a -> [Lint]
-runLintWriter = resultToLints . LintResult . runWriterT
+-- | run a linter
+runLintWriter :: ctxt -> LintWriter ctxt -> LintResult ctxt
+runLintWriter c linter =  LintResult (c, lints)
+  where lints = snd $ flip runReader c $ runWriterT linter
 
 -- | write a hint into the LintWriter monad
-lint :: Level -> Text -> LintWriter ()
+lint :: Level -> Text -> LintWriter a
 lint level = tell . (: []) . hint level
 
-dependsOn :: Dep -> LintWriter ()
+dependsOn :: Dep -> LintWriter a
 dependsOn dep = tell . (: []) $ Depends dep
 
 
-warn = lint Warning
 info = lint Info
-forbid = lint Forbidden
 suggest = lint Suggestion
+warn = lint Warning
+forbid = lint Forbidden
 complain = lint Error
-
-
-
--- TODO: all these functions should probably also just operate on LintWriter
-
--- | converts a Maybe to an Either, with a default value for Left
-unwrap :: b -> Maybe a  -> Either b a
-unwrap hint maybe = case maybe of
-  Just a  -> Right a
-  Nothing -> Left hint
-
--- | unwrap and produce a warning if the value was Nothing
-unwrapWarn :: Text -> Maybe a -> Either Lint a
-unwrapWarn msg = unwrap $ hint Warning msg
-
--- | same as unwrapWarn, but for booleans
-assertWarn :: Text -> Bool -> LintWriter ()
-assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg
-- 
cgit v1.2.3