{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Config
-- Copyright : (C) 2014 Yorick Laupa
-- License : (see the file LICENSE)
--
-- Maintainer : Yorick Laupa <yo.eight@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
-- Config is a small and typesafe configuration library. It provides
-- good error messages and comes with a bottom-up typechecker in order to catch
-- more configuration errors.
--
-- Here some use-cases:
--
-- >>> foo = ["bar", { baz : 42 }]
-- foo:1:8-13: Expecting String but having Object
--
-- Reason: List has only one inner type
--
-- >>> foo = ["bar"] [{ baz : 42 }]
-- foo:1:7-14: Expecting List[String] but having List[Object]
--
-- Reason: You can't merge Lists of different types
--
-- It uses <https://github.com/typesafehub/config Typesafe-config>
-- format: HOCON. HOCON stands for Human-Optimized
-- Config Object Notation. It's basically a JSON superset
--
-- Here's an example:
--
-- > -- app.conf
-- > # This is a comment
-- >
-- > foo.bar = ${toto}
-- >
-- > toto = false
-- >
-- > rawString = """
-- > This is a multi-
-- > lines String
-- > """
-- >
-- > another.string = "I'm a String"
-- >
-- > one.more.string = one more string
-- >
-- > nested {
-- > list: [ one
-- > , 1
-- > , "both"]
-- >
-- > homing = {
-- > pass: { b: feez } { a: "Prop"}
-- > }
-- >
-- > another: [1,2,3] [4,5,6]
-- > }
--
-- How to use:
--
-- @
-- -- Example.hs
-- {-# LANGUAGE OverloadedStrings #-}
-- import Data.Config
-- import Data.Text (Text)
--
-- data Foo = Foo { fooPort :: 'Int', fooAddr :: 'Text' }
--
-- main :: 'IO' ()
-- main = do
-- foo <- loadFooProps
-- withFoo foo
--
-- where
-- loadFooProps = do
-- config <- 'loadConfig' "conf/baz.conf"
-- port <- 'getInteger' "foo.port" config
-- addr <- 'getString' "foo.addr" config
-- return (Foo port addr)
--
-- withFoo :: Foo -> 'IO' ()
-- withFoo = ...
-- @
--------------------------------------------------------------------------------
module Data.Config
( Config
, loadConfig
, getInteger
, getParsec
, getString
, getBool
, getStrings
, getBools
, getIntegers
, getParsecs
) where
--------------------------------------------------------------------------------
import Control.Applicative
import Control.Exception
import Control.Monad.Trans
import Data.Typeable
--------------------------------------------------------------------------------
import Control.Monad.Catch
import qualified Data.Map as M
import Data.Text (Text, unpack)
import qualified Data.Text.IO as T
import Text.Parsec (Parsec)
import qualified Text.Parsec.Char as Char
import Text.Parsec.Combinator
import Text.Parsec.Pos (newPos)
import qualified Text.Parsec.Prim as Prim
import Text.Parsec.Text ()
--------------------------------------------------------------------------------
import Data.Config.Internal.AST
import Data.Config.Internal.Parser
import Data.Config.Internal.Pos
import Data.Config.Internal.Scoped
import Data.Config.Internal.Reg
import Data.Config.Internal.Register
import Data.Config.Internal.Rename
import Data.Config.Internal.Typecheck
import Data.Config.Internal.Typed
--------------------------------------------------------------------------------
-- | Configuration data
newtype Config = Config { unConf :: Reg }
--------------------------------------------------------------------------------
type Extractor a = forall m. MonadThrow m => Text -> Config -> AST Typed -> m a
--------------------------------------------------------------------------------
newtype ConfigError = ConfigError String deriving Typeable
--------------------------------------------------------------------------------
instance Show ConfigError where
show (ConfigError s) = s
--------------------------------------------------------------------------------
instance Exception ConfigError
--------------------------------------------------------------------------------
loadConfig :: (MonadIO m, MonadThrow m) => FilePath -> m Config
loadConfig path
= do txt <- liftIO $ T.readFile path
pse <- parse path txt
let action
= do ps <- pse
(tys, pts) <- typecheck $ rename ps
return $ register tys pts
case action of
Left e -> throwM e
Right reg -> return $ Config reg
--------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------
getString :: MonadThrow m => Text -> Config -> m Text
getString key conf = getValue string key conf
--------------------------------------------------------------------------------
getInteger :: MonadThrow m => Text -> Config -> m Integer
getInteger key conf = getParsec integerParsec key conf
--------------------------------------------------------------------------------
getBool :: MonadThrow m => Text -> Config -> m Bool
getBool key conf = getParsec boolParsec key conf
--------------------------------------------------------------------------------
getParsec :: MonadThrow m
=> (forall s. Parsec Text s a)
-> Text
-> Config
-> m a
getParsec action key conf = getValue (parsec action) key conf
--------------------------------------------------------------------------------
getStrings :: MonadThrow m => Text -> Config -> m [Text]
getStrings key conf = getValues string key conf
--------------------------------------------------------------------------------
getIntegers :: MonadThrow m => Text -> Config -> m [Integer]
getIntegers key conf = getParsecs integerParsec key conf
--------------------------------------------------------------------------------
getBools :: MonadThrow m => Text -> Config -> m [Bool]
getBools key conf = getParsecs boolParsec key conf
--------------------------------------------------------------------------------
getParsecs :: MonadThrow m
=> (forall s. Parsec Text s a)
-> Text
-> Config
-> m [a]
getParsecs action key conf = getValues (parsec action) key conf
--------------------------------------------------------------------------------
-- Utilities
--------------------------------------------------------------------------------
getValue :: MonadThrow m => Extractor a -> Text -> Config -> m a
getValue extr key conf
= maybe (throwM $ propertyNotFound key) go (M.lookup key reg)
where
reg = regAST $ unConf conf
go ast = extr key conf (simplify (unConf conf) ast)
--------------------------------------------------------------------------------
getValues :: MonadThrow m => Extractor a -> Text -> Config -> m [a]
getValues extr key conf = getValue (list extr) key conf
--------------------------------------------------------------------------------
string :: Extractor Text
string key _ (AST expr t)
= case expr of
ID s -> return s
STRING s -> return s
_ -> throwM (wrongType key pos stringType ty)
where
pos = scopePos $ typedScope t
ty = typedType t
--------------------------------------------------------------------------------
list :: Extractor a -> Extractor [a]
list extr key conf (AST expr t)
= case expr of
LIST xs -> mapM (extr key conf) xs
_ -> throwM (wrongType key pos someListType ty)
where
pos = scopePos $ typedScope t
ty = typedType t
--------------------------------------------------------------------------------
integerParsec :: Parsec Text s Integer
integerParsec = fmap read (many1 Char.digit <* eof)
--------------------------------------------------------------------------------
boolParsec :: Parsec Text s Bool
boolParsec
= ( fmap (const True) (Char.string "true")
<|> fmap (const True) (Char.string "True")
<|> fmap (const True) (Char.string "yes")
<|> fmap (const True) (Char.string "Yes")
<|> fmap (const False) (Char.string "false")
<|> fmap (const False) (Char.string "False")
<|> fmap (const False) (Char.string "no")
<|> fmap (const False) (Char.string "No")
<|> onOff
) <* eof
where
msg = " when parsing on|off or On|Off"
onOff
= do _ <- Char.char 'o' <|> Char.char 'O'
c <- Char.anyChar
case c of
'n' -> return True
'f' -> Char.char 'f' >> return False
_ -> Prim.unexpected (show c ++ msg)
--------------------------------------------------------------------------------
parsec :: Parsec Text () a -> Extractor a
parsec action key conf a@(AST _ ty)
= do s <- string key conf a
let pos = scopePos $ typedScope ty
upd _ = newPos (unpack key) (startLine pos) (startCol pos)
ini = Prim.setPosition . upd =<< Prim.getPosition
err e = throwM $ ConfigError (ctxStr key pos ++ show e)
result = Prim.parse (ini >> action) "" s
either err return result
--------------------------------------------------------------------------------
propertyNotFound :: Text -> ConfigError
propertyNotFound k = ConfigError msg where
msg = "Property " ++ unpack k ++ " is not found"
--------------------------------------------------------------------------------
wrongType :: Text -> Pos -> Type -> Type -> ConfigError
wrongType key pos tye tyf = ConfigError msg where
msg = ctxStr key pos ++
"When accessing, expected " ++ show tye ++
" but had " ++ show tyf ++ " instead"
--------------------------------------------------------------------------------
ctxStr :: Text -> Pos -> String
ctxStr e pos = unpack e ++ show pos ++ " "