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
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
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
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 ++ " "