module Language.PureScript.Make.Actions
  ( MakeActions(..)
  , RebuildPolicy(..)
  , ProgressMessage(..)
  , renderProgressMessage
  , buildMakeActions
  , checkForeignDecls
  , cacheDbFile
  , readCacheDb'
  , writeCacheDb'
  , ffiCodegen'
  ) where

import Prelude

import Control.Monad (unless, when)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (asks)
import Control.Monad.Supply (SupplyT)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Aeson (Value(String), (.=), object)
import Data.Bifunctor (bimap, first)
import Data.Either (partitionEithers)
import Data.Foldable (for_)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M
import Data.Maybe (fromMaybe, maybeToList)
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Data.Text.Encoding qualified as TE
import Data.Time.Clock (UTCTime)
import Data.Version (showVersion)
import Language.JavaScript.Parser qualified as JS
import Language.PureScript.AST (SourcePos(..))
import Language.PureScript.Bundle qualified as Bundle
import Language.PureScript.CodeGen.JS qualified as J
import Language.PureScript.CodeGen.JS.Printer (prettyPrintJS, prettyPrintJSWithSourceMaps)
import Language.PureScript.CoreFn qualified as CF
import Language.PureScript.CoreFn.ToJSON qualified as CFJ
import Language.PureScript.Crash (internalError)
import Language.PureScript.CST qualified as CST
import Language.PureScript.Docs.Prim qualified as Docs.Prim
import Language.PureScript.Docs.Types qualified as Docs
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage, errorMessage')
import Language.PureScript.Externs (ExternsFile, externsFileName)
import Language.PureScript.Make.Monad (Make, copyFile, getTimestamp, getTimestampMaybe, hashFile, makeIO, readExternsFile, readJSONFile, readTextFile, writeCborFile, writeJSONFile, writeTextFile)
import Language.PureScript.Make.Cache (CacheDb, ContentHash, normaliseForCache)
import Language.PureScript.Names (Ident(..), ModuleName, runModuleName)
import Language.PureScript.Options (CodegenTarget(..), Options(..))
import Language.PureScript.Pretty.Common (SMap(..))
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.Posix qualified as Posix
import System.IO (stderr)

-- | Determines when to rebuild a module
data RebuildPolicy
  -- | Never rebuild this module
  = RebuildNever
  -- | Always rebuild this module
  | RebuildAlways
  deriving (Int -> RebuildPolicy -> ShowS
[RebuildPolicy] -> ShowS
RebuildPolicy -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RebuildPolicy] -> ShowS
$cshowList :: [RebuildPolicy] -> ShowS
show :: RebuildPolicy -> FilePath
$cshow :: RebuildPolicy -> FilePath
showsPrec :: Int -> RebuildPolicy -> ShowS
$cshowsPrec :: Int -> RebuildPolicy -> ShowS
Show, RebuildPolicy -> RebuildPolicy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RebuildPolicy -> RebuildPolicy -> Bool
$c/= :: RebuildPolicy -> RebuildPolicy -> Bool
== :: RebuildPolicy -> RebuildPolicy -> Bool
$c== :: RebuildPolicy -> RebuildPolicy -> Bool
Eq, Eq RebuildPolicy
RebuildPolicy -> RebuildPolicy -> Bool
RebuildPolicy -> RebuildPolicy -> Ordering
RebuildPolicy -> RebuildPolicy -> RebuildPolicy
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RebuildPolicy -> RebuildPolicy -> RebuildPolicy
$cmin :: RebuildPolicy -> RebuildPolicy -> RebuildPolicy
max :: RebuildPolicy -> RebuildPolicy -> RebuildPolicy
$cmax :: RebuildPolicy -> RebuildPolicy -> RebuildPolicy
>= :: RebuildPolicy -> RebuildPolicy -> Bool
$c>= :: RebuildPolicy -> RebuildPolicy -> Bool
> :: RebuildPolicy -> RebuildPolicy -> Bool
$c> :: RebuildPolicy -> RebuildPolicy -> Bool
<= :: RebuildPolicy -> RebuildPolicy -> Bool
$c<= :: RebuildPolicy -> RebuildPolicy -> Bool
< :: RebuildPolicy -> RebuildPolicy -> Bool
$c< :: RebuildPolicy -> RebuildPolicy -> Bool
compare :: RebuildPolicy -> RebuildPolicy -> Ordering
$ccompare :: RebuildPolicy -> RebuildPolicy -> Ordering
Ord)

-- | Progress messages from the make process
data ProgressMessage
  = CompilingModule ModuleName (Maybe (Int, Int))
  -- ^ Compilation started for the specified module
  deriving (Int -> ProgressMessage -> ShowS
[ProgressMessage] -> ShowS
ProgressMessage -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ProgressMessage] -> ShowS
$cshowList :: [ProgressMessage] -> ShowS
show :: ProgressMessage -> FilePath
$cshow :: ProgressMessage -> FilePath
showsPrec :: Int -> ProgressMessage -> ShowS
$cshowsPrec :: Int -> ProgressMessage -> ShowS
Show, ProgressMessage -> ProgressMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProgressMessage -> ProgressMessage -> Bool
$c/= :: ProgressMessage -> ProgressMessage -> Bool
== :: ProgressMessage -> ProgressMessage -> Bool
$c== :: ProgressMessage -> ProgressMessage -> Bool
Eq, Eq ProgressMessage
ProgressMessage -> ProgressMessage -> Bool
ProgressMessage -> ProgressMessage -> Ordering
ProgressMessage -> ProgressMessage -> ProgressMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ProgressMessage -> ProgressMessage -> ProgressMessage
$cmin :: ProgressMessage -> ProgressMessage -> ProgressMessage
max :: ProgressMessage -> ProgressMessage -> ProgressMessage
$cmax :: ProgressMessage -> ProgressMessage -> ProgressMessage
>= :: ProgressMessage -> ProgressMessage -> Bool
$c>= :: ProgressMessage -> ProgressMessage -> Bool
> :: ProgressMessage -> ProgressMessage -> Bool
$c> :: ProgressMessage -> ProgressMessage -> Bool
<= :: ProgressMessage -> ProgressMessage -> Bool
$c<= :: ProgressMessage -> ProgressMessage -> Bool
< :: ProgressMessage -> ProgressMessage -> Bool
$c< :: ProgressMessage -> ProgressMessage -> Bool
compare :: ProgressMessage -> ProgressMessage -> Ordering
$ccompare :: ProgressMessage -> ProgressMessage -> Ordering
Ord)

-- | Render a progress message
renderProgressMessage :: T.Text -> ProgressMessage -> T.Text
renderProgressMessage :: Text -> ProgressMessage -> Text
renderProgressMessage Text
infx (CompilingModule ModuleName
mn Maybe (Int, Int)
mi) =
  [Text] -> Text
T.concat
    [ Maybe (Int, Int) -> Text
renderProgressIndex Maybe (Int, Int)
mi
    , Text
infx
    , ModuleName -> Text
runModuleName ModuleName
mn
    ]
  where
  renderProgressIndex :: Maybe (Int, Int) -> T.Text
  renderProgressIndex :: Maybe (Int, Int) -> Text
renderProgressIndex = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" forall a b. (a -> b) -> a -> b
$ \(Int
start, Int
end) ->
    let start' :: Text
start' = FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
start)
        end' :: Text
end' = FilePath -> Text
T.pack (forall a. Show a => a -> FilePath
show Int
end)
        preSpace :: Text
preSpace = Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
end' forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
start') Text
" "
    in Text
"[" forall a. Semigroup a => a -> a -> a
<> Text
preSpace forall a. Semigroup a => a -> a -> a
<> Text
start' forall a. Semigroup a => a -> a -> a
<> Text
" of " forall a. Semigroup a => a -> a -> a
<> Text
end' forall a. Semigroup a => a -> a -> a
<> Text
"] "

-- | Actions that require implementations when running in "make" mode.
--
-- This type exists to make two things abstract:
--
-- * The particular backend being used (JavaScript, C++11, etc.)
--
-- * The details of how files are read/written etc.
data MakeActions m = MakeActions
  { forall (m :: * -> *).
MakeActions m
-> ModuleName
-> m (Either RebuildPolicy (Map FilePath (UTCTime, m ContentHash)))
getInputTimestampsAndHashes :: ModuleName -> m (Either RebuildPolicy (M.Map FilePath (UTCTime, m ContentHash)))
  -- ^ Get the timestamps and content hashes for the input files for a module.
  -- The content hash is returned as a monadic action so that the file does not
  -- have to be read if it's not necessary.
  , forall (m :: * -> *).
MakeActions m -> ModuleName -> m (Maybe UTCTime)
getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
  -- ^ Get the time this module was last compiled, provided that all of the
  -- requested codegen targets were also produced then. The defaultMakeActions
  -- implementation uses the modification time of the externs file, because the
  -- externs file is written first and we always write one. If there is no
  -- externs file, or if any of the requested codegen targets were not produced
  -- the last time this module was compiled, this function must return Nothing;
  -- this indicates that the module will have to be recompiled.
  , forall (m :: * -> *).
MakeActions m -> ModuleName -> m (FilePath, Maybe ExternsFile)
readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
  -- ^ Read the externs file for a module as a string and also return the actual
  -- path for the file.
  , forall (m :: * -> *).
MakeActions m
-> Module Ann -> Module -> ExternsFile -> SupplyT m ()
codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
  -- ^ Run the code generator for the module and write any required output files.
  , forall (m :: * -> *). MakeActions m -> Module Ann -> m ()
ffiCodegen :: CF.Module CF.Ann -> m ()
  -- ^ Check ffi and print it in the output directory.
  , forall (m :: * -> *). MakeActions m -> ProgressMessage -> m ()
progress :: ProgressMessage -> m ()
  -- ^ Respond to a progress update.
  , forall (m :: * -> *). MakeActions m -> m CacheDb
readCacheDb :: m CacheDb
  -- ^ Read the cache database (which contains timestamps and hashes for input
  -- files) from some external source, e.g. a file on disk.
  , forall (m :: * -> *). MakeActions m -> CacheDb -> m ()
writeCacheDb :: CacheDb -> m ()
  -- ^ Write the given cache database to some external source (e.g. a file on
  -- disk).
  , forall (m :: * -> *). MakeActions m -> m ()
writePackageJson :: m ()
  -- ^ Write to the output directory the package.json file allowing Node.js to
  -- load .js files as ES modules.
  , forall (m :: * -> *). MakeActions m -> m ()
outputPrimDocs :: m ()
  -- ^ If generating docs, output the documentation for the Prim modules
  }

-- | Given the output directory, determines the location for the
-- CacheDb file
cacheDbFile :: FilePath -> FilePath
cacheDbFile :: ShowS
cacheDbFile = (FilePath -> ShowS
</> FilePath
"cache-db.json")

readCacheDb'
  :: (MonadIO m, MonadError MultipleErrors m)
  => FilePath
  -- ^ The path to the output directory
  -> m CacheDb
readCacheDb' :: forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m CacheDb
readCacheDb' FilePath
outputDir =
  forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, FromJSON a) =>
FilePath -> m (Maybe a)
readJSONFile (ShowS
cacheDbFile FilePath
outputDir)

writeCacheDb'
  :: (MonadIO m, MonadError MultipleErrors m)
  => FilePath
  -- ^ The path to the output directory
  -> CacheDb
  -- ^ The CacheDb to be written
  -> m ()
writeCacheDb' :: forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> CacheDb -> m ()
writeCacheDb' = forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
cacheDbFile

writePackageJson'
  :: (MonadIO m, MonadError MultipleErrors m)
  => FilePath
  -- ^ The path to the output directory
  -> m ()
writePackageJson' :: forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m ()
writePackageJson' FilePath
outputDir = forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile (FilePath
outputDir FilePath -> ShowS
</> FilePath
"package.json") forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
  [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"module"
  ]

-- | A set of make actions that read and write modules from the given directory.
buildMakeActions
  :: FilePath
  -- ^ the output directory
  -> M.Map ModuleName (Either RebuildPolicy FilePath)
  -- ^ a map between module names and paths to the file containing the PureScript module
  -> M.Map ModuleName FilePath
  -- ^ a map between module name and the file containing the foreign javascript for the module
  -> Bool
  -- ^ Generate a prefix comment?
  -> MakeActions Make
buildMakeActions :: FilePath
-> Map ModuleName (Either RebuildPolicy FilePath)
-> Map ModuleName FilePath
-> Bool
-> MakeActions Make
buildMakeActions FilePath
outputDir Map ModuleName (Either RebuildPolicy FilePath)
filePathMap Map ModuleName FilePath
foreigns Bool
usePrefix =
    forall (m :: * -> *).
(ModuleName
 -> m (Either
         RebuildPolicy (Map FilePath (UTCTime, m ContentHash))))
-> (ModuleName -> m (Maybe UTCTime))
-> (ModuleName -> m (FilePath, Maybe ExternsFile))
-> (Module Ann -> Module -> ExternsFile -> SupplyT m ())
-> (Module Ann -> m ())
-> (ProgressMessage -> m ())
-> m CacheDb
-> (CacheDb -> m ())
-> m ()
-> m ()
-> MakeActions m
MakeActions ModuleName
-> Make
     (Either RebuildPolicy (Map FilePath (UTCTime, Make ContentHash)))
getInputTimestampsAndHashes ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp ModuleName -> Make (FilePath, Maybe ExternsFile)
readExterns Module Ann -> Module -> ExternsFile -> SupplyT Make ()
codegen Module Ann -> Make ()
ffiCodegen ProgressMessage -> Make ()
progress Make CacheDb
readCacheDb CacheDb -> Make ()
writeCacheDb Make ()
writePackageJson Make ()
outputPrimDocs
  where

  getInputTimestampsAndHashes
    :: ModuleName
    -> Make (Either RebuildPolicy (M.Map FilePath (UTCTime, Make ContentHash)))
  getInputTimestampsAndHashes :: ModuleName
-> Make
     (Either RebuildPolicy (Map FilePath (UTCTime, Make ContentHash)))
getInputTimestampsAndHashes ModuleName
mn = do
    let path :: Either RebuildPolicy FilePath
path = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => FilePath -> a
internalError FilePath
"Module has no filename in 'make'") forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
mn Map ModuleName (Either RebuildPolicy FilePath)
filePathMap
    case Either RebuildPolicy FilePath
path of
      Left RebuildPolicy
policy ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left RebuildPolicy
policy)
      Right FilePath
filePath -> do
        FilePath
cwd <- forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m) =>
Text -> IO a -> m a
makeIO Text
"Getting the current directory" IO FilePath
getCurrentDirectory
        let inputPaths :: [FilePath]
inputPaths = forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ShowS
normaliseForCache FilePath
cwd) (FilePath
filePath forall a. a -> [a] -> [a]
: forall a. Maybe a -> [a]
maybeToList (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
mn Map ModuleName FilePath
foreigns))
            getInfo :: FilePath -> m (UTCTime, m ContentHash)
getInfo FilePath
fp = do
              UTCTime
ts <- forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m UTCTime
getTimestamp FilePath
fp
              forall (m :: * -> *) a. Monad m => a -> m a
return (UTCTime
ts, forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m ContentHash
hashFile FilePath
fp)
        [(FilePath, (UTCTime, Make ContentHash))]
pathsWithInfo <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\FilePath
fp -> (FilePath
fp,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {m :: * -> *}.
(MonadIO m, MonadIO m, MonadError MultipleErrors m,
 MonadError MultipleErrors m) =>
FilePath -> m (UTCTime, m ContentHash)
getInfo FilePath
fp) [FilePath]
inputPaths
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(FilePath, (UTCTime, Make ContentHash))]
pathsWithInfo

  outputFilename :: ModuleName -> String -> FilePath
  outputFilename :: ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
fn =
    let filePath :: FilePath
filePath = Text -> FilePath
T.unpack (ModuleName -> Text
runModuleName ModuleName
mn)
    in FilePath
outputDir FilePath -> ShowS
</> FilePath
filePath FilePath -> ShowS
</> FilePath
fn

  targetFilename :: ModuleName -> CodegenTarget -> FilePath
  targetFilename :: ModuleName -> CodegenTarget -> FilePath
targetFilename ModuleName
mn = \case
    CodegenTarget
JS -> ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"index.js"
    CodegenTarget
JSSourceMap -> ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"index.js.map"
    CodegenTarget
CoreFn -> ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"corefn.json"
    CodegenTarget
Docs -> ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"docs.json"

  getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
  getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp ModuleName
mn = do
    Set CodegenTarget
codegenTargets <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Set CodegenTarget
optionsCodegenTargets
    Maybe UTCTime
mExternsTimestamp <- forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m (Maybe UTCTime)
getTimestampMaybe (ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
externsFileName)
    case Maybe UTCTime
mExternsTimestamp of
      Maybe UTCTime
Nothing ->
        -- If there is no externs file, we will need to compile the module in
        -- order to produce one.
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Just UTCTime
externsTimestamp ->
        case forall a. [a] -> Maybe (NonEmpty a)
NEL.nonEmpty (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModuleName -> CodegenTarget -> FilePath
targetFilename ModuleName
mn) (forall a. Set a -> [a]
S.toList Set CodegenTarget
codegenTargets)) of
          Maybe (NonEmpty FilePath)
Nothing ->
            -- If the externs file exists and no other codegen targets have
            -- been requested, then we can consider the module up-to-date
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just UTCTime
externsTimestamp)
          Just NonEmpty FilePath
outputPaths -> do
            -- If any of the other output paths are nonexistent or older than
            -- the externs file, then they should be considered outdated, and
            -- so the module will need rebuilding.
            NonEmpty (Maybe UTCTime)
mmodTimes <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m (Maybe UTCTime)
getTimestampMaybe NonEmpty FilePath
outputPaths
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence NonEmpty (Maybe UTCTime)
mmodTimes of
              Maybe (NonEmpty UTCTime)
Nothing ->
                forall a. Maybe a
Nothing
              Just NonEmpty UTCTime
modTimes ->
                if UTCTime
externsTimestamp forall a. Ord a => a -> a -> Bool
<= forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum NonEmpty UTCTime
modTimes
                  then forall a. a -> Maybe a
Just UTCTime
externsTimestamp
                  else forall a. Maybe a
Nothing

  readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
  readExterns :: ModuleName -> Make (FilePath, Maybe ExternsFile)
readExterns ModuleName
mn = do
    let path :: FilePath
path = FilePath
outputDir FilePath -> ShowS
</> Text -> FilePath
T.unpack (ModuleName -> Text
runModuleName ModuleName
mn) FilePath -> ShowS
</> FilePath
externsFileName
    (FilePath
path, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m (Maybe ExternsFile)
readExternsFile FilePath
path

  outputPrimDocs :: Make ()
  outputPrimDocs :: Make ()
outputPrimDocs = do
    Set CodegenTarget
codegenTargets <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Set CodegenTarget
optionsCodegenTargets
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
Docs Set CodegenTarget
codegenTargets) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Module]
Docs.Prim.primModules forall a b. (a -> b) -> a -> b
$ \docsMod :: Module
docsMod@Docs.Module{[(InPackage ModuleName, [Declaration])]
[Declaration]
Maybe Text
ModuleName
modReExports :: Module -> [(InPackage ModuleName, [Declaration])]
modDeclarations :: Module -> [Declaration]
modComments :: Module -> Maybe Text
modName :: Module -> ModuleName
modReExports :: [(InPackage ModuleName, [Declaration])]
modDeclarations :: [Declaration]
modComments :: Maybe Text
modName :: ModuleName
..} ->
      forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile (ModuleName -> ShowS
outputFilename ModuleName
modName FilePath
"docs.json") Module
docsMod

  codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT Make ()
  codegen :: Module Ann -> Module -> ExternsFile -> SupplyT Make ()
codegen Module Ann
m Module
docs ExternsFile
exts = do
    let mn :: ModuleName
mn = forall a. Module a -> ModuleName
CF.moduleName Module Ann
m
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, Serialise a) =>
FilePath -> a -> m ()
writeCborFile (ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
externsFileName) ExternsFile
exts
    Set CodegenTarget
codegenTargets <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Set CodegenTarget
optionsCodegenTargets
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
CoreFn Set CodegenTarget
codegenTargets) forall a b. (a -> b) -> a -> b
$ do
      let coreFnFile :: FilePath
coreFnFile = ModuleName -> CodegenTarget -> FilePath
targetFilename ModuleName
mn CodegenTarget
CoreFn
          json :: Value
json = Version -> Module Ann -> Value
CFJ.moduleToJSON Version
Paths.version Module Ann
m
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile FilePath
coreFnFile Value
json
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
JS Set CodegenTarget
codegenTargets) forall a b. (a -> b) -> a -> b
$ do
      Maybe PSString
foreignInclude <- case ModuleName
mn forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map ModuleName FilePath
foreigns of
        Just FilePath
_
          | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Module a -> Bool
requiresForeign Module Ann
m -> do
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          | Bool
otherwise -> do
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just PSString
"./foreign.js"
        Maybe FilePath
Nothing | forall a. Module a -> Bool
requiresForeign Module Ann
m -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a. Module a -> SourceSpan
CF.moduleSourceSpan Module Ann
m) forall a b. (a -> b) -> a -> b
$ ModuleName -> SimpleErrorMessage
MissingFFIModule ModuleName
mn
                | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Module
rawJs <- forall (m :: * -> *).
(MonadReader Options m, MonadSupply m,
 MonadError MultipleErrors m) =>
Module Ann -> Maybe PSString -> m Module
J.moduleToJs Module Ann
m Maybe PSString
foreignInclude
      FilePath
dir <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m) =>
Text -> IO a -> m a
makeIO Text
"get the current directory" IO FilePath
getCurrentDirectory
      let sourceMaps :: Bool
sourceMaps = forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
JSSourceMap Set CodegenTarget
codegenTargets
          (Text
pjs, [SMap]
mappings) = if Bool
sourceMaps then Module -> (Text, [SMap])
prettyPrintJSWithSourceMaps Module
rawJs else (Module -> Text
prettyPrintJS Module
rawJs, [])
          jsFile :: FilePath
jsFile = ModuleName -> CodegenTarget -> FilePath
targetFilename ModuleName
mn CodegenTarget
JS
          mapFile :: FilePath
mapFile = ModuleName -> CodegenTarget -> FilePath
targetFilename ModuleName
mn CodegenTarget
JSSourceMap
          prefix :: [Text]
prefix = [Text
"Generated by purs version " forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (Version -> FilePath
showVersion Version
Paths.version) | Bool
usePrefix]
          js :: Text
js = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text
"// " forall a. Semigroup a => a -> a -> a
<>) [Text]
prefix forall a. [a] -> [a] -> [a]
++ [Text
pjs]
          mapRef :: Text
mapRef = if Bool
sourceMaps then Text
"//# sourceMappingURL=index.js.map\n" else Text
""
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
        FilePath -> ByteString -> Make ()
writeTextFile FilePath
jsFile (Text -> ByteString
TE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
js forall a. Semigroup a => a -> a -> a
<> Text
mapRef)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
sourceMaps forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Int -> [SMap] -> Make ()
genSourceMap FilePath
dir FilePath
mapFile (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
prefix) [SMap]
mappings
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
Docs Set CodegenTarget
codegenTargets) forall a b. (a -> b) -> a -> b
$ do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile (ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"docs.json") Module
docs

  ffiCodegen :: CF.Module CF.Ann -> Make ()
  ffiCodegen :: Module Ann -> Make ()
ffiCodegen Module Ann
m = do
    Set CodegenTarget
codegenTargets <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Options -> Set CodegenTarget
optionsCodegenTargets
    Map ModuleName FilePath
-> Set CodegenTarget
-> Maybe (ModuleName -> ShowS)
-> Module Ann
-> Make ()
ffiCodegen' Map ModuleName FilePath
foreigns Set CodegenTarget
codegenTargets (forall a. a -> Maybe a
Just ModuleName -> ShowS
outputFilename) Module Ann
m

  genSourceMap :: String -> String -> Int -> [SMap] -> Make ()
  genSourceMap :: FilePath -> FilePath -> Int -> [SMap] -> Make ()
genSourceMap FilePath
dir FilePath
mapFile Int
extraLines [SMap]
mappings = do
    let pathToDir :: FilePath
pathToDir = forall a. (a -> a) -> a -> [a]
iterate (FilePath
".." FilePath -> ShowS
Posix.</>) FilePath
".." forall a. [a] -> Int -> a
!! forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> [FilePath]
splitPath forall a b. (a -> b) -> a -> b
$ ShowS
normalise FilePath
outputDir)
        sourceFile :: Maybe FilePath
sourceFile = case [SMap]
mappings of
                      (SMap Text
file SourcePos
_ SourcePos
_ : [SMap]
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath
pathToDir FilePath -> ShowS
Posix.</> ShowS
normalizeSMPath (FilePath -> ShowS
makeRelative FilePath
dir (Text -> FilePath
T.unpack Text
file))
                      [SMap]
_ -> forall a. Maybe a
Nothing
    let rawMapping :: SourceMapping
rawMapping = SourceMapping { smFile :: FilePath
smFile = FilePath
"index.js", smSourceRoot :: Maybe FilePath
smSourceRoot = forall a. Maybe a
Nothing, smMappings :: [Mapping]
smMappings =
      forall a b. (a -> b) -> [a] -> [b]
map (\(SMap Text
_ SourcePos
orig SourcePos
gen) -> Mapping {
          mapOriginal :: Maybe Pos
mapOriginal = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
convertPos forall a b. (a -> b) -> a -> b
$ Int -> Int -> SourcePos -> SourcePos
add Int
0 (-Int
1) SourcePos
orig
        , mapSourceFile :: Maybe FilePath
mapSourceFile = Maybe FilePath
sourceFile
        , mapGenerated :: Pos
mapGenerated = SourcePos -> Pos
convertPos forall a b. (a -> b) -> a -> b
$ Int -> Int -> SourcePos -> SourcePos
add (Int
extraLines forall a. Num a => a -> a -> a
+ Int
1) Int
0 SourcePos
gen
        , mapName :: Maybe Text
mapName = forall a. Maybe a
Nothing
        }) [SMap]
mappings
    }
    let mapping :: Value
mapping = SourceMapping -> Value
generate SourceMapping
rawMapping
    forall (m :: * -> *) a.
(MonadIO m, MonadError MultipleErrors m, ToJSON a) =>
FilePath -> a -> m ()
writeJSONFile FilePath
mapFile Value
mapping
    where
    add :: Int -> Int -> SourcePos -> SourcePos
    add :: Int -> Int -> SourcePos -> SourcePos
add Int
n Int
m (SourcePos Int
n' Int
m') = Int -> Int -> SourcePos
SourcePos (Int
n forall a. Num a => a -> a -> a
+ Int
n') (Int
m forall a. Num a => a -> a -> a
+ Int
m')

    convertPos :: SourcePos -> Pos
    convertPos :: SourcePos -> Pos
convertPos SourcePos { sourcePosLine :: SourcePos -> Int
sourcePosLine = Int
l, sourcePosColumn :: SourcePos -> Int
sourcePosColumn = Int
c } =
      Pos { posLine :: Int32
posLine = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l, posColumn :: Int32
posColumn = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
c }

    normalizeSMPath :: FilePath -> FilePath
    normalizeSMPath :: ShowS
normalizeSMPath = [FilePath] -> FilePath
Posix.joinPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitDirectories

  requiresForeign :: CF.Module a -> Bool
  requiresForeign :: forall a. Module a -> Bool
requiresForeign = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Module a -> [Ident]
CF.moduleForeign

  progress :: ProgressMessage -> Make ()
  progress :: ProgressMessage -> Make ()
progress = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Text -> IO ()
TIO.hPutStr Handle
stderr forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Semigroup a => a -> a -> a
<> Text
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ProgressMessage -> Text
renderProgressMessage Text
"Compiling "

  readCacheDb :: Make CacheDb
  readCacheDb :: Make CacheDb
readCacheDb = forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m CacheDb
readCacheDb' FilePath
outputDir

  writeCacheDb :: CacheDb -> Make ()
  writeCacheDb :: CacheDb -> Make ()
writeCacheDb = forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> CacheDb -> m ()
writeCacheDb' FilePath
outputDir

  writePackageJson :: Make ()
  writePackageJson :: Make ()
writePackageJson = forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m ()
writePackageJson' FilePath
outputDir

data ForeignModuleType = ESModule | CJSModule deriving (Int -> ForeignModuleType -> ShowS
[ForeignModuleType] -> ShowS
ForeignModuleType -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ForeignModuleType] -> ShowS
$cshowList :: [ForeignModuleType] -> ShowS
show :: ForeignModuleType -> FilePath
$cshow :: ForeignModuleType -> FilePath
showsPrec :: Int -> ForeignModuleType -> ShowS
$cshowsPrec :: Int -> ForeignModuleType -> ShowS
Show)

-- | Check that the declarations in a given PureScript module match with those
-- in its corresponding foreign module.
checkForeignDecls :: CF.Module ann -> FilePath -> Make (Either MultipleErrors (ForeignModuleType, S.Set Ident))
checkForeignDecls :: forall ann.
Module ann
-> FilePath
-> Make (Either MultipleErrors (ForeignModuleType, Set Ident))
checkForeignDecls Module ann
m FilePath
path = do
  FilePath
jsStr <- Text -> FilePath
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> m Text
readTextFile FilePath
path

  let
    parseResult :: Either MultipleErrors JS.JSAST
    parseResult :: Either MultipleErrors JSAST
parseResult = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (ErrorMessage -> MultipleErrors
errorParsingModule forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ErrorMessage
Bundle.UnableToParseModule) forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Either FilePath JSAST
JS.parseModule FilePath
jsStr FilePath
path
  forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse JSAST -> Make (ForeignModuleType, Set Ident)
checkFFI Either MultipleErrors JSAST
parseResult

  where
  mname :: ModuleName
mname = forall a. Module a -> ModuleName
CF.moduleName Module ann
m
  modSS :: SourceSpan
modSS = forall a. Module a -> SourceSpan
CF.moduleSourceSpan Module ann
m

  checkFFI :: JS.JSAST -> Make (ForeignModuleType, S.Set Ident)
  checkFFI :: JSAST -> Make (ForeignModuleType, Set Ident)
checkFFI JSAST
js = do
    (ForeignModuleType
foreignModuleType, [FilePath]
foreignIdentsStrs) <-
        case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSAST -> Either ErrorMessage ForeignModuleExports
getForeignModuleExports JSAST
js forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> JSAST -> Either ErrorMessage ForeignModuleImports
getForeignModuleImports JSAST
js of
          Left ErrorMessage
reason -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ErrorMessage -> MultipleErrors
errorParsingModule ErrorMessage
reason
          Right (Bundle.ForeignModuleExports{[FilePath]
esExports :: ForeignModuleExports -> [FilePath]
cjsExports :: ForeignModuleExports -> [FilePath]
esExports :: [FilePath]
cjsExports :: [FilePath]
..}, Bundle.ForeignModuleImports{[FilePath]
esImports :: ForeignModuleImports -> [FilePath]
cjsImports :: ForeignModuleImports -> [FilePath]
esImports :: [FilePath]
cjsImports :: [FilePath]
..})
            | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
cjsExports Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
cjsImports)
            , forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
esExports
            , forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
esImports -> do
                let deprecatedFFI :: [FilePath]
deprecatedFFI = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
'\'') [FilePath]
cjsExports
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
deprecatedFFI) forall a b. (a -> b) -> a -> b
$
                  forall a. [FilePath] -> Make a
errorDeprecatedForeignPrimes [FilePath]
deprecatedFFI

                forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignModuleType
CJSModule, [FilePath]
cjsExports)
            | Bool
otherwise -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
cjsImports) forall a b. (a -> b) -> a -> b
$
                  forall a. [FilePath] -> Make a
errorUnsupportedFFICommonJSImports [FilePath]
cjsImports

                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
cjsExports) forall a b. (a -> b) -> a -> b
$
                  forall a. [FilePath] -> Make a
errorUnsupportedFFICommonJSExports [FilePath]
cjsExports

                forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignModuleType
ESModule, [FilePath]
esExports)

    Set Ident
foreignIdents <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                      forall a. [FilePath] -> Make a
errorInvalidForeignIdentifiers
                      (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
S.fromList)
                      ([FilePath] -> Either [FilePath] [Ident]
parseIdents [FilePath]
foreignIdentsStrs)
    let importedIdents :: Set Ident
importedIdents = forall a. Ord a => [a] -> Set a
S.fromList (forall a. Module a -> [Ident]
CF.moduleForeign Module ann
m)

    let unusedFFI :: Set Ident
unusedFFI = Set Ident
foreignIdents forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Ident
importedIdents
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Ident
unusedFFI) forall a b. (a -> b) -> a -> b
$
      forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Ident] -> SimpleErrorMessage
UnusedFFIImplementations ModuleName
mname forall a b. (a -> b) -> a -> b
$
        forall a. Set a -> [a]
S.toList Set Ident
unusedFFI

    let missingFFI :: Set Ident
missingFFI = Set Ident
importedIdents forall a. Ord a => Set a -> Set a -> Set a
S.\\ Set Ident
foreignIdents
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Ident
missingFFI) forall a b. (a -> b) -> a -> b
$
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Ident] -> SimpleErrorMessage
MissingFFIImplementations ModuleName
mname forall a b. (a -> b) -> a -> b
$
        forall a. Set a -> [a]
S.toList Set Ident
missingFFI
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForeignModuleType
foreignModuleType, Set Ident
foreignIdents)

  errorParsingModule :: Bundle.ErrorMessage -> MultipleErrors
  errorParsingModule :: ErrorMessage -> MultipleErrors
errorParsingModule = SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe ErrorMessage -> SimpleErrorMessage
ErrorParsingFFIModule FilePath
path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

  getForeignModuleExports :: JS.JSAST -> Either Bundle.ErrorMessage  Bundle.ForeignModuleExports
  getForeignModuleExports :: JSAST -> Either ErrorMessage ForeignModuleExports
getForeignModuleExports = forall (m :: * -> *).
MonadError ErrorMessage m =>
FilePath -> JSAST -> m ForeignModuleExports
Bundle.getExportedIdentifiers (Text -> FilePath
T.unpack (ModuleName -> Text
runModuleName ModuleName
mname))

  getForeignModuleImports :: JS.JSAST -> Either Bundle.ErrorMessage Bundle.ForeignModuleImports
  getForeignModuleImports :: JSAST -> Either ErrorMessage ForeignModuleImports
getForeignModuleImports = forall (m :: * -> *).
MonadError ErrorMessage m =>
FilePath -> JSAST -> m ForeignModuleImports
Bundle.getImportedModules (Text -> FilePath
T.unpack (ModuleName -> Text
runModuleName ModuleName
mname))

  errorInvalidForeignIdentifiers :: [String] -> Make a
  errorInvalidForeignIdentifiers :: forall a. [FilePath] -> Make a
errorInvalidForeignIdentifiers =
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SimpleErrorMessage -> MultipleErrors
errorMessage forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text -> SimpleErrorMessage
InvalidFFIIdentifier ModuleName
mname forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)

  errorDeprecatedForeignPrimes :: [String] -> Make a
  errorDeprecatedForeignPrimes :: forall a. [FilePath] -> Make a
errorDeprecatedForeignPrimes =
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text -> SimpleErrorMessage
DeprecatedFFIPrime ModuleName
mname forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)

  errorUnsupportedFFICommonJSExports :: [String] -> Make a
  errorUnsupportedFFICommonJSExports :: forall a. [FilePath] -> Make a
errorUnsupportedFFICommonJSExports =
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Text] -> SimpleErrorMessage
UnsupportedFFICommonJSExports ModuleName
mname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack

  errorUnsupportedFFICommonJSImports :: [String] -> Make a
  errorUnsupportedFFICommonJSImports :: forall a. [FilePath] -> Make a
errorUnsupportedFFICommonJSImports =
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' SourceSpan
modSS forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Text] -> SimpleErrorMessage
UnsupportedFFICommonJSImports ModuleName
mname forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
T.pack

  parseIdents :: [String] -> Either [String] [Ident]
  parseIdents :: [FilePath] -> Either [FilePath] [Ident]
parseIdents [FilePath]
strs =
    case forall a b. [Either a b] -> ([a], [b])
partitionEithers (forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either FilePath Ident
parseIdent [FilePath]
strs) of
      ([], [Ident]
idents) ->
        forall a b. b -> Either a b
Right [Ident]
idents
      ([FilePath]
errs, [Ident]
_) ->
        forall a b. a -> Either a b
Left [FilePath]
errs

  -- We ignore the error message here, just being told it's an invalid
  -- identifier should be enough.
  parseIdent :: String -> Either String Ident
  parseIdent :: FilePath -> Either FilePath Ident
parseIdent FilePath
str =
    forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall a b. a -> b -> a
const FilePath
str) (Text -> Ident
Ident forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ident -> Text
CST.getIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Name a -> a
CST.nameValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
Parser a
-> [LexResult]
-> Either (NonEmpty ParserError) ([ParserWarning], a)
CST.runTokenParser Parser (Name Ident)
CST.parseIdent
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [LexResult]
CST.lex
      forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
str

-- | FFI check and codegen action.
-- If path maker is supplied copies foreign module to the output.
ffiCodegen'
  :: M.Map ModuleName FilePath
  -> S.Set CodegenTarget
  -> Maybe (ModuleName -> String -> FilePath)
  -> CF.Module CF.Ann
  -> Make ()
ffiCodegen' :: Map ModuleName FilePath
-> Set CodegenTarget
-> Maybe (ModuleName -> ShowS)
-> Module Ann
-> Make ()
ffiCodegen' Map ModuleName FilePath
foreigns Set CodegenTarget
codegenTargets Maybe (ModuleName -> ShowS)
makeOutputPath Module Ann
m = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Ord a => a -> Set a -> Bool
S.member CodegenTarget
JS Set CodegenTarget
codegenTargets) forall a b. (a -> b) -> a -> b
$ do
    let mn :: ModuleName
mn = forall a. Module a -> ModuleName
CF.moduleName Module Ann
m
    case ModuleName
mn forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` Map ModuleName FilePath
foreigns of
      Just FilePath
path
        | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Module a -> Bool
requiresForeign Module Ann
m ->
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall a b. (a -> b) -> a -> b
$ SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a. Module a -> SourceSpan
CF.moduleSourceSpan Module Ann
m) forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath -> SimpleErrorMessage
UnnecessaryFFIModule ModuleName
mn FilePath
path
        | Bool
otherwise -> do
            Either MultipleErrors (ForeignModuleType, Set Ident)
checkResult <- forall ann.
Module ann
-> FilePath
-> Make (Either MultipleErrors (ForeignModuleType, Set Ident))
checkForeignDecls Module Ann
m FilePath
path
            case Either MultipleErrors (ForeignModuleType, Set Ident)
checkResult of
              Left MultipleErrors
_ -> FilePath -> ModuleName -> Make ()
copyForeign FilePath
path ModuleName
mn
              Right (ForeignModuleType
ESModule, Set Ident
_) -> FilePath -> ModuleName -> Make ()
copyForeign FilePath
path ModuleName
mn
              Right (ForeignModuleType
CJSModule, Set Ident
_) -> do
                forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a. Module a -> SourceSpan
CF.moduleSourceSpan Module Ann
m) forall a b. (a -> b) -> a -> b
$ ModuleName -> FilePath -> SimpleErrorMessage
DeprecatedFFICommonJSModule ModuleName
mn FilePath
path
      Maybe FilePath
Nothing | forall a. Module a -> Bool
requiresForeign Module Ann
m -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> SimpleErrorMessage -> MultipleErrors
errorMessage' (forall a. Module a -> SourceSpan
CF.moduleSourceSpan Module Ann
m) forall a b. (a -> b) -> a -> b
$ ModuleName -> SimpleErrorMessage
MissingFFIModule ModuleName
mn
              | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
  requiresForeign :: Module a -> Bool
requiresForeign = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Module a -> [Ident]
CF.moduleForeign

  copyForeign :: FilePath -> ModuleName -> Make ()
copyForeign FilePath
path ModuleName
mn =
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (ModuleName -> ShowS)
makeOutputPath (\ModuleName -> ShowS
outputFilename -> forall (m :: * -> *).
(MonadIO m, MonadError MultipleErrors m) =>
FilePath -> FilePath -> m ()
copyFile FilePath
path (ModuleName -> ShowS
outputFilename ModuleName
mn FilePath
"foreign.js"))