path: root/source/Felix/Parsed/Payload.hs

{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Canonical owner-independent raw parsed modules.
module Felix.Parsed.Payload
    ( CanonicalParsedPayload
    , canonicalParsedPayload
    , canonicalParsedPayloadFromBytes
    , canonicalParsedPayloadBytes
    , putCanonicalParsedPayloadCache
    , getCanonicalParsedPayloadCache
    , ParsedArtifact
    , parsedArtifact
    , parsedArtifactId
    , parsedArtifactPayload
    , DecodedParsedPayload
    , decodeCanonicalParsedPayload
    , decodedParsedImports
    , decodedParsedBlocks
    , decodedParsedOccurrences
    , decodedParsedSyntaxInterface
    ) where

import Base
import Felix.Cache.Codec
import Felix.Parsed.Identity qualified as Identity
import Felix.Source
import Felix.Report.Location
import Felix.Syntax.Abstract qualified as Raw
import Felix.Syntax.Interface
import Felix.Syntax.LexicalPhrase qualified as Phrase
import Felix.Syntax.Token qualified as Token

import Control.DeepSeq (NFData)
import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.ByteString qualified as ByteString
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text qualified as Text
import GHC.Generics qualified as Generic
import Numeric.Natural (Natural)


newtype CanonicalParsedPayload =
    CanonicalParsedPayload ByteString
    deriving stock (Eq, Ord, Generic)
    deriving anyclass (NFData)

instance Show CanonicalParsedPayload where
    show payload =
        "CanonicalParsedPayload <"
            <> show
                (ByteString.length
                    (canonicalParsedPayloadBytes payload))
            <> " bytes>"

canonicalParsedPayloadBytes
    :: CanonicalParsedPayload
    -> ByteString
canonicalParsedPayloadBytes
        (CanonicalParsedPayload bytes) =
    bytes

canonicalParsedPayloadFromBytes
    :: ByteString
    -> Either CacheDecodeError CanonicalParsedPayload
canonicalParsedPayloadFromBytes bytes =
    validateCanonicalParsedPayload
        (CanonicalParsedPayload bytes)

data ParsedArtifact = ParsedArtifact
    !Identity.ParsedModuleId
    !CanonicalParsedPayload
    deriving stock (Show, Eq, Generic)
    deriving anyclass (NFData)

parsedArtifact
    :: Identity.ParsedModuleKey
    -> CanonicalParsedPayload
    -> ParsedArtifact
parsedArtifact key payload =
    ParsedArtifact
        (Identity.parsedModuleId
            key
            (canonicalParsedPayloadBytes payload))
        payload

parsedArtifactId :: ParsedArtifact -> Identity.ParsedModuleId
parsedArtifactId (ParsedArtifact identity _payload) =
    identity

parsedArtifactPayload :: ParsedArtifact -> CanonicalParsedPayload
parsedArtifactPayload (ParsedArtifact _identity payload) =
    payload

data DecodedParsedPayload = DecodedParsedPayload
    ![ImportRef]
    ![Raw.Block]
    ![(Int, Location, Raw.Marker, CanonicalLexicalEntry)]
    !SyntaxInterfaceId

decodedParsedImports :: DecodedParsedPayload -> [ImportRef]
decodedParsedImports
        (DecodedParsedPayload imports _blocks _occurrences _syntax) =
    imports

decodedParsedBlocks :: DecodedParsedPayload -> [Raw.Block]
decodedParsedBlocks
        (DecodedParsedPayload _imports blocks _occurrences _syntax) =
    blocks

decodedParsedOccurrences
    :: DecodedParsedPayload
    -> [(Int, Location, Raw.Marker, CanonicalLexicalEntry)]
decodedParsedOccurrences
        (DecodedParsedPayload _imports _blocks occurrences _syntax) =
    occurrences

decodedParsedSyntaxInterface
    :: DecodedParsedPayload
    -> SyntaxInterfaceId
decodedParsedSyntaxInterface
        (DecodedParsedPayload _imports _blocks _occurrences syntax) =
    syntax

canonicalParsedPayload
    :: [ImportRef]
    -> [Raw.Block]
    -> [(Int, Location, Raw.Marker, CanonicalLexicalEntry)]
    -> SyntaxInterfaceId
    -> CanonicalParsedPayload
canonicalParsedPayload imports blocks occurrences syntax =
    CanonicalParsedPayload
        (encodeCache do
            putCacheTag 0x00
            putCacheList putParsedImport imports
            putCacheList putParsed blocks
            putCacheList putOccurrence occurrences
            putSyntaxInterfaceIdCache syntax)
  where
    putOccurrence (blockIndex, location, marker, entry) = do
        putCacheInteger (toInteger blockIndex)
        putParsed location
        putParsed marker
        putCanonicalLexicalEntryCache entry

decodeCanonicalParsedPayload
    :: FileId
    -> CanonicalParsedPayload
    -> Either CacheDecodeError DecodedParsedPayload
decodeCanonicalParsedPayload fileId payload =
    decodeCache
        (getDecodedParsedPayload fileId)
        (canonicalParsedPayloadBytes payload)

putCanonicalParsedPayloadCache
    :: CanonicalParsedPayload
    -> CachePut
putCanonicalParsedPayloadCache =
    putCacheBytes . canonicalParsedPayloadBytes

getCanonicalParsedPayloadCache
    :: CacheGet CanonicalParsedPayload
getCanonicalParsedPayloadCache = do
    bytes <- getCacheBytes
    case validateCanonicalParsedPayload
            (CanonicalParsedPayload bytes) of
        Left err ->
            fail ("invalid canonical parsed payload: " <> show err)
        Right payload ->
            pure payload

validateCanonicalParsedPayload
    :: CanonicalParsedPayload
    -> Either CacheDecodeError CanonicalParsedPayload
validateCanonicalParsedPayload payload = do
    decoded <- decodeCanonicalParsedPayload (FileId 0) payload
    let reencoded =
            canonicalParsedPayload
                (decodedParsedImports decoded)
                (decodedParsedBlocks decoded)
                (decodedParsedOccurrences decoded)
                (decodedParsedSyntaxInterface decoded)
    unless
        (reencoded == payload)
        (Left
            (CacheBinaryDecodeError
                "canonical parsed payload is not minimally encoded"))
    pure payload

getDecodedParsedPayload
    :: FileId
    -> CacheGet DecodedParsedPayload
getDecodedParsedPayload fileId = do
    getCacheTag >>= \case
        0x00 -> pure ()
        tag ->
            fail
                ("unknown canonical parsed payload tag "
                    <> show tag)
    imports <- getCacheList (getParsedImport fileId)
    blocks <- getCacheList (getParsed fileId)
    occurrences <- getCacheList (getOccurrence fileId)
    syntax <- getSyntaxInterfaceIdCache
    pure
        (DecodedParsedPayload
            imports
            blocks
            occurrences
            syntax)
  where
    getOccurrence currentFileId = do
        blockIndex <- getCacheInteger >>= checkedInt "block index"
        location <- getParsed currentFileId
        marker <- getParsed currentFileId
        entry <- getCanonicalLexicalEntryCache
        pure (blockIndex, location, marker, entry)

putParsedImport :: ImportRef -> CachePut
putParsedImport reference = do
    putCacheText
        (Text.pack
            (safeRelativePathFilePath
                (importPath reference)))
    putParsed (importLocation reference)

getParsedImport :: FileId -> CacheGet ImportRef
getParsedImport fileId = do
    path <- Text.unpack <$> getCacheText
    location <- getParsed fileId
    case importRef location path of
        Left err ->
            fail ("invalid parsed import path: " <> show err)
        Right reference ->
            pure reference


class ParsedCodec value where
    putParsed :: value -> CachePut
    default putParsed
        :: (Generic value, GenericPut (Generic.Rep value))
        => value
        -> CachePut
    putParsed = genericPut . Generic.from

    getParsed :: FileId -> CacheGet value
    default getParsed
        :: (Generic value, GenericGet (Generic.Rep value))
        => FileId
        -> CacheGet value
    getParsed fileId = Generic.to <$> genericGet fileId

class GenericPut representation where
    genericPut :: representation parameter -> CachePut

class GenericGet representation where
    genericGet
        :: FileId
        -> CacheGet (representation parameter)

instance GenericPut Generic.U1 where
    genericPut Generic.U1 = pure ()

instance GenericGet Generic.U1 where
    genericGet _fileId = pure Generic.U1

instance ParsedCodec value => GenericPut (Generic.K1 index value) where
    genericPut (Generic.K1 value) = putParsed value

instance ParsedCodec value => GenericGet (Generic.K1 index value) where
    genericGet fileId = Generic.K1 <$> getParsed fileId

instance GenericPut value => GenericPut (Generic.M1 index meta value) where
    genericPut (Generic.M1 value) = genericPut value

instance GenericGet value => GenericGet (Generic.M1 index meta value) where
    genericGet fileId = Generic.M1 <$> genericGet fileId

instance
    (GenericPut left, GenericPut right)
    => GenericPut (left Generic.:*: right) where
    genericPut (left Generic.:*: right) = do
        genericPut left
        genericPut right

instance
    (GenericGet left, GenericGet right)
    => GenericGet (left Generic.:*: right) where
    genericGet fileId =
        (Generic.:*:)
            <$> genericGet fileId
            <*> genericGet fileId

instance
    (GenericPut left, GenericPut right)
    => GenericPut (left Generic.:+: right) where
    genericPut = \case
        Generic.L1 left -> do
            putCacheTag 0x00
            genericPut left
        Generic.R1 right -> do
            putCacheTag 0x01
            genericPut right

instance
    (GenericGet left, GenericGet right)
    => GenericGet (left Generic.:+: right) where
    genericGet fileId =
        getCacheTag >>= \case
            0x00 -> Generic.L1 <$> genericGet fileId
            0x01 -> Generic.R1 <$> genericGet fileId
            tag ->
                fail ("unknown parsed generic sum tag " <> show tag)


instance ParsedCodec Text where
    putParsed = putCacheText
    getParsed _fileId = getCacheText

instance ParsedCodec Int where
    putParsed = putCacheInteger . toInteger
    getParsed _fileId = getCacheInteger >>= checkedInt "integer"

instance ParsedCodec Natural where
    putParsed = putCacheNatural
    getParsed _fileId = getCacheNatural

instance ParsedCodec value => ParsedCodec [value] where
    putParsed = putCacheList putParsed
    getParsed fileId = getCacheList (getParsed fileId)

instance ParsedCodec value => ParsedCodec (Maybe value) where
    putParsed = putCacheMaybe putParsed
    getParsed fileId = getCacheMaybe (getParsed fileId)

instance ParsedCodec value => ParsedCodec (NonEmpty value) where
    putParsed = putCacheList putParsed . toList
    getParsed fileId = do
        values <- getCacheList (getParsed fileId)
        case NonEmpty.nonEmpty values of
            Nothing -> fail "empty parsed nonempty sequence"
            Just nonempty -> pure nonempty

instance
    (ParsedCodec left, ParsedCodec right)
    => ParsedCodec (left, right)

instance ParsedCodec Location where
    putParsed location =
        case locFileId location of
            Nothing ->
                putCacheTag 0x00
            Just _fileId -> do
                putCacheTag 0x01
                putCacheNatural (fromIntegral (locLine location))
                putCacheNatural (fromIntegral (locColumn location))
    getParsed fileId =
        getCacheTag >>= \case
            0x00 ->
                pure Nowhere
            0x01 -> do
                line <- getCacheNatural
                    >>= checkedInt "source line" . toInteger
                column <- getCacheNatural
                    >>= checkedInt "source column" . toInteger
                case mkLocationChecked fileId line column of
                    Left err ->
                        fail ("invalid parsed source location: " <> show err)
                    Right location ->
                        pure location
            tag ->
                fail ("unknown parsed source location tag " <> show tag)

checkedInt :: String -> Integer -> CacheGet Int
checkedInt label supplied
    | supplied < toInteger (minBound :: Int)
        || supplied > toInteger (maxBound :: Int) =
        fail (label <> " is outside the Int range")
    | otherwise =
        pure (fromInteger supplied)


instance ParsedCodec Token.Token
instance ParsedCodec value => ParsedCodec (Phrase.SgPl value)

instance ParsedCodec Raw.VarSymbol
instance ParsedCodec Raw.Expr
instance ParsedCodec Raw.LexicalItem
instance ParsedCodec Raw.LexicalItemSgPl
instance ParsedCodec Raw.Associativity
instance ParsedCodec Raw.MixfixItem
instance ParsedCodec Raw.Pattern
instance ParsedCodec Raw.ParameterArity
instance ParsedCodec Raw.RelationSymbol
instance ParsedCodec Raw.StructSymbol where
    putParsed = putCacheText . Raw.unStructSymbol
    getParsed _fileId = Raw.StructSymbol <$> getCacheText
instance ParsedCodec Raw.Chain
instance ParsedCodec Raw.Relation
instance ParsedCodec Raw.Sign
instance ParsedCodec Raw.Formula
instance ParsedCodec Raw.PropositionalConstant
instance ParsedCodec Raw.PrefixPredicate
instance ParsedCodec Raw.Connective
instance ParsedCodec value => ParsedCodec (Raw.NounOf value)
instance
    (ParsedCodec value, ParsedCodec (term Raw.VarSymbol))
    => ParsedCodec (Raw.NounPhraseOf term value)
instance ParsedCodec (Raw.Nameless value)
instance ParsedCodec value => ParsedCodec (Raw.AdjLOf value)
instance ParsedCodec value => ParsedCodec (Raw.AdjROf value)
instance ParsedCodec value => ParsedCodec (Raw.AdjOf value)
instance ParsedCodec value => ParsedCodec (Raw.VerbOf value)
instance ParsedCodec value => ParsedCodec (Raw.FunOf value)
instance ParsedCodec value => ParsedCodec (Raw.VerbPhraseOf value)
instance ParsedCodec Raw.Quantifier
instance ParsedCodec Raw.QuantPhrase
instance ParsedCodec Raw.Term
instance ParsedCodec Raw.Stmt
instance ParsedCodec Raw.Bound
instance ParsedCodec Raw.Asm
instance ParsedCodec Raw.Axiom
instance ParsedCodec Raw.Claim
instance ParsedCodec Raw.DefnHead
instance ParsedCodec Raw.Defn
instance ParsedCodec Raw.CalcQuantifier
instance ParsedCodec Raw.Proof
instance ParsedCodec Raw.Justification
instance ParsedCodec Raw.Case
instance ParsedCodec Raw.Calc
instance ParsedCodec Raw.Abbreviation
instance ParsedCodec Raw.Datatype
instance ParsedCodec Raw.DatatypeClause
instance ParsedCodec Raw.Inductive
instance ParsedCodec Raw.IntroRule
instance ParsedCodec Raw.SymbolPattern
instance ParsedCodec Raw.Signature
instance ParsedCodec Raw.StructDefn
instance ParsedCodec Raw.Marker
instance ParsedCodec Raw.ClaimKind
instance ParsedCodec Raw.Block