Externs.hs

{-# language PackageImports, BlockArguments #-}

module Language.PureScript.Ide.Externs
  ( readExternFile
  , convertExterns
  ) where

import Protolude hiding (to, from, (&))

import Codec.CBOR.Term as Term
import Control.Lens (preview, view, (&), (^.))
import "monad-logger" Control.Monad.Logger (MonadLogger, logErrorN)
import Data.Version (showVersion)
import Data.Text qualified as Text
import Language.PureScript qualified as P
import Language.PureScript.Make.Monad qualified as Make
import Language.PureScript.Ide.Error (IdeError (..))
import Language.PureScript.Ide.Types (IdeDataConstructor(..), IdeDeclaration(..), IdeDeclarationAnn(..), IdeType(..), IdeTypeClass(..), IdeTypeOperator(..), IdeTypeSynonym(..), IdeValue(..), IdeValueOperator(..), _IdeDeclType, anyOf, emptyAnn, ideTypeKind, ideTypeName)
import Language.PureScript.Ide.Util (properNameT)

readExternFile
  :: (MonadIO m, MonadError IdeError m, MonadLogger m)
  => FilePath
  -> m P.ExternsFile
readExternFile fp = do
  externsFile <- liftIO (Make.readCborFileIO fp)
  case externsFile of
    Just externs | version == P.efVersion externs ->
      pure externs
    _ ->
      liftIO (Make.readCborFileIO fp) >>= \case
        Just (Term.TList (_tag : Term.TString efVersion : _rest)) -> do
          let errMsg =
                "Version mismatch for the externs at: "
                <> toS fp
                <> " Expected: " <> version
                <> " Found: " <> efVersion
          logErrorN errMsg
          throwError (GeneralError errMsg)
        _ ->
          throwError (GeneralError ("Parsing the extern at: " <> toS fp <> " failed"))
    where
      version = toS (showVersion P.version)

convertExterns :: P.ExternsFile -> ([IdeDeclarationAnn], [(P.ModuleName, P.DeclarationRef)])
convertExterns ef =
  (decls, exportDecls)
  where
    decls = moduleDecl : map
      (IdeDeclarationAnn emptyAnn)
      (resolvedDeclarations <> operatorDecls <> tyOperatorDecls)
    exportDecls = mapMaybe convertExport (P.efExports ef)
    operatorDecls = convertOperator <$> P.efFixities ef
    tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef
    moduleDecl = IdeDeclarationAnn emptyAnn (IdeDeclModule (P.efModuleName ef))
    (toResolve, declarations) =
      second catMaybes (partitionEithers (map convertDecl (P.efDeclarations ef)))
    resolvedDeclarations = resolveSynonymsAndClasses toResolve declarations

resolveSynonymsAndClasses
  :: [ToResolve]
  -> [IdeDeclaration]
  -> [IdeDeclaration]
resolveSynonymsAndClasses trs decls = foldr go decls trs
  where
    go tr acc = case tr of
      TypeClassToResolve tcn ->
        case findType (P.coerceProperName tcn) acc of
          Nothing ->
            acc
          Just tyDecl -> IdeDeclTypeClass
            (IdeTypeClass tcn (tyDecl ^. ideTypeKind) [])
            : filter (not . anyOf (_IdeDeclType . ideTypeName) (== P.coerceProperName tcn)) acc
      SynonymToResolve tn ty ->
        case findType tn acc of
          Nothing ->
            acc
          Just tyDecl ->
            IdeDeclTypeSynonym (IdeTypeSynonym tn ty (tyDecl ^. ideTypeKind))
            : filter (not . anyOf (_IdeDeclType . ideTypeName) (== tn)) acc

findType :: P.ProperName 'P.TypeName -> [IdeDeclaration] -> Maybe IdeType
findType tn decls =
  decls
    & mapMaybe (preview _IdeDeclType)
    & find ((==) tn . view ideTypeName)

-- The Externs format splits information about synonyms across EDType
-- and EDTypeSynonym declarations. For type classes it split them
-- across an EDType and an EDClass . We collect these and resolve them
-- at the end of the conversion process.
data ToResolve
  = TypeClassToResolve (P.ProperName 'P.ClassName)
  | SynonymToResolve (P.ProperName 'P.TypeName) P.SourceType

convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef)
convertExport (P.ReExportRef _ src r) = Just (P.exportSourceDefinedIn src, r)
convertExport _ = Nothing

convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration)
convertDecl ed = case ed of
  -- We need to filter all types and synonyms that contain a '$'
  -- because those are typechecker internal definitions that shouldn't
  -- be user facing
  P.EDType{..} -> Right do
    guard (isNothing (Text.find (== '$') (edTypeName ^. properNameT)))
    Just (IdeDeclType (IdeType edTypeName edTypeKind []))
  P.EDTypeSynonym{..} ->
    if isNothing (Text.find (== '$') (edTypeSynonymName ^. properNameT))
      then Left (SynonymToResolve edTypeSynonymName edTypeSynonymType)
      else Right Nothing
  P.EDDataConstructor{..} -> Right do
    guard (isNothing (Text.find (== '$') (edDataCtorName ^. properNameT)))
    Just
      (IdeDeclDataConstructor
        (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))
  P.EDValue{..} ->
    Right (Just (IdeDeclValue (IdeValue edValueName edValueType)))
  P.EDClass{..} ->
    Left (TypeClassToResolve edClassName)
  P.EDInstance{} ->
    Right Nothing

convertOperator :: P.ExternsFixity -> IdeDeclaration
convertOperator P.ExternsFixity{..} =
  IdeDeclValueOperator
    (IdeValueOperator
      efOperator
      efAlias
      efPrecedence
      efAssociativity
      Nothing)

convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration
convertTypeOperator P.ExternsTypeFixity{..} =
  IdeDeclTypeOperator
    (IdeTypeOperator
      efTypeOperator
      efTypeAlias
      efTypePrecedence
      efTypeAssociativity
      Nothing)