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

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

import Data.JLD.Prelude

import Data.JLD (JLDError (InvalidKeywordValue), 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, runREST, withEnvRES, withStateRES)
import Data.JLD.Model.ActiveContext (ActiveContext (..))
import Data.JLD.Model.InverseContext (InverseContext)

import Control.Monad.Except (MonadError (..))
import Data.Aeson (Value (..))
import Data.Aeson.KeyMap qualified as KM (lookup, member, size)
import Data.JLD.Model.Direction (Direction (..))
import Data.JLD.Model.GraphObject (isGraphObject', isNotGraphObject, isNotGraphObject')
import Data.JLD.Model.Keyword (Keyword (..))
import Data.JLD.Model.Language (Language (..))
import Data.JLD.Model.ListObject (isListObject')
import Data.JLD.Model.ValueObject (isValueObject')
import Data.JLD.Util (valueToArray)
import Data.Set qualified as S
import Data.Text (toLower)
import Data.Text qualified as T (drop, findIndex, isPrefixOf, take)
import Data.Vector (Vector, (!?))
import Data.Vector qualified as V (cons, snoc)

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

data CIEnv = CIEnv
    { ciEnvGlobal :: JLDCompactionEnv
    , ciEnvActiveContext :: ActiveContext
    , 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
    { ciParamsActiveContext :: ActiveContext
    , 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}

compactIri4 :: Monad m => InverseContext -> Text -> CIT e m (Maybe Text)
compactIri4 inverseContext var = do
    CIEnv{..} <- ask
    let ActiveContext{..} = ciEnvActiveContext

    -- 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
                String idValue' -> pure ()
                _ -> throwError <| InvalidKeywordValue KeywordId idValue
        --
        _ -> pure ()

    --
    pure Nothing

compactIri' :: Monad m => Text -> CIT e m (Text, InverseContext)
compactIri' var = do
    CIEnv{..} <- ask

    -- 2. 3.
    let inverseContext = case activeContextInverseContext ciEnvActiveContext of
            Nothing -> buildInverseContext ciEnvActiveContext
            Just ic -> ic

    compactIri4 inverseContext var >>= \case
        Just var' -> pure (var', inverseContext)
        Nothing -> pure (var, inverseContext)

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

    env global =
        CIEnv
            { ciEnvGlobal = global
            , ciEnvActiveContext = ciParamsActiveContext
            , ciEnvValue = ciParamsValue
            , ciEnvVocab = ciParamsVocab
            , ciEnvReverse = ciParamsReverse
            }

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