configifier-0.0.8: src/Data/Configifier.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Data.Configifier
where
import Control.Applicative ((<$>), (<|>))
import Control.Exception (Exception, throwIO)
import Control.Monad (filterM)
import Data.ByteString.Char8 (pack)
import Data.CaseInsensitive (mk)
import Data.Char (toUpper)
import Data.Either.Combinators (mapLeft)
import Data.Function (on)
import Data.Functor.Infix ((<$$>))
import Data.List (nubBy, intercalate, isPrefixOf, findIndices, splitAt)
import Data.Maybe (catMaybes)
import Data.Monoid (Monoid, (<>), mempty, mappend, mconcat)
import Data.String.Conversions (ST, SBS, cs)
import Data.Typeable (Typeable, Proxy(Proxy), typeOf)
import Data.Yaml.Include (decodeFileEither)
import Data.Yaml (ToJSON, FromJSON, Value(Object, Array, Null), object, toJSON, parseJSON, (.=))
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH (runQ)
import System.Directory (doesFileExist)
import System.Environment (getEnvironment, getArgs, getProgName)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as SBS
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Vector as Vector
import qualified Data.Yaml as Yaml
-- * config types
-- | 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 :>
-- | Add descriptive text to record field for documentation.
data a :>: (s :: Symbol)
deriving (Typeable)
infixr 8 :>:
data ConfigCode k =
Record (ConfigCode k) (ConfigCode k)
| Label Symbol (ConfigCode k)
| Descr (ConfigCode k) Symbol
| List (ConfigCode k)
| Option (ConfigCode k)
| Type k
infixr 6 `Record`
-- | 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
{-# DEPRECATED NoDesc "use of NoDesc is redundant and can be dropped without replacement." #-}
type family NoDesc (a :: ConfigCode *) :: ConfigCode * where
NoDesc a = a
-- | 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 (Descr a s) 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 =
YamlString SBS
| YamlFile FilePath -- FIXME: { yamlFilePath :: FilePath, yamlFileOptional :: Bool }
| ShellEnv [(String, String)]
| CommandLine [String]
deriving (Eq, Ord, Show, Typeable)
data ConfigFile
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
data Error =
InvalidYamlString
{ invalidYamlInput :: SBS
, invalidYamlMsg :: Yaml.ParseException
}
| InvalidYamlFile
{ invalidYamlFile :: FilePath
, invalidYamlMsg :: Yaml.ParseException
}
| ShellEnvNil
| ShellEnvNoParse
{ shellEnvNoParseType :: String
, shellEnvNoParseValue :: String
, shellEnvNoParseMsg :: String
}
| CommandLinePrimitiveParseError String
| CommandLinePrimitiveOtherError Error
| FreezeIncomplete
{ freezeIncompleteAtPath :: [String]
}
deriving (Show, Typeable)
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
, CanonicalizePartial cfg
) => [Source] -> IO (Tagged cfg)
configify = configifyWithDefault (mempty :: tm)
configifyWithDefault :: forall cfg tm .
( tm ~ TaggedM cfg
, Show tm
, Monoid tm
, Freeze cfg
, FromJSON tm
, HasParseShellEnv cfg
, HasParseCommandLine cfg
, CanonicalizePartial cfg
) => tm -> [Source] -> IO (Tagged cfg)
configifyWithDefault def sources = sequence (get <$> readUserConfigFiles sources) >>= run . merge . (def:)
where
run :: Either Error a -> IO a
run = either throwIO return
get :: Source -> IO tm
get (YamlString sbs) = run $ parseConfigFile sbs
get (YamlFile fpath) = parseConfigFileWithIncludes fpath >>= run
get (ShellEnv env) = run $ parseShellEnv env
get (CommandLine args) = run $ parseCommandLine args
-- * IO
-- | From a list of config file paths, construct a source list that
-- (1) reads those files allowing for recursive includes; then (2)
-- processes shell environment variables (with `getProgName` as
-- prefix), and finally (3) processes command line args, turning
-- @--config@ arguments into further recursive config file loads.
--
-- File path arguments are optiona; config paths to non-existent
-- files are silently dropped.
defaultSources :: [FilePath] -> IO [Source]
defaultSources filePaths = do
files <- YamlFile <$$> filterM doesFileExist filePaths
env <- ShellEnv <$> (getEnvironment >>= withShellEnvPrefix)
args <- CommandLine <$> getArgs
return $ files ++ [env] ++ readUserConfigFiles [args]
-- | Require that all shell env variables start with executable name.
-- (This is just a call to 'requireShellEnvPrefix'' with the result of
-- 'progName'.)
withShellEnvPrefix :: Env -> IO Env
withShellEnvPrefix env = (`withShellEnvPrefix'` env) <$> getProgName
-- * corner cases
-- FUTURE WORK: the functions in this section operate on sources, not
-- parsers. This has the unintended effect of leaving the
-- documentation functionality oblivious of what happens here, so the
-- user of the apliation that uses configifier has no way of knowing
-- about '--config' or the program name prefix of shell env variables.
-- there should be a better way.
-- | Handle `--config=<FILE>`, `--config <FILE>`: split up
-- 'CommandLine' source on each of these, and inject a
-- 'YamlFile' source with the resp. file name.
readUserConfigFiles :: [Source] -> [Source]
readUserConfigFiles = mconcat . map f
where
f :: Source -> [Source]
f s@(YamlString _) = [s]
f s@(YamlFile _) = [s]
f s@(ShellEnv _) = [s]
f (CommandLine args) = filter (not . (== CommandLine [])) $ g [] args
g :: [String] -> [String] -> [Source]
g acc [] = [CommandLine (reverse acc)]
g acc fresh@(freshHead:freshTail) = case popArg fresh of
Right (("config", v), fresh') -> CommandLine (reverse acc) : YamlFile v : g [] fresh'
_ -> g (freshHead : acc) freshTail
-- | Require prefix for shell env variables. This function will chop
-- off the given prefix of all env entries, and filter all entries
-- that do not have this prefix.
withShellEnvPrefix' :: String -> Env -> Env
withShellEnvPrefix' prefix = catMaybes . map f
where
f (k, v) = if prefix `isPrefixOf` k
then Just (take (length prefix) k, v)
else Nothing
-- * yaml / json
parseConfigFile :: (FromJSON (TaggedM cfg)) => SBS -> Either Error (TaggedM cfg)
parseConfigFile sbs = mapLeft (InvalidYamlString (trunc sbs)) $ Yaml.decodeEither' sbs
where
l = 21
trunc s = if SBS.length s > l then SBS.take l s <> "..." else s
-- | See "Data.Yaml.Include".
parseConfigFileWithIncludes :: (FromJSON (TaggedM cfg)) => FilePath -> IO (Either Error (TaggedM cfg))
parseConfigFileWithIncludes fpath = mapLeft (InvalidYamlFile fpath) <$> decodeFileEither fpath
renderConfigFile :: (Freeze cfg, t ~ Tagged cfg, ToJSON (TaggedM cfg)) => t -> SBS
renderConfigFile = Yaml.encode . thaw
-- render json
-- | @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 ToJSON Label@
instance ( ToJSON (TaggedM cfg)
, KnownSymbol s
)
=> ToJSON (TaggedM (Label s cfg)) where
toJSON (TaggedM Nothing) = Null
toJSON (TaggedM (Just v)) = case toJSON (TaggedM v :: TaggedM cfg) of
Null -> Null
val -> object [key .= val] where key = cs $ symbolVal (Proxy :: Proxy s)
instance ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe
, ToJSON (TaggedM cfg)
) => ToJSON (TaggedM (Descr cfg s)) where
toJSON (TaggedM v) = toJSON (TaggedM v :: TaggedM cfg)
-- | @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 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) = Null
-- | @instance ToJSON Type@
instance (ToJSON a) => ToJSON (TaggedM (Type a)) where
toJSON (TaggedM v) = toJSON v
-- parse json
-- | @instance FromJSON Record@
instance (FromJSON (TaggedM cfg1), FromJSON (TaggedM cfg2)) => FromJSON (TaggedM (Record cfg1 cfg2)) where
parseJSON json = do
TaggedM o1 :: TaggedM cfg1 <- parseJSON json
TaggedM o2 :: TaggedM cfg2 <- parseJSON json
return . TaggedM $ o1 :*> o2
-- | @instance FromJSON Label@ (tolerates unknown fields in json object.)
instance (FromJSON (TaggedM cfg), KnownSymbol s) => FromJSON (TaggedM (Label s cfg)) where
parseJSON (Object hashmap) =
case HashMap.lookup key hashmap of
(Just json) -> TaggedM . Just . fromTaggedM <$> parseJSON' json
Nothing -> return $ TaggedM Nothing
where
key = cs $ symbolVal (Proxy :: Proxy s)
parseJSON' :: Value -> Yaml.Parser (TaggedM cfg) = parseJSON
parseJSON bad = fail $ "when expecting 'Label', encountered this instead: " ++ show bad
instance ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe
, FromJSON (TaggedM cfg)
) => FromJSON (TaggedM (Descr cfg s)) where
parseJSON v = cast <$> parseJSON v
where
cast :: TaggedM cfg -> TaggedM (Descr cfg s)
cast = TaggedM . fromTaggedM
-- | @instance ParseJSON List@
instance (FromJSON (TaggedM cfg)) => FromJSON (TaggedM (List cfg)) where
parseJSON (Array vector) = do
vector' :: [TaggedM cfg] <- sequence $ parseJSON <$> Vector.toList vector
return . TaggedM . (fromTaggedM <$>) $ vector'
parseJSON bad = fail $ "when expecting 'List', encountered this instead: " ++ show bad
-- | @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 <- parseJSON v
return $ (TaggedM (JustO js) :: TaggedM (Option cfg))
-- | @instance FromJSON Type@
instance (FromJSON a) => FromJSON (TaggedM (Type a)) where
parseJSON = (TaggedM <$>) . parseJSON
-- * shell env
type Env = [(String, String)]
class HasParseShellEnv (cfg :: ConfigCode *) where
parseShellEnv :: Env -> Either Error (TaggedM cfg)
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
-- | 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
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 ( ToConfig (Descr cfg s) Maybe ~ ToConfig cfg Maybe
, HasParseShellEnv cfg
) => HasParseShellEnv (Descr cfg s) where
parseShellEnv env = cast <$> parseShellEnv env
where
cast :: TaggedM cfg -> TaggedM (Descr cfg s)
cast = TaggedM . fromTaggedM
-- | 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 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 :: [String] -> Either Error (TaggedM cfg)
instance (HasParseShellEnv cfg) => HasParseCommandLine cfg where
parseCommandLine = primitiveParseCommandLine
-- | Very basic first approach: read @/--(key)(=|\s+)(value)/@;
-- construct shell env from keys and names, and use 'parseShellEnv' on
-- 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) => [String] -> Either Error (TaggedM cfg)
primitiveParseCommandLine args =
mapLeft CommandLinePrimitiveParseError (lastWins <$> parseArgs args)
>>= mapLeft CommandLinePrimitiveOtherError . parseShellEnv
where
lastWins = reverse . nubBy ((==) `on` fst) . reverse
parseArgs :: Args -> Either String Env
parseArgs [] = Right []
parseArgs args = popArg args >>= \ ((k, v), args') -> ((parseArgName k, v):) <$> parseArgs args'
popArg :: Args -> Either String ((String, String), Args)
popArg [] = Left "empty argument list."
popArg (h:[]) = (, []) <$> parseArgsWithEqSign h
popArg (h:h':t) = ((, h':t) <$> parseArgsWithEqSign h)
<|> ((, t) <$> parseArgsWithSpace h h')
parseArgsWithEqSign :: String -> Either String (String, String)
parseArgsWithEqSign = f
where
f ('-':'-':t@(findIndices (== '=') -> [i])) = Right . (\(k, '=':v) -> (k, v)) $ splitAt i t
f s = Left $ "could not parse long-arg: " ++ show s
parseArgsWithSpace :: String -> String -> Either String (String, String)
parseArgsWithSpace s v = f s
where
f ('-':'-':t) | (not . any (== '=') $ t) = Right (t, v)
f _ = Left $ "could not parse long-arg: " ++ show (s, v)
parseArgName :: String -> String
parseArgName = map f
where
f '-' = '_'
f c = toUpper c
-- * accessing config values
-- | 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"
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 (Descr a s) 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
-- | 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)
-- | This is a version of '<|>' on 'Maybe' for 'CMaybe'.
orElse :: CMaybe a -> CMaybe b -> CMaybe (OrElse a b)
orElse (CJust x) _ = CJust x
orElse CNothing y = y
-- *** options
-- for selecting optional parts, i don't think i have found the most
-- elegant solution yet.
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
class NothingValue (a :: Maybe *) where
nothingValue :: Proxy a -> CMaybe (ToValueMaybe a)
instance NothingValue Nothing where
nothingValue _ = CNothing
instance NothingValue (Just x) where
nothingValue _ = CJust Nothing
-- *** cfg traversal
-- 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
instance ( cfg ~ Record cfg' cfg''
, 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'
, 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 ~ Descr cfg' s
, Sel cfg' ps
, ToConfig (Descr cfg' s) Id ~ ToConfig cfg' Id
) => Sel (Descr cfg' s) ps where
sel = sel . cast
where
cast :: Tagged (Descr cfg' s) -> Tagged cfg'
cast = Tagged . fromTagged
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 family ToExc (a :: k) (x :: Maybe l) :: Exc k l where
ToExc a Nothing = Fail a
ToExc a (Just x) = Done x
-- * merge configs
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
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
thaw :: forall cfg tm ti .
( tm ~ TaggedM cfg
, ti ~ Tagged cfg
, Freeze cfg
) => ti -> tm
thaw = TaggedM . thw (Proxy :: Proxy cfg) . fromTagged
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
instance ( ToConfig (Descr a s) Maybe ~ ToConfig a Maybe
, ToConfig a Maybe ~ Maybe a'
, Monoid (TaggedM a)
) => Monoid (TaggedM (Descr a s)) where
mempty = cast $ TaggedM Nothing
where
cast :: TaggedM a -> TaggedM (Descr a s)
cast = TaggedM . fromTaggedM
mappend x x' = cast $ cast' x <> cast' x'
where
cast :: TaggedM a -> TaggedM (Descr a s)
cast' :: TaggedM (Descr a s) -> TaggedM a
cast = TaggedM . fromTaggedM
cast' = TaggedM . fromTaggedM
-- | 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 ( ToConfig (Descr t s) Maybe ~ ToConfig t Maybe
, ToConfig (Descr t s) Id ~ ToConfig t Id
, Freeze t
) => Freeze (Descr t s) where
frz Proxy path x = frz (Proxy :: Proxy t) path x
thw Proxy = thw (Proxy :: Proxy t)
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
-- | Partials are constructed with every 'Nothing' spelled out,
-- resulting in deep skeletons of 'Nothing's. 'CanonicalizePartial'
-- replaces those with single 'Nothing's at their tops.
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 ~ Descr cfg' s, CanonicalizePartial cfg')
=> CanonicalizePartial (Descr cfg' s) where
canonicalizePartial = cast . canonicalizePartial . cast'
where
cast :: TaggedM a -> TaggedM (Descr a s)
cast' :: TaggedM (Descr a s) -> TaggedM a
cast = TaggedM . fromTaggedM
cast' = TaggedM . fromTaggedM
emptyPartial = emptyPartial . cast
where
cast :: TaggedM (Descr a s) -> TaggedM a
cast = TaggedM . fromTaggedM
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
, HasRenderDoc CommandLine
) => Proxy a -> ST
docs proxy = renderDoc (Proxy :: Proxy ConfigFile) (toDoc proxy)
<> renderDoc (Proxy :: Proxy ShellEnv) (toDoc proxy)
<> renderDoc (Proxy :: Proxy CommandLine) (toDoc proxy)
data Doc =
DocDict [(String, Maybe String, Doc, DocOptional)]
| DocList Doc
| 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 $ xs ++ ys
concatDoc bad bad' = error $ "concatDoc: " ++ show (bad, bad')
class HasToDoc (a :: ConfigCode *) where
toDoc :: Proxy a -> Doc
instance (HasToDoc a, HasToDoc b) => HasToDoc (Record a b) where
toDoc Proxy = toDoc (Proxy :: Proxy a) `concatDoc` toDoc (Proxy :: Proxy b)
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, 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 a) => HasToDoc (List a) where
toDoc Proxy = DocList $ toDoc (Proxy :: Proxy a)
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 (Typeable a) => HasToDoc (Type a) where
toDoc Proxy = DocType . show $ typeOf (undefined :: a)
class HasRenderDoc t where
renderDoc :: Proxy t -> Doc -> ST
instance HasRenderDoc ConfigFile where
renderDoc Proxy doc = cs . unlines $
"" :
"Config File" :
"-----------" :
"" :
f doc ++
"" :
[]
where
f :: Doc -> [String]
f (DocDict xs) = concat $ map g xs
f (DocList x) = indent "- " $ f x
f (DocType base) = [base]
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 "
instance HasRenderDoc ShellEnv where
renderDoc Proxy doc = cs . unlines $
"" :
"Shell Environment Variables" :
"---------------------------" :
"" :
(f [] doc) ++
"" :
[]
where
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) (DocType base) =
shellvar :
(" type: " ++ base) :
(let xs = catMaybes (mkd <$> acc) in
if null xs then [] else " documented components:" : xs) ++
"" :
[]
where
shellvar :: String
shellvar = map toUpper . intercalate "_" . map fst $ acc
mkd :: (String, Maybe String) -> Maybe String
mkd (_, Nothing) = Nothing
mkd (key, Just descr) = Just $ " " ++ (toUpper <$> key) ++ ": " ++ descr
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 $
"" :
"Command Line Arguments" :
"----------------------" :
"" :
"See `shell environment`. (Anything you can set with a shell" :
"variable, you can also set with a long arg.)" :
"" :
[]
-- * template haskell
-- | QuasiQuoter for config files.
cfgify :: QuasiQuoter
cfgify = QuasiQuoter { quoteExp = \x -> runQ [| unsafePerformIO $ configify [YamlString $ pack x] |]
, quotePat = error "cfgify: not application to Pat context"
, quoteType = error "cfgify: not application to Type context"
, quoteDec = error "cfgify: not application to Dec context"
}