ScaffoldRecord.hs

{- | Versioned persistence for the files and mapped consumer identities used by
one successful scaffold run. Unknown header fields are ignored so v1 readers
can consume records extended by later tool versions. Mapping rows are canonical
single-line JSON after a @mapping @ prefix; old readers ignore that row kind.
-}
module Keiro.Dsl.ScaffoldRecord (
    ScaffoldRecord (..),
    renderRecord,
    parseRecord,
    recordFileName,
) where

import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as BL
import Data.List (nub)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding qualified as Text
import Keiro.Dsl.ExplainBindings (BindingHole (..))
import Keiro.Dsl.MappedConsumer (MappingIdentity (..))
import Keiro.Dsl.Scaffold (ModuleKind (..))
import System.FilePath (isAbsolute, splitDirectories)

data ScaffoldRecord = ScaffoldRecord
    { recSpecPath :: !Text
    , recModuleRoot :: !Text
    , recLayout :: !Text
    , recFiles :: ![(ModuleKind, FilePath)]
    , recMappings :: ![MappingIdentity]
    , recBindingObligations :: ![BindingHole]
    }
    deriving stock (Eq, Show)

renderRecord :: ScaffoldRecord -> Text
renderRecord record =
    T.unlines $
        [ "keiro-dsl scaffold record v1"
        , "spec: " <> recSpecPath record
        , "module-root: " <> rootLabel
        , "layout: " <> recLayout record
        ]
            <> map renderFile (recFiles record)
            <> map renderMapping (recMappings record)
            <> map renderBindingObligation (recBindingObligations record)
  where
    rootLabel = if T.null (recModuleRoot record) then "(none)" else recModuleRoot record
    renderFile (Generated, path) = "generated " <> T.pack path
    renderFile (HoleStub, path) = "hole " <> T.pack path
    renderMapping mapping =
        "mapping " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode mapping))
    renderBindingObligation obligation =
        "binding " <> Text.decodeUtf8 (BL.toStrict (Aeson.encode obligation))

{- | Parse a v1 record. The version header and the three required fields must
be present exactly once. Unknown lines are ignored for forward compatibility;
unsafe file paths are rejected rather than joined to a scaffold output root.
-}
parseRecord :: Text -> Maybe ScaffoldRecord
parseRecord contents = case T.lines contents of
    header : rows
        | header == "keiro-dsl scaffold record v1" -> do
            specPath <- exactlyOne "spec: " rows
            rootLabel <- exactlyOne "module-root: " rows
            layout <- exactlyOne "layout: " rows
            files <- traverse parseFile (filter isFileRow rows)
            mappings <- traverse parseMapping (filter ("mapping " `T.isPrefixOf`) rows)
            bindingEntries <- traverse parseBindingObligation (filter ("binding " `T.isPrefixOf`) rows)
            if hasDuplicateMappingNames mappings || hasDuplicateBindingObligations bindingEntries
                then Nothing
                else
                    pure
                        ScaffoldRecord
                            { recSpecPath = specPath
                            , recModuleRoot = if rootLabel == "(none)" then "" else rootLabel
                            , recLayout = layout
                            , recFiles = files
                            , recMappings = mappings
                            , recBindingObligations = bindingEntries
                            }
    _ -> Nothing
  where
    exactlyOne prefix rows = case [value | row <- rows, Just value <- [T.stripPrefix prefix row]] of
        [value] -> Just value
        _ -> Nothing
    isFileRow row = "generated " `T.isPrefixOf` row || "hole " `T.isPrefixOf` row
    parseFile row
        | Just path <- T.stripPrefix "generated " row = checkedFile Generated path
        | Just path <- T.stripPrefix "hole " row = checkedFile HoleStub path
        | otherwise = Nothing
    checkedFile fileKind pathText =
        let path = T.unpack pathText
         in if null path || isAbsolute path || ".." `elem` splitDirectories path
                then Nothing
                else Just (fileKind, path)
    parseMapping row = do
        payload <- T.stripPrefix "mapping " row
        Aeson.decodeStrict' (Text.encodeUtf8 payload)
    parseBindingObligation row = do
        payload <- T.stripPrefix "binding " row
        Aeson.decodeStrict' (Text.encodeUtf8 payload)
    hasDuplicateMappingNames mappings =
        let names = map mappingSpecName mappings
         in length names /= length (nub names)
    hasDuplicateBindingObligations obligations =
        let keys = map bindingKey obligations
         in length keys /= length (nub keys)
    bindingKey hole =
        ( holeMappedName hole
        , holeModule hole
        , holeSymbol hole
        , holeKind hole
        , holePath hole
        )

recordFileName :: Text -> FilePath
recordFileName context = "keiro-dsl-scaffold-record." <> T.unpack context <> ".txt"