{- |
Copyright: (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>

This module contains functions that aggregate the result of
'Toml.Parser.Item.tomlP' parser into 'TOML'. This approach allows to keep parser
fast and simple and delegate the process of creating tree structure to a
separate function.

@since 1.2.0.0
-}

module Toml.Parser.Validate
       ( -- * Decoding
         validateItems
       , ValidationError (..)

         -- * Internal helpers
       , groupItems
       , groupWithParent
       , validateItemForest
       ) where

import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Tree (Forest, Tree (..))

import Toml.Parser.Item (Table (..), TomlItem (..), setTableName)
import Toml.Type.Key (Key, KeysDiff (FstIsPref), keysDiff)
import Toml.Type.TOML (TOML (..), insertKeyAnyVal, insertTable, insertTableArrays)

import qualified Data.HashMap.Strict as HashMap
import qualified Toml.Type.PrefixTree as PrefixMap


{- | Validate list of 'TomlItem's and convert to 'TOML' if not validation
errors are found.
-}
validateItems :: [TomlItem] -> Either ValidationError TOML
validateItems :: [TomlItem] -> Either ValidationError TOML
validateItems = Forest TomlItem -> Either ValidationError TOML
validateItemForest (Forest TomlItem -> Either ValidationError TOML)
-> ([TomlItem] -> Forest TomlItem)
-> [TomlItem]
-> Either ValidationError TOML
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TomlItem] -> Forest TomlItem
groupItems

----------------------------------------------------------------------------
-- Grouping
----------------------------------------------------------------------------

{- | This function takes flat list of 'TomlItem's and groups it into list of
'Tree's by putting all corresponding items inside tables and table arrays.  It
doesn't perform any validation, just groups items according to prefixes of their
keys. So, for example, if you have the following keys as flat list:

@
aaa              # ordinary key
aaa.bbb          # ordinary key
[foo]            # table nam
foo.bar
foo.baz
[xxx]            # table name
[xxx.yyy]        # table name
zzz
@

the following tree structure will be created:

@
aaa
aaa.bbb
[foo]
├──── foo.bar
└──── foo.baz
[xxx]
└──── [yyy]
      └──── zzz
@
-}
groupItems :: [TomlItem] -> Forest TomlItem
groupItems :: [TomlItem] -> Forest TomlItem
groupItems = (Forest TomlItem, [TomlItem]) -> Forest TomlItem
forall a b. (a, b) -> a
fst ((Forest TomlItem, [TomlItem]) -> Forest TomlItem)
-> ([TomlItem] -> (Forest TomlItem, [TomlItem]))
-> [TomlItem]
-> Forest TomlItem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent Maybe Key
forall a. Maybe a
Nothing

{- | This function groups list of TOML items into 'Forest' and returns list of
items that are not children of specified parent.

__Invariant:__ When this function is called with 'Nothing', second element in
the result tuple should be empty list.
-}
groupWithParent
    :: Maybe Key   -- ^ Parent name
    -> [TomlItem]  -- ^ List of items
    -> (Forest TomlItem, [TomlItem])  -- ^ Forest of times and remaining items
groupWithParent :: Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent _ [] = ([], [])
groupWithParent parent :: Maybe Key
parent (item :: TomlItem
item:items :: [TomlItem]
items) = case TomlItem
item of
    KeyVal{}            -> TomlItem -> Forest TomlItem -> Tree TomlItem
forall a. a -> Forest a -> Tree a
Node TomlItem
item [] Tree TomlItem
-> (Forest TomlItem, [TomlItem]) -> (Forest TomlItem, [TomlItem])
forall a b. a -> ([a], b) -> ([a], b)
<:> Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent Maybe Key
parent [TomlItem]
items
    InlineTable{}       -> TomlItem -> Forest TomlItem -> Tree TomlItem
forall a. a -> Forest a -> Tree a
Node TomlItem
item [] Tree TomlItem
-> (Forest TomlItem, [TomlItem]) -> (Forest TomlItem, [TomlItem])
forall a b. a -> ([a], b) -> ([a], b)
<:> Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent Maybe Key
parent [TomlItem]
items
    InlineTableArray{}  -> TomlItem -> Forest TomlItem -> Tree TomlItem
forall a. a -> Forest a -> Tree a
Node TomlItem
item [] Tree TomlItem
-> (Forest TomlItem, [TomlItem]) -> (Forest TomlItem, [TomlItem])
forall a b. a -> ([a], b) -> ([a], b)
<:> Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent Maybe Key
parent [TomlItem]
items
    TableName name :: Key
name      -> TomlItem -> Key -> (Forest TomlItem, [TomlItem])
groupTable TomlItem
item Key
name
    TableArrayName name :: Key
name -> TomlItem -> Key -> (Forest TomlItem, [TomlItem])
groupTable TomlItem
item Key
name
  where
    -- prepend to the first list, just to remove some code noise
    (<:>) :: a -> ([a], b) -> ([a], b)
    a :: a
a <:> :: a -> ([a], b) -> ([a], b)
<:> tup :: ([a], b)
tup = ([a] -> [a]) -> ([a], b) -> ([a], b)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a], b)
tup

    -- takes table item and its name, collects all children into table subforest
    -- and returns all elements after the table
    groupTable :: TomlItem -> Key -> (Forest TomlItem, [TomlItem])
    groupTable :: TomlItem -> Key -> (Forest TomlItem, [TomlItem])
groupTable tableItem :: TomlItem
tableItem tableName :: Key
tableName = case Maybe Key
parent of
        Nothing -> Key -> (Forest TomlItem, [TomlItem])
tableWithChildren Key
tableName
        Just parentKey :: Key
parentKey -> case Key -> Key -> KeysDiff
keysDiff Key
parentKey Key
tableName of
            FstIsPref diff :: Key
diff -> Key -> (Forest TomlItem, [TomlItem])
tableWithChildren Key
diff
            _              -> ([], TomlItem
itemTomlItem -> [TomlItem] -> [TomlItem]
forall a. a -> [a] -> [a]
:[TomlItem]
items)
      where
        tableWithChildren :: Key -> (Forest TomlItem, [TomlItem])
        tableWithChildren :: Key -> (Forest TomlItem, [TomlItem])
tableWithChildren newName :: Key
newName =
            let (children :: Forest TomlItem
children, rest :: [TomlItem]
rest) = Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent (Key -> Maybe Key
forall a. a -> Maybe a
Just Key
tableName) [TomlItem]
items
                newItem :: TomlItem
newItem = Key -> TomlItem -> TomlItem
setTableName Key
newName TomlItem
tableItem
            in TomlItem -> Forest TomlItem -> Tree TomlItem
forall a. a -> Forest a -> Tree a
Node TomlItem
newItem Forest TomlItem
children Tree TomlItem
-> (Forest TomlItem, [TomlItem]) -> (Forest TomlItem, [TomlItem])
forall a b. a -> ([a], b) -> ([a], b)
<:> Maybe Key -> [TomlItem] -> (Forest TomlItem, [TomlItem])
groupWithParent Maybe Key
parent [TomlItem]
rest

----------------------------------------------------------------------------
-- Decoding
----------------------------------------------------------------------------

{- | Error that happens during validating TOML which is already syntactically
correct. For the list of all possible validation errors and their explanation,
see the following issue on GitHub:

* https://github.com/kowainik/tomland/issues/5
-}

data ValidationError
    = DuplicateKey !Key
    | DuplicateTable !Key
    | SameNameKeyTable !Key
    | SameNameTableArray !Key
    deriving stock (Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
(Int -> ValidationError -> ShowS)
-> (ValidationError -> String)
-> ([ValidationError] -> ShowS)
-> Show ValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationError] -> ShowS
$cshowList :: [ValidationError] -> ShowS
show :: ValidationError -> String
$cshow :: ValidationError -> String
showsPrec :: Int -> ValidationError -> ShowS
$cshowsPrec :: Int -> ValidationError -> ShowS
Show, ValidationError -> ValidationError -> Bool
(ValidationError -> ValidationError -> Bool)
-> (ValidationError -> ValidationError -> Bool)
-> Eq ValidationError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationError -> ValidationError -> Bool
$c/= :: ValidationError -> ValidationError -> Bool
== :: ValidationError -> ValidationError -> Bool
$c== :: ValidationError -> ValidationError -> Bool
Eq)

{- | Construct 'TOML' from the 'Forest' of 'TomlItem' and performing validation
of TOML at the same time.
-}
validateItemForest :: Forest TomlItem -> Either ValidationError TOML
validateItemForest :: Forest TomlItem -> Either ValidationError TOML
validateItemForest = TOML -> Forest TomlItem -> Either ValidationError TOML
go TOML
forall a. Monoid a => a
mempty
  where
    go :: TOML -> Forest TomlItem -> Either ValidationError TOML
    go :: TOML -> Forest TomlItem -> Either ValidationError TOML
go toml :: TOML
toml [] = TOML -> Either ValidationError TOML
forall a b. b -> Either a b
Right TOML
toml
    go toml :: TOML
toml@TOML{..} (node :: Tree TomlItem
node:nodes :: Forest TomlItem
nodes) = case Tree TomlItem -> TomlItem
forall a. Tree a -> a
rootLabel Tree TomlItem
node of
        -- ignore subforest here
        KeyVal key :: Key
key val :: AnyValue
val -> do
            Key -> HashMap Key AnyValue -> Maybe AnyValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key AnyValue
tomlPairs Maybe AnyValue -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
DuplicateKey Key
key
            Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
PrefixMap.lookup Key
key PrefixMap TOML
tomlTables Maybe TOML -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameKeyTable Key
key
            TOML -> Forest TomlItem -> Either ValidationError TOML
go (Key -> AnyValue -> TOML -> TOML
insertKeyAnyVal Key
key AnyValue
val TOML
toml) Forest TomlItem
nodes

        -- ignore subforest here
        InlineTable key :: Key
key table :: Table
table -> do
            Key -> HashMap Key AnyValue -> Maybe AnyValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key AnyValue
tomlPairs Maybe AnyValue -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameKeyTable Key
key
            Key -> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key (NonEmpty TOML)
tomlTableArrays Maybe (NonEmpty TOML)
-> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameTableArray Key
key
            Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
PrefixMap.lookup Key
key PrefixMap TOML
tomlTables Maybe TOML -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
DuplicateTable Key
key
            TOML
tableToml <- Table -> Either ValidationError TOML
createTomlFromTable Table
table
            TOML -> Forest TomlItem -> Either ValidationError TOML
go (Key -> TOML -> TOML -> TOML
insertTable Key
key TOML
tableToml TOML
toml) Forest TomlItem
nodes

        -- ignore subforest here
        InlineTableArray key :: Key
key tables :: NonEmpty Table
tables -> do
            Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
PrefixMap.lookup Key
key PrefixMap TOML
tomlTables Maybe TOML -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameTableArray Key
key
            NonEmpty TOML
arrayToml <- (Table -> Either ValidationError TOML)
-> NonEmpty Table -> Either ValidationError (NonEmpty TOML)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Table -> Either ValidationError TOML
createTomlFromTable NonEmpty Table
tables
            TOML -> Forest TomlItem -> Either ValidationError TOML
go (Key -> NonEmpty TOML -> TOML -> TOML
insertTableArrays Key
key NonEmpty TOML
arrayToml TOML
toml) Forest TomlItem
nodes

        TableName key :: Key
key -> do
            Key -> HashMap Key AnyValue -> Maybe AnyValue
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key AnyValue
tomlPairs Maybe AnyValue -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameKeyTable Key
key
            Key -> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key (NonEmpty TOML)
tomlTableArrays Maybe (NonEmpty TOML)
-> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameTableArray Key
key
            Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
PrefixMap.lookup Key
key PrefixMap TOML
tomlTables Maybe TOML -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
DuplicateTable Key
key
            TOML
subTable <- TOML -> Forest TomlItem -> Either ValidationError TOML
go TOML
forall a. Monoid a => a
mempty (Tree TomlItem -> Forest TomlItem
forall a. Tree a -> Forest a
subForest Tree TomlItem
node)
            TOML -> Forest TomlItem -> Either ValidationError TOML
go (Key -> TOML -> TOML -> TOML
insertTable Key
key TOML
subTable TOML
toml) Forest TomlItem
nodes

        TableArrayName key :: Key
key -> do
            Key -> PrefixMap TOML -> Maybe TOML
forall a. Key -> PrefixMap a -> Maybe a
PrefixMap.lookup Key
key PrefixMap TOML
tomlTables Maybe TOML -> ValidationError -> Either ValidationError ()
forall a e. Maybe a -> e -> Either e ()
`errorOnJust` Key -> ValidationError
SameNameTableArray Key
key
            TOML
subTable <- TOML -> Forest TomlItem -> Either ValidationError TOML
go TOML
forall a. Monoid a => a
mempty (Tree TomlItem -> Forest TomlItem
forall a. Tree a -> Forest a
subForest Tree TomlItem
node)
            let newArray :: HashMap Key (NonEmpty TOML)
newArray = case Key -> HashMap Key (NonEmpty TOML) -> Maybe (NonEmpty TOML)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Key
key HashMap Key (NonEmpty TOML)
tomlTableArrays of
                    Nothing  -> Key
-> NonEmpty TOML
-> HashMap Key (NonEmpty TOML)
-> HashMap Key (NonEmpty TOML)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Key
key (TOML
subTable TOML -> [TOML] -> NonEmpty TOML
forall a. a -> [a] -> NonEmpty a
:| []) HashMap Key (NonEmpty TOML)
tomlTableArrays
                    Just arr :: NonEmpty TOML
arr ->
                        Key
-> NonEmpty TOML
-> HashMap Key (NonEmpty TOML)
-> HashMap Key (NonEmpty TOML)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Key
key (NonEmpty TOML
arr NonEmpty TOML -> NonEmpty TOML -> NonEmpty TOML
forall a. Semigroup a => a -> a -> a
<> (TOML
subTable TOML -> [TOML] -> NonEmpty TOML
forall a. a -> [a] -> NonEmpty a
:| [])) HashMap Key (NonEmpty TOML)
tomlTableArrays
            TOML -> Forest TomlItem -> Either ValidationError TOML
go (TOML
toml { tomlTableArrays :: HashMap Key (NonEmpty TOML)
tomlTableArrays = HashMap Key (NonEmpty TOML)
newArray }) Forest TomlItem
nodes

    createTomlFromTable :: Table -> Either ValidationError TOML
    createTomlFromTable :: Table -> Either ValidationError TOML
createTomlFromTable (Table table :: [(Key, AnyValue)]
table) =
        TOML -> Forest TomlItem -> Either ValidationError TOML
go TOML
forall a. Monoid a => a
mempty (Forest TomlItem -> Either ValidationError TOML)
-> Forest TomlItem -> Either ValidationError TOML
forall a b. (a -> b) -> a -> b
$ ((Key, AnyValue) -> Tree TomlItem)
-> [(Key, AnyValue)] -> Forest TomlItem
forall a b. (a -> b) -> [a] -> [b]
map (\(k :: Key
k, v :: AnyValue
v) -> TomlItem -> Forest TomlItem -> Tree TomlItem
forall a. a -> Forest a -> Tree a
Node (Key -> AnyValue -> TomlItem
KeyVal Key
k AnyValue
v) []) [(Key, AnyValue)]
table



errorOnJust :: Maybe a -> e -> Either e ()
errorOnJust :: Maybe a -> e -> Either e ()
errorOnJust (Just _) e :: e
e = e -> Either e ()
forall a b. a -> Either a b
Left e
e
errorOnJust Nothing  _ = () -> Either e ()
forall a b. b -> Either a b
Right ()