{-# 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
--
--------------------------------------------------------------------------------
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
{- 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]
> }
> -- Example.hs
> {-# LANGUAGE OverloadedStrings #-}
>
> import Data.Config
>
> data Foo = Foo { fooPort :: Int, fooAddr :: String }
>
> 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 = ...
-}
--------------------------------------------------------------------------------
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 ++ " "