From 7a9226d84cf9dde33d0fc3e7852a22c36ab1c39b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 Sep 2021 23:18:14 +0200
Subject: input options, output json

input options are mostly dummies for now, but some work (e.g. --inpath
and --json). Lints can now be optionally printed as json to be
reasonably machine-readable (and the json can be pretty-printed to make
it human-readable again …).
---
 lib/LintWriter.hs | 40 ++++++++++++++++++++++++++++------------
 1 file changed, 28 insertions(+), 12 deletions(-)

(limited to 'lib/LintWriter.hs')

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 0146366..ca7ff08 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -1,29 +1,32 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NamedFieldPuns #-}
 
 -- | a monad that collects warnings, outputs, etc,
 module LintWriter where
 
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Maybe (isJust, mapMaybe)
-import Control.Monad.Writer
-import Control.Monad.Trans.Maybe
+import           Control.Monad.Trans.Maybe ()
+import           Control.Monad.Writer      (MonadTrans (lift),
+                                            MonadWriter (tell), WriterT)
+import           Data.Aeson                (ToJSON (toJSON))
+import           Data.Text                 (Text)
+import           GHC.Generics              (Generic)
 
 
 -- | Levels of errors and warnings, collectively called
 -- "Hints" until I can think of some better name
 data Level = Warning | Suggestion | Info | Forbidden | Error
-  deriving Show
+  deriving (Show, Generic, ToJSON)
 
 -- | a hint comes with an explanation (and a level)
 data Hint = Hint
   { hintLevel :: Level
-  , hintMsg :: Text }
-  deriving Show
+  , hintMsg   :: Text }
+  deriving (Show, Generic, ToJSON)
 
 -- shorter constructor
+hint :: Level -> Text -> Hint
 hint level msg = Hint { hintLevel = level, hintMsg = msg }
 
 -- | a monad to collect hints. If it yields Left, then the
@@ -31,7 +34,20 @@ hint level msg = Hint { hintLevel = level, hintMsg = msg }
 -- from getting any hints at all except whatever broke it
 type LintWriter a = WriterT [Hint] (Either Hint) a
 
-type LintResult a = Either Hint (a, [Hint])
+-- this is wrapped in a newtype because Aeson is silly and wants
+-- to serialise Either as { "Right" : … } or { "Left" : … } ...
+type LintResult' a = Either Hint (a, [Hint])
+newtype LintResult a = LintResult (LintResult' a)
+
+-- 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
+
+
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter ()
@@ -49,7 +65,7 @@ complain = lint Error
 -- | 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
+  Just a  -> Right a
   Nothing -> Left hint
 
 -- | unwrap and produce a warning if the value was Nothing
-- 
cgit v1.2.3