{-|
Module      : Toml.FromValue.ParseTable
Description : A type for matching keys out of a table
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

This module provides utilities for matching key-value pairs
out of tables while building up application-specific values.

It will help generate warnings for unused keys, help select
between multiple possible keys, and emit location-specific
error messages when keys are unavailable.

This module provides the 'ParseTable' implementation, but
most of the basic functionality is exported directly from
"Toml.FromValue".

-}
module Toml.FromValue.ParseTable (
    -- * Base interface
    ParseTable,
    KeyAlt(..),
    pickKey,
    runParseTable,

    -- * Primitives
    liftMatcher,
    warnTable,
    setTable,
    getTable,
    ) where

import Control.Applicative (Alternative, empty)
import Control.Monad (MonadPlus)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State.Strict (StateT(..), get, put)
import Data.List (intercalate)
import Data.Map qualified as Map
import Toml.FromValue.Matcher (warning, Matcher, inKey)
import Toml.Pretty (prettySimpleKey)
import Toml.Value (Table, Value)

-- | A 'Matcher' that tracks a current set of unmatched key-value
-- pairs from a table.
--
-- Use 'Toml.FromValue.optKey' and 'Toml.FromValue.reqKey' to extract keys.
--
-- Use 'getTable' and 'setTable' to override the table and implement
-- other primitives.
newtype ParseTable a = ParseTable (StateT Table Matcher a)
    deriving ((forall a b. (a -> b) -> ParseTable a -> ParseTable b)
-> (forall a b. a -> ParseTable b -> ParseTable a)
-> Functor ParseTable
forall a b. a -> ParseTable b -> ParseTable a
forall a b. (a -> b) -> ParseTable a -> ParseTable b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ParseTable a -> ParseTable b
fmap :: forall a b. (a -> b) -> ParseTable a -> ParseTable b
$c<$ :: forall a b. a -> ParseTable b -> ParseTable a
<$ :: forall a b. a -> ParseTable b -> ParseTable a
Functor, Functor ParseTable
Functor ParseTable =>
(forall a. a -> ParseTable a)
-> (forall a b.
    ParseTable (a -> b) -> ParseTable a -> ParseTable b)
-> (forall a b c.
    (a -> b -> c) -> ParseTable a -> ParseTable b -> ParseTable c)
-> (forall a b. ParseTable a -> ParseTable b -> ParseTable b)
-> (forall a b. ParseTable a -> ParseTable b -> ParseTable a)
-> Applicative ParseTable
forall a. a -> ParseTable a
forall a b. ParseTable a -> ParseTable b -> ParseTable a
forall a b. ParseTable a -> ParseTable b -> ParseTable b
forall a b. ParseTable (a -> b) -> ParseTable a -> ParseTable b
forall a b c.
(a -> b -> c) -> ParseTable a -> ParseTable b -> ParseTable c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ParseTable a
pure :: forall a. a -> ParseTable a
$c<*> :: forall a b. ParseTable (a -> b) -> ParseTable a -> ParseTable b
<*> :: forall a b. ParseTable (a -> b) -> ParseTable a -> ParseTable b
$cliftA2 :: forall a b c.
(a -> b -> c) -> ParseTable a -> ParseTable b -> ParseTable c
liftA2 :: forall a b c.
(a -> b -> c) -> ParseTable a -> ParseTable b -> ParseTable c
$c*> :: forall a b. ParseTable a -> ParseTable b -> ParseTable b
*> :: forall a b. ParseTable a -> ParseTable b -> ParseTable b
$c<* :: forall a b. ParseTable a -> ParseTable b -> ParseTable a
<* :: forall a b. ParseTable a -> ParseTable b -> ParseTable a
Applicative, Applicative ParseTable
Applicative ParseTable =>
(forall a b. ParseTable a -> (a -> ParseTable b) -> ParseTable b)
-> (forall a b. ParseTable a -> ParseTable b -> ParseTable b)
-> (forall a. a -> ParseTable a)
-> Monad ParseTable
forall a. a -> ParseTable a
forall a b. ParseTable a -> ParseTable b -> ParseTable b
forall a b. ParseTable a -> (a -> ParseTable b) -> ParseTable b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ParseTable a -> (a -> ParseTable b) -> ParseTable b
>>= :: forall a b. ParseTable a -> (a -> ParseTable b) -> ParseTable b
$c>> :: forall a b. ParseTable a -> ParseTable b -> ParseTable b
>> :: forall a b. ParseTable a -> ParseTable b -> ParseTable b
$creturn :: forall a. a -> ParseTable a
return :: forall a. a -> ParseTable a
Monad, Applicative ParseTable
Applicative ParseTable =>
(forall a. ParseTable a)
-> (forall a. ParseTable a -> ParseTable a -> ParseTable a)
-> (forall a. ParseTable a -> ParseTable [a])
-> (forall a. ParseTable a -> ParseTable [a])
-> Alternative ParseTable
forall a. ParseTable a
forall a. ParseTable a -> ParseTable [a]
forall a. ParseTable a -> ParseTable a -> ParseTable a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
$cempty :: forall a. ParseTable a
empty :: forall a. ParseTable a
$c<|> :: forall a. ParseTable a -> ParseTable a -> ParseTable a
<|> :: forall a. ParseTable a -> ParseTable a -> ParseTable a
$csome :: forall a. ParseTable a -> ParseTable [a]
some :: forall a. ParseTable a -> ParseTable [a]
$cmany :: forall a. ParseTable a -> ParseTable [a]
many :: forall a. ParseTable a -> ParseTable [a]
Alternative, Monad ParseTable
Alternative ParseTable
(Alternative ParseTable, Monad ParseTable) =>
(forall a. ParseTable a)
-> (forall a. ParseTable a -> ParseTable a -> ParseTable a)
-> MonadPlus ParseTable
forall a. ParseTable a
forall a. ParseTable a -> ParseTable a -> ParseTable a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
$cmzero :: forall a. ParseTable a
mzero :: forall a. ParseTable a
$cmplus :: forall a. ParseTable a -> ParseTable a -> ParseTable a
mplus :: forall a. ParseTable a -> ParseTable a -> ParseTable a
MonadPlus)

-- | Implemented in terms of 'fail' on 'Matcher'
instance MonadFail ParseTable where
    fail :: forall a. String -> ParseTable a
fail = StateT Table Matcher a -> ParseTable a
forall a. StateT Table Matcher a -> ParseTable a
ParseTable (StateT Table Matcher a -> ParseTable a)
-> (String -> StateT Table Matcher a) -> String -> ParseTable a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> StateT Table Matcher a
forall a. String -> StateT Table Matcher a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

-- | Lift a matcher into the current table parsing context.
liftMatcher :: Matcher a -> ParseTable a
liftMatcher :: forall a. Matcher a -> ParseTable a
liftMatcher = StateT Table Matcher a -> ParseTable a
forall a. StateT Table Matcher a -> ParseTable a
ParseTable (StateT Table Matcher a -> ParseTable a)
-> (Matcher a -> StateT Table Matcher a)
-> Matcher a
-> ParseTable a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matcher a -> StateT Table Matcher a
forall (m :: * -> *) a. Monad m => m a -> StateT Table m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Run a 'ParseTable' computation with a given starting 'Table'.
-- Unused tables will generate a warning. To change this behavior
-- 'getTable' and 'setTable' can be used to discard or generate
-- error messages.
runParseTable :: ParseTable a -> Table -> Matcher a
runParseTable :: forall a. ParseTable a -> Table -> Matcher a
runParseTable (ParseTable StateT Table Matcher a
p) Table
t =
 do (a
x, Table
t') <- StateT Table Matcher a -> Table -> Matcher (a, Table)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT Table Matcher a
p Table
t
    case Table -> [String]
forall k a. Map k a -> [k]
Map.keys Table
t' of
        []  -> a -> Matcher a
forall a. a -> Matcher a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        [String
k] -> a
x a -> Matcher () -> Matcher a
forall a b. a -> Matcher b -> Matcher a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Matcher ()
warning (String
"unexpected key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (String -> Doc Any
forall a. String -> Doc a
prettySimpleKey String
k))
        [String]
ks  -> a
x a -> Matcher () -> Matcher a
forall a b. a -> Matcher b -> Matcher a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> Matcher ()
warning (String
"unexpected keys: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> (String -> Doc Any) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc Any
forall a. String -> Doc a
prettySimpleKey) [String]
ks))

-- | Return the remaining portion of the table being matched.
getTable :: ParseTable Table
getTable :: ParseTable Table
getTable = StateT Table Matcher Table -> ParseTable Table
forall a. StateT Table Matcher a -> ParseTable a
ParseTable StateT Table Matcher Table
forall (m :: * -> *) s. Monad m => StateT s m s
get

-- | Replace the remaining portion of the table being matched.
setTable :: Table -> ParseTable ()
setTable :: Table -> ParseTable ()
setTable = StateT Table Matcher () -> ParseTable ()
forall a. StateT Table Matcher a -> ParseTable a
ParseTable (StateT Table Matcher () -> ParseTable ())
-> (Table -> StateT Table Matcher ()) -> Table -> ParseTable ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> StateT Table Matcher ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put

-- | Emit a warning at the current location.
warnTable :: String -> ParseTable ()
warnTable :: String -> ParseTable ()
warnTable = StateT Table Matcher () -> ParseTable ()
forall a. StateT Table Matcher a -> ParseTable a
ParseTable (StateT Table Matcher () -> ParseTable ())
-> (String -> StateT Table Matcher ()) -> String -> ParseTable ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matcher () -> StateT Table Matcher ()
forall (m :: * -> *) a. Monad m => m a -> StateT Table m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Matcher () -> StateT Table Matcher ())
-> (String -> Matcher ()) -> String -> StateT Table Matcher ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Matcher ()
warning


-- | Key and value matching function
--
-- @since 1.2.0.0
data KeyAlt a
    = Key String (Value -> Matcher a) -- ^ pick alternative based on key match
    | Else (Matcher a) -- ^ default case when no previous cases matched

-- | Take the first option from a list of table keys and matcher functions.
-- This operation will commit to the first table key that matches. If the
-- associated matcher fails, only that error will be propagated and the
-- other alternatives will not be matched.
--
-- If no keys match, an error message is generated explaining which keys
-- would have been accepted.
--
-- This is provided as an alternative to chaining multiple
-- 'Toml.FromValue.reqKey' cases together with @('<|>')@ because that will
-- generate one error message for each unmatched alternative as well as
-- the error associate with the matched alternative.
--
-- @since 1.2.0.0
pickKey :: [KeyAlt a] -> ParseTable a
pickKey :: forall a. [KeyAlt a] -> ParseTable a
pickKey [KeyAlt a]
xs =
 do Table
t <- ParseTable Table
getTable
    (KeyAlt a -> ParseTable a -> ParseTable a)
-> ParseTable a -> [KeyAlt a] -> ParseTable a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Table -> KeyAlt a -> ParseTable a -> ParseTable a
forall {a}. Table -> KeyAlt a -> ParseTable a -> ParseTable a
f Table
t) ParseTable a
forall a. ParseTable a
errCase [KeyAlt a]
xs
    where
        f :: Table -> KeyAlt a -> ParseTable a -> ParseTable a
f Table
_ (Else Matcher a
m) ParseTable a
_ = Matcher a -> ParseTable a
forall a. Matcher a -> ParseTable a
liftMatcher Matcher a
m
        f Table
t (Key String
k Value -> Matcher a
c) ParseTable a
continue =
            case String -> Table -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
k Table
t of
                Maybe Value
Nothing -> ParseTable a
continue
                Just Value
v ->
                 do Table -> ParseTable ()
setTable (Table -> ParseTable ()) -> Table -> ParseTable ()
forall a b. (a -> b) -> a -> b
$! String -> Table -> Table
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete String
k Table
t
                    Matcher a -> ParseTable a
forall a. Matcher a -> ParseTable a
liftMatcher (String -> Matcher a -> Matcher a
forall a. String -> Matcher a -> Matcher a
inKey String
k (Value -> Matcher a
c Value
v))

        errCase :: ParseTable a
errCase =
            case [KeyAlt a]
xs of
                []        -> ParseTable a
forall a. ParseTable a
forall (f :: * -> *) a. Alternative f => f a
empty -- there's nothing a user can do here
                [Key String
k Value -> Matcher a
_] -> String -> ParseTable a
forall a. String -> ParseTable a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"missing key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (String -> Doc Any
forall a. String -> Doc a
prettySimpleKey String
k))
                [KeyAlt a]
_         -> String -> ParseTable a
forall a. String -> ParseTable a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"possible keys: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [Doc Any -> String
forall a. Show a => a -> String
show (String -> Doc Any
forall a. String -> Doc a
prettySimpleKey String
k) | Key String
k Value -> Matcher a
_ <- [KeyAlt a]
xs])