Debug.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- | An account of how a module's fixities were determined.
module Tilia.Fixity.Debug
  ( FixityNotes (..),
    ImportNote (..),
    OperatorNote (..),
    fixityNotes,
    renderFixityNotes,
  )
where

import Data.Choice (Choice)
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Tilia.Fixity
  ( Certain (..),
    Established (..),
    Fixity (..),
    Import (..),
    ModuleChain (..),
    OpName (..),
    Provenance (..),
    Resolution (..),
    Scope (..),
    lookupFixity,
    moduleImports,
    operatorSpelling,
    operatorsUsed,
    reachAmbiguous,
    reachIn,
    reachUnqualified,
    spellDisagreement,
    spellFixity,
    spellModuleChain,
    spellUnreadIn,
  )
import Tilia.Palette (Color (Operator, Place), Palette, paint)
import Tilia.Parser (ParsedModule (..))
import Tilia.Utils (indent, lineWidth, wrapTo)

-- | Everything that decided one module's fixities.
data FixityNotes = FixityNotes
  { -- | What each import brought, in the order the module writes them.
    notedImports :: [ImportNote],
    -- | Resolutions per operator.
    notedOperators :: [OperatorNote],
    -- | What operators the module declares.
    notedDeclarations :: [(Text, Fixity)]
  }
  deriving (Eq, Show)

-- | One import in the module.
data ImportNote = ImportNote
  { -- | The module imported.
    noteModule :: Text,
    -- | The name it goes under here, when that differs from its own.
    noteAlias :: Maybe Text,
    -- | Whether it was imported qualified.
    noteQualified :: Bool,
    -- | How many operators it was read for, or 'Nothing' when it could not
    -- be read at all.
    noteOperatorCount :: Maybe Int,
    -- | Where reading it went before giving up, for each way that left some
    -- names unsettled, ending at the module that actually stopped it. Empty
    -- for an import that settles every name; a way is empty for one unread
    -- on its own account.
    noteUnsettled :: [[Text]]
  }
  deriving (Eq, Show)

-- | One operator the module uses.
data OperatorNote = OperatorNote
  { -- | The operator as the module writes it, qualifier and all.
    noteSpelling :: Text,
    -- | What the scope answered for it.
    noteResolution :: Resolution,
    -- | What each import in scope brings, where they disagree about it.
    noteDisagreement :: Maybe (NonEmpty (Text, Fixity))
  }
  deriving (Eq, Show)

-- | Record everything that decided one module's fixities.
fixityNotes ::
  -- | Whether @ImplicitPrelude@ is on, so that the Prelude is listed among
  -- the imports exactly when the module actually has it.
  Choice "implicitPrelude" ->
  -- | What reading each module in scope established, as the resolver
  -- answers it.
  (Text -> IO Established) ->
  -- | The scope the module was formatted under.
  Scope ->
  -- | The module's configurations.
  NonEmpty ParsedModule ->
  IO FixityNotes
fixityNotes implicitPrelude resolve scope configurations = do
  importNotes <- traverse alongside (moduleImports implicitPrelude (fmap pmModule configurations))
  pure
    FixityNotes
      { notedImports = importNotes,
        notedOperators = fmap aboutOperator used,
        notedDeclarations = here
      }
  where
    alongside i = do
      answer <- resolve (importModule i)
      let fixities = establishedFixities answer
          readNothing =
            Map.null fixities
              && Set.null (certainNames (establishedCertain answer))
              && not (Set.null (establishedUntold answer))
      pure
        ImportNote
          { noteModule = importModule i,
            noteAlias =
              if importAlias i == importModule i
                then Nothing
                else Just (importAlias i),
            noteQualified = importQualified i,
            noteOperatorCount =
              if readNothing
                then Nothing
                else Just (Set.size (Set.map snd (Map.keysSet fixities))),
            noteUnsettled =
              Set.toList (Map.keysSet (establishedUnsettled answer) <> establishedUntold answer)
          }

    used =
      Map.elems
        ( Map.fromList
            [ ((namespace, uncurry operatorSpelling u), (namespace, u))
            | (namespace, u) <- concatMap (operatorsUsed . pmGathered) configurations
            ]
        )

    here =
      [ (op, fixity)
      | (OpName op, (fixity, DeclaredHere)) <- Map.toList declaredHere
      ]
    declaredHere =
      Map.union
        (reachUnqualified (scopeInTerms scope))
        (reachUnqualified (scopeInTypes scope))

    aboutOperator (namespace, (qualifier, op)) =
      OperatorNote
        { noteSpelling = operatorSpelling qualifier op,
          noteResolution = lookupFixity scope namespace qualifier op,
          noteDisagreement =
            Map.lookup (qualifier, op) (reachAmbiguous (reachIn namespace scope))
        }

-- | Set out all the 'FixityNotes' per file.
renderFixityNotes :: Palette -> Map FilePath FixityNotes -> [Text]
renderFixityNotes palette notes =
  concat
    [ (indent 1 <> "fixities for " <> paint palette Place (T.pack path))
        : aboutFile palette told
    | (path, told) <- Map.toList notes
    ]

-- | One file's account, in reading order.
aboutFile :: Palette -> FixityNotes -> [Text]
aboutFile palette notes =
  concat
    [ section "imports" fromImport (notedImports notes),
      section "operators" fromOperator (notedOperators notes),
      section "declared here" fromOwn (notedDeclarations notes)
    ]
  where
    section what render items
      | null items = []
      | otherwise = heading what : concatMap (entry . render) items
    heading what = indent 2 <> "· " <> what

    entry line = case wrapTo (lineWidth - 8) line of
      [] -> []
      (opening : rest) -> (indent 3 <> "· " <> opening) : fmap (indent 4 <>) rest

    fromImport i =
      named (noteModule i)
        <> qualification i
        <> ": "
        <> case noteOperatorCount i of
          Nothing -> "could not be read" <> through (noteUnsettled i)
          Just n
            | null (noteUnsettled i) -> operators n
            | otherwise -> operators n <> ", not settling every name" <> through (noteUnsettled i)

    through ways = case mapMaybe nonEmpty ways of
      [] -> ""
      below ->
        ", through "
          <> T.intercalate
            " or "
            (fmap (spellModuleChain palette . ModuleChain) below)

    qualification i = case (noteQualified i, noteAlias i) of
      (True, Just alias) -> " qualified as " <> named alias
      (True, Nothing) -> " qualified"
      (False, Just alias) -> " as " <> named alias
      (False, Nothing) -> ""

    fromOwn (op, fixity) = operator op <> " " <> spellFixity fixity

    fromOperator o =
      operator (noteSpelling o)
        <> " "
        <> case noteResolution o of
          Resolved fixity provenance ->
            spellFixity fixity <> ", " <> from provenance <> ambiguously o
          Unresolved missing ->
            "unknown: may be declared in " <> spellUnreadIn palette missing

    from = \case
      DeclaredHere -> "declared in this module"
      DeclaredIn m -> "declared in " <> named m
      BuiltIn -> "built into the language"
      ReportDefault -> "the Report's default, nothing in scope declaring it"

    ambiguously o = case noteDisagreement o of
      Nothing -> ""
      Just offers ->
        ", and the imports disagree about it: " <> spellDisagreement palette offers

    named = paint palette Place
    operator = paint palette Operator

    operators = \case
      1 -> "1 operator"
      n -> T.pack (show n) <> " operators"