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.

1 files changed, 99 insertions, 0 deletions

diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
new file mode 100644
index 0000000..fed7e41
--- /dev/null
+++ b/lib/LintConfig.hs
@@ -0,0 +1,99 @@
+{-# 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"