diff options
| -rw-r--r-- | lib/LintConfig.hs | 99 | ||||
| -rw-r--r-- | src/Main.hs | 22 | ||||
| -rw-r--r-- | walint.cabal | 2 |
3 files changed, 120 insertions, 3 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" 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 |