summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/LintConfig.hs99
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"