{-|
Module      : Toml.Schema.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.

-}
module Toml.Schema.ParseTable (
    -- * Base interface
    ParseTable,
    KeyAlt(..),
    pickKey,
    parseTable,

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

import Control.Applicative (Alternative, empty)
import Control.Monad (MonadPlus)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT(..), ask)
import Control.Monad.Trans.State.Strict (StateT(..), get, put)
import Data.Foldable (for_)
import Data.List (intercalate)
import Data.Map qualified as Map
import Data.Text (Text)
import Toml.Schema.Matcher (Matcher, inKey, failAt, warn, warnAt)
import Toml.Semantics (Table'(..), Value')
import Toml.Pretty

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

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

-- | Lift a matcher into the current table parsing context.
liftMatcher :: Matcher l a -> ParseTable l a
liftMatcher :: forall l a. Matcher l a -> ParseTable l a
liftMatcher = ReaderT l (StateT (Table' l) (Matcher l)) a -> ParseTable l a
forall l a.
ReaderT l (StateT (Table' l) (Matcher l)) a -> ParseTable l a
ParseTable (ReaderT l (StateT (Table' l) (Matcher l)) a -> ParseTable l a)
-> (Matcher l a -> ReaderT l (StateT (Table' l) (Matcher l)) a)
-> Matcher l a
-> ParseTable l a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Table' l) (Matcher l) a
-> ReaderT l (StateT (Table' l) (Matcher l)) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT l m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Table' l) (Matcher l) a
 -> ReaderT l (StateT (Table' l) (Matcher l)) a)
-> (Matcher l a -> StateT (Table' l) (Matcher l) a)
-> Matcher l a
-> ReaderT l (StateT (Table' l) (Matcher l)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matcher l a -> StateT (Table' l) (Matcher l) a
forall (m :: * -> *) a. Monad m => m a -> StateT (Table' l) 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.
parseTable :: ParseTable l a -> l -> Table' l -> Matcher l a
parseTable :: forall l a. ParseTable l a -> l -> Table' l -> Matcher l a
parseTable (ParseTable ReaderT l (StateT (Table' l) (Matcher l)) a
p) l
l Table' l
t =
 do (a
x, MkTable Map Text (l, Value' l)
t') <- StateT (Table' l) (Matcher l) a
-> Table' l -> Matcher l (a, Table' l)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ReaderT l (StateT (Table' l) (Matcher l)) a
-> l -> StateT (Table' l) (Matcher l) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT l (StateT (Table' l) (Matcher l)) a
p l
l) Table' l
t
    [(Text, (l, Value' l))]
-> ((Text, (l, Value' l)) -> Matcher l ()) -> Matcher l ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (Map Text (l, Value' l) -> [(Text, (l, Value' l))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text (l, Value' l)
t') \(Text
k, (l
a, Value' l
_)) ->
        l -> String -> Matcher l ()
forall l. l -> String -> Matcher l ()
warnAt l
a (String
"unexpected key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (Text -> Doc Any
forall a. Text -> Doc a
prettySimpleKey Text
k))
    a -> Matcher l a
forall a. a -> Matcher l a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

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

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

-- | Emit a warning without an annotation.
warnTable :: String -> ParseTable l ()
warnTable :: forall l. String -> ParseTable l ()
warnTable = Matcher l () -> ParseTable l ()
forall l a. Matcher l a -> ParseTable l a
liftMatcher (Matcher l () -> ParseTable l ())
-> (String -> Matcher l ()) -> String -> ParseTable l ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Matcher l ()
forall a. String -> Matcher a ()
warn

-- | Emit a warning with the given annotation.
warnTableAt :: l -> String -> ParseTable l ()
warnTableAt :: forall l. l -> String -> ParseTable l ()
warnTableAt l
l = Matcher l () -> ParseTable l ()
forall l a. Matcher l a -> ParseTable l a
liftMatcher (Matcher l () -> ParseTable l ())
-> (String -> Matcher l ()) -> String -> ParseTable l ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> String -> Matcher l ()
forall l. l -> String -> Matcher l ()
warnAt l
l

-- | Abort the current table matching with an error message at the given annotation.
failTableAt :: l -> String -> ParseTable l a
failTableAt :: forall l a. l -> String -> ParseTable l a
failTableAt l
l = Matcher l a -> ParseTable l a
forall l a. Matcher l a -> ParseTable l a
liftMatcher (Matcher l a -> ParseTable l a)
-> (String -> Matcher l a) -> String -> ParseTable l a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l -> String -> Matcher l a
forall l a. l -> String -> Matcher l a
failAt l
l

-- | Key and value matching function
data KeyAlt l a
    = Key Text (Value' l -> Matcher l a) -- ^ pick alternative based on key match
    | Else (Matcher l 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.Schema.reqKey' cases together with 'Control.Applicative.Alternative'
-- which will fall-through as a result of any failure to the next case.
pickKey :: [KeyAlt l a] -> ParseTable l a
pickKey :: forall l a. [KeyAlt l a] -> ParseTable l a
pickKey [KeyAlt l a]
xs =
 do MkTable Map Text (l, Value' l)
t <- ParseTable l (Table' l)
forall l. ParseTable l (Table' l)
getTable
    (KeyAlt l a -> ParseTable l a -> ParseTable l a)
-> ParseTable l a -> [KeyAlt l a] -> ParseTable l a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Map Text (l, Value' l)
-> KeyAlt l a -> ParseTable l a -> ParseTable l a
forall {l} {a}.
Map Text (l, Value' l)
-> KeyAlt l a -> ParseTable l a -> ParseTable l a
f Map Text (l, Value' l)
t) ParseTable l a
forall l a. ParseTable l a
errCase [KeyAlt l a]
xs
    where
        f :: Map Text (l, Value' l)
-> KeyAlt l a -> ParseTable l a -> ParseTable l a
f Map Text (l, Value' l)
_ (Else Matcher l a
m) ParseTable l a
_ = Matcher l a -> ParseTable l a
forall l a. Matcher l a -> ParseTable l a
liftMatcher Matcher l a
m
        f Map Text (l, Value' l)
t (Key Text
k Value' l -> Matcher l a
c) ParseTable l a
continue =
            case Text -> Map Text (l, Value' l) -> Maybe (l, Value' l)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
k Map Text (l, Value' l)
t of
                Maybe (l, Value' l)
Nothing -> ParseTable l a
continue
                Just (l
_, Value' l
v) ->
                 do Table' l -> ParseTable l ()
forall l. Table' l -> ParseTable l ()
setTable (Table' l -> ParseTable l ()) -> Table' l -> ParseTable l ()
forall a b. (a -> b) -> a -> b
$! Map Text (l, Value' l) -> Table' l
forall a. Map Text (a, Value' a) -> Table' a
MkTable (Text -> Map Text (l, Value' l) -> Map Text (l, Value' l)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
k Map Text (l, Value' l)
t)
                    Matcher l a -> ParseTable l a
forall l a. Matcher l a -> ParseTable l a
liftMatcher (Text -> Matcher l a -> Matcher l a
forall l a. Text -> Matcher l a -> Matcher l a
inKey Text
k (Value' l -> Matcher l a
c Value' l
v))

        errCase :: ParseTable a b
errCase =
         do a
l <- ReaderT a (StateT (Table' a) (Matcher a)) a -> ParseTable a a
forall l a.
ReaderT l (StateT (Table' l) (Matcher l)) a -> ParseTable l a
ParseTable ReaderT a (StateT (Table' a) (Matcher a)) a
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            case [KeyAlt l a]
xs of
                []        -> ParseTable a b
forall a. ParseTable a a
forall (f :: * -> *) a. Alternative f => f a
empty -- there's nothing a user can do here
                [Key Text
k Value' l -> Matcher l a
_] -> a -> String -> ParseTable a b
forall l a. l -> String -> ParseTable l a
failTableAt a
l (String
"missing key: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (Text -> Doc Any
forall a. Text -> Doc a
prettySimpleKey Text
k))
                [KeyAlt l a]
_         -> a -> String -> ParseTable a b
forall l a. l -> String -> ParseTable l a
failTableAt a
l (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 (Text -> Doc Any
forall a. Text -> Doc a
prettySimpleKey Text
k) | Key Text
k Value' l -> Matcher l a
_ <- [KeyAlt l a]
xs])