configifier 0.0.2 → 0.0.3

raw patch · 4 files changed

+969/−338 lines, 4 filesdep +eitherdep ~mtlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: either

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• configifier.cabal +7/−2
• examples/Main.hs +38/−34
• src/Data/Configifier.hs +607/−245
• tests/Data/ConfigifierSpec.hs +317/−57

@@ -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

@@ -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"])

@@ -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 $

@@ -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"))))