HaskellName.hs

-- | Checked names for every Haskell declaration generated by keiro-dsl.
--
-- Logical DSL names and external spellings remain ordinary 'Text'.  A value
-- crosses into generated Haskell only through the total constructors in this
-- module, which share one ASCII word-segmentation policy and one keyword set.
module Keiro.Dsl.HaskellName
  ( UpperCamelName,
    LowerCamelName,
    HaskellModuleSegment,
    HaskellModuleName,
    DerivedHaskellName (..),
    NameSourceKind (..),
    NameSiteKind (..),
    HaskellOccurrenceSpace (..),
    NameSite (..),
    HaskellOccurrenceKey (..),
    PlannedOccurrence (..),
    HaskellNameError (..),
    GeneratedHaskellNamingEdition (..),
    currentGeneratedHaskellNamingEdition,
    renderGeneratedHaskellNamingEdition,
    parseGeneratedHaskellNamingEdition,
    deriveHaskellName,
    checkedModuleSegment,
    checkedModuleName,
    checkedUpperOccurrence,
    checkedLowerOccurrence,
    plannedOccurrence,
    detectNameCollisions,
    renderUpperCamelName,
    renderLowerCamelName,
    renderModuleSegment,
    renderModuleName,
    haskellKeywords,
  )
where

import Data.Char (toLower, toUpper)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as Map
import Data.Maybe (listToMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T

newtype UpperCamelName = UpperCamelName Text
  deriving stock (Eq, Ord, Show)

newtype LowerCamelName = LowerCamelName Text
  deriving stock (Eq, Ord, Show)

newtype HaskellModuleSegment = HaskellModuleSegment Text
  deriving stock (Eq, Ord, Show)

newtype HaskellModuleName = HaskellModuleName Text
  deriving stock (Eq, Ord, Show)

data DerivedHaskellName = DerivedHaskellName
  { upperCamel :: !UpperCamelName,
    lowerCamel :: !LowerCamelName
  }
  deriving stock (Eq, Show)

data NameSourceKind
  = LogicalIdentifier
  | LogicalWireWord
  | ExplicitHaskellName
  deriving stock (Eq, Ord, Show)

-- | Stable declaration categories used in diagnostics and source-move roles.
data NameSiteKind
  = ContextModuleSite
  | NodeModuleSite
  | GeneratedTypeSite
  | GeneratedConstructorSite
  | GeneratedValueSite
  | GeneratedFieldSite
  | GeneratedHelperSite
  | ImportAliasSite
  deriving stock (Eq, Ord, Enum, Bounded, Show)

data HaskellOccurrenceSpace
  = ModuleSpace
  | TypeSpace
  | ConstructorSpace
  | ValueSpace
  | FieldSpace
  deriving stock (Eq, Ord, Enum, Bounded, Show)

-- | The source declaration responsible for a generated occurrence.  The
-- owner and kind form a stable identity; the line is evidence, not identity.
data NameSite = NameSite
  { siteKind :: !NameSiteKind,
    siteLogicalName :: !Text,
    siteOwner :: !Text,
    siteLine :: !Int
  }
  deriving stock (Eq, Ord, Show)

-- | A collision key.  Module names are compared case-insensitively because
-- generated trees must remain safe on case-insensitive filesystems.  Scope is
-- normally empty; record fields use their owning record so
-- DuplicateRecordFields can keep identical selectors on different records.
data HaskellOccurrenceKey = HaskellOccurrenceKey
  { occurrenceModule :: !Text,
    occurrenceSpace :: !HaskellOccurrenceSpace,
    occurrenceScope :: !Text,
    occurrenceName :: !Text
  }
  deriving stock (Eq, Ord, Show)

data PlannedOccurrence = PlannedOccurrence
  { plannedOccurrenceKey :: !HaskellOccurrenceKey,
    plannedOccurrenceSite :: !NameSite
  }
  deriving stock (Eq, Ord, Show)

data HaskellNameError
  = EmptyNameSegment !NameSite
  | UnsafeNameSeparator !NameSite !Text
  | ReservedGeneratedOccurrence !NameSite !Text
  | NormalizedNameCollision !HaskellOccurrenceKey !(NonEmpty NameSite)
  | InvalidExplicitHaskellName !NameSite !Text
  deriving stock (Eq, Show)

data GeneratedHaskellNamingEdition
  = LegacyNamingV1
  | IdiomaticNamingV1
  deriving stock (Eq, Ord, Show)

currentGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition
currentGeneratedHaskellNamingEdition = IdiomaticNamingV1

renderGeneratedHaskellNamingEdition :: GeneratedHaskellNamingEdition -> Text
renderGeneratedHaskellNamingEdition = \case
  LegacyNamingV1 -> "legacy-v1"
  IdiomaticNamingV1 -> "idiomatic-v1"

parseGeneratedHaskellNamingEdition :: Text -> Maybe GeneratedHaskellNamingEdition
parseGeneratedHaskellNamingEdition = \case
  "legacy-v1" -> Just LegacyNamingV1
  "idiomatic-v1" -> Just IdiomaticNamingV1
  _ -> Nothing

renderUpperCamelName :: UpperCamelName -> Text
renderUpperCamelName (UpperCamelName value) = value

renderLowerCamelName :: LowerCamelName -> Text
renderLowerCamelName (LowerCamelName value) = value

renderModuleSegment :: HaskellModuleSegment -> Text
renderModuleSegment (HaskellModuleSegment value) = value

renderModuleName :: HaskellModuleName -> Text
renderModuleName (HaskellModuleName value) = value

-- | Derive both Haskell cases from exactly the same word list.  Explicit
-- Haskell references are checked by the namespace-specific smart constructors
-- below and are intentionally never re-cased here.
deriveHaskellName :: NameSourceKind -> NameSite -> Either HaskellNameError DerivedHaskellName
deriveHaskellName source site
  | source == ExplicitHaskellName = Left (InvalidExplicitHaskellName site (siteLogicalName site))
  | otherwise = do
      words' <- segmentLogicalName (source == LogicalWireWord) site
      case words' of
        [] -> Left (EmptyNameSegment site)
        firstWord : restWords -> do
          let upper = T.concat (map upperWord words')
              lower = lowerFirstWord firstWord <> T.concat (map upperWord restWords)
          upperName <- checkedUpperOccurrence site upper
          lowerName <- checkedLowerOccurrence site lower
          pure DerivedHaskellName {upperCamel = upperName, lowerCamel = lowerName}

checkedModuleSegment :: NameSite -> Text -> Either HaskellNameError HaskellModuleSegment
checkedModuleSegment site candidate
  | validUpperIdentifier False candidate = Right (HaskellModuleSegment candidate)
  | otherwise = Left (InvalidExplicitHaskellName site candidate)

checkedModuleName :: NameSite -> Text -> Either HaskellNameError HaskellModuleName
checkedModuleName site candidate
  | not (null components) && all (validUpperIdentifier True) components = Right (HaskellModuleName candidate)
  | otherwise = Left (InvalidExplicitHaskellName site candidate)
  where
    components = T.splitOn "." candidate

checkedUpperOccurrence :: NameSite -> Text -> Either HaskellNameError UpperCamelName
checkedUpperOccurrence site candidate
  | validUpperIdentifier False candidate = Right (UpperCamelName candidate)
  | otherwise = Left (InvalidExplicitHaskellName site candidate)

checkedLowerOccurrence :: NameSite -> Text -> Either HaskellNameError LowerCamelName
checkedLowerOccurrence site candidate
  | Set.member candidate haskellKeywords = Left (ReservedGeneratedOccurrence site candidate)
  | validLowerIdentifier candidate = Right (LowerCamelName candidate)
  | otherwise = Left (InvalidExplicitHaskellName site candidate)

-- | Construct a collision input after the occurrence has passed its checked
-- wrapper.  Field scope is the owning record name; use the empty string for
-- every other namespace.
plannedOccurrence :: Text -> HaskellOccurrenceSpace -> Text -> Text -> NameSite -> PlannedOccurrence
plannedOccurrence targetModule space scope rendered site =
  PlannedOccurrence
    { plannedOccurrenceKey =
        HaskellOccurrenceKey
          { occurrenceModule = T.toCaseFold targetModule,
            occurrenceSpace = space,
            occurrenceScope = T.toCaseFold scope,
            occurrenceName = case space of
              ModuleSpace -> T.toCaseFold rendered
              _ -> rendered
          },
      plannedOccurrenceSite = site
    }

-- | Report deterministic collisions independently of declaration traversal
-- order.  Repeated inventory entries for the same stable site are collapsed.
detectNameCollisions :: [PlannedOccurrence] -> [HaskellNameError]
detectNameCollisions occurrences =
  [ NormalizedNameCollision key (first :| rest)
  | (key, sites) <- Map.toAscList grouped,
    let orderedSites = Set.toAscList sites,
    first : rest <- [orderedSites]
  ]
  where
    grouped =
      Map.filter ((> 1) . Set.size) $
        Map.fromListWith
          Set.union
          [ (plannedOccurrenceKey occurrence, Set.singleton (plannedOccurrenceSite occurrence))
          | occurrence <- sortOn plannedOccurrenceKey occurrences
          ]

segmentLogicalName :: Bool -> NameSite -> Either HaskellNameError [Text]
segmentLogicalName allowHyphen site
  | T.null raw = Left (EmptyNameSegment site)
  | badUnderscore = Left (UnsafeNameSeparator site "underscore separators must be single and may not lead or trail a name")
  | not allowHyphen && T.any (== '-') raw = Left (UnsafeNameSeparator site "hyphens are allowed only in wire-word sources")
  | allowHyphen && badHyphen = Left (UnsafeNameSeparator site "hyphen separators must be single and may not lead or trail a name")
  | any T.null separated = Left (EmptyNameSegment site)
  | otherwise = Right (concatMap splitCamelWord separated)
  where
    raw = siteLogicalName site
    badUnderscore =
      T.isPrefixOf "_" raw
        || T.isSuffixOf "_" raw
        || T.isInfixOf "__" raw
    badHyphen =
      T.isPrefixOf "-" raw
        || T.isSuffixOf "-" raw
        || T.isInfixOf "--" raw
    separated = T.split (`elem` separators) raw
    separators = if allowHyphen then ['_', '-'] else ['_']

splitCamelWord :: Text -> [Text]
splitCamelWord value = map T.pack (go [] (T.unpack value))
  where
    go current [] = [reverse current | not (null current)]
    go [] (character : rest) = go [character] rest
    go current@(previous : _) remaining@(character : rest)
      | camelBoundary previous character (listToMaybe rest) = reverse current : go [] remaining
      | otherwise = go (character : current) rest

camelBoundary :: Char -> Char -> Maybe Char -> Bool
camelBoundary previous current next =
  (asciiLower previous || asciiDigit previous) && asciiUpper current
    || asciiUpper previous && asciiUpper current && maybe False asciiLower next

upperWord :: Text -> Text
upperWord word = case T.uncons word of
  Nothing -> ""
  Just (first, rest) -> T.cons (asciiToUpper first) rest

lowerFirstWord :: Text -> Text
lowerFirstWord word
  | hasUpper && T.all (\character -> not (asciiLower character)) word = T.map asciiToLower word
  | otherwise = case T.uncons word of
      Nothing -> ""
      Just (first, rest) -> T.cons (asciiToLower first) rest
  where
    hasUpper = T.any asciiUpper word

validUpperIdentifier :: Bool -> Text -> Bool
validUpperIdentifier allowUnderscore name = case T.uncons name of
  Just (first, rest) -> asciiUpper first && T.all (identifierTail allowUnderscore) rest
  Nothing -> False

validLowerIdentifier :: Text -> Bool
validLowerIdentifier name = case T.uncons name of
  Just (first, rest) -> asciiLower first && T.all (identifierTail False) rest
  Nothing -> False

identifierTail :: Bool -> Char -> Bool
identifierTail allowUnderscore character =
  asciiUpper character
    || asciiLower character
    || asciiDigit character
    || character == '\''
    || allowUnderscore && character == '_'

asciiUpper :: Char -> Bool
asciiUpper character = character >= 'A' && character <= 'Z'

asciiLower :: Char -> Bool
asciiLower character = character >= 'a' && character <= 'z'

asciiDigit :: Char -> Bool
asciiDigit character = character >= '0' && character <= '9'

asciiToUpper :: Char -> Char
asciiToUpper character
  | asciiLower character = toUpper character
  | otherwise = character

asciiToLower :: Char -> Char
asciiToLower character
  | asciiUpper character = toLower character
  | otherwise = character

-- | Words GHC rejects as term-level identifiers under the generated manifest
-- contract (GHC2024 plus the closed local-extension set in ADR 0019). Contextual
-- words are deliberately absent; widening this refusal set requires compile
-- evidence against that exact contract.
haskellKeywords :: Set Text
haskellKeywords =
  Set.fromList
    [ "case",
      "class",
      "data",
      "default",
      "deriving",
      "do",
      "else",
      "foreign",
      "forall",
      "if",
      "import",
      "in",
      "infix",
      "infixl",
      "infixr",
      "instance",
      "let",
      "module",
      "newtype",
      "of",
      "then",
      "type",
      "where"
    ]