too much type level stuff to read a config file

This got kinda out of hand, but it can now (a) read a json config file
and (b) patch that with another json given on the command line to change
some of the options given in the file.

No, I probably didn't need to make the `patch` function sufficiently
general to work with arbitrary records, but it was kinda fun to do.

lib/LintConfig.hs

+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE StandaloneDeriving    #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+{-# LANGUAGE UndecidableInstances  #-}
+
+-- | Module that deals with handling config options
+module LintConfig where
+
+import           Control.Monad.Identity (Identity)
+import           Data.Aeson             (FromJSON (parseJSON), defaultOptions,
+                                         eitherDecode)
+import           Data.Aeson.Types       (genericParseJSON)
+import qualified Data.ByteString.Char8  as C8
+import qualified Data.ByteString.Lazy   as LB
+import           Data.Text              (Text)
+import           GHC.Generics           (Generic (Rep, from, to), K1 (..),
+                                         M1 (..), (:*:) (..))
+import           WithCli                (Proxy (..))
+import           WithCli.Pure           (Argument (argumentType, parseArgument))
+
+
+type family HKD f a where
+  HKD Identity a = a
+  HKD f a = f a
+
+
+data LintConfig f = LintConfig
+  { assemblies   :: HKD f [Text]
+  , scriptInject :: HKD f (Maybe Text)
+  } deriving (Generic)
+
+
+deriving instance (Show (HKD a (Maybe Text)), Show (HKD a [Text]))
+  => Show (LintConfig a)
+
+instance (FromJSON (HKD a (Maybe Text)), FromJSON (HKD a [Text]))
+    => FromJSON (LintConfig a) where
+  parseJSON = genericParseJSON defaultOptions
+
+-- need to define this one extra, since Aeson will not make
+-- Maybe fields optional if the type isn't given explicitly.
+--
+-- Whoever said instances had confusing semantics?
+instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where
+  parseJSON = genericParseJSON defaultOptions
+
+
+
+-- | generic typeclass for things that are "patchable"
+class GPatch i m where
+  gappend :: i p -> m p -> i p
+
+-- generic instances. It's category theory, but with confusing names!
+instance GPatch (K1 a k) (K1 a (Maybe k)) where
+  gappend _ (K1 (Just k'))    = K1 k'
+  gappend (K1 k) (K1 Nothing) = K1 k
+  {-# INLINE gappend #-}
+
+instance (GPatch i o, GPatch i' o')
+    => GPatch (i :*: i') (o :*: o') where
+  gappend (l :*: r) (l' :*: r') = gappend l l' :*: gappend r r'
+  {-# INLINE gappend #-}
+
+instance GPatch i o
+    => GPatch (M1 _a _b i) (M1 _a' _b' o) where
+  gappend (M1 x) (M1 y) = M1 (gappend x y)
+  {-# INLINE gappend #-}
+
+
+-- | A patch function. For (almost) and a :: * -> *,
+-- take an a Identity and an a Maybe, then replace all appropriate
+-- values in the former with those in the latter.
+--
+-- There isn't actually any useful reason for this function to be this
+-- abstract, I just wanted to play around with higher kinded types for
+-- a bit.
+patch ::
+  ( Generic (f Maybe)
+  , Generic (f Identity)
+  , GPatch (Rep (f Identity))
+    (Rep (f Maybe))
+  )
+  => f Identity
+  -> f Maybe
+  -> f Identity
+patch x y = to (gappend (from x) (from y))
+
+instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
+  parseArgument str =
+    case eitherDecode (LB.fromStrict $ C8.pack str) of
+      Left _    -> Nothing
+      Right res -> Just res
+
+  argumentType Proxy = "LintConfig"

src/Main.hs

@@ -6,7 +6,7 @@
 
 module Main where
 
-import           Data.Aeson               (encode)
+import           Data.Aeson               (eitherDecode, encode)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Char8    as C8
 import qualified Data.ByteString.Lazy     as LB
@@ -14,10 +14,12 @@ import           Data.Maybe               (fromMaybe)
 import           WithCli
 
 import           CheckDir                 (recursiveCheckDir)
-import WriteRepo (writeAdjustedRepository)
+import           Control.Monad.Identity   (Identity)
+import           LintConfig               (LintConfig (..), patch)
+import           System.Exit              (exitWith)
 import           Types                    (Level (..))
 import           Util                     (printPretty)
-import System.Exit (exitWith)
+import           WriteRepo                (writeAdjustedRepository)
 
 -- | the options this cli tool can take
 data Options = Options
@@ -34,6 +36,8 @@ data Options = Options
   , pretty       :: Bool
   -- ^ pretty-print the json to make it human-readable
   , out          :: Maybe String
+  , config       :: Maybe (LintConfig Maybe)
+  , configFile   :: Maybe FilePath
   } deriving (Show, Generic, HasArguments)
 
 
@@ -45,6 +49,18 @@ run options = do
   let repo = fromMaybe "." (repository options)
   let entry = fromMaybe "main.json" (entrypoint options)
   let level = fromMaybe Suggestion (lintlevel options)
+  print (config options)
+
+  lintconfig <- case configFile options of
+    Nothing -> error "Need a config file!"
+    Just path -> LB.readFile path >>= \res ->
+      case eitherDecode res :: Either String (LintConfig Identity) of
+        Left err -> error $ "config file invalid: " <> err
+        Right file -> case config options of
+          Just p  -> pure (patch file p)
+          Nothing -> pure file
+
+  print lintconfig
 
   lints <- recursiveCheckDir repo entry
 

walint.cabal

@@ -35,6 +35,7 @@ library
         Util
         Types
         Paths
+        LintConfig
     build-depends:    base,
                       aeson,
                       bytestring,
@@ -59,6 +60,7 @@ executable walint
                       aeson,
                       aeson-pretty,
                       bytestring,
+                      mtl,
 --                      bytestring-encoding,
                       text
     hs-source-dirs:   src