{-# Language GeneralizedNewtypeDeriving #-}
{-# Language OverloadedStrings #-}
module Config.FromConfig
(
ConfigParser
, decodeConfig
, runConfigParser
, failure
, extendLoc
, FromConfig(parseConfig)
, parseList
, SectionParser
, parseSections
, sectionReq
, sectionReqWith
, sectionOpt
, sectionOptWith
, liftConfigParser
, parseSectionsWith
) where
import Config
import Control.Lens hiding (List)
import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet
import Data.Monoid
import Data.Ratio
import Data.Text (Text)
import qualified Data.Text as Text
newtype ConfigParser a = ConfigParser (ReaderT [Text] (Either Text) a)
deriving (Functor, Applicative, Monad)
runConfigParser :: ConfigParser a -> Either Text a
runConfigParser (ConfigParser p) = runReaderT p []
failure :: Text -> ConfigParser a
failure msg = ConfigParser $
do loc <- ask
let msg' = Text.concat [Text.intercalate "." (reverse loc), ": ", msg]
lift (Left msg')
extendLoc :: Text -> ConfigParser a -> ConfigParser a
extendLoc loc (ConfigParser p) = ConfigParser (local (loc:) p)
decodeConfig :: FromConfig a => Value -> Either Text a
decodeConfig = runConfigParser . parseConfig
class FromConfig a where
parseConfig :: Value -> ConfigParser a
instance FromConfig Text where
parseConfig (Text x) = return x
parseConfig _ = failure "expected text"
instance FromConfig Bool where
parseConfig (Atom "yes") = return True
parseConfig (Atom "no") = return False
parseConfig _ = failure "expected yes or no"
instance FromConfig Integer where
parseConfig (Number _ n) = return n
parseConfig (Floating c e)
| denominator n == 1 = return $! numerator n
where
n = floatingToRatio c e
parseConfig _ = failure "expected integral number"
instance FromConfig Int where
parseConfig v =
do i <- parseConfig v
let small = minBound :: Int
large = maxBound :: Int
when (i < toInteger small || toInteger large < i)
(failure "int out of range")
return (fromInteger i)
instance Integral a => FromConfig (Ratio a) where
parseConfig (Number _ n) = return $! fromIntegral n
parseConfig (Floating c e) = return $! floatingToRatio c e
parseConfig _ = failure "expected fractional number"
instance FromConfig Atom where
parseConfig (Atom a) = return a
parseConfig _ = failure "expected atom"
instance FromConfig a => FromConfig [a] where
parseConfig = parseList parseConfig
newtype SectionParser a =
SectionParser (StateT (HashMap Text Value) ConfigParser a)
deriving (Functor, Applicative, Monad)
liftConfigParser :: ConfigParser a -> SectionParser a
liftConfigParser = SectionParser . lift
parseSections :: SectionParser a -> Value -> ConfigParser a
parseSections (SectionParser p) (Sections xs) =
do hm <- toHashMap xs
(res, xs') <- runStateT p hm
let unused = HashMap.keys xs'
unless (null unused)
(failure ("unknown keys: " <> Text.intercalate ", " unused))
return res
parseSections _ _ = failure "expected sections"
sectionOpt :: FromConfig a => Text -> SectionParser (Maybe a)
sectionOpt = sectionOptWith parseConfig
sectionOptWith :: (Value -> ConfigParser a) -> Text -> SectionParser (Maybe a)
sectionOptWith p key = SectionParser $
do mb <- at key <<.= Nothing
lift (traverse (extendLoc key . p) mb)
sectionReq :: FromConfig a => Text -> SectionParser a
sectionReq = sectionReqWith parseConfig
sectionReqWith :: (Value -> ConfigParser a) -> Text -> SectionParser a
sectionReqWith p key =
do mb <- sectionOptWith p key
liftConfigParser $ case mb of
Nothing -> failure ("section required: " <> key)
Just x -> return x
toHashMap :: [Section] -> ConfigParser (HashMap Text Value)
toHashMap xs =
case duplicateCheck xs of
Just key -> failure ("duplicate section: " <> key)
Nothing -> return $! HashMap.fromList [ (k,v) | Section k v <- xs ]
duplicateCheck :: [Section] -> Maybe Text
duplicateCheck = go HashSet.empty
where
go _ [] = Nothing
go seen (Section x _:xs)
| HashSet.member x seen = Just x
| otherwise = go (HashSet.insert x seen) xs
floatingToRatio :: Integral a => Integer -> Integer -> Ratio a
floatingToRatio c e = fromIntegral c * 10 ^^ e
parseSectionsWith :: (a -> Text -> Value -> ConfigParser a) -> a -> Value -> ConfigParser a
parseSectionsWith p start s =
case s of
Sections xs -> foldM (\x (Section k v) -> extendLoc k (p x k v)) start xs
_ -> failure "Expected sections"
parseList :: (Value -> ConfigParser a) -> Value -> ConfigParser [a]
parseList p (List xs) = ifor xs $ \i x ->
extendLoc (Text.pack (show (i+1))) (p x)
parseList _ _ = failure "expected list"