From 34e66b3ab80fb201f49998ab46bb7a35370012c0 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 14 Nov 2021 02:27:36 +0100
Subject: [PATCH] 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 | 99 +++++++++++++++++++++++++++++++++++++++++++++++
src/Main.hs | 22 +++++++++--
walint.cabal | 2 +
3 files changed, 120 insertions(+), 3 deletions(-)
create mode 100644 lib/LintConfig.hs
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"
diff --git a/src/Main.hs b/src/Main.hs
index 9fefd82..5dcf13c 100644
--- a/src/Main.hs
+++ b/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
diff --git a/walint.cabal b/walint.cabal
index 069d8f3..4faf69c 100644
--- a/walint.cabal
+++ b/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
--
GitLab