Allow TS to be used for FFI modules

CHANGELOG.d/non_js_ffi-4587.md

@@ -0,0 +1 @@
+- Add `--ffi-exts` compiler option to allow non-JS FFI module implementations

CONTRIBUTORS.md

@@ -112,6 +112,7 @@ If you would prefer to use different terms, please use the section below instead
 | [@ncaq](https://github.com/ncaq) | ncaq | [MIT license] |
 | [@NickMolloy](https://github.com/NickMolloy) | Nick Molloy | [MIT license] |
 | [@nicodelpiano](https://github.com/nicodelpiano) | Nicolas Del Piano | [MIT license] |
+| [@noisyscanner](https://github.com/noisyscanner) | Brad Reed | [MIT license] |
 | [@noraesae](https://github.com/noraesae) | Hyunje Jun | [MIT license] |
 | [@nullobject](https://github.com/nullobject) | Josh Bassett | [MIT license] |
 | [@osa1](https://github.com/osa1) | Ömer Sinan Ağacan | [MIT license] |

app/Command/Compile.hs

@@ -73,7 +73,7 @@ compile PSCMakeOptions{..} = do
   (makeErrors, makeWarnings) <- runMake pscmOpts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
-    foreigns <- inferForeignModules filePathMap
+    foreigns <- inferForeignModules (P.optionsFFIExts pscmOpts) filePathMap
     let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
     P.make_ makeActions (map snd ms)
   printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors
@@ -133,12 +133,27 @@ targetParser =
       . T.unpack
       . T.strip
 
+ffiExtParser :: Opts.ReadM [String]
+ffiExtParser =
+  Opts.str >>= \s -> 
+    for (T.split (== ',') s)
+      $ pure . T.unpack . T.strip
+
+ffiExtensions :: Opts.Parser [String]
+ffiExtensions = Opts.option ffiExtParser $ Opts.long "ffi-exts"
+  <> Opts.value ["js"]
+  <> Opts.help
+      ( "Specifies comma-separated file extensions to consider for foriegn module implementations. "
+      <> "Defaults to js"
+      )
+
 options :: Opts.Parser P.Options
 options =
   P.Options
     <$> verboseErrors
     <*> (not <$> comments)
     <*> (handleTargets <$> codegenTargets)
+    <*> (S.fromList <$> ffiExtensions)
   where
     -- Ensure that the JS target is included if sourcemaps are
     handleTargets :: [P.CodegenTarget] -> S.Set P.CodegenTarget

src/Language/PureScript/Docs/Collect.hs

@@ -95,7 +95,8 @@ compileForDocs outputDir inputFiles = do
     fmap fst $ P.runMake testOptions $ do
       ms <- P.parseModulesFromFiles identity moduleFiles
       let filePathMap = Map.fromList $ map (\(fp, pm) -> (P.getModuleName $ P.resPartial pm, Right fp)) ms
-      foreigns <- P.inferForeignModules filePathMap
+      ffiExts <- asks P.optionsFFIExts
+      foreigns <- P.inferForeignModules ffiExts filePathMap
       let makeActions =
             (P.buildMakeActions outputDir filePathMap foreigns False)
               { P.progress = liftIO . TIO.hPutStr stdout . (<> "\n") . P.renderProgressMessage "documentation for "

src/Language/PureScript/Ide/Rebuild.hs

@@ -87,13 +87,14 @@ rebuildFile file actualFile codegenTargets runOpenBuild = do
   let filePathMap = M.singleton moduleName (Left P.RebuildAlways)
   let pureRebuild = fp == ""
   let modulePath = if pureRebuild then fp' else file
-  foreigns <- P.inferForeignModules (M.singleton moduleName (Right modulePath))
+  let opts = P.defaultOptions { P.optionsCodegenTargets = codegenTargets }
+  foreigns <- P.inferForeignModules (P.optionsFFIExts opts) (M.singleton moduleName (Right modulePath))
   let makeEnv = P.buildMakeActions outputDirectory filePathMap foreigns False
         & (if pureRebuild then enableForeignCheck foreigns codegenTargets . shushCodegen else identity)
         & shushProgress
   -- Rebuild the single module using the cached externs
   (result, warnings) <- logPerf (labelTimespec "Rebuilding Module") $
-    liftIO $ P.runMake (P.defaultOptions { P.optionsCodegenTargets = codegenTargets }) do
+    liftIO $ P.runMake opts do
       newExterns <- P.rebuildModule makeEnv externs m
       unless pureRebuild
         $ updateCacheDb codegenTargets outputDirectory file actualFile moduleName
@@ -137,7 +138,8 @@ updateCacheDb codegenTargets outputDirectory file actualFile moduleName = do
 
   foreignCacheInfo <-
     if S.member P.JS codegenTargets then do
-      foreigns' <- P.inferForeignModules (M.singleton moduleName (Right (fromMaybe file actualFile)))
+      let opts = P.defaultOptions { P.optionsCodegenTargets = codegenTargets }
+      foreigns' <- P.inferForeignModules (P.optionsFFIExts opts) (M.singleton moduleName (Right (fromMaybe file actualFile)))
       for (M.lookup moduleName foreigns') \foreignPath -> do
         foreignHash <- P.hashFile foreignPath
         pure (normaliseForCache cwd foreignPath, (dayZero, foreignHash))

src/Language/PureScript/Interactive.hs

@@ -81,12 +81,13 @@ make
   :: [(FilePath, CST.PartialResult P.Module)]
   -> P.Make ([P.ExternsFile], P.Environment)
 make ms = do
-    foreignFiles <- P.inferForeignModules filePathMap
-    externs <- P.make (buildActions foreignFiles) (map snd ms)
+    ffiExts <- asks P.optionsFFIExts
+    foreignFiles <- P.inferForeignModules ffiExts filePathMap
+    externs <- P.make (buildActions ffiExts foreignFiles) (map snd ms)
     return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
   where
-    buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
-    buildActions foreignFiles =
+    buildActions :: S.Set String -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make
+    buildActions _ffiExts foreignFiles =
       P.buildMakeActions modulesDir
                          filePathMap
                          foreignFiles

src/Language/PureScript/Make.hs

@@ -367,20 +367,30 @@ make' MakeOptions{..} ma@MakeActions{..} ms = do
     BuildPlan.markComplete buildPlan moduleName result
 
 -- | Infer the module name for a module by looking for the same filename with
--- a .js extension.
+-- an FFI extension (e.g., .js, .ts, or other configured extensions).
 inferForeignModules
   :: forall m
    . MonadIO m
-  => M.Map ModuleName (Either RebuildPolicy FilePath)
+  => S.Set String
+  -- ^ Set of FFI extensions to check (e.g., {"js", "ts"})
+  -> M.Map ModuleName (Either RebuildPolicy FilePath)
   -> m (M.Map ModuleName FilePath)
-inferForeignModules =
+inferForeignModules exts =
     fmap (M.mapMaybe id) . traverse inferForeignModule
   where
     inferForeignModule :: Either RebuildPolicy FilePath -> m (Maybe FilePath)
     inferForeignModule (Left _) = return Nothing
     inferForeignModule (Right path) = do
-      let jsFile = replaceExtension path "js"
-      exists <- liftIO $ doesFileExist jsFile
+      -- Try each extension in order
+      let extList = S.toList exts
+          candidates = map (replaceExtension path) extList
+      findFirst candidates
+
+    findFirst :: [FilePath] -> m (Maybe FilePath)
+    findFirst [] = return Nothing
+    findFirst (fp:fps) = do
+      exists <- liftIO $ doesFileExist fp
       if exists
-        then return (Just jsFile)
-        else return Nothing
+        then return (Just fp)
+        else findFirst fps
+

src/Language/PureScript/Make/Actions.hs

@@ -51,11 +51,12 @@ import Language.PureScript.Make.Cache (CacheDb, ContentHash, cacheDbIsCurrentVer
 import Language.PureScript.Names (Ident(..), ModuleName, runModuleName)
 import Language.PureScript.Options (CodegenTarget(..), Options(..))
 import Language.PureScript.Pretty.Common (SMap(..))
+import Language.PureScript.PSString (mkString)
 import Paths_purescript qualified as Paths
 import SourceMap (generate)
 import SourceMap.Types (Mapping(..), Pos(..), SourceMapping(..))
 import System.Directory (getCurrentDirectory)
-import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories)
+import System.FilePath ((</>), makeRelative, splitPath, normalise, splitDirectories, takeExtension)
 import System.FilePath.Posix qualified as Posix
 import System.IO (stderr)
 import Language.PureScript.Make.IdeCache ( sqliteExtern, sqliteInit)
@@ -299,11 +300,12 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
       lift $ writeJSONFile coreFnFile json
     when (S.member JS codegenTargets) $ do
       foreignInclude <- case mn `M.lookup` foreigns of
-        Just _
+        Just path
           | not $ requiresForeign m -> do
               return Nothing
           | otherwise -> do
-              return $ Just "./foreign.js"
+              let ext = takeExtension path
+              return $ Just (mkString $ T.pack $ "./foreign" ++ ext)
         Nothing | requiresForeign m -> throwError . errorMessage' (CF.moduleSourceSpan m) $ MissingFFIModule mn
                 | otherwise -> return Nothing
       rawJs <- J.moduleToJs m foreignInclude
@@ -375,12 +377,19 @@ data ForeignModuleType = ESModule | CJSModule deriving (Show)
 checkForeignDecls :: CF.Module ann -> FilePath -> Make (Either MultipleErrors (ForeignModuleType, S.Set Ident))
 -- checkForeignDecls :: CF.Module ann -> FilePath -> Make (ForeignModuleType, S.Set Ident
 checkForeignDecls m path = do
-  jsStr <- T.unpack <$> readTextFile path
-
-  let
-    parseResult :: Either MultipleErrors JS.JSAST
-    parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path
-  traverse checkFFI parseResult
+  if takeExtension path == ".js"
+    then do
+      jsStr <- T.unpack <$> readTextFile path
+
+      let
+        parseResult :: Either MultipleErrors JS.JSAST
+        parseResult = first (errorParsingModule . Bundle.UnableToParseModule) $ JS.parseModule jsStr path
+      traverse checkFFI parseResult
+    else do
+      -- We cannot parse non-JS files to check for exports
+      -- Instead return a successful ES module result without validation
+      let foreignIdents = S.fromList (CF.moduleForeign m)
+      return $ Right (ESModule, foreignIdents)
 
   where
   mname = CF.moduleName m
@@ -495,5 +504,6 @@ ffiCodegen' foreigns codegenTargets makeOutputPath m = do
   where
   requiresForeign = not . null . CF.moduleForeign
 
-  copyForeign path mn =
-    for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn "foreign.js"))
+  copyForeign path mn = do
+    let ext = takeExtension path
+    for_ makeOutputPath (\outputFilename -> copyFile path (outputFilename mn ("foreign" ++ ext)))

src/Language/PureScript/Options.hs

@@ -14,11 +14,12 @@ data Options = Options
   -- ^ Remove the comments from the generated js
   , optionsCodegenTargets :: S.Set CodegenTarget
   -- ^ Codegen targets (JS, CoreFn, etc.)
+  , optionsFFIExts :: S.Set String
   } deriving Show
 
 -- Default make options
 defaultOptions :: Options
-defaultOptions = Options False False (S.singleton JS)
+defaultOptions = Options False False (S.singleton JS) (S.singleton "js")
 
 data CodegenTarget = JS | JSSourceMap | CoreFn | Docs
   deriving (Eq, Ord, Show)
@@ -30,3 +31,4 @@ codegenTargets = Map.fromList
   , ("corefn", CoreFn)
   , ("docs", Docs)
   ]
+

tests/TestCompiler.hs

@@ -46,7 +46,8 @@ import System.IO.UTF8 (readUTF8File)
 import Text.Regex.Base (RegexContext(..), RegexMaker(..))
 import Text.Regex.TDFA (Regex)
 
-import TestUtils (ExpectedModuleName(..), SupportModules, compile, createOutputFile, getTestFiles, goldenVsString, modulesDir, trim)
+import Data.Set qualified as S
+import TestUtils (ExpectedModuleName(..), SupportModules, compile, compile', createOutputFile, getTestFiles, goldenVsString, modulesDir, trim)
 import Test.Hspec (Expectation, SpecWith, beforeAllWith, describe, expectationFailure, it, runIO)
 
 spec :: SpecWith SupportModules
@@ -134,7 +135,11 @@ assertCompiles
   -> Handle
   -> Expectation
 assertCompiles support inputFiles outputFile = do
-  (fileContents, (result, _)) <- compile (Just IsMain) support inputFiles
+  extraFfiExts <- getFfiExts (getTestMain inputFiles)
+  let opts = if null extraFfiExts
+        then P.defaultOptions
+        else P.defaultOptions { P.optionsFFIExts = S.fromList extraFfiExts `S.union` P.optionsFFIExts P.defaultOptions }
+  (fileContents, (result, _)) <- compile' opts (Just IsMain) support inputFiles
   let errorOptions = P.defaultPPEOptions { P.ppeFileContents = fileContents }
   case result of
     Left errs -> expectationFailure . P.prettyPrintMultipleErrors errorOptions $ errs
@@ -253,6 +258,11 @@ getShouldFailWith = extractPragma "shouldFailWith"
 getShouldWarnWith :: FilePath -> IO [String]
 getShouldWarnWith = extractPragma "shouldWarnWith"
 
+-- Scans a file for @ffiExts directives in the comments, used to
+-- determine additional FFI file extensions for the test
+getFfiExts :: FilePath -> IO [String]
+getFfiExts = extractPragma "ffiExts"
+
 extractPragma :: String -> FilePath -> IO [String]
 extractPragma pragma = fmap go . readUTF8File
   where

tests/TestMake.hs

@@ -11,6 +11,7 @@ import Language.PureScript.Make.IdeCache (sqliteInit)
 
 import Control.Concurrent (threadDelay)
 import Control.Monad (guard, void, forM_, when)
+import Control.Monad.Reader (asks)
 import Control.Exception (tryJust)
 import Control.Monad.IO.Class (liftIO)
 import Control.Concurrent.MVar (readMVar, newMVar, modifyMVar_)
@@ -703,7 +704,8 @@ compileWithOptions opts input = do
   (makeResult, _) <- P.runMake opts $ do
     ms <- CST.parseModulesFromFiles id moduleFiles
     let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
-    foreigns <- P.inferForeignModules filePathMap
+    ffiExts <- asks P.optionsFFIExts
+    foreigns <- P.inferForeignModules ffiExts filePathMap
     let makeActions =
           (P.buildMakeActions modulesDir filePathMap foreigns True)
             { P.progress = \case

tests/TestUtils.hs

@@ -22,6 +22,7 @@ import Data.Char (isSpace)
 import Data.Function (on)
 import Data.List (sort, sortBy, stripPrefix, groupBy, find)
 import Data.Map qualified as M
+import Data.Set (Set)
 import Data.Maybe (isJust)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
@@ -147,7 +148,7 @@ setupSupportModules = do
   ms <- getSupportModuleTuples
   let modules = map snd ms
   supportExterns <- runExceptT $ do
-    foreigns <- inferForeignModules ms
+    foreigns <- inferForeignModules (P.optionsFFIExts P.defaultOptions) ms
     externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules)
     return (externs, foreigns)
   case supportExterns of
@@ -206,7 +207,7 @@ compile' options expectedModule SupportModules{..} inputFiles = do
     msWithWarnings <- CST.parseFromFiles id fs
     tell $ foldMap (\(fp, (ws, _)) -> CST.toMultipleWarnings fp ws) msWithWarnings
     let ms = fmap snd <$> msWithWarnings
-    foreigns <- inferForeignModules ms
+    foreigns <- inferForeignModules (P.optionsFFIExts options) ms
     let
       actions = makeActions supportModules (foreigns `M.union` supportForeigns)
       (hasExpectedModuleName, expectedModuleName, compiledModulePath) = case expectedModule of
@@ -240,7 +241,7 @@ getPsModuleName psModule = case snd psModule of
   AST.Module _ _ (N.ModuleName t) _ _ -> t
 
 makeActions :: [P.Module] -> M.Map P.ModuleName FilePath -> P.MakeActions P.Make
-makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns False)
+makeActions modules foreigns = (P.buildMakeActions modulesDir (P.internalError "makeActions: input file map was read.") foreigns mempty False)
                                { P.getInputTimestampsAndHashes = getInputTimestampsAndHashes
                                , P.getOutputTimestamp = getOutputTimestamp
                                , P.progress = const (pure ())
@@ -267,9 +268,10 @@ runTest action = do
 
 inferForeignModules
   :: MonadIO m
-  => [(FilePath, P.Module)]
+  => Set String
+  -> [(FilePath, P.Module)]
   -> m (M.Map P.ModuleName FilePath)
-inferForeignModules = P.inferForeignModules . fromList
+inferForeignModules exts = P.inferForeignModules exts . fromList
   where
     fromList :: [(FilePath, P.Module)] -> M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
     fromList = M.fromList . map ((P.getModuleName *** Right) . swap)

tests/purs/failing/MissingFFIModuleUnknownExt.purs

@@ -0,0 +1,6 @@
+-- @shouldFailWith MissingFFIModule
+module Main where
+
+foreign import greeting :: String
+
+main = greeting

tests/purs/failing/MissingFFIModuleUnknownExt.ts

@@ -0,0 +1 @@
+export const greeting = "hello";

tests/purs/passing/TSFFI.purs

@@ -0,0 +1,9 @@
+-- @ffiExts ts
+module Main where
+
+import Prelude
+import Effect.Console (log)
+
+foreign import functionName :: String -> String
+
+main = log "Done"

tests/purs/passing/TSFFI.ts

@@ -0,0 +1,3 @@
+export function functionName(foo: string) {
+  return foo;
+}