module Data.Configurator.Config.Implementation where
import Prelude hiding ((++),null)
import Control.Applicative
import Data.Maybe(mapMaybe)
import Data.Configurator.Types.Internal hiding (Group)
import Data.Typeable
import Data.CritBit.Map.Lazy (CritBit)
import qualified Data.CritBit.Map.Lazy as CB
import qualified Data.List.Ordered as OL
import Data.Monoid
import Data.Function (on)
import Data.Text(Text)
import qualified Data.Text as T
data ConfigPlan a
= Subconfig Text (ConfigPlan a)
| Superconfig Text (ConfigPlan a)
| Union (ConfigPlan a) (ConfigPlan a)
| ConfigPlan a
| Empty
deriving (Show, Typeable, Functor)
addPrefix :: Name -> Name -> Name
addPrefix pre key
| T.null pre = key
| T.null key = pre
| otherwise = T.concat [pre, ".", key]
stripPrefix :: Name -> Name -> Maybe Name
stripPrefix pre key =
if T.null pre
then Just key
else case T.stripPrefix pre key of
Nothing -> Nothing
Just key' -> if T.null key'
then Just T.empty
else T.stripPrefix "." key'
foldPlan :: b -> (b -> b -> b) -> (Text -> a -> b) -> Text -> ConfigPlan a -> b
foldPlan empty union lookup = loop
where
loop key (Subconfig pre pl ) = loop (addPrefix pre key) pl
loop key (Superconfig pre pl ) = case stripPrefix pre key of
Nothing -> empty
Just key' -> loop key' pl
loop key (Union pl1 pl2) = loop key pl1 `union` loop key pl2
loop key (ConfigPlan a ) = lookup key a
loop _key Empty = empty
type ConfigMap a = ConfigPlan (CB.CritBit Text a)
newtype Config = Config (ConfigMap Value)
subassocs :: Text -> ConfigMap a -> [(Text,a)]
subassocs key c = filter pred (subassocs' key c)
where
pred (name,_) = case stripPrefix key name of
Nothing -> False
Just name' -> T.find ('.'==) name' == Nothing
subassocs' :: Text -> ConfigMap a -> [(Text,a)]
subassocs' key c = subassocs_ subassocsMap key c
lookup :: Text -> ConfigMap a -> Maybe a
lookup = foldPlan Nothing (<|>) CB.lookup
lookupWithName :: Name -> ConfigMap a -> Maybe (Name,a)
lookupWithName = foldPlan Nothing (<|>) (\k m -> (k,) <$> CB.lookup k m)
subassocs_ :: (Text -> a -> [(Text,b)])
-> Text -> ConfigPlan a -> [(Text,b)]
subassocs_ subassocs = loop
where
addPrefixes pre
| T.null pre = id
| otherwise = map (\(k,v) -> (addPrefix pre k,v))
stripPrefixes pre
| T.null pre = id
| otherwise = mapMaybe $ \(k,v) -> case stripPrefix pre k of
Nothing -> Nothing
Just k' -> Just (k',v)
loop !_key Empty = []
loop !key (Subconfig pre pl) =
stripPrefixes pre (loop (addPrefix pre key) pl)
loop !key (Superconfig pre pl) =
if T.length key <= T.length pre
then case stripPrefix key pre of
Nothing -> []
Just _pre' -> addPrefixes pre (loop T.empty pl)
else case stripPrefix pre key of
Nothing -> []
Just key' -> addPrefixes pre (loop key' pl)
loop !key (Union pl1 pl2) =
OL.unionBy (compare `on` fst) (loop key pl1) (loop key pl2)
loop !key (ConfigPlan map) = subassocs key map
submap :: Text -> CritBit Text a -> CritBit Text a
submap key map
| T.null key = map
| otherwise = let (_ , gt) = CB.split (key <> ".") map
(lt, _ ) = CB.split (key <> ".~") gt
in lt
subassocsMap :: Text -> CritBit Text a -> [(Text, a)]
subassocsMap key map = CB.assocs (submap key map)
null :: ConfigPlan (CritBit Text a) -> Bool
null = foldPlan True (&&) nullSubmap T.empty
nullSubmap :: Text -> CritBit Text a -> Bool
nullSubmap key map =
if T.null key
then CB.null map
else case CB.lookupGT key map of
Nothing -> True
Just (key', _) ->
case stripPrefix key key' of
Nothing -> False
Just _ -> True
subgroups :: Text -> ConfigMap a -> [Text]
subgroups = loop
where
stripPrefixes pre
| T.null pre = id
| otherwise = mapMaybe (stripPrefix pre)
addPrefixes pre
| T.null pre = id
| otherwise = map (addPrefix pre)
loop !_key Empty = []
loop !key (Subconfig pre pl) =
stripPrefixes pre (loop (addPrefix pre key) pl)
loop !key (Superconfig pre pl) =
if T.length pre <= T.length key
then case stripPrefix pre key of
Nothing -> []
Just key' -> addPrefixes pre (loop key' pl)
else case stripPrefix key pre of
Nothing -> []
Just pre' -> if null pl
then []
else [addPrefix key (T.takeWhile ('.' /=) pre')]
loop !key (Union pl1 pl2) =
OL.unionBy compare (loop key pl1) (loop key pl2)
loop !key (ConfigPlan map) = subgroupsMap key map
subgroupsMap :: Text -> CritBit Text a -> [Text]
subgroupsMap pre_ map = loop (CB.lookupGT pre map)
where
pre | T.null pre_ = T.empty
| otherwise = pre_ <> "."
loop Nothing = []
loop (Just (key,_)) =
case T.stripPrefix pre key of
Nothing -> []
Just sfx -> let (sfxa, sfxz) = T.break ('.' ==) sfx
in if T.null sfxz
then loop (CB.lookupGT key map)
else let key' = pre <> sfxa
in key' : loop (CB.lookupGT (key' <> "/") map)
union :: ConfigMap a -> ConfigMap a -> ConfigMap a
union x y
| null x = y
| null y = x
| otherwise = Union x y
subconfig :: Text -> ConfigMap a -> ConfigMap a
subconfig = \k c -> if T.null k then c else loop k c
where
loop k c =
case c of
Empty -> Empty
Union a b -> union (loop k a) (loop k b)
Superconfig kk cc ->
if T.length k <= T.length kk
then case stripPrefix k kk of
Nothing -> Empty
Just kk' -> if T.null kk'
then cc
else Superconfig kk' cc
else case stripPrefix kk k of
Nothing -> Empty
Just k' -> loop k' cc
ConfigPlan map ->
let map' = submap k map
in if CB.null map'
then Empty
else Subconfig k (ConfigPlan map')
(Subconfig _ _) ->
let c' = Subconfig k c
in if null c'
then Empty
else c'
superconfig :: Text -> ConfigMap a -> ConfigMap a
superconfig k c =
if T.null k
then c
else if null c
then Empty
else Superconfig k c