{-# 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

--------------------------------------------------------------------------------
-- | Snaplet initialization
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
  -- If they do not exist, create the required directories
  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
           }

  -- compile at least once, unless `CompileNever` was passed.
  -- NOTE: We ignore the ouput of this first compilation
  -- if we are running in a 'permissive' mode, to avoid having the entire
  -- web service to grind to an halt in case our Purs does not compile.
  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 ()
pursServe :: Handler b PureScript ()
pursServe = 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 the project (without bundling it).
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 = ""
}
|]