Validate.hs

{- |
Module                  : Toml.Parser.Validate
Copyright               : (c) 2018-2022 Kowainik
SPDX-License-Identifier : MPL-2.0
Maintainer              : Kowainik <xrom.xkov@gmail.com>
Stability               : Stable
Portability             : Portable

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 = validateItemForest . 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 = fst . groupWithParent 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 _ [] = ([], [])
groupWithParent parent (item:items) = case item of
    KeyVal{}            -> Node item [] <:> groupWithParent parent items
    InlineTable{}       -> Node item [] <:> groupWithParent parent items
    InlineTableArray{}  -> Node item [] <:> groupWithParent parent items
    TableName name      -> groupTable item name
    TableArrayName name -> groupTable item name
  where
    -- prepend to the first list, just to remove some code noise
    (<:>) :: a -> ([a], b) -> ([a], b)
    a <:> tup = first (a :) 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 tableItem tableName = case parent of
        Nothing -> tableWithChildren tableName
        Just parentKey -> case keysDiff parentKey tableName of
            FstIsPref diff -> tableWithChildren diff
            _              -> ([], item:items)
      where
        tableWithChildren :: Key -> (Forest TomlItem, [TomlItem])
        tableWithChildren newName =
            let (children, rest) = groupWithParent (Just tableName) items
                newItem = setTableName newName tableItem
            in Node newItem children <:> groupWithParent parent 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 (Show, Eq)

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

        -- ignore subforest here
        InlineTable key table -> do
            HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key
            HashMap.lookup key tomlTableArrays `errorOnJust` SameNameTableArray key
            PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key
            tableToml <- createTomlFromTable table
            go (insertTable key tableToml toml) nodes

        -- ignore subforest here
        InlineTableArray key tables -> do
            PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key
            arrayToml <- mapM createTomlFromTable tables
            go (insertTableArrays key arrayToml toml) nodes

        TableName key -> do
            HashMap.lookup key tomlPairs `errorOnJust` SameNameKeyTable key
            HashMap.lookup key tomlTableArrays `errorOnJust` SameNameTableArray key
            PrefixMap.lookup key tomlTables `errorOnJust` DuplicateTable key
            subTable <- go mempty (subForest node)
            go (insertTable key subTable toml) nodes

        TableArrayName key -> do
            PrefixMap.lookup key tomlTables `errorOnJust` SameNameTableArray key
            subTable <- go mempty (subForest node)
            let newArray = case HashMap.lookup key tomlTableArrays of
                    Nothing  -> HashMap.insert key (subTable :| []) tomlTableArrays
                    Just arr ->
                        HashMap.insert key (arr <> (subTable :| [])) tomlTableArrays
            go (toml { tomlTableArrays = newArray }) nodes

    createTomlFromTable :: Table -> Either ValidationError TOML
    createTomlFromTable (Table table) =
        go mempty $ map (\(k, v) -> Node (KeyVal k v) []) table



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