{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | Durable logical module owners, independent of invocation-local mount IDs.
module Felix.Module
    ( SourceNamespaceId
    , sourceNamespaceId
    , sourceNamespaceIdFromDigest
    , sourceNamespaceDigest
    , ModuleName
    , moduleName
    , moduleNameFromParts
    , moduleNameNamespace
    , moduleNameRelativePath
    , preludeModuleName
    , encodeAbsoluteSourceRoot
    , encodeSafeRelativePath
    , encodeModuleName
    , LocalDeclarationOrdinal
    , localDeclarationOrdinal
    , localDeclarationOrdinalValue
    , LocalFactOrdinal
    , localFactOrdinal
    , localFactOrdinalValue
    , GeneratedObjectSlot
    , generatedObjectSlot
    , generatedObjectSlotValue
    , DeclarationFamilyTag(..)
    , encodeDeclarationFamilyTag
    ) where

import Base
import Felix.Math.Codec
import Felix.Source

import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.Text qualified as Text
import Numeric.Natural (Natural)
import System.FilePath.Posix qualified as Posix


newtype SourceNamespaceId =
    SourceNamespaceId MathematicalDigest
    deriving stock (Show, Eq, Ord)

sourceNamespaceId :: CanonicalPath -> SourceNamespaceId
sourceNamespaceId root =
    SourceNamespaceId
        (codecInvariant
            (hashCanonicalFields
                "felix-source-namespace-v1"
                [encodeAbsoluteSourceRoot root]))

sourceNamespaceIdFromDigest
    :: MathematicalDigest
    -> SourceNamespaceId
sourceNamespaceIdFromDigest =
    SourceNamespaceId

sourceNamespaceDigest :: SourceNamespaceId -> MathematicalDigest
sourceNamespaceDigest (SourceNamespaceId digest) =
    digest

data ModuleName = ModuleName
    !SourceNamespaceId
    !SafeRelativePath
    deriving stock (Show, Eq, Ord)

moduleName :: ResolvedSourceAddress -> ModuleName
moduleName address =
    ModuleName
        (sourceNamespaceId (sourceAddressRoot address))
        (sourceAddressRelativePath address)

moduleNameFromParts
    :: SourceNamespaceId
    -> SafeRelativePath
    -> ModuleName
moduleNameFromParts =
    ModuleName

moduleNameNamespace :: ModuleName -> SourceNamespaceId
moduleNameNamespace (ModuleName namespace _relativePath) =
    namespace

moduleNameRelativePath :: ModuleName -> SafeRelativePath
moduleNameRelativePath (ModuleName _namespace relativePath) =
    relativePath

preludeModuleName :: ModuleName
preludeModuleName =
    ModuleName
        reservedPreludeNamespace
        (case safeRelativePath "prelude" of
            Right relative -> relative
            Left err ->
                impossible
                    ("invalid reserved prelude path: " <> show err))
  where
    reservedPreludeNamespace =
        SourceNamespaceId
            (codecInvariant
                (hashCanonicalFields
                    "felix-reserved-prelude-namespace-v1"
                    []))

encodeAbsoluteSourceRoot :: CanonicalPath -> ByteString
encodeAbsoluteSourceRoot root =
    encodePath
        "felix-absolute-source-root-path-v1"
        components
  where
    path =
        Posix.dropTrailingPathSeparator
            (canonicalPathFilePath root)
    components =
        case Posix.splitDirectories path of
            [] ->
                []
            rootComponent : rest
                | endsInPathSeparator rootComponent ->
                        rest
                | otherwise ->
                    impossible
                        "canonical source root is not absolute"

    endsInPathSeparator component =
        case reverse component of
            character : _ ->
                Posix.isPathSeparator character
            [] ->
                False

encodeSafeRelativePath :: SafeRelativePath -> ByteString
encodeSafeRelativePath relative =
    encodePath
        "felix-safe-relative-path-v1"
        (splitComponents
            (safeRelativePathFilePath relative))

encodeModuleName :: ModuleName -> ByteString
encodeModuleName (ModuleName namespace relative) =
    mathematicalDigestBytes (sourceNamespaceDigest namespace)
        <> encodeSafeRelativePath relative

encodePath :: Text -> [FilePath] -> ByteString
encodePath domain components =
    codecInvariant
        (encodeCanonicalPathRecord
            domain
            (Text.pack <$> components))

splitComponents :: FilePath -> [FilePath]
splitComponents path =
    case break (== '/') path of
        (component, []) ->
            [component]
        (component, _slash : rest) ->
            component : splitComponents rest


newtype LocalDeclarationOrdinal =
    LocalDeclarationOrdinal Natural
    deriving stock (Show, Eq, Ord)

localDeclarationOrdinal
    :: Natural
    -> LocalDeclarationOrdinal
localDeclarationOrdinal =
    LocalDeclarationOrdinal

localDeclarationOrdinalValue
    :: LocalDeclarationOrdinal
    -> Natural
localDeclarationOrdinalValue
        (LocalDeclarationOrdinal ordinal) =
    ordinal

newtype LocalFactOrdinal =
    LocalFactOrdinal Natural
    deriving stock (Show, Eq, Ord)

localFactOrdinal :: Natural -> LocalFactOrdinal
localFactOrdinal =
    LocalFactOrdinal

localFactOrdinalValue :: LocalFactOrdinal -> Natural
localFactOrdinalValue (LocalFactOrdinal ordinal) =
    ordinal

newtype GeneratedObjectSlot =
    GeneratedObjectSlot Natural
    deriving stock (Show, Eq, Ord)

generatedObjectSlot :: Natural -> GeneratedObjectSlot
generatedObjectSlot =
    GeneratedObjectSlot

generatedObjectSlotValue :: GeneratedObjectSlot -> Natural
generatedObjectSlotValue (GeneratedObjectSlot slot) =
    slot

data DeclarationFamilyTag
    = SignatureDeclaration
    | StructureDeclaration
    | DatatypeDeclaration
    | InductiveDeclaration
    deriving stock (Show, Eq, Ord, Enum, Bounded)

encodeDeclarationFamilyTag :: DeclarationFamilyTag -> ByteString
encodeDeclarationFamilyTag =
    ByteString.singleton . \case
        SignatureDeclaration ->
            0x00
        StructureDeclaration ->
            0x01
        DatatypeDeclaration ->
            0x02
        InductiveDeclaration ->
            0x03

codecInvariant
    :: Either MathematicalCodecError value
    -> value
codecInvariant =
    either
        (impossible . ("canonical codec invariant: " <>) . show)
        id