diff --git a/configifier.cabal b/configifier.cabal --- a/configifier.cabal +++ b/configifier.cabal @@ -1,5 +1,5 @@ name: configifier -version: 0.0.2 +version: 0.0.3 synopsis: parser for config files, shell variables, command line args. description: @@ -31,6 +31,8 @@ src default-language: Haskell2010 + ghc-options: + -Wall exposed-modules: Data.Configifier build-depends: @@ -39,7 +41,8 @@ , aeson >=0.8 && <0.9 , case-insensitive >=1.2 && <1.3 , containers >=0.5 && <0.6 - , mtl >=2.2.1 && <2.3 + , either >=4.3 && <4.4 + , mtl >=2.1 && <2.3 , regex-easy >=0.1.0.0 && <0.2 , safe >=0.3 && <0.4 , string-conversions >=0.3 && <0.4 @@ -65,6 +68,7 @@ , configifier , bytestring >=0.10 && <0.11 + , mtl >=2.1 && <2.3 , pretty-show >=1.6.8 && <1.7 , string-conversions >=0.3.0.3 && <0.4 , text >=1.2 && <1.3 @@ -96,6 +100,7 @@ , case-insensitive >= 1.2.0.3 && < 1.3 , hspec >= 2.1.3 && < 2.2 , hspec-discover >= 2.1.3 && < 2.2 + , mtl >=2.1 && <2.3 , pretty-show >= 1.6.8 && < 1.7 , QuickCheck >= 2.7.6 && < 2.8 , scientific >= 0.3.3.5 && < 0.4 diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -16,47 +16,49 @@ module Main where -import Control.Applicative -import Data.String.Conversions -import Data.Typeable -import Prelude +import Control.Applicative ((<$>)) +import Data.String.Conversions (ST, cs) +import Data.Typeable (Proxy(Proxy)) +import System.Environment (getEnvironment, getArgs) import Text.Show.Pretty (ppShow) -import System.Environment import qualified Data.ByteString as SBS import qualified Data.Text.IO as ST -import qualified Data.Yaml as Yaml import Data.Configifier --- * the config types +-- * an interesting example -type Cfg = - "bla" :> Int - :| "blu" :> SubCfg :>: "description of blu" - :| "uGH" :> [Cfg'] :>: "... and something about uGH" +type Cfg = NoDesc CfgDesc +type CfgDesc = ToConfigCode Cfg' type Cfg' = - "go" :> ST - :| "blu" :> SubCfg + "frontend" :> ServerCfg :>: "descr" + :*> Maybe ("backend" :> ServerCfg) + :*> "default_users" :> [UserCfg] :>: "list of users that are created on start if database is empty" -type SubCfg = - "lii" :> Bool :>: "lii-desc" +type ServerCfg = + "bind_port" :> Int + :*> "bind_host" :> ST + :*> Maybe ("expose_host" :> ST) +type UserCfg = + "name" :> ST :>: "user name (must be unique)" + :*> "email" :> ST :>: "email address (must also be unique)" + :*> "password" :> ST :>: "password (not encrypted)" --- | you can write sample configs in haskell syntax. (it's not very --- convenient, so luckily it's not usually required either. see test --- suite on how to access fields in cfg from here on.) -defaultCfg :: Cfg -defaultCfg = - entry 3 - :| entry False - :| entry [ entry "drei" :| entry True - , entry "vier" :| entry False - ] +defaultCfg :: Tagged Cfg +defaultCfg = Tagged $ + Id (Id 8001 :*> Id "localhost" :*> JustO (Id "expose")) + :*> JustO (Id (Id 8002 :*> Id "localhost" :*> NothingO)) + :*> Id [u1, u2] + where + u1 = Id "ralf" :*> Id "ralf@localhost" :*> Id "gandalf" + u2 = Id "claudi" :*> Id "claudi@remotehost" :*> Id "also_gandalf" + main :: IO () main = do sources <- sequence @@ -65,17 +67,19 @@ , CommandLine <$> getArgs ] - -- putStrLn $ ppShow sources + ST.putStrLn $ docs (Proxy :: Proxy CfgDesc) - ST.putStrLn $ docs (Proxy :: Proxy Cfg) + let dump cfg = do + putStrLn $ ppShow cfg + putStrLn . cs . renderConfigFile $ cfg - case configify sources of + dump defaultCfg + + case configify sources :: Result Cfg of Left e -> print e - Right (cfg :: Cfg) -> do - putStrLn $ ppShow cfg - putStrLn . cs . Yaml.encode $ cfg + Right cfg -> do + dump cfg putStrLn "accessing config values:" - print $ (cfg >. (Proxy :: Proxy '["bla"])) - print $ (cfg >. (Proxy :: Proxy '["blu", "lii"])) - print $ (>. (Proxy :: Proxy '["go"])) <$> (cfg >. (Proxy :: Proxy '["uGH"])) + print $ cfg >>. (Proxy :: Proxy '["frontend"]) + print $ cfg >>. (Proxy :: Proxy '["frontend", "expose_host"]) diff --git a/src/Data/Configifier.hs b/src/Data/Configifier.hs --- a/src/Data/Configifier.hs +++ b/src/Data/Configifier.hs @@ -1,88 +1,113 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE UndecidableInstances #-} -- should only be required to run 'HasParseCommandLine'; remove later! - -{-# OPTIONS #-} - module Data.Configifier where import Control.Applicative ((<$>), (<*>), (<|>)) -import Control.Exception (assert) -import Control.Monad.Error.Class (catchError) -import Data.Aeson (ToJSON, FromJSON, Value(Object, Null), object, toJSON) +import Control.Exception (Exception) +import Data.Aeson (ToJSON, FromJSON, Value(Object, Null), object, toJSON, (.=)) import Data.CaseInsensitive (mk) import Data.Char (toUpper) +import Data.Either.Combinators (mapLeft) import Data.Function (on) -import Data.List (nubBy, intercalate, sort) +import Data.List (nubBy, intercalate) import Data.Maybe (catMaybes) -import Data.String.Conversions (ST, SBS, cs, (<>)) -import Data.Typeable (Typeable, Proxy(Proxy)) +import Data.Monoid (Monoid, (<>), mempty, mappend, mconcat) +import Data.String.Conversions (ST, SBS, cs) +import Data.Typeable (Typeable, Proxy(Proxy), typeOf) import GHC.TypeLits (Symbol, KnownSymbol, symbolVal) -import Safe (readMay) --- (FIXME: can i replace aeson entirely with yaml? right now, the mix --- of use of both is rather chaotic.) - import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as Set import qualified Data.Vector as Vector import qualified Data.Yaml as Yaml import qualified Text.Regex.Easy as Regex --- * type combinators +-- * config types --- | the equivalent of record field selectors. -data (s :: Symbol) :> (t :: *) = L t +-- | Construction of config records (@cons@ for record fields). +data a :*> b = a :*> b deriving (Eq, Ord, Show, Typeable) +infixr 6 :*> + +-- | Construction of config record fields. +data (s :: Symbol) :> (t :: *) + deriving (Typeable) infixr 9 :> --- | descriptive strings for documentation. (the way we use this is --- still a little awkward. use tuple of name string and descr string? --- or a type class "path" with a type family that translates both @"" --- :>: ""@ and @""@ to @""@?) -data a :>: (s :: Symbol) = D a - deriving (Eq, Ord, Show, Typeable) +-- | Add descriptive text to record field for documentation. +data a :>: (s :: Symbol) + deriving (Typeable) infixr 8 :>: --- | @cons@ for record fields. -data a :| b = a :| b - deriving (Eq, Ord, Show, Typeable) -infixr 6 :| +data ConfigCode k = + Record (ConfigCode k) (ConfigCode k) + | Label Symbol (ConfigCode k) + | Descr (ConfigCode k) Symbol + | List (ConfigCode k) + | Option (ConfigCode k) + | Type k --- * constructing config values +infixr 6 `Record` -class Entry a b where - entry :: a -> b -instance (a ~ b) => Entry a b where - entry = id +-- | Map user-provided config type to 'ConfigCode' types. +type family ToConfigCode (a :: *) :: ConfigCode * where + ToConfigCode (a :*> b) = Record (ToConfigCode a) (ToConfigCode b) + ToConfigCode (s :> a) = Label s (ToConfigCode a) + ToConfigCode (a :>: s) = Descr (ToConfigCode a) s + ToConfigCode [a] = List (ToConfigCode a) + ToConfigCode (Maybe a) = Option (ToConfigCode a) + ToConfigCode a = Type a -instance Entry a b => Entry a (s :> b) where - entry = L . entry +-- | Filter 'Descr' constructors from 'ConfigCode'. +type family NoDesc (a :: ConfigCode *) :: ConfigCode * where + NoDesc (Record a b) = Record (NoDesc a) (NoDesc b) + NoDesc (Label s a) = Label s (NoDesc a) + NoDesc (Descr a s) = NoDesc a + NoDesc (List a) = List (NoDesc a) + NoDesc (Option a) = Option (NoDesc a) + NoDesc (Type a) = Type a -instance Entry a b => Entry a (b :>: s) where - entry = D . entry +-- | Map 'ConfgCode' types to the types of config values. +type family ToConfig (a :: ConfigCode *) (f :: * -> *) :: * where + ToConfig (Record a b) f = ToConfig a f :*> ToConfig b f + ToConfig (Label s a) f = f (ToConfig a f) + ToConfig (List a) f = [ToConfig a f] + ToConfig (Option a) f = MaybeO (ToConfig a f) + ToConfig (Type a) f = a +-- | 'MaybeO' is isomorphic to 'Maybe', but is only used for 'Option' +-- values. +data MaybeO a = JustO a | NothingO + deriving (Eq, Ord, Show, Typeable) +-- | Transformers' 'Identity' is not in 'Typeable', so we roll our +-- own. It's also less work to write. +data Id a = Id a + deriving (Eq, Ord, Show, Typeable) + + -- * sources data Source = @@ -95,137 +120,250 @@ data ShellEnv data CommandLine + +-- * tagged values + +data Tagged cfg = Tagged { fromTagged :: ToConfig cfg Id } + +data TaggedM cfg = TaggedM { fromTaggedM :: ToConfig cfg Maybe } + + +-- deriving with type functions does not work, so we just write a lot +-- of boilerplate here. + +instance (Eq (ToConfig cfg Id)) => Eq (Tagged cfg) where + Tagged a == Tagged b = a == b + +instance (Eq (ToConfig cfg Maybe)) => Eq (TaggedM cfg) where + TaggedM a == TaggedM b = a == b + +instance (Show (ToConfig cfg Id)) => Show (Tagged cfg) where + show (Tagged x) = "(Tagged " ++ show x ++ ")" + +instance (Show (ToConfig cfg Maybe)) => Show (TaggedM cfg) where + show (TaggedM x) = "(TaggedM " ++ show x ++ ")" + + +-- * results and errors + +type Result cfg = Either Error (Tagged cfg) + data Error = - InvalidJSON String - | ShellEnvNoParse (String, String) - | ShellEnvSegmentNotFound String + InvalidYaml + { invalidYamlInput :: SBS + , invalidYamlMsg :: String + } + | ShellEnvNil + | ShellEnvNoParse + { shellEnvNoParseType :: String + , shellEnvNoParseValue :: String + , shellEnvNoParseMsg :: String + } | CommandLinePrimitiveParseError String - | CommandLinePrimitiveOther Error + | CommandLinePrimitiveOtherError Error + | FreezeIncomplete + { freezeIncompleteAtPath :: [String] + } deriving (Eq, Ord, Show, Typeable) -configify :: forall cfg . - ( FromJSON cfg - , HasParseConfigFile cfg +instance Exception Error + + +-- * the main function + +configify :: forall cfg tm . + ( tm ~ TaggedM cfg + , Show tm + , Monoid tm + , Freeze cfg + , FromJSON tm , HasParseShellEnv cfg , HasParseCommandLine cfg - ) => [Source] -> Either Error cfg -configify sources = sequence (_get <$> sources) >>= _parse . merge + , CanonicalizePartial cfg + ) => [Source] -> Result cfg +configify = configify' (mempty :: tm) + +configify' :: forall cfg tm . + ( tm ~ TaggedM cfg + , Show tm + , Monoid tm + , Freeze cfg + , FromJSON tm + , HasParseShellEnv cfg + , HasParseCommandLine cfg + , CanonicalizePartial cfg + ) => tm -> [Source] -> Result cfg +configify' def sources = sequence (get <$> sources) >>= merge . (def:) where - proxy = Proxy :: Proxy cfg + get :: Source -> Either Error tm + get (ConfigFileYaml sbs) = parseConfigFile sbs + get (ShellEnv env) = parseShellEnv env + get (CommandLine args) = parseCommandLine args - _get :: Source -> Either Error Aeson.Value - _get (ConfigFileYaml sbs) = parseConfigFile proxy sbs - _get (ShellEnv env) = parseShellEnv proxy env - _get (CommandLine args) = parseCommandLine proxy args - _parse :: Aeson.Value -> Either Error cfg - _parse = either (Left . InvalidJSON) (Right) . Aeson.parseEither Aeson.parseJSON +-- * yaml / json +parseConfigFile :: (FromJSON (TaggedM cfg)) => SBS -> Either Error (TaggedM cfg) +parseConfigFile sbs = mapLeft (InvalidYaml sbs) $ Yaml.decodeEither sbs --- * json / yaml +renderConfigFile :: (Freeze cfg, t ~ Tagged cfg, ToJSON (TaggedM cfg)) => t -> SBS +renderConfigFile = Yaml.encode . thaw -class HasParseConfigFile cfg where - parseConfigFile :: Proxy cfg -> SBS -> Either Error Aeson.Value -instance HasParseConfigFile cfg where - parseConfigFile Proxy sbs = either (Left . InvalidJSON) (Right) (Yaml.decodeEither sbs) +-- render json -instance (KnownSymbol path, FromJSON v) => FromJSON (path :> v) where - parseJSON = Aeson.withObject "config object" $ \ m -> - let proxy = Proxy :: Proxy path - key = cs $ symbolVal proxy - in L <$> m Aeson..: key +-- | @instance ToJSON Record@ +instance ( t1 ~ ToConfig cfg1 Maybe, ToJSON (TaggedM cfg1) + , t2 ~ ToConfig cfg2 Maybe, ToJSON (TaggedM cfg2) + ) + => ToJSON (TaggedM (Record cfg1 cfg2)) where + toJSON (TaggedM (o1 :*> o2)) = case ( toJSON (TaggedM o1 :: TaggedM cfg1) + , toJSON (TaggedM o2 :: TaggedM cfg2) + ) of + (Object m1, Object m2) -> Object $ HashMap.union m2 m1 + (v, Null) -> v + (_, v') -> v' -instance (FromJSON o1, FromJSON o2) - => FromJSON (o1 :| o2) where - parseJSON value = (:|) <$> (Aeson.parseJSON value :: Aeson.Parser o1) - <*> (Aeson.parseJSON value :: Aeson.Parser o2) +-- | @instance ToJSON Label@ +instance ( ToJSON (TaggedM cfg) + , KnownSymbol s + ) + => ToJSON (TaggedM (Label s cfg)) where + toJSON (TaggedM Nothing) = Aeson.Null + toJSON (TaggedM (Just v)) = case toJSON (TaggedM v :: TaggedM cfg) of + Aeson.Null -> Aeson.Null + val -> object [key .= val] where key = cs $ symbolVal (Proxy :: Proxy s) -instance (KnownSymbol path, KnownSymbol descr, FromJSON v) => FromJSON (path :> v :>: descr) where - parseJSON = Aeson.withObject "config object" $ \ m -> - let key = cs $ symbolVal (Proxy :: Proxy path) - in D . L <$> m Aeson..: key +-- | @instance ToJSON List@ +instance ( t ~ ToConfig cfg Maybe + , ToJSON (TaggedM cfg) + ) + => ToJSON (TaggedM (List cfg)) where + toJSON (TaggedM vs) = toJSON $ (TaggedM :: t -> TaggedM cfg) <$> vs -instance (KnownSymbol path, ToJSON v) => ToJSON (path :> v) where - toJSON (L v) = object [cs (symbolVal (Proxy :: Proxy path)) Aeson..= toJSON v] +-- | @instance ToJSON Option@ +instance ( t ~ ToConfig cfg Maybe + , ToConfig (Option cfg) Maybe ~ MaybeO t'' + , ToJSON (TaggedM cfg) + ) => ToJSON (TaggedM (Option cfg)) where + toJSON (TaggedM (JustO v)) = toJSON $ (TaggedM v :: TaggedM cfg) + toJSON (TaggedM NothingO) = Aeson.Null -instance (ToJSON o1, ToJSON o2) => ToJSON (o1 :| o2) where - toJSON (o1 :| o2) = toJSON o1 <<>> toJSON o2 +-- | @instance ToJSON Type@ +instance (ToJSON a) => ToJSON (TaggedM (Type a)) where + toJSON (TaggedM v) = toJSON v -instance (KnownSymbol path, KnownSymbol descr, ToJSON v) => ToJSON (path :> v :>: descr) where - toJSON (D l) = toJSON l +-- parse json --- * shell env. +-- | @instance FromJSON Record@ +instance (FromJSON (TaggedM cfg1), FromJSON (TaggedM cfg2)) => FromJSON (TaggedM (Record cfg1 cfg2)) where + parseJSON json = do + TaggedM o1 :: TaggedM cfg1 <- Aeson.parseJSON json + TaggedM o2 :: TaggedM cfg2 <- Aeson.parseJSON json + return . TaggedM $ o1 :*> o2 -type Env = [(String, String)] +-- | @instance FromJSON Label@ (tolerates unknown fields in json object.) +instance (FromJSON (TaggedM cfg), KnownSymbol s) => FromJSON (TaggedM (Label s cfg)) where + parseJSON = Aeson.withObject "configifier object" $ \ m -> + case HashMap.lookup key m of + (Just json) -> TaggedM . Just . fromTaggedM <$> parseJSON' json + Nothing -> return $ TaggedM Nothing + where + key = cs $ symbolVal (Proxy :: Proxy s) + parseJSON' :: Aeson.Value -> Aeson.Parser (TaggedM cfg) = Aeson.parseJSON -class HasParseShellEnv a where - parseShellEnv :: Proxy a -> Env -> Either Error Aeson.Value +-- | @instance ParseJSON List@ +instance (FromJSON (TaggedM cfg)) => FromJSON (TaggedM (List cfg)) where + parseJSON = Aeson.withArray "configifier list" $ \ vector -> do + vector' :: [TaggedM cfg] <- sequence $ Aeson.parseJSON <$> Vector.toList vector + return . TaggedM . (fromTaggedM <$>) $ vector' -class HasParseShellEnv' a where - parseShellEnv' :: Proxy a -> Env -> Either Error Aeson.Pair +-- | @instance ParseJSON Option@ +instance (FromJSON (TaggedM cfg)) => FromJSON (TaggedM (Option cfg)) where + parseJSON Null = return (TaggedM NothingO :: TaggedM (Option cfg)) + parseJSON v = do + TaggedM js :: TaggedM cfg <- Aeson.parseJSON v + return $ (TaggedM (JustO js) :: TaggedM (Option cfg)) -instance HasParseShellEnv Int where - parseShellEnv Proxy [("", s)] = Aeson.Number <$> _catch (readMay s) - where - _catch = maybe (Left $ ShellEnvNoParse ("Int", s)) Right +-- | @instance FromJSON Type@ +instance (FromJSON a) => FromJSON (TaggedM (Type a)) where + parseJSON = (TaggedM <$>) . Aeson.parseJSON -instance HasParseShellEnv Bool where - parseShellEnv Proxy [("", s)] = Aeson.Bool <$> _catch (readMay s) - where - _catch = maybe (Left $ ShellEnvNoParse ("Bool", s)) Right -instance HasParseShellEnv ST where - parseShellEnv Proxy [("", s)] = Right . Aeson.String $ cs s +-- * shell env --- | since shell env is not ideally suitable for providing --- arbitrary-length lists of sub-configs, we cheat: if a value is fed --- into a place where a list of values is expected, a singleton list --- is constructed implicitly. -instance HasParseShellEnv a => HasParseShellEnv [a] where - parseShellEnv Proxy = fmap (Aeson.Array . Vector.fromList . (:[])) . parseShellEnv (Proxy :: Proxy a) +type Env = [(String, String)] --- | the sub-object structure of the config file is represented by '_' --- in the shell variable names. (i think it's still ok to have '_' in --- your config variable names instead of caml case; this parser first --- chops off matching names, then worries about trailing '_'.) -instance (KnownSymbol path, HasParseShellEnv v) => HasParseShellEnv (path :> v) where - parseShellEnv Proxy env = do - let key = symbolVal (Proxy :: Proxy path) - env' = catMaybes $ _crop <$> env +class HasParseShellEnv (cfg :: ConfigCode *) where + parseShellEnv :: Env -> Either Error (TaggedM cfg) - _crop :: (String, String) -> Maybe (String, String) - _crop (k, v) = case splitAt (length key) k of - (key', s@"") | mk key == mk key' -> Just (s, v) - (key', '_':s@(_:_)) | mk key == mk key' -> Just (s, v) - _ -> Nothing +instance (HasParseShellEnv a, HasParseShellEnv b) => HasParseShellEnv (Record a b) where + parseShellEnv env = do + TaggedM x :: TaggedM a <- parseShellEnv env + TaggedM y :: TaggedM b <- parseShellEnv env + return . TaggedM $ x :*> y - if null env' - then Left $ ShellEnvSegmentNotFound key - else do - val :: Aeson.Value <- parseShellEnv (Proxy :: Proxy v) env' - return $ object [cs key Aeson..= val] +-- | The paths into the recursive structure of the config file are +-- concatenated to shell variable names with separating '_'. (It is +-- still ok to have '_' in your config path names. This parser chops +-- off complete matching names, whether they contain '_' or not, and +-- only then worries about trailing '_'.) +instance (KnownSymbol path, HasParseShellEnv a) => HasParseShellEnv (Label path a) where + parseShellEnv [] = return $ TaggedM Nothing + parseShellEnv env@(_:_) = + case parseShellEnv env' :: Either Error (TaggedM a) of + Right (TaggedM a) -> Right . TaggedM . Just $ a + Left ShellEnvNil -> Right . TaggedM $ Nothing + Left e -> Left e + where + key = symbolVal (Proxy :: Proxy path) + env' = catMaybes $ crop <$> env -instance (KnownSymbol path, HasParseShellEnv v, HasParseShellEnv o) => HasParseShellEnv (path :> v :| o) where - parseShellEnv Proxy env = mergeAndCatch - [ parseShellEnv (Proxy :: Proxy o) env - , parseShellEnv (Proxy :: Proxy (path :> v)) env - ] + crop :: (String, String) -> Maybe (String, String) + crop (k, v) = case splitAt (length key) k of + (key', s@"") | mk key == mk key' -> Just (s, v) + (key', '_':s@(_:_)) | mk key == mk key' -> Just (s, v) + _ -> Nothing -instance (KnownSymbol path, KnownSymbol descr, HasParseShellEnv v) => HasParseShellEnv (path :> v :>: descr) where - parseShellEnv Proxy = parseShellEnv (Proxy :: Proxy (path :> v)) +-- | You can provide a list value via the shell environment by +-- providing a single element. This element will be put into a list +-- implicitly. +-- +-- (A more general approach that allows for yaml-encoded list values +-- in shell variables is more tricky to design, implement, and use: If +-- you have a list of sub-configs and don't want the entire sub-config +-- to be yaml-encoded, but use a longer shell variable name to go +-- further down to deeper sub-configs, there is a lot of ambiguity. +-- It may be possible to resolve that at run-time, but it's more +-- tricky.) +instance (HasParseShellEnv a) => HasParseShellEnv (List a) where + parseShellEnv env = do + TaggedM a :: TaggedM a <- parseShellEnv env + return $ TaggedM [a] -instance (KnownSymbol path, KnownSymbol descr, HasParseShellEnv v, HasParseShellEnv o) => HasParseShellEnv (path :> v :>: descr :| o) where - parseShellEnv Proxy = parseShellEnv (Proxy :: Proxy (path :> v :| o)) +instance HasParseShellEnv a => HasParseShellEnv (Option a) where + parseShellEnv env = do + TaggedM a :: TaggedM a <- parseShellEnv env + return $ TaggedM (JustO a) +instance (Typeable a, FromJSON (TaggedM (Type a))) => HasParseShellEnv (Type a) where + parseShellEnv = f + where + f [] = Left $ ShellEnvNil + f (filter (null . fst) -> [("", s)]) = mapLeft renderError (Yaml.decodeEither (cs s)) + where + renderError :: String -> Error + renderError e = ShellEnvNoParse (show $ typeOf (undefined :: a)) s e + f bad = error $ "instance HasParseShellEnv (Type a): inconsistent environment: " ++ show bad + -- * cli type Args = [String] class HasParseCommandLine cfg where - parseCommandLine :: Proxy cfg -> [String] -> Either Error Aeson.Value + parseCommandLine :: [String] -> Either Error (TaggedM cfg) instance (HasParseShellEnv cfg) => HasParseCommandLine cfg where parseCommandLine = primitiveParseCommandLine @@ -236,14 +374,12 @@ -- the command line. If it doesn't like the syntax used in the -- command line, it will crash. I hope for this to get much fancier -- in the future. -primitiveParseCommandLine :: (HasParseShellEnv cfg) => Proxy cfg -> [String] -> Either Error Aeson.Value -primitiveParseCommandLine proxy args = - convertParseError (lastWins <$> parseArgs args) - >>= convertShellEnvError . parseShellEnv proxy +primitiveParseCommandLine :: (HasParseShellEnv cfg) => [String] -> Either Error (TaggedM cfg) +primitiveParseCommandLine args = + mapLeft CommandLinePrimitiveParseError (lastWins <$> parseArgs args) + >>= mapLeft CommandLinePrimitiveOtherError . parseShellEnv where - convertParseError = either (Left . CommandLinePrimitiveParseError) Right - convertShellEnvError = either (Left . CommandLinePrimitiveOther) Right - lastWins = reverse . nubBy ((==) `on` fst) . reverse + lastWins = reverse . nubBy ((==) `on` fst) . reverse parseArgs :: Args -> Either String Env parseArgs [] = Right [] @@ -253,93 +389,150 @@ parseArgsWithEqSign :: String -> Either String Env parseArgsWithEqSign s = case cs s Regex.=~- "^--([^=]+)=(.*)$" of - [_, k, v] -> Right [(cs k, cs v)] + [_, k, v] -> Right [(parseArgName $ cs k, cs v)] bad -> Left $ "could not parse last arg: " ++ show (s, bad) parseArgsWithSpace :: String -> String -> Either String Env parseArgsWithSpace s v = case cs s Regex.=~- "^--([^=]+)$" of - [_, k] -> Right [(cs k, cs v)] + [_, k] -> Right [(parseArgName $ cs k, cs v)] bad -> Left $ "could not parse long-arg with value: " ++ show (s, v, bad) +parseArgName :: String -> String +parseArgName = map f + where + f '-' = '_' + f c = toUpper c + -- * accessing config values --- ** data types +-- | Map a 'Tagged' config value and a type-level path to the part of +-- the config value the path points to. Trigger an informative type +-- error if path does not exist. +(>>.) :: forall cfg ps r . (Sel cfg ps, ToValE cfg ps ~ Done r) => Tagged cfg -> Proxy ps -> r +(>>.) v p = case sel v p of + CJust x -> x + _ -> error "inaccessible" --- | Type-level lookup of a path in a configuration type. --- A path is represented as a list of symbols. -type family Val (a :: *) (p :: [Symbol]) :: Maybe * where - Val a '[] = Just a - Val (a :| b) (p ': ps) = OrElse (Val a (p ': ps)) (Val b (p ': ps)) - Val (a :>: s) (p ': ps) = Val a (p ': ps) - Val (p :> t) (p ': ps) = Val t ps - Val a p = Nothing +infix 7 >>. + +-- | Map 'ConfgCode' types to the types of config values. +type family ToVal (a :: ConfigCode *) (p :: [Symbol]) :: Maybe * where + ToVal (Record a b) '[] = Just (ToConfig (Record a b) Id) + ToVal (Record a b) ps = OrElse (ToVal a ps) (ToVal b ps) + ToVal (Label p a) (p ': ps) = ToVal a ps + ToVal (Option a) ps = ToValueMaybe (ToVal a ps) + ToVal a '[] = Just (ToConfig a Id) + ToVal a (p ': ps) = Nothing + -- | This is '<|>' on 'Maybe' lifted to the type level. type family OrElse (x :: Maybe k) (y :: Maybe k) :: Maybe k where - OrElse (Just x) y = Just x - OrElse Nothing y = y + OrElse (Just x) y = Just x + OrElse Nothing y = y --- | A 'CMaybe' is a static version of 'Maybe', i.e., we know at --- compile time whether we have 'Just' or 'Nothing'. +-- | Compile-time 'Maybe'. Type-level 'Just' / 'Nothing' (as produced +-- by 'ToVal') are embedded in each constructor, resp.. Since 'Just' +-- and 'Nothing' are different types, 'CNothing' and 'CJust' can be +-- distinguished by the type checker. data CMaybe (a :: Maybe *) where - CNothing :: CMaybe Nothing - CJust :: a -> CMaybe (Just a) + CNothing :: CMaybe Nothing + CJust :: a -> CMaybe (Just a) -- | This is a version of '<|>' on 'Maybe' for 'CMaybe'. -combine :: CMaybe a -> CMaybe b -> CMaybe (OrElse a b) -combine (CJust x) _ = CJust x -combine CNothing y = y +orElse :: CMaybe a -> CMaybe b -> CMaybe (OrElse a b) +orElse (CJust x) _ = CJust x +orElse CNothing y = y --- ** exposed interface +-- *** options --- | This is a wrapper around 'sel' that hides the interal use of --- 'CMaybe'. As we expect, this version will just cause a type error --- if it is applied to an illegal path. -(>.) :: forall a p r . (Sel a p, ValE a p ~ Done r) => a -> Proxy p -> r -(>.) cfg p = case sel cfg p of - CJust x -> x - _ -> error "inaccessible" +-- for selecting optional parts, i don't think i have found the most +-- elegant solution yet. --- | FIXME: is it possible to remove 'CMaybe' from the signature and --- return @Val a p@ instead? -class Sel a p where - sel :: a -> Proxy p -> CMaybe (Val a p) +type family ToValueMaybe (a :: Maybe *) :: Maybe * where + ToValueMaybe (Just x) = Just (Maybe x) + ToValueMaybe Nothing = Nothing +toValueMaybe :: CMaybe a -> CMaybe (ToValueMaybe a) +toValueMaybe (CJust x) = CJust $ Just x +toValueMaybe CNothing = CNothing --- ** implementation of 'Sel' +class NothingValue (a :: Maybe *) where + nothingValue :: Proxy a -> CMaybe (ToValueMaybe a) -instance Sel a '[] where - sel x _ = CJust x +instance NothingValue Nothing where + nothingValue _ = CNothing -instance Sel a (p ': ps) => Sel (a :>: s) (p ': ps) where - sel (D x) _ = sel x (Proxy :: Proxy (p ': ps)) +instance NothingValue (Just x) where + nothingValue _ = CJust Nothing -instance Sel t ps => Sel (p :> t) (p ': ps) where - sel (L x) _ = sel x (Proxy :: Proxy ps) -instance (Sel a (p ': ps), Sel b (p ': ps)) => Sel (a :| b) (p ': ps) where - sel (x :| y) _ = combine (sel x (Proxy :: Proxy (p ': ps))) (sel y (Proxy :: Proxy (p ': ps))) +-- *** cfg traversal --- | We need the 'Val' constraint here because overlapping instances --- and closed type families aren't fully compatible. GHC won't be --- able to recognize that we've already excluded the other cases and --- not reduce 'Val' automatically. But the constraint should always --- resolve, unless we've made a mistake, and the worst outcome if we --- did are extra type errors, not run-time errors. -instance (Val a ps ~ Nothing) => Sel a ps where - sel _ _ = CNothing +-- We need the 'Val' constraint in some instances because overlapping +-- instances and closed type families aren't fully compatible. GHC +-- won't be able to recognize that we've already excluded the other +-- cases and not reduce 'Val' automatically. But the constraints should +-- always resolve, unless we've made a mistake, and the worst outcome +-- if we did are extra type errors, not run-time errors. +class Sel cfg ps where + sel :: Tagged cfg -> Proxy ps -> CMaybe (ToVal cfg ps) +instance Sel (Record cfg' cfg'') '[] where + sel (Tagged record) Proxy = CJust record --- ** better errors +instance ( cfg ~ Record cfg' cfg'' + -- @ToVal cfg ps ~ Just t@ or @ToVal cfg ps ~ Nothing@ + , Sel cfg' (p ': ps) + , Sel cfg'' (p ': ps) + ) => Sel (Record cfg' cfg'') (p ': ps) where + sel (Tagged (a :*> b)) path = orElse (sel (Tagged a :: Tagged cfg') path) (sel (Tagged b :: Tagged cfg'') path) +instance ( cfg ~ Label p cfg' + -- @ToVal cfg ps ~ Just t@ or @ToVal cfg ps ~ Nothing@ + , t ~ ToConfig cfg Id + , Sel cfg' ps + , KnownSymbol p + ) => Sel (Label p cfg') (p ': ps) where + sel (Tagged (Id a)) Proxy = sel (Tagged a :: Tagged cfg') (Proxy :: Proxy ps) + +instance ( cfg ~ Option cfg' + , NothingValue (ToVal cfg' ps) + , Sel cfg' ps + ) => Sel (Option cfg') ps where + sel (Tagged NothingO) _ = nothingValue (Proxy :: Proxy (ToVal cfg' ps)) + sel (Tagged (JustO a)) ps = toValueMaybe $ sel (Tagged a :: Tagged cfg') ps + +instance Sel' cfg ps => Sel cfg ps where + sel = sel' + +-- | Helper class for disambiguating overlaps. The trick is that the +-- 'Sel' instance based on the 'Sel'' constraint is more general +-- than all other instances, so @OverlappingInstances@ will ensure it +-- is matched last. This way, no instance of 'Sel'' can wrongly +-- overlap with any instance of 'Sel'. +class Sel' cfg ps where + sel' :: Tagged cfg -> Proxy ps -> CMaybe (ToVal cfg ps) + +instance ( t ~ ToConfig cfg Id + , ToVal cfg '[] ~ Just t + ) => Sel' cfg '[] where + sel' (Tagged a) Proxy = CJust a + +instance ( ToVal cfg (p ': ps) ~ Nothing + ) => Sel' cfg (p ': ps) where + sel' _ _ = CNothing + + +-- *** static lookup error handling + +type ToValE (a :: ConfigCode *) (p :: [Symbol]) = ToExc (LookupFailed a p) (ToVal a p) + data Exc a b = Fail a | Done b data LookupFailed a p -type ValE (a :: *) (p :: [Symbol]) = ToExc (LookupFailed a p) (Val a p) - type family ToExc (a :: k) (x :: Maybe l) :: Exc k l where ToExc a Nothing = Fail a ToExc a (Just x) = Done x @@ -347,40 +540,197 @@ -- * merge configs --- | Merge two json trees such that the latter overwrites nodes in the --- former. 'Null' is considered as non-existing. Otherwise, right --- values overwrite left values. -(<<>>) :: Aeson.Value -> Aeson.Value -> Aeson.Value -(<<>>) (Object m) (Object m') = object $ f <$> ks - where - ks :: [ST] - ks = Set.toList . Set.fromList $ HashMap.keys m ++ HashMap.keys m' +merge :: forall cfg tm ti . + ( tm ~ TaggedM cfg + , ti ~ Tagged cfg + , Freeze cfg + , Monoid tm + , CanonicalizePartial cfg + ) => [tm] -> Either Error ti +merge = freeze . mconcat . map canonicalizePartial - f :: ST -> Aeson.Pair - f k = k Aeson..= - case (k `HashMap.lookup` m, k `HashMap.lookup` m') of - (Just v, Just v') -> v <<>> v' - (Nothing, Just v') -> v' - (Just v, Nothing) -> v - (Nothing, Nothing) -> assert False $ error "internal error in (<<>>)" +freeze :: forall cfg tm ti . + ( tm ~ TaggedM cfg + , ti ~ Tagged cfg + , Freeze cfg + ) => tm -> Either Error ti +freeze = fmap Tagged . frz (Proxy :: Proxy cfg) [] . fromTaggedM -(<<>>) v Null = v -(<<>>) _ v' = v' +thaw :: forall cfg tm ti . + ( tm ~ TaggedM cfg + , ti ~ Tagged cfg + , Freeze cfg + ) => ti -> tm +thaw = TaggedM . thw (Proxy :: Proxy cfg) . fromTagged -merge :: [Aeson.Value] -> Aeson.Value -merge = foldl (<<>>) Aeson.Null -mergeAndCatch :: [Either Error Aeson.Value] -> Either Error Aeson.Value -mergeAndCatch = foldl (\ ev ev' -> (<<>>) <$> c'tcha ev <*> c'tcha ev') (Right Null) - where - -- (this name is a sound from the samurai jack title tune. it - -- has nothing to do with this, but it sounds nice. go watch - -- samurai jack!) - c'tcha = (`catchError` \ _ -> return Null) +instance (Monoid (TaggedM a), Monoid (TaggedM b)) => Monoid (TaggedM (Record a b)) where + mempty = + TaggedM $ fromTaggedM (mempty :: TaggedM a) + :*> fromTaggedM (mempty :: TaggedM b) + mappend (TaggedM (x :*> y)) (TaggedM (x' :*> y')) = + TaggedM $ (fromTaggedM $ tagA x <> tagA x') + :*> (fromTaggedM $ tagB y <> tagB y') + where + tagA v = TaggedM v :: TaggedM a + tagB v = TaggedM v :: TaggedM b +-- | If one of two configs is 'Nothing', do the expected thing. If +-- both are 'Just', append the values. +instance (Monoid (TaggedM a)) => Monoid (TaggedM (Label s a)) where + mempty = TaggedM Nothing + mappend xt@(TaggedM _) (TaggedM Nothing) = xt + mappend (TaggedM Nothing) xt'@(TaggedM _) = xt' + mappend (TaggedM (Just x)) (TaggedM (Just x')) = TaggedM . Just . fromTaggedM $ tagA x <> tagA x' + where + tagA :: ToConfig a Maybe -> TaggedM a + tagA = TaggedM --- * docs. +-- | There is no @instance Monoid (TaggedM (Type a))@, since there +-- is no reasonable 'mempty'. Therefore, we offer a specialized +-- instance for labels that map to 'Type'. +instance Monoid (TaggedM (Label s (Type a))) where + mempty = TaggedM Nothing + mappend xt@(TaggedM _) (TaggedM Nothing) = xt + mappend (TaggedM _ ) xt'@(TaggedM _) = xt' +-- | Lists are initialized empty by default. Append overwrites left +-- values with right values. (If we tried to append list elements +-- recursively, there would be awkward questions about matching list +-- lengths.) +instance Monoid (TaggedM (List a)) where + mempty = TaggedM [] + mappend _ l = l + +instance (Monoid (TaggedM a)) => Monoid (TaggedM (Option a)) where + mempty = TaggedM NothingO + mappend x (TaggedM NothingO) = x + mappend (TaggedM NothingO) x' = x' + mappend (TaggedM (JustO x)) (TaggedM (JustO x')) = TaggedM . JustO . fromTaggedM $ tagA x <> tagA x' + where + tagA :: ToConfig a Maybe -> TaggedM a + tagA = TaggedM + + +class Freeze c where + frz :: Proxy c -> [String] -> ToConfig c Maybe -> Either Error (ToConfig c Id) + thw :: Proxy c -> ToConfig c Id -> ToConfig c Maybe + +instance (Freeze a, Freeze b) => Freeze (Record a b) where + frz Proxy path (x :*> y) = do + x' <- frz (Proxy :: Proxy a) path x + y' <- frz (Proxy :: Proxy b) path y + Right $ x' :*> y' + + thw Proxy (x :*> y) = + let x' = thw (Proxy :: Proxy a) x in + let y' = thw (Proxy :: Proxy b) y in + x' :*> y' + +instance (KnownSymbol s, Freeze t) => Freeze (Label s t) where + frz Proxy path = f + where + path' = symbolVal (Proxy :: Proxy s) : path + f (Just x) = Id <$> frz (Proxy :: Proxy t) path' x + f Nothing = Left $ FreezeIncomplete path' + + thw Proxy (Id x) = Just $ thw (Proxy :: Proxy t) x + +instance (Freeze c) => Freeze (List c) where + frz Proxy path xs = sequence $ frz (Proxy :: Proxy c) path <$> xs + thw Proxy xs = thw (Proxy :: Proxy c) <$> xs + +-- | FIXME: if a non-optional part of an optional sub-config is +-- missing, the 'FreezeIncomplete' error is ignored and the entire +-- sub-config is cleared. it would be better to distinguish between +-- the cases `sub-config missing` and `sub-config provided +-- incompletely`, and still raise an error in the latter. +instance ( ToConfig ('Option c) Maybe ~ MaybeO tm + , ToConfig ('Option c) Id ~ MaybeO ti + , tm ~ ToConfig c Maybe + , ti ~ ToConfig c Id + , Freeze c + ) => Freeze (Option c) where + frz :: Proxy ('Option c) + -> [String] + -> ToConfig ('Option c) Maybe -- (if i replace this with @MaybeO tm@, ghc 7.8.4 gives up... ?) + -> Either Error (ToConfig ('Option c) Id) + frz Proxy _ NothingO = Right NothingO + frz Proxy path (JustO (mx :: tm)) = case frz (Proxy :: Proxy c) path mx of + Right mx' -> Right $ JustO mx' + Left (FreezeIncomplete _) -> Right NothingO + Left e -> Left e + + thw Proxy (JustO mx) = JustO $ thw (Proxy :: Proxy c) mx + thw Proxy NothingO = NothingO + +instance Freeze (Type c) where + frz Proxy _ x = Right x + thw Proxy x = x + + +class CanonicalizePartial a where + canonicalizePartial :: TaggedM a -> TaggedM a + emptyPartial :: TaggedM a -> Bool + +instance (CanonicalizePartial cfg, CanonicalizePartial cfg') + => CanonicalizePartial (Record cfg cfg') where + canonicalizePartial (TaggedM (a :*> a')) = TaggedM $ + fromTaggedM (canonicalizePartial (TaggedM a :: TaggedM cfg)) + :*> fromTaggedM (canonicalizePartial (TaggedM a' :: TaggedM cfg')) + + emptyPartial (TaggedM (a :*> a')) = + emptyPartial (TaggedM a :: TaggedM cfg) + && emptyPartial (TaggedM a' :: TaggedM cfg') + +instance (cfg ~ Label s cfg', CanonicalizePartial cfg') + => CanonicalizePartial (Label s cfg') where + canonicalizePartial l@(TaggedM Nothing) = l + canonicalizePartial l@(TaggedM (Just a)) = if emptyPartial l + then TaggedM Nothing + else TaggedM . Just . fromTaggedM . canonicalizePartial . tag $ a + where + tag :: ToConfig cfg' Maybe -> TaggedM cfg' + tag = TaggedM + + emptyPartial (TaggedM Nothing) = True + emptyPartial (TaggedM (Just a)) = emptyPartial (TaggedM a :: TaggedM cfg') + +instance (cfg ~ List cfg', CanonicalizePartial cfg') + => CanonicalizePartial (List cfg') where + canonicalizePartial (TaggedM xs) = + TaggedM . map fromTaggedM . filter (not . emptyPartial) . map (canonicalizePartial . tag) $ xs + where + tag :: ToConfig cfg' Maybe -> TaggedM cfg' + tag = TaggedM + + emptyPartial (TaggedM xs@(_:_)) = all (\ x -> emptyPartial (TaggedM x :: TaggedM cfg')) xs + emptyPartial (TaggedM []) = True + + -- FIXME: our treatment of lists is confused (overwrite + -- vs. ignore). this is particularly appearent here, but applies + -- to other parts of the code. + +instance (cfg ~ Option cfg', CanonicalizePartial cfg') + => CanonicalizePartial (Option cfg') where + canonicalizePartial (TaggedM NothingO) = TaggedM NothingO + canonicalizePartial (TaggedM (JustO x)) = if emptyPartial $ tag x + then TaggedM NothingO + else TaggedM . JustO . fromTaggedM . canonicalizePartial . tag $ x + where + tag :: ToConfig cfg' Maybe -> TaggedM cfg' + tag = TaggedM + + emptyPartial (TaggedM (JustO x)) = emptyPartial (TaggedM x :: TaggedM cfg') + emptyPartial (TaggedM NothingO) = True + +instance CanonicalizePartial (Type a) where + canonicalizePartial = id + emptyPartial _ = False + + +-- * docs + docs :: ( HasToDoc a , HasRenderDoc ConfigFile , HasRenderDoc ShellEnv @@ -390,44 +740,53 @@ <> renderDoc (Proxy :: Proxy ShellEnv) (toDoc proxy) <> renderDoc (Proxy :: Proxy CommandLine) (toDoc proxy) + data Doc = - DocDict [(String, Maybe String, Doc)] + DocDict [(String, Maybe String, Doc, DocOptional)] | DocList Doc - | DocBase String + | DocType String deriving (Eq, Ord, Show, Read, Typeable) +data DocOptional = DocMandatory | DocOptional + deriving (Eq, Ord, Show, Read, Typeable) + concatDoc :: Doc -> Doc -> Doc -concatDoc (DocDict xs) (DocDict ys) = DocDict . sort $ xs ++ ys +concatDoc (DocDict xs) (DocDict ys) = DocDict $ xs ++ ys concatDoc bad bad' = error $ "concatDoc: " ++ show (bad, bad') - -class HasToDoc a where +class HasToDoc (a :: ConfigCode *) where toDoc :: Proxy a -> Doc -_makeDocPair :: (KnownSymbol path, KnownSymbol descr, HasToDoc v) - => Proxy path -> Maybe (Proxy descr) -> Proxy v -> Doc -_makeDocPair pathProxy descrProxy vProxy = DocDict [(symbolVal pathProxy, symbolVal <$> descrProxy, toDoc vProxy)] - -instance (KnownSymbol path, HasToDoc v) => HasToDoc (path :> v) where - toDoc Proxy = _makeDocPair (Proxy :: Proxy path) (Nothing :: Maybe (Proxy path)) (Proxy :: Proxy v) - -instance (KnownSymbol path, KnownSymbol descr, HasToDoc v) => HasToDoc (path :> v :>: descr) where - toDoc Proxy = _makeDocPair (Proxy :: Proxy path) (Just (Proxy :: Proxy descr)) (Proxy :: Proxy v) +instance (HasToDoc a, HasToDoc b) => HasToDoc (Record a b) where + toDoc Proxy = toDoc (Proxy :: Proxy a) `concatDoc` toDoc (Proxy :: Proxy b) -instance (HasToDoc o1, HasToDoc o2) => HasToDoc (o1 :| o2) where - toDoc Proxy = toDoc (Proxy :: Proxy o1) `concatDoc` toDoc (Proxy :: Proxy o2) +instance (KnownSymbol path, HasToDoc a) => HasToDoc (Label path a) where + toDoc Proxy = DocDict + [( symbolVal (Proxy :: Proxy path) + , Nothing + , toDoc (Proxy :: Proxy a) + , DocMandatory + )] -instance HasToDoc a => HasToDoc [a] where - toDoc Proxy = DocList . toDoc $ (Proxy :: Proxy a) +instance (HasToDoc a, KnownSymbol path, KnownSymbol descr) + => HasToDoc (Descr (Label path a) descr) where + toDoc Proxy = DocDict + [( symbolVal (Proxy :: Proxy path) + , Just $ symbolVal (Proxy :: Proxy descr) + , toDoc (Proxy :: Proxy a) + , DocMandatory + )] -instance HasToDoc ST where - toDoc Proxy = DocBase "string" +instance (HasToDoc a) => HasToDoc (List a) where + toDoc Proxy = DocList $ toDoc (Proxy :: Proxy a) -instance HasToDoc Int where - toDoc Proxy = DocBase "number" +instance (HasToDoc a) => HasToDoc (Option a) where + toDoc Proxy = case toDoc (Proxy :: Proxy a) of + DocDict xs -> DocDict $ (\ (p, d, t, _) -> (p, d, t, DocOptional)) <$> xs + bad -> error $ "HasToDoc Option: " ++ show bad -instance HasToDoc Bool where - toDoc Proxy = DocBase "boolean" +instance (Typeable a) => HasToDoc (Type a) where + toDoc Proxy = DocType . show $ typeOf (undefined :: a) class HasRenderDoc t where @@ -446,11 +805,14 @@ f :: Doc -> [String] f (DocDict xs) = concat $ map g xs f (DocList x) = indent "- " $ f x - f (DocBase base) = [base] + f (DocType base) = [base] - g :: (String, Maybe String, Doc) -> [String] - g (key, Just mDescr, subdoc) = ("# " <> mDescr) : (key <> ":") : indent " " (f subdoc) - g (key, Nothing, subdoc) = (key <> ":") : indent " " (f subdoc) + g :: (String, Maybe String, Doc, DocOptional) -> [String] + g (key, mDescr, subdoc, optional) = + maybe [] (\ descr -> ["# " <> descr]) mDescr ++ + [ "# [optional]" | case optional of DocMandatory -> False; DocOptional -> True ] ++ + (key <> ":") : indent " " (f subdoc) ++ + [""] indent :: String -> [String] -> [String] indent start = lines . (start <>) . intercalate "\n " @@ -468,7 +830,7 @@ f :: [(String, Maybe String)] -> Doc -> [String] f acc (DocDict xs) = concat $ map (g acc) xs f acc (DocList x) = f acc x - f (reverse -> acc) (DocBase base) = + f (reverse -> acc) (DocType base) = shellvar : (" type: " ++ base) : (let xs = catMaybes (mkd <$> acc) in @@ -483,8 +845,8 @@ mkd (_, Nothing) = Nothing mkd (key, Just descr) = Just $ " " ++ (toUpper <$> key) ++ ": " ++ descr - g :: [(String, Maybe String )] -> (String, Maybe String, Doc) -> [String] - g acc (key, descr, subdoc) = f ((key, descr) : acc) subdoc + g :: [(String, Maybe String)] -> (String, Maybe String, Doc, DocOptional) -> [String] + g acc (key, descr, subdoc, _) = f ((key, descr) : acc) subdoc instance HasRenderDoc CommandLine where renderDoc Proxy _ = cs . unlines $ diff --git a/tests/Data/ConfigifierSpec.hs b/tests/Data/ConfigifierSpec.hs --- a/tests/Data/ConfigifierSpec.hs +++ b/tests/Data/ConfigifierSpec.hs @@ -1,27 +1,23 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} - -{-# OPTIONS #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} module Data.ConfigifierSpec where -import Control.Applicative +import Data.Either +import Data.Monoid import Data.Proxy import Data.String.Conversions -import Debug.Trace -import Prelude import Test.Hspec -import Test.QuickCheck -import Text.Show.Pretty import qualified Data.Aeson as Aeson -import qualified Data.Aeson.Encode.Pretty as Aeson -import Data.Configifier +import Data.Configifier as Configifier import Test.Arbitrary () @@ -31,61 +27,325 @@ spec :: Spec spec = describe "Configifier" $ do - misc + miscSpec + selectSpec + mergeSpec + sourcesSpec -misc :: Spec -misc = describe "misc" $ do - describe "<<>>" $ do - it "does not crash" . property $ \ a b -> (length . show $ a <<>> b) > 0 +miscSpec :: Spec +miscSpec = do + describe "misc" $ do + it "simple" $ + let text :: SBS + want :: (c ~ ToConfigCode ("bla" :> Int)) => Tagged c - describe "(>.)" $ do - it "works (unit)" $ do - (cfg >. (Proxy :: Proxy '["bla"])) `shouldBe` 3 - (cfg >. (Proxy :: Proxy '["blu", "lii"])) `shouldBe` False - (>. (Proxy :: Proxy '["go"])) <$> (cfg >. (Proxy :: Proxy '["uGH"])) `shouldBe` ["drei","vier"] + text = "bla: 3" + want = Tagged $ Id 3 - describe "FromJSON, ToJSON" $ do - it "is mutually inverse" $ do - simpleJSONTest False cfg - simpleJSONTest False subCfg - sequence_ (simpleJSONTest False <$> cfg's) + in run text want - describe "parseShellEnv" $ do - it "works" $ do - parseShellEnv (Proxy :: Proxy ("bla" :> Int)) [("BLA", "3")] `shouldBe` - (Right $ Aeson.object ["bla" Aeson..= Aeson.Number 3.0]) + it "descriptions" $ + let text :: SBS + want :: ( c ~ ToConfigCode ("bla" :> Int :>: "describe stuff!") + , c' ~ NoDesc c + ) => Tagged c' -simpleJSONTest :: (Eq a, Aeson.FromJSON a, Aeson.ToJSON a, Show a) => Bool -> a -> IO () -simpleJSONTest noisy x = _trace $ x' `shouldBe` Aeson.Success x - where - x' = Aeson.fromJSON $ Aeson.toJSON x - _trace = if noisy - then trace $ cs (Aeson.encodePretty x) ++ "\n" ++ ppShow (x, x') - else id + text = "bla: 3" + want = Tagged $ Id 3 -type Cfg = - "bla" :> Int :>: "description of bla" - :| "blu" :> SubCfg - :| "uGH" :> [Cfg'] :>: "... and something about uGH" + in run text want -type Cfg' = - "go" :> ST - :| "blu" :> SubCfg + it "option" $ + let text :: SBS + want :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Tagged c -type SubCfg = - "lii" :> Bool + text = "bla: 3" + want = Tagged $ JustO (Id 3) -cfg :: Cfg -cfg = - entry 3 - :| entry False -- Curiously, it's not ok to put 'subCfg' here. - :| entry cfg's + in run text want -cfg's :: [Cfg'] -cfg's = - [ entry "drei" :| entry True - , entry "vier" :| entry False - ] + it "option, no sources" $ + let have :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Configifier.Result c + want :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Tagged c -subCfg :: SubCfg -subCfg = entry False + have = configify [] + want = Tagged NothingO + + in have `shouldBe` Right want + + it "yaml cannot parse empty cfg files (even if all config data is optional!)" $ + let text1, text2, text3 :: SBS + + text1 = "" + text2 = " \n\t \n\t" + text3 = " \n\t# comments are also nothing\n\t\n...\n" + + want :: (c ~ ToConfigCode (Maybe ("bla" :> Int))) => Either Error (TaggedM c) -> Bool + want = isLeft + + f sbs = parseConfigFile sbs `shouldSatisfy` want + + in mapM_ f [text1, text2, text3] + + it "option, missing in non-empty cfg file" $ + let text :: SBS + want :: (c ~ ToConfigCode ("org" :> Int :*> Maybe ("bla" :> Int))) => Tagged c + + text = "org: 3" + want = Tagged (Id 3 :*> NothingO) + + in run text want + + it "something more nested" $ + let text1, text2 :: SBS + want1, want2 :: + ( c ~ ToConfigCode c' + , c' ~ ("frontend" :> sc :*> Maybe ("backend" :> sc)) + , sc ~ ("bind_port" :> Int :*> Maybe ("expose_host" :> ST)) + ) => Tagged c + + text1 = cs . unlines $ + "frontend:" : + " bind_port: 3" : + " expose_host: host" : + "backend:" : + " bind_port: 4" : + " expose_host: hist" : + [] + text2 = cs . unlines $ + "frontend:" : + " bind_port: 3" : + [] + + want1 = Tagged $ Id (Id 3 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "hist"))) + want2 = Tagged $ Id (Id 3 :*> NothingO) + :*> NothingO + + in run text1 want1 >> run text2 want2 + + it "lists" $ + let text :: SBS + want :: ( c ~ ToConfigCode ("bla" :> [Bool]) + , c' ~ NoDesc c + ) => Tagged c' + + text = "bla: [yes, no]" + want = Tagged $ Id [True, False] + + in run text want + + +run :: forall cfg tm ti . + ( tm ~ TaggedM cfg + , ti ~ Tagged cfg + , Show tm, Eq tm, Show ti, Eq ti + , Monoid tm + , Freeze cfg + , Aeson.FromJSON tm + , Aeson.ToJSON tm + , HasParseShellEnv cfg + , HasParseCommandLine cfg + , CanonicalizePartial cfg + ) => SBS -> ti -> IO () +run text parsedWant = do + let f :: SBS -> Either Error ti + f sbs = configify [ConfigFileYaml sbs] + + f text `shouldBe` Right parsedWant + f (renderConfigFile parsedWant) `shouldBe` Right parsedWant + + +selectSpec :: Spec +selectSpec = do + describe "select" $ do + it "(\"l\" :> Int)" $ + let t :: forall c . (c ~ ToConfigCode ("l" :> Int)) => IO () + t = cfg >>. (Proxy :: Proxy '["l"]) `shouldBe` 3 + where + cfg :: Tagged c = Tagged $ Id 3 + in t + + it "(\"l\" :> (\"l'\" :> Bool))" $ + let t :: forall c . (c ~ ToConfigCode ("l" :> ("l'" :> Bool))) => IO () + t = do + cfg >>. (Proxy :: Proxy '["l"]) `shouldBe` Id False + cfg >>. (Proxy :: Proxy '["l", "l'"]) `shouldBe` False + where + cfg :: Tagged c = Tagged . Id . Id $ False + in t + + it "(\"l\" :> Int :*> \"l'\" :> Bool)" $ + let t :: forall c . (c ~ ToConfigCode ("l" :> Int :*> "l'" :> Bool)) => IO () + t = do + cfg >>. (Proxy :: Proxy '["l"]) `shouldBe` 0 + cfg >>. (Proxy :: Proxy '["l'"]) `shouldBe` False + where + cfg :: Tagged c = Tagged $ Id 0 :*> Id False + in t + + it "(Maybe (\"l\" :> Int))" $ + let t :: forall c . (c ~ ToConfigCode (Maybe ("l" :> Int))) => IO () + t = do + cfg >>. (Proxy :: Proxy '["l"]) `shouldBe` Just 0 + where + cfg :: Tagged c = Tagged $ JustO (Id 0) + in t + + it "(Maybe (\"l\" :> Maybe (\"l'\" :> Int)))" $ + let t :: forall c . (c ~ ToConfigCode (Maybe ("l" :> Maybe ("l'" :> Int)))) => IO () + t = do + cfg1 >>. (Proxy :: Proxy '["l", "l'"]) `shouldBe` Just (Just 0) + cfg2 >>. (Proxy :: Proxy '["l", "l'"]) `shouldBe` Just Nothing + cfg3 >>. (Proxy :: Proxy '["l", "l'"]) `shouldBe` Nothing + where + cfg1 :: Tagged c = Tagged $ JustO (Id (JustO (Id 0))) + cfg2 :: Tagged c = Tagged $ JustO (Id NothingO) + cfg3 :: Tagged c = Tagged $ NothingO + in t + + it "(\"l\" :> Int :*> \"l'\" :> Int)" $ + let t :: forall c . ( c ~ ToConfigCode ("l" :> Int :*> "l'" :> Int) + , ToVal c '["l"] ~ Just Int -- (redundant) + , ToConfig c Id ~ (Id Int :*> Id Int) -- (redundant) + ) => IO () + t = do + cfg1 >>. (Proxy :: Proxy '["l"]) `shouldBe` 3 + cfg1 >>. (Proxy :: Proxy '["l'"]) `shouldBe` 0 + cfg2 >>. (Proxy :: Proxy '["l'"]) `shouldBe` 0 + where + cfg1 :: Tagged c = Tagged $ Id 3 :*> Id (0 :: Int) + cfg2 :: Tagged c = Tagged $ Id 4 :*> Id (0 :: Int) + in t + + it "(\"l\" :> Int :*> Maybe (\"l'\" :> Int))" $ + let t :: forall c . ( c ~ ToConfigCode ("l" :> Int :*> Maybe ("l'" :> Int)) + , ToVal c '["l"] ~ Just Int -- (redundant) + , ToConfig c Id ~ (Id Int :*> MaybeO (Id Int)) -- (redundant) + ) => IO () + t = do + cfg1 >>. (Proxy :: Proxy '["l"]) `shouldBe` 3 + cfg1 >>. (Proxy :: Proxy '["l'"]) `shouldBe` (Just 0) + cfg2 >>. (Proxy :: Proxy '["l'"]) `shouldBe` Nothing + where + cfg1 :: Tagged c = Tagged $ Id 3 :*> JustO (Id (0 :: Int)) + cfg2 :: Tagged c = Tagged $ Id 4 :*> NothingO + in t + + it "partial select paths and non-leaf sub-configs" $ + let t :: forall config config' ponfig ponfig' . + ( config ~ Tagged (NoDesc (ToConfigCode config')) + , config' ~ (Maybe ("a" :> ST) :*> ("b" :> ST)) + + , ponfig ~ Tagged (NoDesc (ToConfigCode ponfig')) + , ponfig' ~ ("c" :> config') + + ) => IO () + t = do + let Right (cfg1 :: ponfig) = configify [ConfigFileYaml . cs . unlines $ + "c:" : + " a: goih" : + " b: c38" : + "..." : + []] + + Right (Tagged cfg2 :: config) = configify [ConfigFileYaml . cs . unlines $ + "a: goih" : + "b: c38" : + "..." : + []] + + (cfg1 >>. (Proxy :: Proxy '["c"])) `shouldBe` cfg2 + + in t + + +mergeSpec :: Spec +mergeSpec = describe "instance Monoid (ToConfigCode *)" $ + let cfg1, cfg2, cfg3, cfg4, cfg5 :: + ( c ~ ToConfigCode c' + , c' ~ Maybe ("frontend" :> sc' :*> Maybe ("backend" :> sc')) + , sc' ~ ("bind_port" :> Int :*> Maybe ("expose_host" :> ST)) + ) => TaggedM c + + cfg1 = TaggedM . JustO $ + Just (Just 3 :*> JustO (Just "host")) + :*> JustO (Just (Just 4 :*> JustO (Just "hist"))) + cfg2 = TaggedM . JustO $ + Just (Just 3 :*> NothingO) + :*> JustO (Just (Just 4 :*> NothingO)) + cfg3 = TaggedM . JustO $ + Just (Just 3 :*> NothingO) + :*> NothingO + cfg4 = TaggedM NothingO + + cfg5 = TaggedM . JustO $ + Just (Just 1 :*> JustO (Just "ast")) + :*> JustO (Just (Just 5 :*> JustO (Just "hust"))) + in do + -- JustO wins over NothingO + + it "1" $ (cfg1 <> cfg1) `shouldBe` cfg1 + it "2" $ (cfg1 <> cfg2) `shouldBe` cfg1 + it "3" $ (cfg1 <> cfg3) `shouldBe` cfg1 + it "4" $ (cfg1 <> cfg4) `shouldBe` cfg1 + + it "5" $ (cfg2 <> cfg1) `shouldBe` cfg1 + it "6" $ (cfg3 <> cfg1) `shouldBe` cfg1 + it "7" $ (cfg4 <> cfg1) `shouldBe` cfg1 + + -- right JustO wins over left JustO + + it "8" $ (cfg1 <> cfg5) `shouldBe` cfg5 + + +sourcesSpec :: Spec +sourcesSpec = describe "sources" $ + let f :: ( c ~ ToConfigCode c' + , c' ~ ("frontend" :> sc :*> Maybe ("backend" :> sc)) + , sc ~ ("bind_port" :> Int :*> Maybe ("expose_host" :> ST)) + ) => [Source] -> Result c + f = configify + + configFile1 :: Source = ConfigFileYaml . cs . unlines $ + "frontend:" : + " bind_port: 3" : + " expose_host: host" : + "backend:" : + " bind_port: 4" : + " expose_host: hist" : + [] + configFile2 :: Source = ConfigFileYaml . cs . unlines $ + "frontend:" : + " bind_port: 3" : + [] + + shellEnv1 :: Source = ShellEnv [("FRONTEND_BIND_PORT", "18")] + shellEnv2 :: Source = ShellEnv [("BACKEND_EXPOSE_HOST", "bom")] + + commandLine1 :: Source = CommandLine ["--frontend-bind-port", "31"] + commandLine2 :: Source = CommandLine ["--backend-expose-host=mab", "--backend-bind-port=8710"] + + in do + it "parseArgs" $ + parseArgs (["--arg=31", "--flob", "gluh"] :: Args) `shouldBe` Right ([("ARG", "31"), ("FLOB", "gluh")] :: Env) + + it "1" $ + f [configFile1] `shouldBe` + (Right . Tagged $ Id (Id 3 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "hist")))) + + it "2" $ + f [configFile1, shellEnv1, shellEnv2] `shouldBe` + (Right . Tagged $ Id (Id 18 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "bom")))) + + it "3" $ + f [configFile1, shellEnv1, shellEnv2, commandLine1] `shouldBe` + (Right . Tagged $ Id (Id 31 :*> JustO (Id "host")) + :*> JustO (Id (Id 4 :*> JustO (Id "bom")))) + + it "4" $ + f [configFile2, commandLine2] `shouldBe` + (Right . Tagged $ Id (Id 3 :*> NothingO) + :*> JustO (Id (Id 8710 :*> JustO (Id "mab"))))