path: root/src/Data/JLD/Expansion/Context.hs

module Data.JLD.Expansion.Context (BTDParams (..), EIParams (..), BACParams (..), buildTermDefinition, expandIri, buildActiveContext) where

import Data.JLD.Prelude

import Data.JLD.Control.Monad.RES (REST, withEnvRES, withErrorRES, withErrorRES', withStateRES)
import Data.JLD.Error (JLDError (..))
import Data.JLD.Expansion.Global (JLDExpansionEnv (..), JLDExpansionState (..), JLDExpansionT, hoistEnv, modifyContextCache, modifyDocumentCache)
import Data.JLD.Model.ActiveContext (ActiveContext (..), containsProtectedTerm, lookupTerm, newActiveContext)
import Data.JLD.Model.Direction (Direction (..))
import Data.JLD.Model.IRI (CompactIRI (..), endsWithGenericDelim, isBlankIri, parseCompactIri)
import Data.JLD.Model.Keyword (Keyword (..), allKeywords, isKeyword, isKeywordLike, isNotKeyword, parseKeyword)
import Data.JLD.Model.Language (Language (..))
import Data.JLD.Model.TermDefinition (TermDefinition (..), newTermDefinition)
import Data.JLD.Model.URI (parseUri, uriToIri)
import Data.JLD.Options (ContextCache, Document (..), DocumentCache, DocumentLoader (..), JLDVersion (..))
import Data.JLD.Util (flattenSingletonArray, valueContains, valueContainsAny, valueToArray)

import Control.Monad.Except (MonadError (..))
import Data.Aeson (Object, Value (..))
import Data.Aeson.Key qualified as K (fromText, toText)
import Data.Aeson.KeyMap qualified as KM (delete, keys, lookup, member, size)
import Data.Map.Strict qualified as M (delete, insert, lookup)
import Data.RDF (parseIRI, parseRelIRI, resolveIRI, serializeIRI, validateIRI)
import Data.Set qualified as S (insert, member, notMember, size)
import Data.Text qualified as T (drop, dropEnd, elem, findIndex, isPrefixOf, null, take, toLower)
import Data.Vector qualified as V (length)
import Text.URI (URI, isPathAbsolute, relativeTo)
import Text.URI qualified as U (render)

type BACT e m = REST (BACEnv e m) (Either (JLDError e) ()) BACState m

data BACEnv e m = BACEnv
    { bacEnvGlobal :: JLDExpansionEnv e m
    , bacEnvOverrideProtected :: Bool
    , bacEnvValidateScopedContext :: Bool
    , bacEnvPropagate :: Bool
    }
    deriving (Show)

data BACState = BACState
    { bacStateGlobal :: JLDExpansionState
    , bacStateActiveContext :: ActiveContext
    , bacStateRemoteContexts :: Set Text
    }
    deriving (Show, Eq)

data BACParams = BACParams
    { bacParamsOverrideProtected :: Bool
    , bacParamsPropagate :: Bool
    , bacParamsValidateScopedContext :: Bool
    , bacParamsRemoteContexts :: Set Text
    }
    deriving (Show, Eq)

bacModifyContextCache :: Monad m => (ContextCache -> ContextCache) -> BACT e m ()
bacModifyContextCache = modifyContextCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})

bacModifyDocumentCache :: Monad m => (DocumentCache -> DocumentCache) -> BACT e m ()
bacModifyDocumentCache = modifyDocumentCache .> withStateRES bacStateGlobal (\s g -> s{bacStateGlobal = g})

bacModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BACT e m ()
bacModifyActiveContext fn = modify \s -> s{bacStateActiveContext = fn (bacStateActiveContext s)}

bacModifyRemoteContexts :: Monad m => (Set Text -> Set Text) -> BACT e m ()
bacModifyRemoteContexts fn = modify \s -> s{bacStateRemoteContexts = fn (bacStateRemoteContexts s)}

bacBuildTermDefinition :: Monad m => Object -> Maybe URI -> Text -> BACT e m ()
bacBuildTermDefinition contextDefinition baseUrl term = do
    BACEnv{..} <- ask
    activeContext <- gets bacStateActiveContext
    remoteContexts <- gets bacStateRemoteContexts
    let params p =
            p
                { btdParamsBaseUrl = baseUrl
                , btdParamsOverrideProtectedFlag = bacEnvOverrideProtected
                , btdParamsProtectedFlag = contextDefinition |> KM.lookup (show KeywordProtected) .> maybe False (== Bool True)
                , btdParamsRemoteContexts = remoteContexts
                }
    (activeContext', _) <-
        buildTermDefinition activeContext contextDefinition term params
            |> withEnvRES (const bacEnvGlobal)
            |> withErrorRES Left
            |> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
    bacModifyActiveContext <| const activeContext'

bacBuildActiveContext :: Monad m => Value -> URI -> BACT e m ()
bacBuildActiveContext context uri = do
    BACEnv{..} <- ask
    activeContext <- gets bacStateActiveContext
    remoteContexts <- gets bacStateRemoteContexts
    let params p =
            p
                { bacParamsValidateScopedContext = bacEnvValidateScopedContext
                , bacParamsRemoteContexts = remoteContexts
                }
    activeContext' <-
        buildActiveContext activeContext context (Just uri) params
            |> withEnvRES (const bacEnvGlobal)
            .> withErrorRES Left
            .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
    bacModifyActiveContext <| const activeContext'

bacProcessItem :: Monad m => Maybe URI -> Value -> BACT e m ()
bacProcessItem baseUrl item = do
    BACEnv{..} <- ask
    let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal

    result <- gets bacStateActiveContext

    case item of
        -- 5.1.
        Null
            -- 5.1.1.
            | not bacEnvOverrideProtected && containsProtectedTerm result -> throwError <| Left InvalidContextNullification
            -- 5.1.2.
            | bacEnvPropagate ->
                bacModifyActiveContext \ac -> newActiveContext \nac ->
                    nac
                        { activeContextBaseUrl = activeContextBaseUrl ac
                        , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac
                        }
            | otherwise ->
                bacModifyActiveContext \ac -> newActiveContext \nac ->
                    nac
                        { activeContextBaseUrl = activeContextBaseUrl ac
                        , activeContextBaseIri = uriToIri =<< activeContextBaseUrl ac
                        , activeContextPreviousContext = activeContextPreviousContext ac
                        }
        -- 5.2.
        String value -> bacFetchRemoteContext value baseUrl
        -- 5.4.
        Object contextDefinition -> do
            -- 5.5. 5.5.1. 5.5.2.
            case KM.lookup (show KeywordVersion) contextDefinition of
                Just (String "1.1")
                    | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left ProcessingModeConflict
                    | otherwise -> pure ()
                Just (Number 1.1)
                    | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left ProcessingModeConflict
                    | otherwise -> pure ()
                Just value -> throwError <. Left <| InvalidKeywordValue KeywordVersion value
                --
                Nothing -> pure ()

            -- 5.6.
            contextDefinition' <- case KM.lookup (show KeywordImport) contextDefinition of
                -- 5.6.1.
                Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry
                -- 5.6.3.
                Just (String value)
                    | Just importUri <- parseUri value
                    , Just contextUri <- relativeTo importUri =<< baseUrl ->
                        runDocumentLoader jldExpansionEnvDocumentLoader contextUri >>= \case
                            Right (Object document) -> case KM.lookup (show KeywordContext) document of
                                Just (Object remoteContext)
                                    -- 5.6.7.
                                    | KM.member (show KeywordImport) remoteContext -> throwError <| Left InvalidContextEntry
                                    -- 5.6.8.
                                    | otherwise -> pure <| contextDefinition <> remoteContext
                                -- 5.6.6.
                                _ -> throwError <| Left InvalidRemoteContext
                            -- 5.6.6.
                            Right _ -> throwError <| Left InvalidRemoteContext
                            -- 5.6.5.
                            Left err -> throwError <. Left <| DocumentLoaderError err
                -- 5.6.2.
                Just value -> throwError <. Left <| InvalidKeywordValue KeywordImport value
                --
                Nothing -> pure contextDefinition

            -- 5.7. 5.7.1.
            case KM.lookup (show KeywordBase) contextDefinition' of
                -- 5.7.2.
                Just Null -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Nothing}
                Just (String "") -> pure ()
                Just (String value)
                    -- 5.7.3.
                    | Right iri <- parseIRI value -> bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri}
                    -- 5.7.4.
                    | Just baseIri <- activeContextBaseIri result
                    , Right iri <- parseIRI =<< resolveIRI (serializeIRI baseIri) value ->
                        bacModifyActiveContext \ac -> ac{activeContextBaseIri = Just iri}
                --
                Just _ -> throwError <| Left InvalidBaseIri
                --
                Nothing -> pure ()

            -- 5.8. 5.8.1.
            case KM.lookup (show KeywordVocab) contextDefinition' of
                -- 5.8.2.
                Just Null -> bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Nothing}
                -- 5.8.3.
                Just (String value) | T.null value || isBlankIri value || isRight (parseIRI value) || isRight (parseRelIRI value) -> do
                    activeContext <- gets bacStateActiveContext
                    let params p =
                            p
                                { eiParamsVocab = True
                                , eiParamsDocumentRelative = True
                                }
                    (maybeVocabMapping, activeContext', _) <-
                        expandIri activeContext value params
                            |> withEnvRES (const bacEnvGlobal)
                            .> withErrorRES Left
                            .> withStateRES bacStateGlobal (\bac global -> bac{bacStateGlobal = global})
                    bacModifyActiveContext <| const activeContext'

                    case maybeVocabMapping of
                        Just vocabMapping | isBlankIri vocabMapping || isRight (parseIRI vocabMapping) ->
                            bacModifyActiveContext \ac -> ac{activeContextVocabularyMapping = Just vocabMapping}
                        _ ->
                            throwError <| Left InvalidVocabMapping
                Just _ -> throwError <| Left InvalidVocabMapping
                --
                Nothing -> pure ()

            -- 5.9. 5.9.1.
            case KM.lookup (show KeywordLanguage) contextDefinition' of
                -- 5.9.2.
                Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just NoLanguage}
                -- 5.9.3.
                Just (String language) -> bacModifyActiveContext \ac -> ac{activeContextDefaultLanguage = Just <. Language <| T.toLower language}
                Just _ -> throwError <| Left InvalidDefaultLanguage
                --
                Nothing -> pure ()

            -- 5.10. 5.10.2.
            case KM.lookup (show KeywordDirection) contextDefinition' of
                -- 5.10.1.
                Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry
                -- 5.10.3.
                Just Null -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Nothing}
                --
                Just (String (T.toLower -> "ltr")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just LTR}
                Just (String (T.toLower -> "rtl")) -> bacModifyActiveContext \ac -> ac{activeContextDefaultBaseDirection = Just RTL}
                Just _ -> throwError <| Left InvalidBaseDirection
                --
                Nothing -> pure ()

            -- 5.11.
            case KM.lookup (show KeywordPropagate) contextDefinition' of
                -- 5.11.1.
                Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidContextEntry
                Just (Bool _) -> pure ()
                Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPropagate invalid
                --
                Nothing -> pure ()

            -- 5.13.
            let filteredKeywords =
                    [ KeywordBase
                    , KeywordDirection
                    , KeywordImport
                    , KeywordLanguage
                    , KeywordPropagate
                    , KeywordProtected
                    , KeywordVersion
                    , KeywordVocab
                    ]
            KM.keys contextDefinition'
                |> fmap K.toText
                .> filter (`isNotKeyword` filteredKeywords)
                .> mapM_ (bacBuildTermDefinition contextDefinition' baseUrl)
        -- 5.3.
        _ -> throwError <| Left InvalidLocalContext

bacFetchRemoteContext :: Monad m => Text -> Maybe URI -> BACT e m ()
bacFetchRemoteContext url maybeBaseUrl
    | Just uri <- parseUri url
    , Just contextUri <- relativeTo uri =<< maybeBaseUrl -- 5.2.1.
    , isPathAbsolute contextUri
    , contextKey <- U.render contextUri = do
        BACEnv{..} <- ask
        let JLDExpansionEnv{..} = hoistEnv (lift .> lift .> lift) bacEnvGlobal

        remoteContexts <- gets bacStateRemoteContexts

        -- 5.2.2.
        when (not bacEnvValidateScopedContext && S.member contextKey remoteContexts) <| throwError (Right ())

        -- 5.2.3.
        when (S.size remoteContexts > jldExpansionEnvMaxRemoteContexts) <| throwError (Left ContextOverflow)

        bacModifyRemoteContexts <| S.insert contextKey

        -- 5.2.4.
        gets (bacStateGlobal .> jldExpansionStateContextCache .> M.lookup contextKey) >>= \case
            Just cachedContext -> do
                bacBuildActiveContext cachedContext contextUri
                throwError <| Right ()
            --
            Nothing -> pure ()

        -- 5.2.5.
        document <-
            gets (bacStateGlobal .> jldExpansionStateDocumentCache .> M.lookup contextKey) >>= \case
                Just document -> pure document
                Nothing ->
                    runDocumentLoader jldExpansionEnvDocumentLoader contextUri >>= \case
                        Right (Object document) -> pure <| Document contextUri document
                        -- 5.2.5.2.
                        Right _ -> throwError <| Left InvalidRemoteContext
                        -- 5.2.5.1.
                        Left err -> throwError <. Left <| DocumentLoaderError err

        -- 5.2.5.3.
        importedContext <- case KM.lookup (show KeywordContext) (documentContent document) of
            Just (Object context) -> pure <. Object <. KM.delete (show KeywordBase) <| context
            Just context -> pure context
            Nothing -> throwError <| Left InvalidRemoteContext

        bacModifyDocumentCache <| M.insert contextKey document

        -- 5.2.6.
        bacBuildActiveContext importedContext (documentUri document)
        bacModifyContextCache <| M.insert contextKey importedContext
    | otherwise = throwError <| Left LoadingRemoteContextError

buildActiveContext' :: Monad m => Value -> Maybe URI -> BACT e m ()
buildActiveContext' localContext baseUrl = do
    activeContext <- gets bacStateActiveContext

    -- 1.
    bacModifyActiveContext \ac -> ac{activeContextInverseContext = mempty}

    -- 2.
    propagate <- case localContext of
        Object ctx | Just prop <- KM.lookup (show KeywordPropagate) ctx -> case prop of
            Bool p -> pure p
            _ -> throwError <. Left <| InvalidKeywordValue KeywordPropagate prop
        _ -> asks bacEnvPropagate

    -- 3.
    previousContext <- gets <| activeContextPreviousContext <. bacStateActiveContext
    when (not propagate && isNothing previousContext) do
        bacModifyActiveContext \ac -> ac{activeContextPreviousContext = Just activeContext}

    -- 4. 5.
    forM_ (valueToArray localContext)
        <| bacProcessItem baseUrl
        .> withEnvRES (\env -> env{bacEnvPropagate = propagate})
        .> withErrorRES' (either (Left .> throwError) pure)

buildActiveContext :: Monad m => ActiveContext -> Value -> Maybe URI -> (BACParams -> BACParams) -> JLDExpansionT e m ActiveContext
buildActiveContext activeContext localContext baseUrl paramsFn = do
    BACState{..} <-
        (buildActiveContext' localContext baseUrl >> get)
            |> withEnvRES env
            .> withErrorRES' (either throwError (const get))
            .> withStateRES st (const bacStateGlobal)
    pure bacStateActiveContext
  where
    BACParams{..} =
        paramsFn
            BACParams
                { bacParamsOverrideProtected = False
                , bacParamsPropagate = True
                , bacParamsValidateScopedContext = True
                , bacParamsRemoteContexts = mempty
                }

    env options =
        BACEnv
            { bacEnvGlobal = options
            , bacEnvOverrideProtected = bacParamsOverrideProtected
            , bacEnvValidateScopedContext = bacParamsValidateScopedContext
            , bacEnvPropagate = bacParamsPropagate
            }

    st global =
        BACState
            { bacStateGlobal = global
            , bacStateActiveContext = activeContext
            , bacStateRemoteContexts = bacParamsRemoteContexts
            }

--

type EIT e m = REST (EIEnv e m) (JLDError e) EIState m

data EIEnv e m = EIEnv
    { eiEnvGlobal :: JLDExpansionEnv e m
    , eiEnvDocumentRelative :: Bool
    , eiEnvVocab :: Bool
    , eiEnvLocalContext :: Maybe Object
    }
    deriving (Show)

data EIState = EIState
    { eiStateGlobal :: JLDExpansionState
    , eiStateDefined :: Map Text Bool
    , eiStateActiveContext :: ActiveContext
    }
    deriving (Show, Eq)

data EIParams = EIParams
    { eiParamsDocumentRelative :: Bool
    , eiParamsVocab :: Bool
    , eiParamsLocalContext :: Maybe Object
    , eiParamsDefined :: Map Text Bool
    }
    deriving (Show, Eq)

eiBuildTermDefinition :: Monad m => Text -> EIT e m ()
eiBuildTermDefinition value = do
    EIEnv{..} <- ask
    defined <- gets eiStateDefined
    activeContext <- gets eiStateActiveContext
    let params p = p{btdParamsDefined = defined}
        localContext = fromMaybe mempty eiEnvLocalContext
    (activeContext', defined') <-
        buildTermDefinition activeContext localContext value params
            |> withEnvRES (const eiEnvGlobal)
            |> withStateRES eiStateGlobal (\ei global -> ei{eiStateGlobal = global})
    modify \s ->
        s
            { eiStateActiveContext = activeContext'
            , eiStateDefined = defined'
            }

eiInitLocalContext :: Monad m => Text -> EIT e m ()
eiInitLocalContext value =
    -- 3.
    asks eiEnvLocalContext >>= \case
        Just localContext | Just (String entry) <- KM.lookup (K.fromText value) localContext -> do
            defined <- gets eiStateDefined
            when (maybe True not (M.lookup entry defined)) <| eiBuildTermDefinition value
        _ -> pure ()

eiInitPropertyContext :: Monad m => Text -> Text -> Text -> EIT e m Text
eiInitPropertyContext prefix suffix value = do
    -- 6.3.
    defined <- gets eiStateDefined
    asks eiEnvLocalContext >>= \case
        Just localContext
            | KM.member (K.fromText prefix) localContext
            , M.lookup prefix defined /= Just True ->
                eiBuildTermDefinition prefix
        _ -> pure ()

    -- 6.4.
    gets (eiStateActiveContext .> lookupTerm prefix) >>= \case
        Just prefixDefiniton
            | Just iriMapping <- termDefinitionIriMapping prefixDefiniton
            , termDefinitionPrefixFlag prefixDefiniton ->
                pure <| iriMapping <> suffix
        _ -> pure value

eiExpandResult :: Monad m => Text -> EIT e m (Maybe Text)
eiExpandResult value = do
    EIEnv{..} <- ask
    activeContext <- gets eiStateActiveContext
    case activeContextVocabularyMapping activeContext of
        -- 7.
        Just vocabMapping | eiEnvVocab -> pure <. Just <| vocabMapping <> value
        -- 8.
        _
            | eiEnvDocumentRelative
            , baseIri <- serializeIRI <$> activeContextBaseIri activeContext
            , Right iri <- maybe (Right value) (`resolveIRI` value) baseIri ->
                pure <| Just iri
        -- 9.
        _ -> pure <| Just value

expandIri' :: Monad m => Text -> EIT e m (Maybe Text)
expandIri' value
    -- 1.
    | Just _ <- parseKeyword value = pure <| Just value
    -- 2.
    | isKeywordLike value = pure Nothing
    --
    | otherwise = do
        EIEnv{..} <- ask

        -- 3.
        eiInitLocalContext value

        gets (eiStateActiveContext .> lookupTerm value) >>= \case
            -- 4. 5.
            Just definition
                | Just iriMapping <- termDefinitionIriMapping definition
                , Just _ <- parseKeyword iriMapping ->
                    pure <| Just iriMapping
                | eiEnvVocab ->
                    pure <| termDefinitionIriMapping definition
            -- 6. 6.1.
            _
                | Just idx <- (+ 1) <$> T.findIndex (== ':') (T.drop 1 value)
                , prefix <- T.take idx value
                , suffix <- T.drop (idx + 1) value ->
                    -- 6.2.
                    if "_" `T.isPrefixOf` prefix || "//" `T.isPrefixOf` suffix
                        then pure <| Just value
                        else do
                            value' <- eiInitPropertyContext prefix suffix value

                            if isBlankIri value' || isRight (validateIRI value')
                                then pure <| Just value'
                                else eiExpandResult value'
            --
            _ -> eiExpandResult value

expandIri :: Monad m => ActiveContext -> Text -> (EIParams -> EIParams) -> JLDExpansionT e m (Maybe Text, ActiveContext, Map Text Bool)
expandIri activeContext value paramsFn = do
    (value', EIState{..}) <-
        (expandIri' value >>= \v -> gets (v,))
            |> withEnvRES env
            .> withStateRES st (const eiStateGlobal)
    pure (value', eiStateActiveContext, eiStateDefined)
  where
    EIParams{..} =
        paramsFn
            EIParams
                { eiParamsDocumentRelative = False
                , eiParamsVocab = False
                , eiParamsLocalContext = Nothing
                , eiParamsDefined = mempty
                }

    env options =
        EIEnv
            { eiEnvGlobal = options
            , eiEnvDocumentRelative = eiParamsDocumentRelative
            , eiEnvVocab = eiParamsVocab
            , eiEnvLocalContext = eiParamsLocalContext
            }

    st global =
        EIState
            { eiStateGlobal = global
            , eiStateDefined = eiParamsDefined
            , eiStateActiveContext = activeContext
            }

--

type BTDT e m = REST (BTDEnv e m) (Either (JLDError e) ()) BTDState m

data BTDEnv e m = BTDEnv
    { btdEnvGlobal :: JLDExpansionEnv e m
    , btdEnvLocalContext :: Object
    , btdEnvBaseUrl :: Maybe URI
    , btdEnvProtectedFlag :: Bool
    , btdEnvOverrideProtectedFlag :: Bool
    , btdEnvRemoteContexts :: Set Text
    }
    deriving (Show)

data BTDState = BTDState
    { btdStateGlobal :: JLDExpansionState
    , btdStateDefined :: Map Text Bool
    , btdStateTermDefinition :: TermDefinition
    , btdStateActiveContext :: ActiveContext
    }
    deriving (Show, Eq)

data BTDParams = BTDParams
    { btdParamsBaseUrl :: Maybe URI
    , btdParamsProtectedFlag :: Bool
    , btdParamsOverrideProtectedFlag :: Bool
    , btdParamsRemoteContexts :: Set Text
    , btdParamsDefined :: Map Text Bool
    , btdParamsTermDefinition :: TermDefinition
    }
    deriving (Show, Eq)

btdModifyActiveContext :: Monad m => (ActiveContext -> ActiveContext) -> BTDT e m ()
btdModifyActiveContext fn = modify \s -> s{btdStateActiveContext = fn (btdStateActiveContext s)}

btdModifyTermDefinition :: Monad m => (TermDefinition -> TermDefinition) -> BTDT e m ()
btdModifyTermDefinition fn = modify \s -> s{btdStateTermDefinition = fn (btdStateTermDefinition s)}

btdModifyDefined :: Monad m => (Map Text Bool -> Map Text Bool) -> BTDT e m ()
btdModifyDefined fn = modify \s -> s{btdStateDefined = fn (btdStateDefined s)}

btdValidateContainer :: JLDExpansionEnv e m -> Value -> Bool
btdValidateContainer _ Null = False
btdValidateContainer JLDExpansionEnv{..} value
    | JLD1_0 <- jldExpansionEnvProcessingMode = case value of
        String value' -> isNotKeyword value' [KeywordGraph, KeywordId, KeywordType]
        _ -> False
    | otherwise = case flattenSingletonArray value of
        String container' ->
            isKeyword
                container'
                [ KeywordGraph
                , KeywordId
                , KeywordIndex
                , KeywordLanguage
                , KeywordList
                , KeywordSet
                , KeywordType
                ]
        container@(Array (V.length -> len))
            | len > 3 ->
                False
            | valueContains (show KeywordGraph) container
            , valueContainsAny (show <$> [KeywordId, KeywordIndex]) container ->
                len == 2 || valueContains (show KeywordSet) container
            | len == 2
            , valueContains (show KeywordSet) container
            , valueContainsAny (show <$> [KeywordGraph, KeywordId, KeywordIndex, KeywordLanguage, KeywordType]) container ->
                True
        _ -> False

btdExpandIri :: Monad m => Text -> BTDT e m (Maybe Text)
btdExpandIri value = do
    BTDEnv{..} <- ask
    defined <- gets btdStateDefined
    activeContext <- gets btdStateActiveContext
    let params p =
            p
                { eiParamsLocalContext = Just btdEnvLocalContext
                , eiParamsVocab = True
                , eiParamsDefined = defined
                }
    (expanded, activeContext', defined') <-
        expandIri activeContext value params
            |> withEnvRES (const btdEnvGlobal)
            .> withErrorRES Left
            .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
    modify \s ->
        s
            { btdStateActiveContext = activeContext'
            , btdStateDefined = defined'
            }
    pure expanded

btdBuildTermDefinition :: Monad m => Text -> BTDT e m ()
btdBuildTermDefinition term = do
    BTDEnv{..} <- ask
    defined <- gets btdStateDefined
    activeContext <- gets btdStateActiveContext
    let params p = p{btdParamsDefined = defined}
    (activeContext', defined') <-
        buildTermDefinition activeContext btdEnvLocalContext term params
            |> withEnvRES (const btdEnvGlobal)
            .> withErrorRES Left
            .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
    modify \env ->
        env
            { btdStateActiveContext = activeContext'
            , btdStateDefined = defined'
            }

buildTermDefinition' :: Monad m => Text -> BTDT e m ()
buildTermDefinition' "" = throwError <| Left InvalidTermDefinition -- 2.
buildTermDefinition' term = do
    BTDEnv{..} <- ask
    let JLDExpansionEnv{..} = btdEnvGlobal

    -- 1.
    gets (btdStateDefined .> M.lookup term) >>= \case
        Just True -> throwError <| Right ()
        Just False -> throwError <| Left CyclicIriMapping
        Nothing -> pure ()

    -- 2.
    btdModifyDefined <| M.insert term False

    -- 3.
    let value = btdEnvLocalContext |> KM.lookup (K.fromText term) .> fromMaybe Null

    -- 4.
    case term of
        ((`isKeyword` [KeywordType]) -> True)
            | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left KeywordRedefinition
            | Object map' <- value ->
                if
                        | KM.size map' == 1
                        , Just container <- KM.lookup (show KeywordContainer) map' ->
                            when (container /= String (show KeywordSet)) <| throwError (Left KeywordRedefinition)
                        | KM.size map' == 2
                        , Just container <- KM.lookup (show KeywordContainer) map'
                        , KM.member (show KeywordProtected) map' ->
                            unless (valueContains (show KeywordSet) container) <| throwError (Left KeywordRedefinition)
                        | KM.size map' /= 1 || not (KM.member (show KeywordProtected) map') ->
                            throwError <| Left KeywordRedefinition
                        | otherwise -> pure ()
            | otherwise -> throwError <| Left KeywordRedefinition
        -- 5.
        (parseKeyword -> Just _) -> throwError <| Left KeywordRedefinition
        (isKeywordLike -> True) -> throwError <| Right ()
        _ -> pure ()

    -- 6.
    maybePreviousDefinition <- gets (btdStateActiveContext .> lookupTerm term)
    btdModifyActiveContext \ac -> ac{activeContextTerms = M.delete term (activeContextTerms ac)}

    -- 7. 8. 9.
    (valueObject, idValue, simpleTerm) <- case value of
        Null -> pure (mempty, Just Null, False)
        (String s) -> pure (mempty, Just (String s), True)
        (Object o) -> pure (o, KM.lookup (show KeywordId) o, False)
        _ -> throwError <| Left InvalidTermDefinition

    -- 10.
    btdModifyTermDefinition <| const (newTermDefinition btdEnvProtectedFlag id)

    -- 11.
    case KM.lookup (show KeywordProtected) valueObject of
        Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition
        Just (Bool protected) -> btdModifyTermDefinition \d -> d{termDefinitionProtectedFlag = protected}
        Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordProtected invalid
        Nothing -> pure ()

    -- 12.
    case KM.lookup (show KeywordType) valueObject of
        -- 12.2.
        Just (String type') ->
            btdExpandIri type' >>= \case
                Nothing -> throwError <| Left InvalidTypeMapping
                Just expandedType
                    -- 12.3.
                    | isKeyword expandedType [KeywordJson, KeywordNone]
                    , JLD1_0 <- jldExpansionEnvProcessingMode ->
                        throwError <| Left InvalidTypeMapping
                    -- 12.4.
                    | isNotKeyword expandedType [KeywordId, KeywordJson, KeywordNone, KeywordVocab]
                    , Left _ <- validateIRI expandedType ->
                        throwError <| Left InvalidTypeMapping
                    -- 12.5.
                    | otherwise ->
                        btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just expandedType}
        -- 12.1.
        Just _ -> throwError <| Left InvalidTypeMapping
        --
        Nothing -> pure ()

    -- 13.
    case KM.lookup (show KeywordReverse) valueObject of
        -- 13.1.
        Just _ | KM.member (show KeywordId) valueObject || KM.member (show KeywordNest) valueObject -> throwError <| Left InvalidReverseProperty
        Just (String (isKeywordLike -> True)) -> throwError <| Right ()
        -- 13.3.
        Just (String reverse') -> do
            -- 13.4.
            btdExpandIri reverse' >>= \case
                Just (validateIRI -> Right expandedReverse) ->
                    btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedReverse}
                _ -> throwError <| Left InvalidIriMapping

            -- 13.5.
            case KM.lookup (show KeywordContainer) valueObject of
                Just (String container) | isKeyword container [KeywordSet, KeywordIndex] -> do
                    btdModifyTermDefinition \d ->
                        d
                            { termDefinitionContainerMapping = S.insert container <| termDefinitionContainerMapping d
                            }
                Just Null -> pure ()
                Just _ -> throwError <| Left InvalidReverseProperty
                Nothing -> pure ()

            -- 13.6.
            btdModifyTermDefinition \d -> d{termDefinitionReversePropertyFlag = True}

            -- 13.7.
            definition <- gets btdStateTermDefinition
            btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition}
            btdModifyDefined <| M.insert term True

            throwError <| Right ()
        -- 13.2.
        Just _ -> throwError <| Left InvalidIriMapping
        --
        Nothing -> pure ()

    -- 14. 15. 16. 17. 18.
    maybeVocabMapping <- gets (btdStateActiveContext .> activeContextVocabularyMapping)
    if
            -- 14. 14.1.
            | Just idValue' <- idValue
            , idValue' /= String term -> case idValue' of
                Null -> pure ()
                String id'
                    -- 14.2.2.
                    | isNothing (parseKeyword id') && isKeywordLike id' -> throwError <| Right ()
                    | otherwise -> do
                        -- 14.2.3.
                        iriMapping <-
                            btdExpandIri id' >>= \case
                                Nothing -> throwError <| Left InvalidIriMapping
                                Just expandedId
                                    | isKeyword expandedId [KeywordContext] ->
                                        throwError <| Left InvalidKeywordAlias
                                    | Nothing <- parseKeyword expandedId
                                    , Left _ <- validateIRI expandedId
                                    , isBlankIri expandedId ->
                                        throwError <| Left InvalidIriMapping
                                    | otherwise ->
                                        expandedId <$ btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedId}

                        -- 14.2.4.
                        when (T.elem ':' (T.dropEnd 1 <. T.drop 1 <| term) || T.elem '/' term) do
                            -- 14.2.4.1
                            btdModifyDefined <| M.insert term True

                            -- 14.2.4.2.
                            expandedTerm <- btdExpandIri term
                            when (expandedTerm /= Just iriMapping) <| throwError (Left InvalidIriMapping)

                        -- 14.2.5.
                        definition <- gets btdStateTermDefinition
                        when (not <| termDefinitionPrefixFlag definition) do
                            let validIri = isRight <. validateIRI <. T.dropEnd 1 <| iriMapping
                            let prefix =
                                    not (T.elem ':' term || T.elem '/' term)
                                        && simpleTerm
                                        && ((endsWithGenericDelim iriMapping && validIri) || isBlankIri iriMapping)
                            btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix}
                -- 14.2.1.
                _ -> throwError <| Left InvalidIriMapping
            -- 15.
            | T.elem ':' (T.drop 1 term) -> do
                let maybeCompactIri = parseCompactIri term

                -- 15.1.
                case maybeCompactIri of
                    Just (CompactIRI prefix _) | KM.member (K.fromText prefix) btdEnvLocalContext -> do
                        btdBuildTermDefinition prefix
                    _ -> pure ()

                -- 15.2.
                activeContextTerms <- gets (btdStateActiveContext .> activeContextTerms)
                case maybeCompactIri of
                    Just (CompactIRI prefix suffix)
                        | Just term' <- M.lookup prefix activeContextTerms
                        , iriMapping <- (<> suffix) <$> termDefinitionIriMapping term' ->
                            btdModifyTermDefinition \d -> d{termDefinitionIriMapping = iriMapping}
                    -- 15.3.
                    _
                        | isRight (validateIRI term) || isBlankIri term ->
                            btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term}
                    _ -> pure ()
            -- 16.
            | T.elem '/' term ->
                btdExpandIri term >>= \case
                    Just expandedTerm -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just expandedTerm}
                    Nothing -> throwError <| Left InvalidIriMapping
            -- 17.
            | isKeyword term [KeywordType] -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just term}
            -- 18.
            | Just vocabMapping <- maybeVocabMapping -> btdModifyTermDefinition \d -> d{termDefinitionIriMapping = Just (vocabMapping <> term)}
            --
            | otherwise -> throwError <| Left InvalidIriMapping

    -- 19.
    case KM.lookup (show KeywordContainer) valueObject of
        Just container -> do
            when (not <| btdValidateContainer btdEnvGlobal container) <| throwError (Left InvalidContainerMapping)

            forM_ (valueToArray container) \case
                String item -> btdModifyTermDefinition \d -> d{termDefinitionContainerMapping = termDefinitionContainerMapping d |> S.insert item}
                _ -> pure ()

            definition <- gets btdStateTermDefinition
            when (S.member (show KeywordType) <| termDefinitionContainerMapping definition) do
                let typeMapping = termDefinitionTypeMapping definition |> fromMaybe (show KeywordId)
                btdModifyTermDefinition \d -> d{termDefinitionTypeMapping = Just typeMapping}
                when (isNotKeyword typeMapping [KeywordId, KeywordVocab]) do
                    throwError <| Left InvalidTypeMapping
        --
        Nothing -> pure ()

    -- 20.
    containerMapping <- gets (btdStateTermDefinition .> termDefinitionContainerMapping)
    case KM.lookup (show KeywordIndex) valueObject of
        -- 20.1.
        Just _ | jldExpansionEnvProcessingMode == JLD1_0 || S.notMember (show KeywordIndex) containerMapping -> throwError <| Left InvalidTermDefinition
        -- 20.2.
        Just (String index) ->
            btdExpandIri index >>= \case
                Just (validateIRI -> Right _) -> btdModifyTermDefinition \d -> d{termDefinitionIndexMapping = Just index}
                _ -> throwError <| Left InvalidTermDefinition
        Just _ -> throwError <| Left InvalidTermDefinition
        --
        Nothing -> pure ()

    -- 21.
    case KM.lookup (show KeywordContext) valueObject of
        -- 21.1.
        Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition
        -- 21.2.
        Just context -> do
            -- 21.3.
            activeContext <- gets btdStateActiveContext
            let params p =
                    p
                        { bacParamsOverrideProtected = True
                        , bacParamsRemoteContexts = btdEnvRemoteContexts
                        , bacParamsValidateScopedContext = False
                        }
            buildActiveContext activeContext context btdEnvBaseUrl params
                |> withEnvRES (const btdEnvGlobal)
                .> withStateRES btdStateGlobal (\btd global -> btd{btdStateGlobal = global})
                .> withErrorRES (const <| Left InvalidScopedContext)
                .> void

            -- 21.4.
            btdModifyTermDefinition \d ->
                d
                    { termDefinitionLocalContext = Just context
                    , termDefinitionBaseUrl = btdEnvBaseUrl
                    }
        --
        Nothing -> pure ()

    -- 22. 23.
    unless (KM.member (show KeywordType) valueObject) do
        -- 22.
        case KM.lookup (show KeywordLanguage) valueObject of
            Just Null -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just NoLanguage}
            Just (String language) -> btdModifyTermDefinition \d -> d{termDefinitionLanguageMapping = Just <. Language <| T.toLower language}
            Just _ -> throwError <| Left InvalidLanguageMapping
            Nothing -> pure ()

        -- 23.
        case KM.lookup (show KeywordDirection) valueObject of
            Just Null -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just NoDirection}
            Just (String "ltr") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just LTR}
            Just (String "rtl") -> btdModifyTermDefinition \d -> d{termDefinitionDirectionMapping = Just RTL}
            Just _ -> throwError <| Left InvalidBaseDirection
            Nothing -> pure ()

    -- 24.
    case KM.lookup (show KeywordNest) valueObject of
        -- 24.1.
        Just _ | JLD1_0 <- jldExpansionEnvProcessingMode -> throwError <| Left InvalidTermDefinition
        Just (String nest)
            | parseKeyword nest /= Just KeywordNest -> throwError <. Left <| InvalidKeywordValue KeywordNest (String nest)
            | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionNestValue = Just nest}
        Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordNest invalid
        Nothing -> pure ()

    -- 25.
    maybeIriMapping <- gets (btdStateTermDefinition .> termDefinitionIriMapping)
    case KM.lookup (show KeywordPrefix) valueObject of
        -- 25.1.
        Just _
            | jldExpansionEnvProcessingMode == JLD1_0 || T.elem ':' term || T.elem '/' term ->
                throwError <| Left InvalidTermDefinition
        Just (Bool prefix)
            | prefix, Just _ <- parseKeyword =<< maybeIriMapping -> throwError <| Left InvalidTermDefinition
            | otherwise -> btdModifyTermDefinition \d -> d{termDefinitionPrefixFlag = prefix}
        Just invalid -> throwError <. Left <| InvalidKeywordValue KeywordPrefix invalid
        Nothing -> pure ()

    -- 26.
    unless
        ( allKeywords
            (KM.keys valueObject <&> K.toText)
            [ KeywordId
            , KeywordReverse
            , KeywordContainer
            , KeywordContext
            , KeywordDirection
            , KeywordIndex
            , KeywordLanguage
            , KeywordNest
            , KeywordPrefix
            , KeywordProtected
            , KeywordType
            ]
        )
        do throwError <| Left InvalidTermDefinition

    -- 27.
    definition <- gets btdStateTermDefinition

    case maybePreviousDefinition of
        Just previousDefinition | not btdEnvOverrideProtectedFlag && termDefinitionProtectedFlag previousDefinition -> do
            -- 27.1.
            when (definition{termDefinitionProtectedFlag = True} /= previousDefinition) do
                throwError <| Left ProtectedTermRedefinition

            -- 27.2.
            btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term previousDefinition}
        --
        _ ->
            btdModifyActiveContext \ac -> ac{activeContextTerms = activeContextTerms ac |> M.insert term definition}

    btdModifyDefined <| M.insert term True

buildTermDefinition :: Monad m => ActiveContext -> Object -> Text -> (BTDParams -> BTDParams) -> JLDExpansionT e m (ActiveContext, Map Text Bool)
buildTermDefinition activeContext localContext term paramsFn = do
    BTDState{..} <-
        (buildTermDefinition' term >> get)
            |> withEnvRES env
            .> withErrorRES' (either throwError (const get))
            .> withStateRES st (const btdStateGlobal)
    pure (btdStateActiveContext, btdStateDefined)
  where
    BTDParams{..} =
        paramsFn
            BTDParams
                { btdParamsBaseUrl = Nothing
                , btdParamsProtectedFlag = False
                , btdParamsOverrideProtectedFlag = False
                , btdParamsRemoteContexts = mempty
                , btdParamsDefined = mempty
                , btdParamsTermDefinition = newTermDefinition False id
                }

    env options =
        BTDEnv
            { btdEnvGlobal = options
            , btdEnvLocalContext = localContext
            , btdEnvBaseUrl = btdParamsBaseUrl
            , btdEnvProtectedFlag = btdParamsProtectedFlag
            , btdEnvOverrideProtectedFlag = btdParamsOverrideProtectedFlag
            , btdEnvRemoteContexts = btdParamsRemoteContexts
            }

    st global =
        BTDState
            { btdStateGlobal = global
            , btdStateDefined = btdParamsDefined
            , btdStateTermDefinition = btdParamsTermDefinition
            , btdStateActiveContext = activeContext
            }