{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.PureScript
( initPurs
, pursServe
, module Internals
) where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State.Strict
import Data.Configurator as Cfg
import Data.Monoid
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Paths_snaplet_purescript
import Prelude hiding (FilePath)
import Shelly hiding (get)
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.PureScript.Hooks
import Snap.Snaplet.PureScript.Internal as I
import Snap.Snaplet.PureScript.Internal as Internals (PureScript)
import Text.Printf
import Text.RawString.QQ
initPurs :: SnapletInit b PureScript
initPurs :: SnapletInit b PureScript
initPurs = Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b PureScript PureScript
-> SnapletInit b PureScript
forall b v.
Text
-> Text
-> Maybe (IO FilePath)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"purs" Text
description (IO FilePath -> Maybe (IO FilePath)
forall a. a -> Maybe a
Just IO FilePath
dataDir) (Initializer b PureScript PureScript -> SnapletInit b PureScript)
-> Initializer b PureScript PureScript -> SnapletInit b PureScript
forall a b. (a -> b) -> a -> b
$ do
FilePath
env <- Initializer b PureScript FilePath
forall b v. Initializer b v FilePath
getEnvironment
Text
destDir <- Initializer b PureScript Text
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadIO (m b v), MonadSnaplet m) =>
m b v Text
getDestDir
Sh () -> Initializer b PureScript ()
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh () -> Initializer b PureScript ())
-> Sh () -> Initializer b PureScript ()
forall a b. (a -> b) -> a -> b
$ Sh () -> Sh ()
forall a. Sh a -> Sh a
verbosely (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh () -> Sh ()
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
destDir) (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ do
let envCfg :: FilePath
envCfg = Text -> FilePath
fromText (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
destDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack (FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
env FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".cfg")
Text -> Sh ()
echo (Text -> Sh ()) -> Text -> Sh ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking existance of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
toTextIgnore FilePath
envCfg
Bool
envCfgExists <- FilePath -> Sh Bool
test_f FilePath
envCfg
Bool -> Sh () -> Sh ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
envCfgExists (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Sh ()
touchfile FilePath
envCfg
FilePath -> Text -> Sh ()
writefile FilePath
envCfg Text
envCfgTemplate
Config
config <- Initializer b PureScript Config
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig
Hooks
hooks <- IO Hooks -> Initializer b PureScript Hooks
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Hooks -> Initializer b PureScript Hooks)
-> IO Hooks -> Initializer b PureScript Hooks
forall a b. (a -> b) -> a -> b
$ Config -> IO Hooks
getHooks Config
config
Sh () -> Initializer b PureScript ()
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh () -> Initializer b PureScript ())
-> Sh () -> Initializer b PureScript ()
forall a b. (a -> b) -> a -> b
$ Sh () -> Sh ()
forall a. Sh a -> Sh a
verbosely (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh () -> Sh ()
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
destDir) (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ Hooks -> Sh ()
preInitHook Hooks
hooks
Text
outDir <- IO Text -> Initializer b PureScript Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Config -> Text -> IO Text
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Text
"js" Config
config Text
"buildDir")
Verbosity
verbosity <- IO Verbosity -> Initializer b PureScript Verbosity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Verbosity -> Config -> Text -> IO Verbosity
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Verbosity
Verbose Config
config Text
"verbosity")
Bool
bndl <- IO Bool -> Initializer b PureScript Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> Config -> Text -> IO Bool
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Bool
True Config
config Text
"bundle")
Text
bundleName <- IO Text -> Initializer b PureScript Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Config -> Text -> IO Text
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Text
"app.js" Config
config Text
"bundleName")
Text
bundleExe <- IO Text -> Initializer b PureScript Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Config -> Text -> IO Text
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Text
"purs" Config
config Text
"bundleExe")
[Text]
bundleOpts <- IO [Text] -> Initializer b PureScript [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Text] -> Config -> Text -> IO [Text]
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault [Text]
forall a. Monoid a => a
mempty Config
config Text
"bundleOpts")
[Text]
modules <- IO [Text] -> Initializer b PureScript [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Text] -> Config -> Text -> IO [Text]
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault [Text
"Main"] Config
config Text
"modules")
Text
psPath <- IO Text -> Initializer b PureScript Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> Config -> Text -> IO Text
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Text
forall a. Monoid a => a
mempty Config
config Text
"pureScriptPath")
SpagoPath
spagoPath <- Text
-> Maybe SpagoPath
-> (Monad (Initializer b PureScript),
MonadIO (Initializer b PureScript), MonadSnaplet Initializer) =>
Initializer b PureScript SpagoPath
forall (m :: * -> * -> * -> *) b v.
Text
-> Maybe SpagoPath
-> (Monad (m b v), MonadIO (m b v), MonadSnaplet m) =>
m b v SpagoPath
findOrInstallSpago Text
psPath (Maybe SpagoPath -> Initializer b PureScript SpagoPath)
-> Initializer b PureScript (Maybe SpagoPath)
-> Initializer b PureScript SpagoPath
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Maybe SpagoPath) -> Initializer b PureScript (Maybe SpagoPath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Config -> Text -> IO (Maybe SpagoPath)
forall a. Configured a => Config -> Text -> IO (Maybe a)
Cfg.lookup Config
config Text
"spagoPath")
[Text]
psaOpts <- IO [Text] -> Initializer b PureScript [Text]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Text] -> Config -> Text -> IO [Text]
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault [Text]
forall a. Monoid a => a
mempty Config
config Text
"psaOpts")
Bool
permissive <- IO Bool -> Initializer b PureScript Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> Config -> Text -> IO Bool
forall a. Configured a => a -> Config -> Text -> IO a
lookupDefault Bool
False Config
config Text
"permissiveInit")
CompilationMode
cm <- Initializer b PureScript CompilationMode
forall b v. Initializer b v CompilationMode
getCompilationFlavour
FilePath
spagofile <- Text -> FilePath
fromText (Text -> FilePath)
-> Initializer b PureScript Text
-> Initializer b PureScript FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Initializer b PureScript Text
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadIO (m b v), MonadSnaplet m) =>
m b v Text
getSpagoFile
PureScript
purs <- Sh PureScript -> Initializer b PureScript PureScript
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh PureScript -> Initializer b PureScript PureScript)
-> Sh PureScript -> Initializer b PureScript PureScript
forall a b. (a -> b) -> a -> b
$ Sh PureScript -> Sh PureScript
forall a. Sh a -> Sh a
verbosely (Sh PureScript -> Sh PureScript) -> Sh PureScript -> Sh PureScript
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh PureScript -> Sh PureScript
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
destDir) (Sh PureScript -> Sh PureScript) -> Sh PureScript -> Sh PureScript
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Sh ()
mkdir_p (Text -> FilePath
fromText Text
outDir)
Bool
spagofileExists <- FilePath -> Sh Bool
test_f FilePath
spagofile
Text -> Sh ()
echo (Text -> Sh ()) -> Text -> Sh ()
forall a b. (a -> b) -> a -> b
$ Text
"Checking existance of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
toTextIgnore FilePath
spagofile
Bool -> Sh () -> Sh ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
spagofileExists (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ do
FilePath -> [Text] -> Sh ()
run_ (FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SpagoPath -> FilePath
getSpagoPath SpagoPath
spagoPath) [Text
"init"]
PureScript -> Sh PureScript
forall (m :: * -> *) a. Monad m => a -> m a
return PureScript :: CompilationMode
-> Verbosity
-> Bool
-> Text
-> Text
-> [Text]
-> SpagoPath
-> Text
-> [Text]
-> Bool
-> Text
-> Text
-> [Text]
-> Hooks
-> PureScript
PureScript {
pursCompilationMode :: CompilationMode
pursCompilationMode = CompilationMode
cm
, pursVerbosity :: Verbosity
pursVerbosity = Verbosity
verbosity
, pursBundle :: Bool
pursBundle = Bool
bndl
, pursBundleName :: Text
pursBundleName = Text
bundleName
, pursBundleExe :: Text
pursBundleExe = Text
bundleExe
, pursBundleOpts :: [Text]
pursBundleOpts = [Text]
bundleOpts
, pursSpagoPath :: SpagoPath
pursSpagoPath = SpagoPath
spagoPath
, pursPsPath :: Text
pursPsPath = Text
psPath
, pursPsaOpts :: [Text]
pursPsaOpts = [Text]
psaOpts
, pursPermissiveInit :: Bool
pursPermissiveInit = Bool
permissive
, pursPwdDir :: Text
pursPwdDir = Text
destDir
, pursOutputDir :: Text
pursOutputDir = Text
outDir
, pursModules :: [Text]
pursModules = [Text]
modules
, pursHooks :: Hooks
pursHooks = Hooks
hooks
}
Bool -> Initializer b PureScript () -> Initializer b PureScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CompilationMode
cm CompilationMode -> CompilationMode -> Bool
forall a. Eq a => a -> a -> Bool
== CompilationMode
CompileNever) (Initializer b PureScript () -> Initializer b PureScript ())
-> Initializer b PureScript () -> Initializer b PureScript ()
forall a b. (a -> b) -> a -> b
$ do
CompilationOutput
res <- PureScript -> Initializer b PureScript CompilationOutput
forall (m :: * -> *).
MonadIO m =>
PureScript -> m CompilationOutput
build PureScript
purs
CompilationOutput
_ <- PureScript -> Initializer b PureScript CompilationOutput
forall (m :: * -> *).
MonadIO m =>
PureScript -> m CompilationOutput
bundle PureScript
purs
case CompilationOutput
res of
CompilationFailed Text
reason -> Bool -> Initializer b PureScript () -> Initializer b PureScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
permissive (FilePath -> Initializer b PureScript ()
forall a. HasCallStack => FilePath -> a
error (Text -> FilePath
T.unpack Text
reason))
CompilationOutput
CompilationSucceeded -> () -> Initializer b PureScript ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Sh () -> Initializer b PureScript ()
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh () -> Initializer b PureScript ())
-> Sh () -> Initializer b PureScript ()
forall a b. (a -> b) -> a -> b
$ Sh () -> Sh ()
forall a. Sh a -> Sh a
verbosely (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh () -> Sh ()
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
destDir) (Sh () -> Sh ()) -> Sh () -> Sh ()
forall a b. (a -> b) -> a -> b
$ Hooks -> Sh ()
postInitHook Hooks
hooks
PureScript -> Initializer b PureScript PureScript
forall (m :: * -> *) a. Monad m => a -> m a
return PureScript
purs
where
description :: Text
description = Text
"Automatic (re)compilation of PureScript projects"
dataDir :: IO FilePath
dataDir = (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/resources") IO FilePath
getDataDir
pursLog :: String -> Handler b PureScript ()
pursLog :: FilePath -> Handler b PureScript ()
pursLog FilePath
l = do
Verbosity
verb <- Handler b PureScript PureScript
forall s (m :: * -> *). MonadState s m => m s
get Handler b PureScript PureScript
-> (PureScript -> Handler b PureScript Verbosity)
-> Handler b PureScript Verbosity
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Verbosity -> Handler b PureScript Verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return (Verbosity -> Handler b PureScript Verbosity)
-> (PureScript -> Verbosity)
-> PureScript
-> Handler b PureScript Verbosity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PureScript -> Verbosity
pursVerbosity
Bool -> Handler b PureScript () -> Handler b PureScript ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) (IO () -> Handler b PureScript ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Handler b PureScript ())
-> IO () -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"snaplet-purescript: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
l)
pursServe :: Handler b PureScript ()
= do
(Text
_, Text
requestedJs) <- ((Text -> Text) -> (Text, Text) -> (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?')) ((Text, Text) -> (Text, Text))
-> (Request -> (Text, Text)) -> Request -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> (Text, Text)
T.breakOn Text
"/" (Text -> (Text, Text))
-> (Request -> Text) -> Request -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Request -> Text) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (Request -> ByteString) -> Request -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> ByteString
rqURI) (Request -> (Text, Text))
-> Handler b PureScript Request
-> Handler b PureScript (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler b PureScript Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
case Text
requestedJs of
Text
"" -> FilePath -> Handler b PureScript ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (Text -> FilePath
jsNotFound Text
requestedJs)
Text
_ -> do
FilePath -> Handler b PureScript ()
forall b. FilePath -> Handler b PureScript ()
pursLog (FilePath -> Handler b PureScript ())
-> FilePath -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Requested file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
requestedJs
(Response -> Response) -> Handler b PureScript ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse ((Response -> Response) -> Handler b PureScript ())
-> (ByteString -> Response -> Response)
-> ByteString
-> Handler b PureScript ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Response -> Response
setContentType (ByteString -> Handler b PureScript ())
-> ByteString -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ ByteString
"text/javascript;charset=utf-8"
Text
outDir <- Handler b PureScript Text
forall b. Handler b PureScript Text
getAbsoluteOutputDir
let fulljsPath :: Text
fulljsPath = Text
outDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
requestedJs
FilePath -> Handler b PureScript ()
forall b. FilePath -> Handler b PureScript ()
pursLog (FilePath -> Handler b PureScript ())
-> FilePath -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Serving " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack (Text
fulljsPath)
CompilationOutput
res <- Handler b PureScript CompilationOutput
forall b. Handler b PureScript CompilationOutput
compileWithMode
CompilationOutput
_ <- Text -> Handler b PureScript CompilationOutput
forall b. Text -> Handler b PureScript CompilationOutput
bundleWithMode (Int -> Text -> Text
T.drop Int
1 Text
requestedJs)
case CompilationOutput
res of
CompilationFailed Text
reason -> do
let curatedOutput :: Text
curatedOutput = Text -> Text -> Text -> Text
T.replace Text
"\"" Text
"\\\"" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
T.replace Text
"\n" Text
"\\n" (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
reason
Text -> Handler b PureScript ()
forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText (Text -> Handler b PureScript ())
-> Text -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ Text
"(function() { console.log(\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
curatedOutput Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"); })();"
CompilationOutput
CompilationSucceeded ->
(Sh Text -> Handler b PureScript Text
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh Text -> Handler b PureScript Text)
-> Sh Text -> Handler b PureScript Text
forall a b. (a -> b) -> a -> b
$ Sh Text -> Sh Text
forall a. Sh a -> Sh a
silently (Sh Text -> Sh Text) -> Sh Text -> Sh Text
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh Text
readfile (Text -> FilePath
fromText Text
fulljsPath)) Handler b PureScript Text
-> (Text -> Handler b PureScript ()) -> Handler b PureScript ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Handler b PureScript ()
forall (m :: * -> *). MonadSnap m => Text -> m ()
writeText
build :: MonadIO m => PureScript -> m CompilationOutput
build :: PureScript -> m CompilationOutput
build PureScript{Bool
[Text]
Text
Hooks
Verbosity
SpagoPath
CompilationMode
pursHooks :: Hooks
pursModules :: [Text]
pursOutputDir :: Text
pursPwdDir :: Text
pursPermissiveInit :: Bool
pursPsaOpts :: [Text]
pursPsPath :: Text
pursSpagoPath :: SpagoPath
pursBundleOpts :: [Text]
pursBundleExe :: Text
pursBundleName :: Text
pursBundle :: Bool
pursVerbosity :: Verbosity
pursCompilationMode :: CompilationMode
pursHooks :: PureScript -> Hooks
pursModules :: PureScript -> [Text]
pursOutputDir :: PureScript -> Text
pursPwdDir :: PureScript -> Text
pursPermissiveInit :: PureScript -> Bool
pursPsaOpts :: PureScript -> [Text]
pursPsPath :: PureScript -> Text
pursSpagoPath :: PureScript -> SpagoPath
pursBundleOpts :: PureScript -> [Text]
pursBundleExe :: PureScript -> Text
pursBundleName :: PureScript -> Text
pursBundle :: PureScript -> Bool
pursVerbosity :: PureScript -> Verbosity
pursCompilationMode :: PureScript -> CompilationMode
..} = Sh CompilationOutput -> m CompilationOutput
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shV (Sh CompilationOutput -> m CompilationOutput)
-> Sh CompilationOutput -> m CompilationOutput
forall a b. (a -> b) -> a -> b
$ Bool -> Sh CompilationOutput -> Sh CompilationOutput
forall a. Bool -> Sh a -> Sh a
errExit Bool
False (Sh CompilationOutput -> Sh CompilationOutput)
-> Sh CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Sh CompilationOutput -> Sh CompilationOutput
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
pursPwdDir) (Sh CompilationOutput -> Sh CompilationOutput)
-> Sh CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Sh ()
I.prependToPath (Text -> FilePath
fromText Text
pursPsPath)
Hooks -> Sh ()
preBuildHook Hooks
pursHooks
let args :: [Text]
args = [Text
"build"] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
pursPsaOpts
FilePath -> [Text] -> Sh ()
run_ (FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath)
-> (SpagoPath -> FilePath) -> SpagoPath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpagoPath -> FilePath
getSpagoPath (SpagoPath -> FilePath) -> SpagoPath -> FilePath
forall a b. (a -> b) -> a -> b
$ SpagoPath
pursSpagoPath) [Text]
args
Int
eC <- Sh Int
lastExitCode
Hooks -> Sh ()
preBuildHook Hooks
pursHooks
case (Int
eC Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) of
Bool
True -> CompilationOutput -> Sh CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
Bool
False -> Text -> CompilationOutput
CompilationFailed (Text -> CompilationOutput) -> Sh Text -> Sh CompilationOutput
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sh Text
lastStderr
bundle :: MonadIO m => PureScript -> m CompilationOutput
bundle :: PureScript -> m CompilationOutput
bundle PureScript{Bool
[Text]
Text
Hooks
Verbosity
SpagoPath
CompilationMode
pursHooks :: Hooks
pursModules :: [Text]
pursOutputDir :: Text
pursPwdDir :: Text
pursPermissiveInit :: Bool
pursPsaOpts :: [Text]
pursPsPath :: Text
pursSpagoPath :: SpagoPath
pursBundleOpts :: [Text]
pursBundleExe :: Text
pursBundleName :: Text
pursBundle :: Bool
pursVerbosity :: Verbosity
pursCompilationMode :: CompilationMode
pursHooks :: PureScript -> Hooks
pursModules :: PureScript -> [Text]
pursOutputDir :: PureScript -> Text
pursPwdDir :: PureScript -> Text
pursPermissiveInit :: PureScript -> Bool
pursPsaOpts :: PureScript -> [Text]
pursPsPath :: PureScript -> Text
pursSpagoPath :: PureScript -> SpagoPath
pursBundleOpts :: PureScript -> [Text]
pursBundleExe :: PureScript -> Text
pursBundleName :: PureScript -> Text
pursBundle :: PureScript -> Bool
pursVerbosity :: PureScript -> Verbosity
pursCompilationMode :: PureScript -> CompilationMode
..} =
IO CompilationOutput -> m CompilationOutput
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CompilationOutput -> m CompilationOutput)
-> IO CompilationOutput -> m CompilationOutput
forall a b. (a -> b) -> a -> b
$ Sh CompilationOutput -> IO CompilationOutput
forall (m :: * -> *) a. MonadIO m => Sh a -> m a
shelly (Sh CompilationOutput -> IO CompilationOutput)
-> Sh CompilationOutput -> IO CompilationOutput
forall a b. (a -> b) -> a -> b
$ Sh CompilationOutput -> Sh CompilationOutput
forall a. Sh a -> Sh a
verbosely (Sh CompilationOutput -> Sh CompilationOutput)
-> Sh CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ Bool -> Sh CompilationOutput -> Sh CompilationOutput
forall a. Bool -> Sh a -> Sh a
errExit Bool
False (Sh CompilationOutput -> Sh CompilationOutput)
-> Sh CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ FilePath -> Sh CompilationOutput -> Sh CompilationOutput
forall a. FilePath -> Sh a -> Sh a
chdir (Text -> FilePath
fromText Text
pursPwdDir) (Sh CompilationOutput -> Sh CompilationOutput)
-> Sh CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ do
FilePath -> Sh ()
I.prependToPath (Text -> FilePath
fromText Text
pursPsPath)
let bundlePath :: Text
bundlePath = Text
pursOutputDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
pursBundleName
case Bool
pursBundle of
Bool
False -> CompilationOutput -> Sh CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
Bool
True -> do
Hooks -> Sh ()
preBundleHook Hooks
pursHooks
FilePath -> Sh ()
rm_rf (Text -> FilePath
fromText Text
bundlePath)
Text -> Sh ()
echo (Text -> Sh ()) -> Text -> Sh ()
forall a b. (a -> b) -> a -> b
$ Text
"Bundling everything in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
bundlePath
Text
res <- case (Text
pursBundleExe, [Text]
pursBundleOpts) of
(Text
"purs", []) ->
let modules :: Text
modules = Text -> [Text] -> Text
T.intercalate Text
" -m " [Text]
pursModules
pursBundlExe :: Text
pursBundlExe = Text -> (Text -> Text) -> Text -> Text
forall m. (Eq m, Monoid m) => m -> (m -> m) -> m -> m
maybeM Text
"purs" (\Text
x -> Text
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"purs") Text
pursPsPath
in FilePath -> [Text] -> Sh Text
run (Text -> FilePath
fromText Text
pursBundlExe) ([Text
"bundle", Text
"output/*/**/*.js", Text
"-m"]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text]
T.words Text
modules)
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"-o", Text
bundlePath, Text
"-n", Text
"PS"])
(Text
"spago", []) ->
let modules :: Text
modules = Text -> [Text] -> Text
T.intercalate Text
"," [Text]
pursModules
in FilePath -> [Text] -> Sh Text
run (FilePath -> FilePath
forall a. IsString a => FilePath -> a
fromString (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SpagoPath -> FilePath
getSpagoPath SpagoPath
pursSpagoPath) ([Text
"build", Text
"-I", Text
"src", Text
"--modules"]
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text]
T.words Text
modules)
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"-t", Text
bundlePath])
(Text
exe, [Text]
args) -> FilePath -> [Text] -> Sh Text
run (Text -> FilePath
fromText Text
exe) [Text]
args
Hooks -> Sh ()
postBundleHook Hooks
pursHooks
Int
eC <- Sh Int
lastExitCode
case (Int
eC Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) of
Bool
True -> CompilationOutput -> Sh CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
Bool
False -> CompilationOutput -> Sh CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (CompilationOutput -> Sh CompilationOutput)
-> CompilationOutput -> Sh CompilationOutput
forall a b. (a -> b) -> a -> b
$ Text -> CompilationOutput
CompilationFailed Text
res
where
maybeM :: (Eq m, Monoid m) => m -> (m -> m) -> m -> m
maybeM :: m -> (m -> m) -> m -> m
maybeM m
alt m -> m
f m
x = if m
x m -> m -> Bool
forall a. Eq a => a -> a -> Bool
== m
forall a. Monoid a => a
mempty then m
alt else m -> m
f m
x
compileWithMode :: Handler b PureScript CompilationOutput
compileWithMode :: Handler b PureScript CompilationOutput
compileWithMode = do
CompilationMode
mode <- (PureScript -> CompilationMode)
-> Handler b PureScript CompilationMode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PureScript -> CompilationMode
pursCompilationMode
case CompilationMode
mode of
CompilationMode
CompileNever -> CompilationOutput -> Handler b PureScript CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
CompilationMode
CompileOnce -> CompilationOutput -> Handler b PureScript CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
CompilationMode
CompileAlways -> do
Text
workDir <- (PureScript -> Text) -> Handler b PureScript Text
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PureScript -> Text
pursPwdDir
FilePath -> Handler b PureScript ()
forall b. FilePath -> Handler b PureScript ()
pursLog (FilePath -> Handler b PureScript ())
-> FilePath -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Compiling Purescript project at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
workDir
Handler b PureScript PureScript
forall s (m :: * -> *). MonadState s m => m s
get Handler b PureScript PureScript
-> (PureScript -> Handler b PureScript CompilationOutput)
-> Handler b PureScript CompilationOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PureScript -> Handler b PureScript CompilationOutput
forall (m :: * -> *).
MonadIO m =>
PureScript -> m CompilationOutput
build
bundleWithMode :: T.Text -> Handler b PureScript CompilationOutput
bundleWithMode :: Text -> Handler b PureScript CompilationOutput
bundleWithMode Text
_ = do
CompilationMode
mode <- (PureScript -> CompilationMode)
-> Handler b PureScript CompilationMode
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PureScript -> CompilationMode
pursCompilationMode
case CompilationMode
mode of
CompilationMode
CompileOnce -> CompilationOutput -> Handler b PureScript CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
CompilationMode
CompileNever -> CompilationOutput -> Handler b PureScript CompilationOutput
forall (m :: * -> *) a. Monad m => a -> m a
return CompilationOutput
CompilationSucceeded
CompilationMode
CompileAlways -> do
Text
workDir <- (PureScript -> Text) -> Handler b PureScript Text
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets PureScript -> Text
pursPwdDir
FilePath -> Handler b PureScript ()
forall b. FilePath -> Handler b PureScript ()
pursLog (FilePath -> Handler b PureScript ())
-> FilePath -> Handler b PureScript ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Bundling Purescript project at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
workDir
Handler b PureScript PureScript
forall s (m :: * -> *). MonadState s m => m s
get Handler b PureScript PureScript
-> (PureScript -> Handler b PureScript CompilationOutput)
-> Handler b PureScript CompilationOutput
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PureScript -> Handler b PureScript CompilationOutput
forall (m :: * -> *).
MonadIO m =>
PureScript -> m CompilationOutput
bundle
jsNotFound :: T.Text -> String
jsNotFound :: Text -> FilePath
jsNotFound Text
js = FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf [r|
You asked me to serve:
%s
But I wasn't able to find a suitable PureScript module to build.
If this is the first time you are running snaplet-purescript, have
a look inside snaplets/purs/devel.cfg.
|] (Text -> FilePath
T.unpack Text
js)
envCfgTemplate :: T.Text
envCfgTemplate :: Text
envCfgTemplate = FilePath -> Text
T.pack [r|
# Choose one between 'Verbose' and 'Quiet'
#
verbosity = "Verbose"
#
# Choose one between 'CompileOnce' and 'CompileAlways'
#
compilationMode = "CompileAlways"
#
# Whether bundle everything in a fat app
#
bundle = true
#
# Override the bundle command executable
#
bundleExe = "purs"
#
# Override the bundle command arguments
#
bundleOpts = []
#
# The path to a specific directory containing the purescript toolchain.
# Example: snaplet/purs/node_modules/purescript/vendor.
# Leave it uncommented if you plan to use the globally-installed one.
#
# pureScriptPath = ""
#
# The path to a specific, user-provided version of Spago.
# Leave it uncommented if you plan to use the globally-installed one or you
# are OK with snaplet-purescript installing it for you.
#
# spagoPath = ""
#
# Extra options to pass to https://github.com/natefaubion/purescript-psa,
# if available.
psaOpts = []
#
permissiveInit = false
# Be lenient towards compilation errors in case the `pursInit` function
# initial compilation fails. Useful in devel mode to avoid your web server
# to not start at all when you are debugging your PS.
#
# The name of the output bundle
bundleName = "index.js"
#
# The list of modules you want to compile under the PS namespace (bundle only)
# Adding 'Main' will make sure you will have something like PS.Main.main in
# your generated JS.
modules = ["Main"]
#
# Hooks - They are a way to invoke certain action during the snaplet lifecycle.
# They accept a shell command where the first token is the command itself,
# the rest are the parameters for the command. The entire hook section or each
# individual hook can be omitted.
hooks {
preInit = "echo 'hello'"
postInit = ""
preBuild = ""
postBuild = ""
preBundle = ""
postBundle = ""
}
|]