path: root/src/Data/JLD/Compaction/IRI.hs

module Data.JLD.Compaction.IRI (compactIri) where

import Data.JLD.Prelude

import Data.JLD (JLDError (..), JLDVersion (JLD1_0))
import Data.JLD.Compaction.Global (JLDCompactionEnv (jldCompactionEnvProcessingMode), JLDCompactionT)
import Data.JLD.Compaction.InverseContext (buildInverseContext)
import Data.JLD.Control.Monad.RES (REST, evalREST, withEnvRES, withErrorRES, withErrorRES')
import Data.JLD.Model.ActiveContext (ActiveContext (..))
import Data.JLD.Model.InverseContext (InverseContext, selectTerm)

import Control.Monad.Except (MonadError (..))
import Data.Aeson (Value (..))
import Data.Aeson.KeyMap qualified as KM (lookup, member, size)
import Data.Foldable.WithIndex (FoldableWithIndex (..))
import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject')
import Data.JLD.Model.IRI (isBlankIri)
import Data.JLD.Model.Keyword (Keyword (..))
import Data.JLD.Model.Language (Language (..))
import Data.JLD.Model.ListObject (isListObject')
import Data.JLD.Model.TermDefinition (TermDefinition (termDefinitionIriMapping, termDefinitionPrefixFlag))
import Data.JLD.Model.ValueObject (isValueObject')
import Data.JLD.Util (valueToArray)
import Data.Map qualified as M (lookup, member)
import Data.RDF (IRIRef (..), Scheme (..), parseIRI, resolveIRI, serializeIRI)
import Data.Set qualified as S (insert)
import Data.Text (toLower)
import Data.Text qualified as T (drop, findIndex, isPrefixOf, length)
import Data.Vector (Vector, (!?))
import Data.Vector qualified as V (cons)

type CIT e m = REST CIEnv (Either (JLDError e) Text) CIState m

data CIEnv = CIEnv
    { ciEnvGlobal :: JLDCompactionEnv
    , ciEnvActiveContext :: ActiveContext
    , ciEnvInverseContext :: InverseContext
    , ciEnvValue :: Maybe Value
    , ciEnvVocab :: Bool
    , ciEnvReverse :: Bool
    }
    deriving (Show)

data CIState = CIState
    { ciStateContainers :: Set Text
    , ciStateTypeLanguage :: Keyword
    , ciStateTypeLanguageValue :: Text
    , ciStatePreferredValues :: Vector Text
    }
    deriving (Show, Eq)

data CIParams = CIParams
    { ciParamsInverseContext :: Maybe InverseContext
    , ciParamsValue :: Maybe Value
    , ciParamsVocab :: Bool
    , ciParamsReverse :: Bool
    }
    deriving (Show, Eq)

ciModifyContainers :: Monad m => (Set Text -> Set Text) -> CIT e m ()
ciModifyContainers fn = modify \s -> s{ciStateContainers = fn (ciStateContainers s)}

ciModifyPreferredValues :: Monad m => (Vector Text -> Vector Text) -> CIT e m ()
ciModifyPreferredValues fn = modify \s -> s{ciStatePreferredValues = fn (ciStatePreferredValues s)}

ciPutTypeLanguage :: Monad m => Keyword -> CIT e m ()
ciPutTypeLanguage v = modify \s -> s{ciStateTypeLanguage = v}

ciPutTypeLanguageValue :: Monad m => Text -> CIT e m ()
ciPutTypeLanguageValue v = modify \s -> s{ciStateTypeLanguageValue = v}

ciCompactIri :: Monad m => Text -> CIT e m Text
ciCompactIri var = do
    CIEnv{..} <- ask
    let params p =
            p
                { ciParamsInverseContext = Just ciEnvInverseContext
                , ciParamsVocab = True
                }
    (var', _) <-
        compactIri ciEnvActiveContext var params
            |> withEnvRES (const ciEnvGlobal)
            .> withErrorRES Left
    pure var'

compactIri' :: Monad m => Text -> CIT e m Text
compactIri' var = do
    CIEnv{..} <- ask
    let ActiveContext{..} = ciEnvActiveContext

    -- 4.
    when (M.member var ciEnvInverseContext) do
        -- 4.1.
        let defaultLanguage = case (activeContextDefaultLanguage, activeContextDefaultBaseDirection) of
                (Just (Language language), Just dir) -> language <> show dir
                (Nothing, Just dir) -> "_" <> show dir
                _ -> show KeywordNone

            -- 4.2.
            value = case ciEnvValue of
                Just v@(Object o) -> case KM.lookup (show KeywordPreserve) o of
                    Just Null -> Just v
                    Just preserve -> valueToArray preserve !? 0
                    _ -> Just v
                _ -> Nothing

        -- 4.5.
        case value of
            Just (Object o)
                | KM.member (show KeywordIndex) o && isNotGraphObject' o ->
                    ciModifyContainers
                        <| S.insert (show KeywordIndex)
                        .> S.insert (show KeywordIndex <> show KeywordSet)
            _ -> pure ()

        case value of
            -- 4.6.
            _ | ciEnvReverse -> do
                ciPutTypeLanguage KeywordType
                ciPutTypeLanguageValue <| show KeywordReverse
            --
            Just (Object o)
                -- 4.7.
                | isListObject' o
                , Just (Array list) <- KM.lookup (show KeywordList) o -> do
                    -- 4.7.1.
                    unless (KM.member (show KeywordIndex) o) <| ciModifyContainers (S.insert (show KeywordList))

                    -- 4.7.4.
                    let go (commonType, commonLanguage) item
                            -- 4.7.4.8.
                            | commonLanguage == Just (show KeywordNone)
                            , commonType == Just (show KeywordNone) =
                                (commonType, commonLanguage)
                            --
                            | otherwise = (Just commonType', Just commonLanguage')
                          where
                            (itemLanguage, itemType) = case item of
                                Object objectItem
                                    | KM.member (show KeywordValue) objectItem ->
                                        if
                                                -- 4.7.4.2.1.
                                                | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem
                                                , Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem ->
                                                    (toLower lang <> "_" <> toLower dir, show KeywordId)
                                                | Just (String dir) <- KM.lookup (show KeywordDirection) objectItem ->
                                                    ("_" <> toLower dir, show KeywordId)
                                                -- 4.7.4.2.2.
                                                | Just (String lang) <- KM.lookup (show KeywordLanguage) objectItem ->
                                                    (toLower lang, show KeywordId)
                                                -- 4.7.4.2.3.
                                                | Just (String type') <- KM.lookup (show KeywordType) objectItem ->
                                                    (show KeywordNone, type')
                                                -- 4.7.4.2.4.
                                                | otherwise ->
                                                    (show KeywordNone, show KeywordId)
                                -- 4.7.4.2.4.
                                _ -> (show KeywordNone, show KeywordId)

                            commonLanguage' = case commonLanguage of
                                -- 4.7.4.4.
                                Nothing -> itemLanguage
                                -- 4.7.4.5.
                                Just lang
                                    | itemLanguage /= lang
                                    , Object itemObject <- item
                                    , KM.member (show KeywordValue) itemObject ->
                                        show KeywordNone
                                    | otherwise -> lang

                            commonType' = case commonType of
                                Nothing -> itemType
                                Just it
                                    | itemType /= it -> show KeywordNone
                                    | otherwise -> it

                        -- 4.7.3. 4.7.5. 4.7.6.
                        (commonType'', commonLanguage'') =
                            list
                                |> foldl' go (Nothing, if null list then Just defaultLanguage else Nothing)
                                .> bimap (fromMaybe (show KeywordNone)) (fromMaybe (show KeywordNone))

                    -- 4.7.7.
                    if commonType'' /= show KeywordNone
                        then do
                            ciPutTypeLanguage KeywordType
                            ciPutTypeLanguageValue (show commonType'')
                        else -- 4.7.8.
                            ciPutTypeLanguageValue (show commonLanguage'')
                -- 4.8.
                | isGraphObject' o -> do
                    -- 4.8.1.
                    when (KM.member (show KeywordIndex) o) do
                        ciModifyContainers
                            <| S.insert (show KeywordGraph <> show KeywordIndex)
                            .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet)
                    -- 4.8.2.
                    when (KM.member (show KeywordId) o) do
                        ciModifyContainers
                            <| S.insert (show KeywordGraph <> show KeywordId)
                            .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet)
                    -- 4.8.3.
                    ciModifyContainers
                        <| S.insert (show KeywordGraph)
                        .> S.insert (show KeywordGraph <> show KeywordSet)
                        .> S.insert (show KeywordSet)
                    -- 4.8.4.
                    unless (KM.member (show KeywordIndex) o) do
                        ciModifyContainers
                            <| S.insert (show KeywordGraph <> show KeywordIndex)
                            .> S.insert (show KeywordGraph <> show KeywordIndex <> show KeywordSet)
                    -- 4.8.5.
                    unless (KM.member (show KeywordId) o) do
                        ciModifyContainers
                            <| S.insert (show KeywordGraph <> show KeywordId)
                            .> S.insert (show KeywordGraph <> show KeywordId <> show KeywordSet)
                    -- 4.8.6.
                    ciModifyContainers
                        <| S.insert (show KeywordIndex)
                        .> S.insert (show KeywordIndex <> show KeywordSet)
                    -- 4.8.7.
                    ciPutTypeLanguage KeywordType
                    ciPutTypeLanguageValue (show KeywordId)
                -- 4.9. 4.9.1.
                | isValueObject' o -> do
                    if
                            -- 4.9.1.1.
                            | Just (String dir) <- KM.lookup (show KeywordDirection) o
                            , Just (String lang) <- KM.lookup (show KeywordLanguage) o
                            , not (KM.member (show KeywordIndex) o) -> do
                                ciPutTypeLanguageValue (toLower lang <> "_" <> toLower dir)
                                ciModifyContainers
                                    <| S.insert (show KeywordLanguage)
                                    .> S.insert (show KeywordLanguage <> show KeywordSet)
                            | Just (String dir) <- KM.lookup (show KeywordDirection) o
                            , not (KM.member (show KeywordIndex) o) -> do
                                ciPutTypeLanguageValue ("_" <> toLower dir)
                                ciModifyContainers
                                    <| S.insert (show KeywordLanguage)
                                    .> S.insert (show KeywordLanguage <> show KeywordSet)
                            -- 4.9.1.2.
                            | Just (String lang) <- KM.lookup (show KeywordLanguage) o
                            , not (KM.member (show KeywordIndex) o) -> do
                                ciPutTypeLanguageValue (toLower lang)
                                ciModifyContainers
                                    <| S.insert (show KeywordLanguage)
                                    .> S.insert (show KeywordLanguage <> show KeywordSet)
                            -- 4.9.1.3.
                            | Just (String type') <- KM.lookup (show KeywordType) o -> do
                                ciPutTypeLanguage KeywordType
                                ciPutTypeLanguageValue type'
                            --
                            | otherwise -> pure ()
                    -- 4.9.3.
                    ciModifyContainers <| S.insert (show KeywordSet)
            -- 4.9.2.
            _ -> do
                ciPutTypeLanguage KeywordType
                ciPutTypeLanguageValue (show KeywordId)
                -- 4.9.3.
                ciModifyContainers
                    <| S.insert (show KeywordId)
                    .> S.insert (show KeywordId <> show KeywordSet)
                    .> S.insert (show KeywordType)
                    .> S.insert (show KeywordSet <> show KeywordType)
                    .> S.insert (show KeywordSet)

        -- 4.10.
        ciModifyContainers <| S.insert (show KeywordNone)

        -- 4.11.
        case value of
            Just (Object o)
                | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0
                , not (KM.member (show KeywordIndex) o) ->
                    ciModifyContainers
                        <| S.insert (show KeywordIndex)
                        .> S.insert (show KeywordIndex <> show KeywordSet)
            _
                | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0 ->
                    ciModifyContainers
                        <| S.insert (show KeywordIndex)
                        .> S.insert (show KeywordIndex <> show KeywordSet)
                --
                | otherwise -> pure ()

        -- 4.12.
        case value of
            Just (Object o)
                | jldCompactionEnvProcessingMode ciEnvGlobal /= JLD1_0
                , KM.member (show KeywordIndex) o
                , KM.size o == 1 ->
                    ciModifyContainers
                        <| S.insert (show KeywordLanguage)
                        .> S.insert (show KeywordLanguage <> show KeywordSet)
            --
            _ -> pure ()

        -- 4.15.
        typeLanguageValue <- gets ciStateTypeLanguageValue
        when (typeLanguageValue == show KeywordReverse) <| ciModifyPreferredValues (V.cons (show KeywordReverse))

        -- 4.16.
        case value of
            Just (Object o)
                | typeLanguageValue == show KeywordReverse || typeLanguageValue == show KeywordId
                , Just idValue <- KM.lookup (show KeywordId) o -> case idValue of
                    -- 4.16.1.
                    String idValue' -> do
                        compactedIdValue <- ciCompactIri idValue'
                        case M.lookup compactedIdValue activeContextTerms of
                            Just term
                                | termDefinitionIriMapping term == Just idValue' ->
                                    ciModifyPreferredValues
                                        <| V.cons (show KeywordVocab)
                                        .> V.cons (show KeywordId)
                            -- 4.16.2.
                            _ ->
                                ciModifyPreferredValues
                                    <| V.cons (show KeywordId)
                                    .> V.cons (show KeywordVocab)
                        ciModifyPreferredValues <| V.cons (show KeywordNone)
                    --
                    _ -> throwError <. Left <| InvalidKeywordValue KeywordId idValue
                -- 4.17.
                | Just (Array a) <- KM.lookup (show KeywordList) o
                , null a -> do
                    ciModifyPreferredValues
                        <| V.cons typeLanguageValue
                        .> V.cons (show KeywordNone)
                    ciPutTypeLanguage KeywordAny
            _ -> do
                ciModifyPreferredValues
                    <| V.cons typeLanguageValue
                    .> V.cons (show KeywordNone)

        -- 4.18.
        ciModifyPreferredValues <| V.cons (show KeywordAny)

        -- 4.19.
        gets ciStatePreferredValues >>= mapM_ \preferredValue -> case T.findIndex (== ':') preferredValue of
            Just idx -> ciModifyPreferredValues <| V.cons (T.drop idx preferredValue)
            Nothing -> pure ()

        -- 4.20.
        maybeTerm <-
            liftA3
                (\containers typeLanguage preferredValues -> selectTerm var containers typeLanguage preferredValues ciEnvInverseContext)
                (gets ciStateContainers)
                (gets ciStateTypeLanguage)
                (gets ciStatePreferredValues)

        -- 4.21.
        case maybeTerm of
            Just term -> throwError <| Right term
            Nothing -> pure ()

    -- 5.
    case activeContextVocabularyMapping of
        Just vocabMapping
            | ciEnvVocab && T.isPrefixOf vocabMapping var && T.length var > T.length vocabMapping
            , suffix <- T.drop (T.length vocabMapping) var
            , not (M.member suffix activeContextTerms) ->
                throwError <| Right suffix
        _ -> pure ()

    -- 6. 7.
    let go key ci term = case termDefinitionIriMapping term of
            -- 7.1.
            Nothing -> ci
            Just iriMapping
                | var == iriMapping || not (T.isPrefixOf iriMapping var) || not (termDefinitionPrefixFlag term) -> ci
                -- 7.3.
                | (maybe True (ciCandidate <) ci && not (M.member ciCandidate activeContextTerms))
                    || (M.lookup ciCandidate activeContextTerms >>= termDefinitionIriMapping) == Just var && maybe True (== Null) ciEnvValue ->
                    Just ciCandidate
                --
                | otherwise -> ci
              where
                -- 7.2.
                ciCandidate = key <> ":" <> T.drop (T.length iriMapping) var

    -- 8.
    case ifoldl' go Nothing activeContextTerms of
        Just ci -> throwError <| Right ci
        Nothing -> pure ()

    -- 9.
    case parseIRI var of
        Right (IRIRef (Just (Scheme scheme)) Nothing _ _ _)
            | Just term <- M.lookup scheme activeContextTerms
            , termDefinitionPrefixFlag term ->
                throwError <| Left IRIConfusedWithPrefix
        _ -> pure ()

    -- 10.
    case activeContextBaseIri of
        -- 11.
        _ -> pure var

compactIri :: Monad m => ActiveContext -> Text -> (CIParams -> CIParams) -> JLDCompactionT e m (Text, InverseContext)
compactIri activeContext var paramsFn = do
    env' <- asks env
    result <-
        compactIri' var
            |> withErrorRES' (either throwError pure)
            .> evalREST env' st
    case result of
        Left err -> throwError err
        Right res -> pure (res, ciEnvInverseContext env')
  where
    CIParams{..} =
        paramsFn
            CIParams
                { ciParamsInverseContext = Nothing
                , ciParamsValue = Nothing
                , ciParamsVocab = False
                , ciParamsReverse = False
                }

    env global =
        CIEnv
            { ciEnvGlobal = global
            , ciEnvActiveContext = activeContext
            , ciEnvInverseContext = fromMaybe (buildInverseContext activeContext) ciParamsInverseContext
            , ciEnvValue = ciParamsValue
            , ciEnvVocab = ciParamsVocab
            , ciEnvReverse = ciParamsReverse
            }

    st =
        CIState
            { ciStateContainers = mempty
            , ciStateTypeLanguage = KeywordLanguage
            , ciStateTypeLanguageValue = show KeywordNull
            , ciStatePreferredValues = mempty
            }