keiro-dsl-0.7.0.0: src/Keiro/Dsl/Workspace.hs
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Service workspaces: several complete @.keiro@ member files validated,
-- scaffolded, and diffed as __one service contract__.
--
-- A /workspace manifest/ is a @.keiro-workspace@ file that names the service and
-- lists its member @.keiro@ files. It is deliberately a file rather than repeated
-- CLI flags: @keiro-dsl diff --since \<rev\>@ must be able to reconstruct the
-- member set as it existed at an older git revision from git alone, and the
-- scaffold record needs one durable identity that outlives member renames.
--
-- The manifest is line-oriented in the spirit of the member grammar: @#@ starts a
-- comment, blank lines are insignificant, and clause keywords drive structure.
--
-- @
-- # The demo-project service workspace.
-- service demo-project
-- module Demo.Modules.Project
-- layout collocated
-- spec domain/project-artifact.keiro
-- spec domain/project.keiro
-- spec domain/shared.keiro
-- @
--
-- Membership is a __set__: 'parseWorkspaceManifest' accepts @spec@ lines in any
-- order and canonically sorts them (codepoint order on the normalized relative
-- path), and 'renderWorkspaceManifest' always emits that canonical order. Source
-- order therefore never changes meaning or generated bytes.
--
-- This module owns the workspace file format only; the member @.keiro@ grammar in
-- "Keiro.Dsl.Parser" is untouched. Note the unrelated "Keiro.Dsl.Manifest", which
-- is the /scaffold build manifest/ (the record of emitted modules) — every
-- identifier here carries a @Workspace@ prefix to keep the two apart.
module Keiro.Dsl.Workspace
( -- * The workspace manifest
WorkspaceManifest (..),
WorkspaceMemberRef (..),
parseWorkspaceManifest,
renderWorkspaceManifest,
-- * Input dispatch
workspaceExtension,
isWorkspacePath,
-- * Member paths
normalizeMemberPath,
-- * Loading members
ContentSource (..),
fileContentSource,
loadWorkspace,
-- * The composed service graph
WorkspaceSpec (..),
WorkspaceMember (..),
OwnershipIndex (..),
declarationOwner,
nodeOwner,
LineMap (..),
resolveWorkspaceLine,
composeWorkspace,
oneMemberWorkspace,
oneMemberParsedWorkspace,
checkedWorkspace,
checkWorkspace,
-- * Multi-file diagnostics
WorkspaceDiagnostic (..),
WorkspaceLocation (..),
WorkspaceFile (..),
WorkspaceFailure (..),
renderWorkspaceDiagnostic,
renderWorkspaceFailure,
workspaceDisplayPath,
-- * Line relocation
relocateLocs,
collectLocs,
)
where
import Control.Exception qualified as Exception
import Data.Bifunctor (first)
import Data.Char (isAscii, isDigit, isLetter, toLower)
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.List (nub, sort, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Void (Void)
import GHC.Generics
import Keiro.Dsl.Grammar
import Keiro.Dsl.LanguageVersion (ParsedSource (..), SourceLanguage (..), SourceLanguageDiagnostic, effectiveLanguageVersion, languageVersionText)
import Keiro.Dsl.Parser (ParseError, ParseFailure (..), parseSource, renderParseFailure)
import Keiro.Dsl.Scaffold (Context (..))
import Keiro.Dsl.ScaffoldRun (Refusal (..), planServiceScaffoldWithGoldens)
import Keiro.Dsl.SemanticContract (CheckedService (..), EffectiveLanguageContract, checkedSource, effectiveLanguageContract)
import Keiro.Dsl.Validate (Diagnostic (..), DiagnosticCode (..), Severity (..), nodeIdentity, validateService)
import System.Directory (doesFileExist)
import System.FilePath (takeBaseName, takeDirectory, takeFileName, (</>))
import Text.Megaparsec hiding (ParseError)
import Text.Megaparsec.Char (char, space1)
import Text.Megaparsec.Char.Lexer qualified as L
import Text.Read (readMaybe)
-- | A parsed workspace manifest. Members are held in canonical order
-- (codepoint-sorted normalized paths), so two manifests that list the same
-- members in different source orders are 'Eq'-equal and render to identical
-- bytes.
--
-- Unlike 'Keiro.Dsl.Grammar.Spec', which records no location for its
-- @context@\/@module@\/@layout@ clauses, this type keeps a 'Loc' per clause: the
-- workspace composer needs to cite a manifest clause line when a member
-- contradicts it.
data WorkspaceManifest = WorkspaceManifest
{ -- | The stable workspace identity, e.g. @demo-project@.
wmfService :: !Text,
wmfServiceLoc :: !Loc,
-- | The optional @module@ clause: the workspace's module-root authority.
wmfModuleRoot :: !(Maybe Text),
-- | Meaningful only when 'wmfModuleRoot' is 'Just'.
wmfModuleRootLoc :: !Loc,
-- | The optional @layout@ clause: the workspace's placement authority.
wmfLayout :: !(Maybe Placement),
-- | Meaningful only when 'wmfLayout' is 'Just'.
wmfLayoutLoc :: !Loc,
-- | At least one member, in canonical order.
wmfMembers :: !(NonEmpty WorkspaceMemberRef)
}
deriving stock (Eq, Show)
-- | One @spec \<path\>@ line: the normalized manifest-relative member path.
data WorkspaceMemberRef = WorkspaceMemberRef
{ -- | Normalized: forward slashes, no @./@ segments, relative, ends in @.keiro@.
wmrPath :: !FilePath,
wmrLoc :: !Loc
}
deriving stock (Eq, Show)
-- | The file extension that marks a workspace manifest.
workspaceExtension :: String
workspaceExtension = ".keiro-workspace"
-- | Does this @FILE@ argument name a workspace manifest? The test is on the
-- extension, case-insensitively, and never on the file's content: a file's role
-- must not depend on which parser happens to succeed, and a corrupted manifest
-- must produce a manifest parse error rather than a confusing @.keiro@ one.
isWorkspacePath :: FilePath -> Bool
isWorkspacePath path = map toLower workspaceExtension `isSuffixOfString` map toLower path
where
isSuffixOfString needle haystack = length haystack > length needle && drop (length haystack - length needle) haystack == needle
--------------------------------------------------------------------------------
-- Member path normalization
--------------------------------------------------------------------------------
-- | Normalize and validate a @spec@ path token. Member paths must be relative,
-- use forward slashes, end in @.keiro@, and stay inside the manifest's directory
-- tree; @.\/@ segments are normalized away. A manifest may not list another
-- manifest (a @.keiro-workspace@ path fails the @.keiro@ suffix rule).
--
-- The restrictions exist so a workspace can be reconstructed at an arbitrary git
-- revision with @git show \<rev\>:\<repo-relative-path\>@: a path that escapes the
-- repository cannot be reconstructed at all. Every rule can be relaxed additively
-- later; none can be tightened without breaking users.
--
-- Returns 'Left' with a human-readable reason, or 'Right' the normalized path.
normalizeMemberPath :: Text -> Either Text FilePath
normalizeMemberPath raw
| T.null raw = Left "member path is empty"
| T.isPrefixOf "/" raw = Left ("member path must be relative, not absolute: '" <> raw <> "'")
| ".." `elem` segments = Left ("member path must not contain '..' segments: '" <> raw <> "'")
| null kept = Left ("member path is empty after normalization: '" <> raw <> "'")
| not (T.isSuffixOf ".keiro" normalized) =
Left ("member path must name a .keiro spec: '" <> raw <> "'")
| normalized == ".keiro" = Left ("member path must name a .keiro spec: '" <> raw <> "'")
| otherwise = Right (T.unpack normalized)
where
segments = T.splitOn "/" raw
kept = [s | s <- segments, not (T.null s), s /= "."]
normalized = T.intercalate "/" kept
--------------------------------------------------------------------------------
-- Parser
--------------------------------------------------------------------------------
type WP = Parsec Void Text
-- | Parse a workspace manifest. The 'FilePath' is used only as the source name
-- in diagnostics (megaparsec's line reporting); it need not exist on disk.
--
-- Duplicate clauses, a missing or misplaced @service@ clause, an empty member
-- list, an invalid member path, and duplicate members (including two paths equal
-- under Unicode case folding — macOS's default filesystem is case-insensitive, so
-- two such paths can silently be one file) are all rejected here, at the manifest
-- boundary, with the manifest path and line.
parseWorkspaceManifest :: FilePath -> Text -> Either ParseError WorkspaceManifest
parseWorkspaceManifest src input =
case runParser (sc *> pManifest <* eof) src input of
Left bundle -> Left (T.pack (errorBundlePretty bundle))
Right manifest -> Right manifest
-- | One source clause, tagged with the offset used to position its diagnostics.
data Clause
= ClService !Int !Loc !Text
| ClModule !Int !Loc !Text
| ClLayout !Int !Loc !Placement
| ClSpec !Int !Loc !Text
clauseOffset :: Clause -> Int
clauseOffset (ClService o _ _) = o
clauseOffset (ClModule o _ _) = o
clauseOffset (ClLayout o _ _) = o
clauseOffset (ClSpec o _ _) = o
-- | Space consumer: spaces, newlines, and @#@ line comments are all whitespace.
sc :: WP ()
sc = L.space space1 (L.skipLineComment "#") empty
lexeme :: WP a -> WP a
lexeme = L.lexeme sc
-- | A literal keyword not followed by an identifier character.
keyword :: Text -> WP ()
keyword word = lexeme (try (chunk word *> notFollowedBy (satisfy pathChar)))
getLoc :: WP Loc
getLoc = (Loc . unPos . sourceLine) <$> getSourcePos
pManifest :: WP WorkspaceManifest
pManifest = do
startOffset <- getOffset
clauses <- many pClause
buildManifest startOffset clauses
pClause :: WP Clause
pClause =
choice
[ mk ClService "service" pServiceName,
mk ClModule "module" pModulePrefix,
mk ClLayout "layout" pPlacement,
mk ClSpec "spec" pPathToken
]
where
mk construct word value = try $ do
offset <- getOffset
loc <- getLoc
keyword word
construct offset loc <$> value
-- | The workspace identity uses the member grammar's wire-word spelling: an
-- ASCII letter or digit, then letters, digits, @_@, and @-@ (e.g. @mori-project@).
pServiceName :: WP Text
pServiceName = lexeme $ do
c <- satisfy asciiAlphaNum <?> "workspace service name"
cs <- many (satisfy (\x -> asciiAlphaNum x || x == '_' || x == '-'))
pure (T.pack (c : cs))
-- | A dotted module prefix: one-or-more PascalCase segments joined by dots,
-- matching the member grammar's @module@ clause (e.g. @Demo.Modules.Project@).
pModulePrefix :: WP Text
pModulePrefix = lexeme $ do
seg0 <- pSeg
segs <- many (char '.' *> pSeg)
pure (T.intercalate "." (seg0 : segs))
where
pSeg = do
c <- satisfy (\x -> x >= 'A' && x <= 'Z') <?> "PascalCase module segment"
cs <- many (satisfy (\x -> asciiAlphaNum x || x == '_'))
pure (T.pack (c : cs))
pPlacement :: WP Placement
pPlacement =
choice
[ GeneratedPrefix <$ keyword "prefixed",
CollocatedLeaf <$ keyword "collocated"
]
<?> "'prefixed' or 'collocated'"
-- | A relative path token: no spaces, no drive letters, no quoting.
pPathToken :: WP Text
pPathToken = lexeme (T.pack <$> some (satisfy pathChar)) <?> "relative .keiro member path"
pathChar :: Char -> Bool
pathChar c = asciiAlphaNum c || c == '.' || c == '_' || c == '-' || c == '/'
asciiAlphaNum :: Char -> Bool
asciiAlphaNum c = isAscii c && (isLetter c || isDigit c)
-- | Fold the parsed clauses into a manifest, rejecting every structural error
-- at the offending clause's own source position.
buildManifest :: Int -> [Clause] -> WP WorkspaceManifest
buildManifest startOffset clauses = do
case clauses of
[] -> failAt startOffset "workspace manifest must begin with a 'service <name>' clause"
leading : _ -> case leading of
ClService {} -> pure ()
other -> failAt (clauseOffset other) "the first clause of a workspace manifest must be 'service <name>'"
(service, serviceLoc) <- case [(name, loc) | ClService _ loc name <- clauses] of
[one] -> pure one
_ -> failAt (secondOffset [c | c@ClService {} <- clauses]) "duplicate 'service' clause: a workspace has exactly one identity"
(moduleRoot, moduleLoc) <- case [(root, loc) | ClModule _ loc root <- clauses] of
[] -> pure (Nothing, Loc 0)
[(root, loc)] -> pure (Just root, loc)
_ -> failAt (secondOffset [c | c@ClModule {} <- clauses]) "duplicate 'module' clause"
(layout, layoutLoc) <- case [(placement, loc) | ClLayout _ loc placement <- clauses] of
[] -> pure (Nothing, Loc 0)
[(placement, loc)] -> pure (Just placement, loc)
_ -> failAt (secondOffset [c | c@ClLayout {} <- clauses]) "duplicate 'layout' clause"
let specClauses = [(offset, loc, raw) | ClSpec offset loc raw <- clauses]
normalized <- traverse normalizeOne specClauses
case normalized of
[] -> failAt startOffset "workspace manifest must list at least one 'spec <path>.keiro' member"
_ -> pure ()
rejectDuplicates normalized
let sorted = sortOn (T.pack . snd3) normalized
pure
WorkspaceManifest
{ wmfService = service,
wmfServiceLoc = serviceLoc,
wmfModuleRoot = moduleRoot,
wmfModuleRootLoc = moduleLoc,
wmfLayout = layout,
wmfLayoutLoc = layoutLoc,
wmfMembers = NE.fromList [WorkspaceMemberRef path loc | (_, path, loc) <- sorted]
}
where
snd3 (_, path, _) = path
normalizeOne (offset, loc, raw) = case normalizeMemberPath raw of
Left reason -> failAt offset (T.unpack reason)
Right path -> pure (offset, path, loc)
secondOffset cs = case cs of
_ : second : _ -> clauseOffset second
_ -> startOffset
-- | Refuse a member listed twice, and a member listed under two spellings that
-- case-fold to the same path. Detecting a source file assigned to /two different/
-- workspaces is deliberately out of scope here: one invocation sees one manifest,
-- and repository-wide manifest discovery is exactly the dynamic discovery this
-- design excludes.
rejectDuplicates :: [(Int, FilePath, Loc)] -> WP ()
rejectDuplicates entries = go [] entries
where
go _ [] = pure ()
go seen ((offset, path, _) : rest)
| path `elem` map fst seen =
failAt offset ("duplicate workspace member '" <> path <> "': membership is a set")
| Just earlier <- lookup (T.toCaseFold (T.pack path)) (map swap seen) =
failAt
offset
( "workspace members '"
<> earlier
<> "' and '"
<> path
<> "' differ only by case; on a case-insensitive filesystem they are one file"
)
| otherwise = go ((path, T.toCaseFold (T.pack path)) : seen) rest
swap (path, folded) = (folded, path)
-- | Fail with a plain message positioned at a specific source offset.
failAt :: Int -> String -> WP a
failAt offset message = setOffset offset >> fail message
--------------------------------------------------------------------------------
-- Renderer
--------------------------------------------------------------------------------
-- | Render a manifest in canonical form: @service@, then the optional @module@
-- and @layout@ clauses, then the members in codepoint order, one per line, with
-- no trailing newline (comments are not preserved, exactly like the member
-- pretty-printer). @parse . render@ is the identity on the AST and
-- @render . parse . render@ is the identity on bytes.
renderWorkspaceManifest :: WorkspaceManifest -> Text
renderWorkspaceManifest manifest =
T.intercalate "\n" $
["service " <> wmfService manifest]
++ maybe [] (\root -> ["module " <> root]) (wmfModuleRoot manifest)
++ maybe [] (\placement -> ["layout " <> renderPlacement placement]) (wmfLayout manifest)
++ [ "spec " <> T.pack (wmrPath member)
| member <- sortOn (T.pack . wmrPath) (NE.toList (wmfMembers manifest))
]
renderPlacement :: Placement -> Text
renderPlacement GeneratedPrefix = "prefixed"
renderPlacement CollocatedLeaf = "collocated"
--------------------------------------------------------------------------------
-- Generic line relocation
--------------------------------------------------------------------------------
-- | Everything in the AST that carries source lines. The generic default walks
-- a value's 'Generic' representation and applies the function at every 'Loc'
-- field, however deeply nested.
--
-- The instance list below covers every type in "Keiro.Dsl.Grammar". Completeness
-- is compiler-enforced rather than reviewed by eye: the generic default demands a
-- 'HasLocs' instance for each field type, so a new AST type is a build error here
-- until it is listed, and no 'Loc' can be silently missed.
class HasLocs a where
traverseLocs :: (Applicative f) => (Loc -> f Loc) -> a -> f a
default traverseLocs :: (Generic a, GHasLocs (Rep a), Applicative f) => (Loc -> f Loc) -> a -> f a
traverseLocs f = fmap to . gtraverseLocs f . from
class GHasLocs rep where
gtraverseLocs :: (Applicative f) => (Loc -> f Loc) -> rep p -> f (rep p)
instance GHasLocs V1 where
gtraverseLocs _ = pure
instance GHasLocs U1 where
gtraverseLocs _ = pure
instance (GHasLocs a, GHasLocs b) => GHasLocs (a :*: b) where
gtraverseLocs f (a :*: b) = (:*:) <$> gtraverseLocs f a <*> gtraverseLocs f b
instance (GHasLocs a, GHasLocs b) => GHasLocs (a :+: b) where
gtraverseLocs f (L1 a) = L1 <$> gtraverseLocs f a
gtraverseLocs f (R1 b) = R1 <$> gtraverseLocs f b
instance (GHasLocs a) => GHasLocs (M1 i c a) where
gtraverseLocs f (M1 a) = M1 <$> gtraverseLocs f a
instance (HasLocs c) => GHasLocs (K1 i c) where
gtraverseLocs f (K1 c) = K1 <$> traverseLocs f c
-- The one interesting instance: this is where the function actually fires.
instance HasLocs Loc where
traverseLocs f = f
-- Leaf types that carry no location.
instance HasLocs Int where
traverseLocs _ = pure
instance HasLocs Integer where
traverseLocs _ = pure
instance HasLocs Double where
traverseLocs _ = pure
instance HasLocs Bool where
traverseLocs _ = pure
instance HasLocs Char where
traverseLocs _ = pure
instance HasLocs Text where
traverseLocs _ = pure
instance (HasLocs a) => HasLocs [a] where
traverseLocs f = traverse (traverseLocs f)
instance (HasLocs a) => HasLocs (Maybe a) where
traverseLocs f = traverse (traverseLocs f)
instance (HasLocs a, HasLocs b) => HasLocs (a, b) where
traverseLocs f (a, b) = (,) <$> traverseLocs f a <*> traverseLocs f b
instance (HasLocs a, HasLocs b) => HasLocs (Either a b) where
traverseLocs f (Left a) = Left <$> traverseLocs f a
traverseLocs f (Right b) = Right <$> traverseLocs f b
-- | Rewrite every source line in a spec. This is a compiler line map, not
-- textual inclusion: only line numbers move, and 'Keiro.Dsl.Grammar.Loc''s 'Eq'
-- instance deliberately ignores the line, so relocation cannot change any
-- equality-based behavior.
relocateLocs :: (Int -> Int) -> Spec -> Spec
relocateLocs shift = runIdentity . traverseLocs (Identity . Loc . shift . unLoc)
-- | Every source line the spec's AST carries, in traversal order. Exists so a
-- test can prove 'relocateLocs' misses nothing: relocate by a known offset and
-- assert the collected multiset shifted exactly.
collectLocs :: Spec -> [Int]
collectLocs = getConst . traverseLocs (\l -> Const [unLoc l])
--------------------------------------------------------------------------------
-- Multi-file diagnostics
--------------------------------------------------------------------------------
-- | Which file a workspace diagnostic points at. Member paths are stored
-- manifest-relative — the canonical identity a scaffold record or diff report can
-- key on — and joined with the manifest's directory only at render time.
data WorkspaceFile
= -- | The manifest itself.
WorkspaceManifestFile
| -- | A member, by its normalized manifest-relative path.
WorkspaceMemberFile !FilePath
deriving stock (Eq, Ord, Show)
-- | One cited source position. 'wlRole' explains why a /secondary/ position is
-- relevant ("also declared here", "member declares context 'kotei'"); it is
-- unused for the primary position, which carries the diagnostic's own message.
data WorkspaceLocation = WorkspaceLocation
{ wlFile :: !WorkspaceFile,
wlLine :: !Int,
wlRole :: !Text
}
deriving stock (Eq, Show)
-- | A diagnostic that can cite several files at once — the whole point of
-- whole-service checking. The first location is primary; the rest render as
-- indented notes. The code comes from the same append-only registry as
-- single-spec diagnostics ("Keiro.Dsl.Validate"), so every gate stays
-- correlatable by code.
data WorkspaceDiagnostic = WorkspaceDiagnostic
{ wdLocations :: !(NonEmpty WorkspaceLocation),
wdSeverity :: !Severity,
wdCode :: !DiagnosticCode,
wdSourceLanguageCause :: !(Maybe SourceLanguageDiagnostic),
wdMessage :: !Text
}
deriving stock (Eq, Show)
-- | Why a workspace could not be produced. The three constructors are the
-- three stages at which loading can stop: the manifest could not be read, it
-- could not be parsed, or the members were read but the service refused to
-- compose.
data WorkspaceFailure
= WorkspaceManifestUnreadable !Text
| WorkspaceManifestUnparseable !ParseError
| WorkspaceRefused !(NonEmpty WorkspaceDiagnostic)
deriving stock (Eq, Show)
-- | The clickable path for a cited file: the manifest as the user typed it, or
-- the manifest's directory joined with the member's relative path.
workspaceDisplayPath :: FilePath -> WorkspaceFile -> FilePath
workspaceDisplayPath manifestPath = \case
WorkspaceManifestFile -> manifestPath
WorkspaceMemberFile relative ->
let dir = takeDirectory manifestPath
in if dir == "." then relative else dir </> relative
-- | Render one diagnostic. The primary location keeps the established
-- single-file shape so existing consumers and greps keep working; each additional
-- location follows on an indented continuation line.
--
-- @
-- …/domain/shared.keiro:3: error[WorkspaceDuplicateDeclaration]: duplicate declaration 'ProjectId' …
-- …/domain/project.keiro:4: note: also declared here
-- @
renderWorkspaceDiagnostic :: FilePath -> WorkspaceDiagnostic -> Text
renderWorkspaceDiagnostic manifestPath diagnostic =
T.intercalate "\n" (primary : notes)
where
primaryLocation :| secondary = wdLocations diagnostic
primary =
renderAt primaryLocation
<> ": "
<> severityWord
<> "["
<> T.pack (show (wdCode diagnostic))
<> "]: "
<> wdMessage diagnostic
notes = [" " <> renderAt location <> ": note: " <> wlRole location | location <- secondary]
renderAt location =
T.pack (workspaceDisplayPath manifestPath (wlFile location))
<> ":"
<> T.pack (show (wlLine location))
severityWord = case wdSeverity diagnostic of Error -> "error"; Warning -> "warning"
-- | Render a whole failure as the lines a command should print to stderr.
renderWorkspaceFailure :: FilePath -> WorkspaceFailure -> [Text]
renderWorkspaceFailure manifestPath = \case
WorkspaceManifestUnreadable reason ->
["cannot read workspace manifest " <> T.pack manifestPath <> ": " <> reason]
WorkspaceManifestUnparseable err -> [err]
WorkspaceRefused diagnostics ->
map (renderWorkspaceDiagnostic manifestPath) (NE.toList diagnostics)
--------------------------------------------------------------------------------
-- The composed graph
--------------------------------------------------------------------------------
-- | Maps a merged-spec line back to the member that owns it. Each entry is
-- @(exclusiveLow, inclusiveHigh, memberPath)@: merged line @n@ belongs to the
-- entry with @low < n <= high@, and the member's own line is @n - low@.
newtype LineMap = LineMap {lmRanges :: [(Int, Int, FilePath)]}
deriving stock (Eq, Show)
-- | Where each shared declaration and each node was defined. Keys are
-- @(namespace, name)@ — namespaces are @id@, @enum@, @rule@, @mapped@ for
-- declarations and the node kind ("aggregate", "readmodel", …) for nodes, the
-- same keying the single-spec duplicate-node rule uses. Values are the owning
-- member's manifest-relative path and its /original/ (unrelocated) location.
data OwnershipIndex = OwnershipIndex
{ oiDeclarations :: !(Map (Text, Name) (FilePath, Loc)),
oiNodes :: !(Map (Text, Name) (FilePath, Loc))
}
deriving stock (Eq, Show)
-- | Which member owns a shared declaration, e.g. @declarationOwner index "id" "ProjectId"@.
declarationOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc)
declarationOwner index namespace name = Map.lookup (namespace, name) (oiDeclarations index)
-- | Which member owns a node, e.g. @nodeOwner index "aggregate" "Project"@.
nodeOwner :: OwnershipIndex -> Text -> Name -> Maybe (FilePath, Loc)
nodeOwner index kind name = Map.lookup (kind, name) (oiNodes index)
-- | One member of a composed workspace.
data WorkspaceMember = WorkspaceMember
{ -- | Normalized, manifest-relative.
wmPath :: !FilePath,
-- | Exactly as parsed: line numbers are the member's own.
wmSpec :: !Spec,
-- | The member's declared-versus-legacy source contract.
wmSourceLanguage :: !SourceLanguage,
-- | Added to this member's lines to place them in the merged spec.
wmLineBase :: !Int,
-- | Source lines in the member file.
wmLineCount :: !Int
}
deriving stock (Eq, Show)
-- | A whole service, composed from its members and ready to be checked,
-- scaffolded, or diffed as one contract.
--
-- 'wsMergedSpec' is the load-bearing field: it is a single 'Spec' holding every
-- member's declarations and nodes in canonical member order, with line numbers
-- relocated into disjoint ranges. Because it is an ordinary 'Spec', the existing
-- whole-spec validation, type-graph resolution, coverage, and binding analysis
-- run over it unchanged — cross-file references resolve by name exactly as if the
-- members had been one file, with no risk of a node-specific rule diverging
-- between the single-file and workspace paths.
data WorkspaceSpec = WorkspaceSpec
{ -- | The stable workspace identity (the manifest's @service@ name).
wsService :: !Text,
wsManifestPath :: !FilePath,
-- | The unanimous effective contract selected before graph composition.
-- Member declared/legacy provenance remains in 'wsMembers'.
wsLanguageContract :: !EffectiveLanguageContract,
-- | The members' unanimous @context@.
wsContext :: !Name,
wsModuleRoot :: !(Maybe Text),
wsLayout :: !(Maybe Placement),
-- | Canonical order.
wsMembers :: ![WorkspaceMember],
wsMergedSpec :: !Spec,
wsLineMap :: !LineMap,
wsOwnership :: !OwnershipIndex
}
deriving stock (Eq, Show)
-- | Resolve a merged-spec line to @(member path, that member's own line)@.
-- 'Nothing' means the line belongs to no member — render it against the manifest.
resolveWorkspaceLine :: WorkspaceSpec -> Int -> Maybe (FilePath, Int)
resolveWorkspaceLine workspace n
| n <= 0 = Nothing
| otherwise =
listToMaybe
[ (path, n - low)
| (low, high, path) <- lmRanges (wsLineMap workspace),
n > low,
n <= high
]
-- | A single @.keiro@ file as a one-member workspace. The identity is the
-- file's base name, the merged spec is the spec itself, and the line map is the
-- identity, so @checkWorkspace (oneMemberWorkspace fp spec)@ yields exactly
-- @validateSpec spec@ attributed to @fp@. Downstream plans use this as the
-- uniform input type for single-file inputs.
oneMemberWorkspace :: FilePath -> Spec -> WorkspaceSpec
oneMemberWorkspace path spec = oneMemberParsedWorkspace path (ParsedSource LegacyUnversioned spec)
-- | Preserve provenance when adapting one parsed source to workspace consumers.
oneMemberParsedWorkspace :: FilePath -> ParsedSource -> WorkspaceSpec
oneMemberParsedWorkspace path parsedSource =
WorkspaceSpec
{ wsService = T.pack (takeBaseName path),
wsManifestPath = path,
wsLanguageContract = checkedLanguageContract service,
wsContext = specContext spec,
wsModuleRoot = specModuleRoot spec,
wsLayout = specLayout spec,
wsMembers =
[ WorkspaceMember
{ wmPath = relative,
wmSpec = spec,
wmSourceLanguage = parsedSourceLanguage parsedSource,
wmLineBase = 0,
wmLineCount = maximum (0 : collectLocs spec)
}
],
wsMergedSpec = spec,
wsLineMap = LineMap [(0, maxBound, relative)],
wsOwnership = ownershipOf [(relative, spec)]
}
where
service = checkedSource parsedSource
spec = parsedSpec parsedSource
relative = takeFileName path
-- | Recover the contract-preserving semantic input from a composed workspace.
-- Composition has already proved that every member selects this one effective
-- contract, so downstream consumers need not inspect member provenance.
checkedWorkspace :: WorkspaceSpec -> CheckedService
checkedWorkspace workspace =
CheckedService
{ checkedLanguageContract = wsLanguageContract workspace,
checkedSpec = wsMergedSpec workspace
}
-- | Validate a composed workspace. This runs the /existing/ whole-spec
-- validator over the merged spec once and maps each diagnostic's line back
-- through the line map, so the workspace and single-file paths can never diverge
-- on what counts as valid.
checkWorkspace :: WorkspaceSpec -> [WorkspaceDiagnostic]
checkWorkspace workspace =
[ WorkspaceDiagnostic
{ wdLocations = pure (locationFor (line diagnostic)),
wdSeverity = severity diagnostic,
wdCode = code diagnostic,
wdSourceLanguageCause = Nothing,
wdMessage = message diagnostic
}
| diagnostic <- validateService (checkedWorkspace workspace)
]
where
locationFor n = case resolveWorkspaceLine workspace n of
Just (path, original) -> WorkspaceLocation (WorkspaceMemberFile path) original ""
-- A line owned by no member (the placeholder location 'Loc 0') is the
-- workspace's own; point at the manifest rather than invent a member.
Nothing -> WorkspaceLocation WorkspaceManifestFile (max 1 n) ""
--------------------------------------------------------------------------------
-- Composition
--------------------------------------------------------------------------------
-- | Compose parsed members into one service graph, or refuse with every
-- relevant file and line cited.
--
-- The third argument supplies one entry per manifest member as
-- @(normalized manifest-relative path, source text, parsed spec)@. The source
-- text is needed for two things the AST cannot provide: counting lines for the
-- line map, and locating the @context@\/@module@\/@layout@ clause lines that
-- 'Keiro.Dsl.Grammar.Spec' does not record, so a refusal can point at the clause
-- an author actually wrote. The scan is used for diagnostics only, never for
-- semantics.
--
-- Composition proceeds in a fixed order, and every stage's refusals are collected
-- before any is reported — a workspace with two problems reports both. The stages
-- are: the members' @context@ must be unanimous; the manifest is the
-- @module@\/@layout@ authority and members must be absent-or-exactly-equal; every
-- shared declaration has exactly one owning member (identical duplicates are
-- refused, they never silently merge); every node identity has exactly one owning
-- member; and no two members may claim generated module paths that collide under
-- case folding.
composeWorkspace ::
FilePath ->
WorkspaceManifest ->
[(FilePath, Text, ParsedSource)] ->
Either (NonEmpty WorkspaceDiagnostic) WorkspaceSpec
composeWorkspace manifestPath manifest supplied
| (d : ds) <- unsupplied = Left (d :| ds)
| (d : ds) <- refusals = Left (d :| ds)
| otherwise = Right composed
where
ordered =
[ (ref, lookup (wmrPath ref) [(path, (text, parsedSource)) | (path, text, parsedSource) <- supplied])
| ref <- NE.toList (wmfMembers manifest)
]
unsupplied =
[ WorkspaceDiagnostic
{ wdLocations = pure (manifestLocation (wmrLoc ref) ""),
wdSeverity = Error,
wdCode = WorkspaceMemberUnreadable,
wdSourceLanguageCause = Nothing,
wdMessage = "workspace member '" <> T.pack (wmrPath ref) <> "' was not supplied to the composer"
}
| (ref, Nothing) <- ordered
]
entries =
[ (ref, text, parsedSourceLanguage parsedSource, parsedSpec parsedSource)
| (ref, Just (text, parsedSource)) <- ordered
]
refusals =
languageRefusals
<> contextRefusals
<> moduleRefusals
<> layoutRefusals
<> declarationRefusals
<> nodeRefusals
<> collisionRefusals
--------------------------------------------------------------------------
-- Effective source language and context
--------------------------------------------------------------------------
effectiveVersions = nub [effectiveLanguageVersion sourceLanguage | (_, _, sourceLanguage, _) <- entries]
languageRefusals
| length effectiveVersions <= 1 = []
| otherwise =
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ memberLocation
ref
(sourceLanguageLine text sourceLanguage)
("member selects effective language version " <> languageVersionText (effectiveLanguageVersion sourceLanguage))
| (ref, text, sourceLanguage, _) <- entries
],
wdSeverity = Error,
wdCode = WorkspaceLanguageVersionMismatch,
wdSourceLanguageCause = Nothing,
wdMessage =
"workspace members select different effective language versions ("
<> T.intercalate ", " (map languageVersionText effectiveVersions)
<> "); one semantic graph cannot combine different language contracts"
}
]
sourceLanguageLine text LegacyUnversioned = clauseLine "context" text
sourceLanguageLine _ DeclaredLanguage {languageVersionLoc = Loc lineNumber} = Just lineNumber
declaredContexts = nub [specContext spec | (_, _, _, spec) <- entries]
effectiveContext = case entries of
(_, _, _, spec) : _ -> specContext spec
[] -> ""
contextRefusals
| length declaredContexts <= 1 = []
| otherwise =
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ memberLocation ref (clauseLine "context" text) ("member declares context '" <> specContext spec <> "'")
| (ref, text, _, spec) <- entries
],
wdSeverity = Error,
wdCode = WorkspaceContextMismatch,
wdSourceLanguageCause = Nothing,
wdMessage =
"workspace '"
<> wmfService manifest
<> "' members declare different contexts ("
<> T.intercalate ", " (sort declaredContexts)
<> "); every member of one workspace must declare the same context"
}
]
--------------------------------------------------------------------------
-- Effective module root and layout
--------------------------------------------------------------------------
(effectiveModuleRoot, moduleRefusals) =
resolveAuthority "module" id (wmfModuleRoot manifest) (wmfModuleRootLoc manifest) specModuleRoot
(effectiveLayout, layoutRefusals) =
resolveAuthority "layout" renderPlacement (wmfLayout manifest) (wmfLayoutLoc manifest) specLayout
-- The absent-or-exactly-equal authority rule, shared by @module@ and
-- @layout@. When the manifest declares the clause it is the authority and
-- every member's clause must be absent or identical — never silently
-- overridden. When the manifest is silent, the members that declare the
-- clause must agree unanimously, and that value becomes effective. Both
-- halves exist so adoption needs no member edits: a fleet whose members
-- carry no clauses can put the authority wholly in the manifest, and a file
-- that already declares one can keep it when it becomes a member.
resolveAuthority ::
(Eq a) =>
Text ->
(a -> Text) ->
Maybe a ->
Loc ->
(Spec -> Maybe a) ->
(Maybe a, [WorkspaceDiagnostic])
resolveAuthority clauseKeyword renderValue manifestValue manifestLoc memberValue =
case manifestValue of
Just authority ->
( Just authority,
[ WorkspaceDiagnostic
{ wdLocations =
manifestLocation manifestLoc ""
:| [ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value)
| (ref, text, value) <- disagreeing
],
wdSeverity = Error,
wdCode = WorkspaceAuthorityConflict,
wdSourceLanguageCause = Nothing,
wdMessage =
"workspace manifest declares "
<> clauseKeyword
<> " "
<> renderValue authority
<> ", so every member's "
<> clauseKeyword
<> " clause must be absent or exactly equal"
}
| not (null disagreeing)
]
)
where
disagreeing =
[ (ref, text, value)
| (ref, text, _, spec) <- entries,
Just value <- [memberValue spec],
value /= authority
]
Nothing
| length (nub (map thd declared)) <= 1 -> (listToMaybe (map thd declared), [])
| otherwise ->
( Nothing,
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ memberLocation ref (clauseLine clauseKeyword text) ("member declares " <> clauseKeyword <> " " <> renderValue value)
| (ref, text, value) <- declared
],
wdSeverity = Error,
wdCode = WorkspaceAuthorityConflict,
wdSourceLanguageCause = Nothing,
wdMessage =
"the workspace manifest declares no "
<> clauseKeyword
<> " clause, so the members that declare one must agree; they do not"
}
]
)
where
declared = [(ref, text, value) | (ref, text, _, spec) <- entries, Just value <- [memberValue spec]]
where
thd (_, _, value) = value
--------------------------------------------------------------------------
-- Single-owner declarations and nodes
--------------------------------------------------------------------------
declarationSites =
[ (name, (namespace, ref, loc))
| (ref, _, _, spec) <- entries,
(namespace, name, loc) <- sharedDeclarations spec
]
declarationRefusals =
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ memberLocation ref (Just (unLoc loc)) ("also declared here, as " <> namespace <> " '" <> name <> "'")
| (namespace, ref, loc) <- sites
],
wdSeverity = Error,
wdCode = WorkspaceDuplicateDeclaration,
wdSourceLanguageCause = Nothing,
wdMessage =
"duplicate declaration '"
<> name
<> "': a shared declaration has exactly one owning member (identical duplicates do not merge)"
}
| (name, sites) <- groupSites declarationSites,
length (nub [wmrPath ref | (_, ref, _) <- sites]) > 1
]
nodeSites =
[ ((kind, name), (ref, loc))
| (ref, _, _, spec) <- entries,
node <- specNodes spec,
let (kind, name, loc) = nodeIdentity node
]
nodeRefusals =
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ memberLocation ref (Just (unLoc loc)) ("also defined here")
| (ref, loc) <- sites
],
wdSeverity = Error,
wdCode = WorkspaceDuplicateNodeName,
wdSourceLanguageCause = Nothing,
wdMessage =
"duplicate "
<> kind
<> " node name '"
<> name
<> "': a node has exactly one owning member"
}
| ((kind, name), sites) <- groupSites nodeSites,
length (nub [wmrPath ref | (ref, _) <- sites]) > 1
]
--------------------------------------------------------------------------
-- Merged spec and line map
--------------------------------------------------------------------------
lineCounts = [max 1 (length (T.lines text)) | (_, text, _, _) <- entries]
lineBases = scanl (+) 0 lineCounts
members =
[ WorkspaceMember
{ wmPath = wmrPath ref,
wmSpec = spec,
wmSourceLanguage = sourceLanguage,
wmLineBase = base,
wmLineCount = memberLines
}
| ((ref, _, sourceLanguage, spec), base, memberLines) <- zip3 entries lineBases lineCounts
]
relocatedSpecs = [relocateLocs (shiftBy (wmLineBase member)) (wmSpec member) | member <- members]
-- The placeholder location 'Loc 0' must stay 0: shifting it would land it
-- inside the previous member's range and mis-attribute the diagnostic.
shiftBy base n = if n <= 0 then n else n + base
lineMap =
LineMap
[ (wmLineBase member, wmLineBase member + wmLineCount member, wmPath member)
| member <- members
]
mergedSpec =
Spec
{ specContext = effectiveContext,
specModuleRoot = effectiveModuleRoot,
specLayout = effectiveLayout,
specIds = concatMap specIds relocatedSpecs,
specEnums = concatMap specEnums relocatedSpecs,
specRules = concatMap specRules relocatedSpecs,
specNominalScalars = concatMap specNominalScalars relocatedSpecs,
specMapped = concatMap specMapped relocatedSpecs,
specNodes = concatMap specNodes relocatedSpecs
}
--------------------------------------------------------------------------
-- Cross-member generated-path collisions
--------------------------------------------------------------------------
plannerContext =
Context
{ contextName = effectiveContext,
moduleRoot = fromMaybe "" effectiveModuleRoot,
placement = fromMaybe GeneratedPrefix effectiveLayout
}
collisionRefusals
-- The effective context/module/layout are only meaningful once the
-- earlier stages agree; without them there is no honest planner input.
| not (null contextRefusals && null moduleRefusals && null layoutRefusals) = []
-- Only ask the scaffold planner about a spec that already validates.
-- An invalid merged spec is 'checkWorkspace''s report to make, and the
-- planner is only designed to see specs that passed validation.
| any ((== Error) . severity) (validateService (checkedWorkspace composed)) = []
| otherwise = case planServiceScaffoldWithGoldens [] plannerContext (checkedWorkspace composed) of
Right _ -> []
Left plannerRefusals -> concatMap crossMemberCollision plannerRefusals
crossMemberCollision (PathCollision path origins) =
[ WorkspaceDiagnostic
{ wdLocations =
NE.fromList
[ WorkspaceLocation (WorkspaceMemberFile owner) original ("claimed here by " <> origin)
| (origin, owner, original) <- resolved
],
wdSeverity = Error,
wdCode = WorkspacePathCollision,
wdSourceLanguageCause = Nothing,
wdMessage =
"generated module path '"
<> T.pack path
<> "' is claimed by nodes in more than one member; on a case-insensitive filesystem these are one file"
}
| length (nub [owner | (_, owner, _) <- resolved]) > 1
]
where
resolved =
[ (origin, owner, original)
| origin <- origins,
Just mergedLine <- [originLine origin],
Just (owner, original) <- [lookupLine mergedLine]
]
crossMemberCollision _ = []
lookupLine n =
listToMaybe
[ (path, n - low)
| (low, high, path) <- lmRanges lineMap,
n > low,
n <= high
]
--------------------------------------------------------------------------
-- Result
--------------------------------------------------------------------------
composed =
WorkspaceSpec
{ wsService = wmfService manifest,
wsManifestPath = manifestPath,
wsLanguageContract = effectiveLanguageContract effectiveSourceLanguage,
wsContext = effectiveContext,
wsModuleRoot = effectiveModuleRoot,
wsLayout = effectiveLayout,
wsMembers = members,
wsMergedSpec = mergedSpec,
wsLineMap = lineMap,
wsOwnership = ownershipOf [(wmPath member, wmSpec member) | member <- members]
}
effectiveSourceLanguage = case entries of
(_, _, sourceLanguage, _) : _ -> sourceLanguage
[] -> LegacyUnversioned
manifestLocation loc role = WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc loc)) role
memberLocation ref found role =
WorkspaceLocation (WorkspaceMemberFile (wmrPath ref)) (fromMaybe 1 found) role
-- | Group @(key, site)@ pairs by key, preserving first-appearance order.
groupSites :: (Ord k) => [(k, v)] -> [(k, [v])]
groupSites pairs =
[ (key, reverse sites)
| key <- nub (map fst pairs),
Just sites <- [Map.lookup key grouped]
]
where
grouped = Map.fromListWith (<>) [(key, [value]) | (key, value) <- pairs]
-- | The four shared-declaration namespaces of one spec, with names and lines.
sharedDeclarations :: Spec -> [(Text, Name, Loc)]
sharedDeclarations spec =
[("id", idName d, idLoc d) | d <- specIds spec]
<> [("enum", enumName d, enumLoc d) | d <- specEnums spec]
<> [("rule", ruleName d, ruleLoc d) | d <- specRules spec]
<> [("nominal", nominalScalarName d, nominalScalarLoc d) | d <- specNominalScalars spec]
<> [("mapped", mappedDeclName d, mappedDeclLoc d) | d <- specMapped spec]
mappedDeclName :: MappedDecl -> Name
mappedDeclName MappedStructural {msName = name} = name
mappedDeclName MappedOpaque {moName = name} = name
mappedDeclLoc :: MappedDecl -> Loc
mappedDeclLoc MappedStructural {msLoc = loc} = loc
mappedDeclLoc MappedOpaque {moLoc = loc} = loc
-- | Build the ownership index from members carrying their original locations.
ownershipOf :: [(FilePath, Spec)] -> OwnershipIndex
ownershipOf members =
OwnershipIndex
{ oiDeclarations =
Map.fromList
[ ((namespace, name), (path, loc))
| (path, spec) <- members,
(namespace, name, loc) <- sharedDeclarations spec
],
oiNodes =
Map.fromList
[ ((kind, name), (path, loc))
| (path, spec) <- members,
node <- specNodes spec,
let (kind, name, loc) = nodeIdentity node
]
}
-- | The line of the first non-comment source line whose first word is the
-- given clause keyword. Used only to point a refusal at the @context@,
-- @module@, or @layout@ clause an author wrote, because 'Spec' records no
-- location for them.
clauseLine :: Text -> Text -> Maybe Int
clauseLine clauseKeyword source =
listToMaybe
[ index
| (index, raw) <- zip [1 ..] (T.lines source),
(leading : _) <- [T.words (T.takeWhile (/= '#') raw)],
leading == clauseKeyword
]
-- | The merged-spec line embedded in a scaffold module's origin string, which
-- "Keiro.Dsl.Scaffold" formats as @\<kind\> \<name\> (line N)@. Context-level
-- modules carry no line and yield 'Nothing', which is correct: they belong to the
-- workspace, not to any one member, so they can never be a cross-member
-- collision.
originLine :: Text -> Maybe Int
originLine origin = do
withoutClose <- T.stripSuffix ")" origin
let (before, after) = T.breakOnEnd " (line " withoutClose
if T.null before then Nothing else readMaybe (T.unpack after)
--------------------------------------------------------------------------------
-- Loading
--------------------------------------------------------------------------------
-- | How the loader obtains file contents. 'csRead' receives a path relative to
-- the workspace root (the manifest's own directory); 'Left' is a human-readable
-- read-failure reason.
--
-- This seam exists so the same loader can read from the working tree now and
-- from @git show \<rev\>:\<path\>@ blobs later, when whole-workspace @diff@ must
-- resolve a workspace as it existed at an older revision without re-implementing
-- composition.
newtype ContentSource = ContentSource
{ csRead :: FilePath -> IO (Either Text Text)
}
-- | Read files from a directory on disk.
fileContentSource :: FilePath -> ContentSource
fileContentSource root =
ContentSource
{ csRead = \relative -> do
let full = if root == "." then relative else root </> relative
exists <- doesFileExist full
if not exists
then pure (Left ("no such file: " <> T.pack full))
else do
attempt <- Exception.try (TIO.readFile full)
pure $ case attempt of
Left readError -> Left (T.pack (show (readError :: Exception.IOException)))
Right contents -> Right contents
}
-- | Read a manifest and all its members through a content source, then compose
-- them into one service graph.
--
-- Member read and parse failures are collected, not fail-fast: a workspace with
-- two unreadable members reports both, which matters when a whole service is
-- being adopted at once.
loadWorkspace :: ContentSource -> FilePath -> IO (Either WorkspaceFailure WorkspaceSpec)
loadWorkspace source manifestPath = do
manifestRead <- csRead source (takeFileName manifestPath)
case manifestRead of
Left reason -> pure (Left (WorkspaceManifestUnreadable reason))
Right manifestText -> case parseWorkspaceManifest manifestPath manifestText of
Left err -> pure (Left (WorkspaceManifestUnparseable err))
Right manifest -> do
results <- traverse readMember (NE.toList (wmfMembers manifest))
case [diagnostic | Left diagnostic <- results] of
(d : ds) -> pure (Left (WorkspaceRefused (d :| ds)))
[] ->
pure
( first
WorkspaceRefused
(composeWorkspace manifestPath manifest [entry | Right entry <- results])
)
where
readMember ref = do
result <- csRead source (wmrPath ref)
pure $ case result of
Left reason -> Left (memberFailure ref WorkspaceMemberUnreadable ("workspace member '" <> T.pack (wmrPath ref) <> "' could not be read: " <> reason) Nothing)
Right text -> case parseSource (workspaceDisplayPath manifestPath (WorkspaceMemberFile (wmrPath ref))) text of
Left parseFailure ->
Left
( memberFailure
ref
WorkspaceMemberParseFailed
("workspace member '" <> T.pack (wmrPath ref) <> "' failed to parse:\n" <> renderParseFailure parseFailure)
(case parseFailure of SourceLanguageFailure diagnostic -> Just diagnostic; BodyGrammarFailure {} -> Nothing)
)
Right parsedSource -> Right (wmrPath ref, text, parsedSource)
memberFailure ref failureCode note sourceLanguageCause =
WorkspaceDiagnostic
{ wdLocations = pure (WorkspaceLocation WorkspaceManifestFile (max 1 (unLoc (wmrLoc ref))) ""),
wdSeverity = Error,
wdCode = failureCode,
wdSourceLanguageCause = sourceLanguageCause,
wdMessage = note
}
--------------------------------------------------------------------------------
-- 'HasLocs' coverage of the AST
--
-- One line per type in "Keiro.Dsl.Grammar". A new AST type fails to compile
-- here until it is added, which is what makes 'relocateLocs' provably total.
--------------------------------------------------------------------------------
instance HasLocs AdvanceNode
instance HasLocs Aggregate
instance HasLocs AggregateField
instance HasLocs Atom
instance HasLocs BackoffSpec
instance HasLocs BindRow
instance HasLocs CmpOp
instance HasLocs Command
instance HasLocs Consistency
instance HasLocs ContractEvent
instance HasLocs ContractField
instance HasLocs ContractNode
instance HasLocs ContractType
instance HasLocs CorrelateDecl
instance HasLocs DecodeSpec
instance HasLocs DerivStrategy
instance HasLocs Derivation
instance HasLocs DeriveSpec
instance HasLocs Disp
instance HasLocs DispAction
instance HasLocs DispatchDisposition
instance HasLocs DispatchNode
instance HasLocs Disposition
instance HasLocs DispositionRow
instance HasLocs EmitMapRow
instance HasLocs EmitNode
instance HasLocs EnumDecl
instance HasLocs EnvelopeBinding
instance HasLocs EnvelopeLayer
instance HasLocs Event
instance HasLocs EventBody
instance HasLocs Expr
instance HasLocs ExprRoot
instance HasLocs Field
instance HasLocs FieldBinding
instance HasLocs FireAtExpr
instance HasLocs FireDisposition
instance HasLocs FireNode
instance HasLocs FireOutcome
instance HasLocs HandleNode
instance HasLocs HaskellSource
instance HasLocs Hole
instance HasLocs IdDecl
instance HasLocs IdExpr
instance HasLocs IdStrategy
instance HasLocs InboxAction
instance HasLocs InkPersist
instance HasLocs InputDecl
instance HasLocs IntakeNode
instance HasLocs MappedDecl
instance HasLocs MappedShape
instance HasLocs Mapping
instance HasLocs NominalBindingDecl
instance HasLocs NominalScalarDecl
instance HasLocs Node
instance HasLocs OnMissing
instance HasLocs OperationNode
instance HasLocs OperationShape
instance HasLocs PgmqDispatchNode
instance HasLocs Placement
instance HasLocs PolicyChoice
instance HasLocs Presence
instance HasLocs ProcessNode
instance HasLocs ProjectionSpec
instance HasLocs PublisherNode
instance HasLocs ReadModelNode
instance HasLocs RegDecl
instance HasLocs RegInitial
instance HasLocs ResolveDecl
instance HasLocs ResolveSource
instance HasLocs RmColumn
instance HasLocs RmFeed
instance HasLocs RmScope
instance HasLocs RouterDispatchNode
instance HasLocs RouterNode
instance HasLocs RuleDecl
instance HasLocs SagaRef
instance HasLocs SnapPolicy
instance HasLocs SnapshotSpec
instance HasLocs ScalarLiteral
instance HasLocs Spec
instance HasLocs StateDecl
instance HasLocs TimerNode
instance HasLocs Transition
instance HasLocs TransitionImplementation
instance HasLocs TransitionMode
instance HasLocs TypeExpr
instance HasLocs UnionEncoding
instance HasLocs UnknownFields
instance HasLocs WfBodyItem
instance HasLocs WireArm
instance HasLocs WireEnum
instance HasLocs WireField
instance HasLocs WireSource
instance HasLocs WireSpec
instance HasLocs WorkflowNode
instance HasLocs WorkqueueNode
instance HasLocs WqDispRow
instance HasLocs WqField
instance HasLocs WqGroupKey
instance HasLocs WqOrdering
instance HasLocs WqProvision