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)
data RebuildPolicy
= RebuildNever
| 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)
data ProgressMessage
= CompilingModule ModuleName (Maybe (Int, Int))
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)
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
"] "
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)))
, forall (m :: * -> *).
MakeActions m -> ModuleName -> m (Maybe UTCTime)
getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
, forall (m :: * -> *).
MakeActions m -> ModuleName -> m (FilePath, Maybe ExternsFile)
readExterns :: ModuleName -> m (FilePath, Maybe ExternsFile)
, forall (m :: * -> *).
MakeActions m
-> Module Ann -> Module -> ExternsFile -> SupplyT m ()
codegen :: CF.Module CF.Ann -> Docs.Module -> ExternsFile -> SupplyT m ()
, forall (m :: * -> *). MakeActions m -> Module Ann -> m ()
ffiCodegen :: CF.Module CF.Ann -> m ()
, forall (m :: * -> *). MakeActions m -> ProgressMessage -> m ()
progress :: ProgressMessage -> m ()
, forall (m :: * -> *). MakeActions m -> m CacheDb
readCacheDb :: m CacheDb
, forall (m :: * -> *). MakeActions m -> CacheDb -> m ()
writeCacheDb :: CacheDb -> m ()
, forall (m :: * -> *). MakeActions m -> m ()
writePackageJson :: m ()
, forall (m :: * -> *). MakeActions m -> m ()
outputPrimDocs :: m ()
}
cacheDbFile :: FilePath -> FilePath
cacheDbFile :: ShowS
cacheDbFile = (FilePath -> ShowS
</> FilePath
"cache-db.json")
readCacheDb'
:: (MonadIO m, MonadError MultipleErrors m)
=> FilePath
-> 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
-> CacheDb
-> 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
-> 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"
]
buildMakeActions
:: FilePath
-> M.Map ModuleName (Either RebuildPolicy FilePath)
-> M.Map ModuleName FilePath
-> Bool
-> 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 ->
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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just UTCTime
externsTimestamp)
Just NonEmpty FilePath
outputPaths -> do
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)
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
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
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"))