Parser.hs

{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns, ViewPatterns, TupleSections   #-}

-- |
-- Module:      Data.Configurator.Parser
-- Copyright:   (c) 2015 Leon P Smith
-- License:     BSD3
-- Maintainer:  Leon P Smith <leon@melding-monads.com>
-- Stability:   experimental
-- Portability: portable
--
-- A set of combinators for high-level configuration parsing.

module Data.Configurator.Parser
    ( ConfigParser
    , ConfigParserA
    , ConfigParserM
    , ConfigError (..)
    , ConfigErrorLocation (..)
    , ConversionError (..)
    , ConversionErrorWhy (..)
    , Config
    , ConfigTransform
    , unsafeBind
    , runParser
    , runParserA
    , runParserM
    , parserA
    , parserM
    , subassocs
    , subassocs'
    , subgroups
    , localConfig
    , union
    , subconfig
    , superconfig
    , recover
    , key
    , keyWith
    ) where

import           Prelude hiding (null)

import           Data.DList (DList)
import qualified Data.DList as DL

#if !(MIN_VERSION_base(4,8,0))
import           Data.Monoid(Monoid(..))
#endif
import           Data.Monoid((<>))
import           Data.Configurator.Config
                   ( Config )
import           Data.Configurator.Types.Internal hiding (Group)
import           Data.Configurator.FromValue
                   ( FromMaybeValue(fromMaybeValue)
                   , MaybeParser
                   , runMaybeParser
                   )
import qualified Data.Configurator.Config as C
import qualified Data.Configurator.Config.Internal as CI
import           Data.Configurator.Parser.Implementation

runParser :: ConfigParser m => m a -> Config -> (Maybe a, [ConfigError])
runParser m conf = let (ma, errs) = unConfigParser_ m conf
                    in (ma, toErrors errs)

{- | Returns all the value bindings from the current configuration context
--   that is contained within the given subgroup, in lexicographic order.
--   For example, given the following context:

@
x = 1
foo {
  x = 2
  bar {
    y = on
  }
}
foo = \"Hello\"
@

Then the following arguments to 'subassocs' would return the following lists:

@
subassocs ""         ==>  [("foo",String \"Hello\"),("x",Number 1)]
subassocs "foo"      ==>  [("foo.x",Number 2)]
subassocs "foo.bar"  ==>  [("foo.bar.x",Bool True)]
@

All other arguments to subassocs would return [] in the given context.
-}


subassocs :: ConfigParser m => Name -> m [(Name, Value)]
subassocs t = configParser_ (\c -> (Just (C.subassocs t c), mempty))

{- | Returns all the value bindings from the current configuration context
--   that is contained within the given subgroup and all of it's subgroups
--   in lexicographic order. For example, given the following context:

@
x = 1
foo {
  x = 2
  bar {
    y = on
  }
}
foo = \"Hello\"
@

Then the following arguments to 'subassocs\'' would return the following lists:

@
subassocs\' ""         ==>  [ ("foo"       , String \"Hello\")
                           , ("foo.bar.y" , Bool True     )
                           , ("foo.x"     , Number 2      )
                           , ("x"         , Number 1      )
                           ]
subassocs\' "foo"      ==>  [ ("foo.bar.y" , Bool True     )
                           , ("foo.x"     , Number 2      )
                           ]
subassocs\' "foo.bar"  ==>  [ ("foo.bar.y" , Bool True     )
                           ]
@

All other arguments to @subassocs\'@ would return @[]@ in the given context.
-}

subassocs' :: ConfigParser m => Name -> m [(Name, Value)]
subassocs' t = configParser_ (\c -> (Just (C.subassocs' t c), mempty))

{- | Returns all the non-empty value groupings that is directly under
--   the argument grouping in the current configuration context.
--   For example, given the following context:

@
foo { }
bar {
  a {
    x = 1
  }
  b {
    c {
      y = 2
    }
  }
}
default
  a {
    x = 3
  }
}
@

Then the following arguments to 'subgroups' would return the following lists:

@
subgroups ""         ==>  [ "bar", "default" ]
subgroups "bar"      ==>  [ "bar.a", "bar.b" ]
subgroups "bar.b"    ==>  [ "bar.b.c" ]
subgroups "default"  ==>  [ "default.a" ]
@

All other arguments to @subgroups@ would return @[]@ in the given context.
-}

subgroups :: ConfigParser m => Name -> m [Name]
subgroups t = configParser_ (\c -> (Just (C.subgroups t c), mempty))

-- |  Modifies the 'Config' that a subparser is operating on.
--    This is perfectly analogous to 'Control.Monad.Reader.local'.

localConfig :: ConfigParser m => ConfigTransform -> m a -> m a
localConfig f m = configParser_ (\r -> unConfigParser_ m (interpConfigTransform f r))

-- |  Exactly the same as 'runParser',  except less polymorphic

runParserA :: ConfigParserA a -> Config -> (Maybe a, [ConfigError])
runParserA = runParser

-- |  Exactly the same as 'runParser',  except less polymorphic

runParserM :: ConfigParserM a -> Config -> (Maybe a, [ConfigError])
runParserM = runParser

-- |  Lift a 'ConfigParserM' action into a generic 'ConfigParser'
--    action.  Note that this does not change the semantics of the
--    argument,  it just allows a 'ConfigParserM' computation to be
--    embedded in another 'ConfigParser' computation of either variant.

parserM :: ConfigParser m => ConfigParserM a -> m a
parserM (ConfigParserM m) = configParser_ m

-- |  Lift a 'ConfigParserA' action into a generic 'ConfigParser'
--    action.  Note that this does not change the semantics of the
--    argument,  it just allows a 'ConfigParserA' computation to be
--    embedded in another 'ConfigParser' computation of either variant.

parserA :: ConfigParser m => ConfigParserA a -> m a
parserA (ConfigParserA m) = configParser_ m

-- |  Given the expression @'recover' action@, the @action@ will be
--    run,  and if it returns no value,  @recover action@ will return
--    'Nothing'.   If @action@ returns the value @a@, then
--    @recover action@ will return the value @'Just' a@.  Any errors
--    or warnings are passed through as-is.

recover :: ConfigParser m => m a -> m (Maybe a)
recover m = configParser_ $ \r -> let (ma, errs) = unConfigParser_ m r
                                   in (Just ma, errs)

--  Look up a given value in the current configuration context,  and convert
--  the value using the 'fromMaybeValue' method.

key :: (ConfigParser m, FromMaybeValue a) => Name -> m a
key name = keyWith name fromMaybeValue

--  Look up a given value in the current configuration context,  and convert
--  the value using the 'MaybeParser' argument.

keyWith :: (ConfigParser m) => Name -> MaybeParser a -> m a
keyWith name parser =
    configParser_ $ \(CI.Config c) ->
        case CI.lookupWithName name c of
          Nothing ->
              convert (KeyMissing (DL.toList (getLookupPlan name c))) Nothing
          Just (name', v) ->
              convert (Key "" name') (Just v)
  where
    convert loc mv =
        case runMaybeParser parser mv of
          (Nothing, errs) ->
              (Nothing, singleError (ConfigError loc (Just errs)))
          (Just a, []) ->
              (Just a, mempty)
          (Just a, errs@(_:_)) ->
              (Just a,  singleError (ConfigError loc (Just errs)))

getLookupPlan :: Name -> CI.ConfigPlan a -> DList Name
getLookupPlan = CI.foldPlan DL.empty (<>) (\k _ -> DL.singleton k)