Interface.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | Reading a module's operators out of interface files.
module Tilia.Fixity.Interface
  ( Interface (..),
    readInterface,
    parseInterface,
    fromHiFile,
  )
where

import Control.DeepSeq (NFData)
import Control.Monad ((<=<))
import Data.ByteString qualified as BS
import Data.Char (isUpper)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe, maybeToList)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Read qualified as T
import GHC.Generics (Generic)
import Tilia.Fixity
import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..), decodeHiFile)
import Tilia.Process (readProgramOutput)
import Tilia.Utils (quietly)

-- | What an interface says about the operators a module offers.
data Interface = Interface
  { -- | The fixities the module declares itself, by the namespace each
    -- governs.
    interfaceDeclares :: Fixities,
    -- | The names it reexports, each with the source module.
    interfaceReexports :: [(Text, OpName)],
    -- | The members it exports with each name, which is what @T(..)@ in an
    -- import list stands for.
    interfaceMembers :: Map OpName (Set OpName),
    -- | What it certainly brings into scope, where the interface was decoded
    -- rather than read off what @ghc --show-iface@ prints.
    interfaceExports :: Maybe Certain
  }
  deriving (Eq, Show, Generic)

instance NFData Interface

-- | Read a module's interface file.
--
-- The file is decoded directly where it can be, and put to @ghc
-- --show-iface@ otherwise.
readInterface ::
  -- | The module the file is supposed to hold.
  Text ->
  -- | The file.
  FilePath ->
  IO (Maybe Interface)
readInterface modName path =
  quietly Nothing $
    (fromHiFile modName <=< decodeHiFile) <$> BS.readFile path >>= \case
      Right interface -> pure (Just interface)
      Left _ ->
        readProgramOutput "ghc" ["--show-iface", path] >>= \case
          Nothing -> pure Nothing
          Just out -> pure (parseInterface modName out)

-- | What a decoded interface file says, if it is this module's.
fromHiFile :: Text -> HiFile -> Either Text Interface
fromHiFile modName HiFile{..}
  | hiModule /= modName = Left ("the interface of " <> hiModule)
  | otherwise =
      Right
        Interface
          { interfaceDeclares =
              Map.fromList [((namespace, op), fixity) | (namespace, op, fixity) <- hiFixities],
            interfaceReexports =
              [ (m, op)
              | names <- exports,
                (Just m, _, op) <- names,
                m /= hiModule
              ],
            interfaceMembers = Map.map (Set.map snd) members,
            interfaceExports =
              Just
                Certain
                  { certainNames = Set.fromList [(namespace, op) | (_, namespace, op) <- exported],
                    certainMembers = members
                  }
          }
  where
    exports = concatMap resolved hiExports
    exported = concatMap exportedNames hiExports
    members =
      Map.fromListWith
        Set.union
        [ (op, Set.fromList [(namespace, kid) | (_, namespace, kid) <- kids])
        | parent@(_, _, op) : named <- exports,
          let kids = case named of
                first : rest | first == parent -> rest
                _ -> named,
          not (null kids)
        ]
    exportedNames = \case
      Avail n -> maybeToList (known n)
      AvailTC _ ns -> mapMaybe known ns
    resolved = \case
      Avail n -> maybe [] (pure . pure) (known n)
      AvailTC p ns ->
        let kids = mapMaybe known ns
         in maybe (fmap pure kids) (\named -> [named : kids]) (known p)
    known = \case
      HiName m namespace op -> Just (Just m, namespace, op)
      BuiltInSyntax namespace op -> Just (Nothing, namespace, op)
      Unneeded -> Nothing

-- | Read what @ghc --show-iface@ printed, if it is this module's interface.
parseInterface :: Text -> Text -> Maybe Interface
parseInterface modName out
  | not (any holdsModule (T.lines out)) = Nothing
  | otherwise =
      Just
        Interface
          { interfaceDeclares =
              namespaced
                (typeNamesIn out)
                (Map.fromList (concatMap declared (sectionsNamed "fixities"))),
            interfaceReexports = concatMap reexports (sectionsNamed "exports:"),
            interfaceMembers =
              Map.unionsWith Set.union (fmap membersIn (sectionsNamed "exports:")),
            interfaceExports = Nothing
          }
  where
    holdsModule l = case T.words l of
      ("interface" : m : _) -> m == modName
      _ -> False
    sectionsNamed name =
      [ T.replace "|{" "{" body
      | (heading, body) <- sections out,
        heading == name
      ]
    declared = mapMaybe fixityEntry . T.splitOn ","
    reexports = concatMap reexportsIn . T.words
    membersIn section =
      Map.fromListWith
        Set.union
        [ (nameOnly parent, Set.fromList (fmap nameOnly kids))
        | (parent, kids@(_ : _)) <- exportEntries section
        ]

-- | The names an interface declares as types.
typeNamesIn :: Text -> Set OpName
typeNamesIn out =
  Set.fromList
    [ nameOnly (T.dropWhileEnd (== ')') (T.dropWhile (== '(') name))
    | l <- T.lines out,
      indented l,
      (keyword : rest) <- [T.words l],
      keyword `elem` (["data", "type", "newtype", "class"] :: [Text]),
      name <- take 1 (dropWhile (`elem` (["family", "role", "instance"] :: [Text])) rest)
    ]
  where
    indented l = maybe False (== ' ') (fst <$> T.uncons l)

-- | Sort declared fixities into the namespaces they govern.
namespaced :: Set OpName -> Map OpName Fixity -> Fixities
namespaced types declared =
  Map.fromList
    [ ((namespace, op), fixity)
    | (op, fixity) <- Map.toList declared,
      namespace <- if Set.member op types then [InTypes] else [InTerms]
    ]

-- | Split the output into sections.
sections :: Text -> [(Text, Text)]
sections = go . T.lines
  where
    go = \case
      [] -> []
      (l : ls)
        | indented l -> go ls
        | otherwise ->
            let (body, rest) = span indented ls
                (heading, opening) = T.breakOn " " l
             in (heading, T.unwords (opening : body)) : go rest
    indented l = maybe False (== ' ') (fst <$> T.uncons l)

-- | One entry of a @fixities@ line: @infixl 9 !@ and the like.
fixityEntry :: Text -> Maybe (OpName, Fixity)
fixityEntry entry = case T.words entry of
  [direction, precedence, op] -> do
    d <- case direction of
      "infixl" -> Just LeftAssoc
      "infixr" -> Just RightAssoc
      "infix" -> Just NoAssoc
      _ -> Nothing
    p <- readPrecedence precedence
    pure (OpName op, Fixity d p)
  _ -> Nothing
  where
    -- Not one digit: GHC gives @->@ a precedence of -1, below anything the
    -- report allows anyone to write, and drops it into a fixities line like
    -- any other.
    readPrecedence t = case T.signed T.decimal t of
      Right (p, rest) | T.null rest -> Just p
      _ -> Nothing

-- | Split an exports section into its entries, keeping the members an entry
-- wears in braces with the name they belong to.
exportEntries :: Text -> [(Text, [Text])]
exportEntries = go
  where
    go text = case T.uncons (T.dropWhile (== ' ') text) of
      Nothing -> []
      Just _ ->
        let trimmed = T.dropWhile (== ' ') text
            (name, rest) = T.break (\c -> c == ' ' || c == '{') trimmed
         in case T.uncons rest of
              Just ('{', inside) ->
                let (kids, after) = T.break (== '}') inside
                 in (bare name, T.words kids) : go (T.drop 1 after)
              _ -> (bare name, []) : go rest
    bare = T.dropWhileEnd (== ',')

-- | An exported name without the module that declared it.
nameOnly :: Text -> OpName
nameOnly t = OpName (maybe t snd (moduleOf t))

-- | The names an export entry reexports, with the module that declared
-- each.
reexportsIn :: Text -> [(Text, OpName)]
reexportsIn = mapMaybe qualified . T.split (`elem` ("{}," :: String))
  where
    qualified name = case moduleOf name of
      Just (m, n) | not (T.null n) -> Just (m, OpName n)
      _ -> Nothing

-- | Split a name into the module that declared it and the name itself.
moduleOf :: Text -> Maybe (Text, Text)
moduleOf = go []
  where
    go seen t = case component t of
      Just (c, rest) -> go (c : seen) rest
      Nothing
        | null seen -> Nothing
        | otherwise -> Just (T.intercalate "." (reverse seen), t)
    component t = do
      (c, _) <- T.uncons t
      if isUpper c
        then case T.break (== '.') t of
          (before, rest)
            | Just after <- T.stripPrefix "." rest,
              not (T.null before) ->
                Just (before, after)
          _ -> Nothing
        else Nothing