module Yesod.PureScript (
PureScriptSite,
YesodPureScript,
YesodPureScriptOptions(..),
addPureScriptWidget,
createYesodPureScriptSite,
defaultYesodPureScriptOptions,
getPureScriptRoute,
yesodPureScript
)
where
import Control.Applicative ((<$>))
import Control.Exception (catch, SomeException)
import Control.Monad (forever, forM, forM_)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT)
import Data.Either (rights)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Filesystem.Path ((</>))
import Formatting
import Formatting.Time
import Language.Haskell.TH
import Language.PureScript (Module(Module))
import Prelude
import Text.Julius
import Text.Regex.TDFA ((=~))
import Text.Regex.TDFA.Text ()
import Yesod.Core ( HandlerT
, Route
, TypedContent (TypedContent)
, Yesod
, YesodSubDispatch
, addScript
, getYesod
, mkYesodSubDispatch
, shamlet
, toContent
, toTypedContent
, toWidget
, yesodSubDispatch )
import qualified Control.Concurrent as C
import qualified Control.Concurrent.MVar as CM
import qualified Data.Aeson.Types as AesonTypes
import qualified Data.ByteString as BS
import qualified Data.Default as DD
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.IO as TIO
import qualified Data.Text.Lazy as TL
import qualified Filesystem as FS
import qualified Filesystem.Path as FSP
import qualified Filesystem.Path.CurrentOS as FSPC
import qualified Language.PureScript as P
import qualified System.FSNotify as SFN
import Yesod.PureScript.Data
class Yesod master => YesodPureScript master
instance YesodPureScript master => YesodSubDispatch PureScriptSite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesPureScriptSite)
instance DD.Default YesodPureScriptOptions where
def = defaultYesodPureScriptOptions
type PureScriptHandler a = (YesodPureScript master) => HandlerT PureScriptSite (HandlerT master IO) a
defaultYesodPureScriptOptions :: YesodPureScriptOptions
defaultYesodPureScriptOptions = YesodPureScriptOptions
{ ypsoSourceDirectories = ["purs", "bower_components"]
, ypsoSourceIgnores = []
, ypsoErrorDivId = Nothing
, ypsoVerboseErrors = False
, ypsoMode = Dynamic
, ypsoCompileOptions = [] }
createYesodPureScriptSite :: YesodPureScriptOptions -> IO PureScriptSite
createYesodPureScriptSite opts = do
let state = PureScriptSiteState { psssWatchStarted = False
, psssModules = M.empty
, psssCompiledModules = M.empty }
mv <- CM.newMVar state
return $ PureScriptSite { pssState = mv
, pssOptions = opts }
getPureScriptRoute :: [Text] -> Route PureScriptSite
getPureScriptRoute p = PureScriptCompiledR p
createJavaScriptError :: TL.Text -> TL.Text -> TL.Text
createJavaScriptError errorDivId errorText = renderJavascriptUrl render tmpl
where
render _ _ = error "no links supported here"
_s _tl = AesonTypes.String (TL.toStrict _tl)
tmpl = [julius|
var err = #{_s errorText};
var errorDiv = document.getElementById(#{_s errorDivId});
if (window && window.console && window.console.log) {
window.console.log(err);
}
if (errorDiv) {
var errnode = document.createTextNode(err);
var prenode = document.createElement("pre");
prenode.appendChild(errnode);
if (errorDiv.firstChild) {
errorDiv.insertBefore(prenode, errorDiv.firstChild);
} else {
errorDiv.appendChild(errnode);
}
}
|]
getPureScriptInfo :: PureScriptSite -> PureScriptHandler TypedContent
getPureScriptInfo site = do
moduleMap <- liftIO $ CM.withMVar (pssState site) $ \state -> return (psssModules state)
let _justSndRight (_k, (_t, _mv)) = case _mv of
Right _v -> Just (_k, (_t, _v))
_ -> Nothing
let _justSndLeft (_k, (_t, _mv)) = case _mv of
Left _v -> Just (_k, (_t, _v))
_ -> Nothing
let fnsmodules = mapMaybe _justSndRight (M.toAscList moduleMap) :: [(FSP.FilePath, (UTCTime, [Module]))]
let fnerrs = mapMaybe _justSndLeft (M.toAscList moduleMap) :: [(FSP.FilePath, (UTCTime, Text))]
let _formatTime _t = format (dateDash % " " % hms) _t _t
let filePathToText fp = case FSPC.toText fp of
Left _t -> _t
Right _t -> _t
return $ toTypedContent $ [shamlet|
$doctype 5
<html>
<style>
body {
fontfamily: sansserif;
fontsize: 10pt;
}
<body>
<h1>yesodpurescript Status
<h2>Failed Modules
$case fnerrs
$of []
<p>All modules loaded without errors
$of _
<table>
<thead>
<tr>
<th>File name
<th>Error message
<th>Load time
<tbody>
$forall (fn, (time, err)) <- fnerrs
<tr>
<td>#{filePathToText fn}
<td>#{err}
<td>#{_formatTime time}
<h2>Loaded Modules
$case fnsmodules
$of []
<p>No modules loaded
$of _
<table>
<thead>
<tr>
<th>Module
<th>File name
<th>Load time
<tbody>
$forall fnmods <- fnsmodules
$with (fn, (time, modules)) <- fnmods
$forall (Module name _ _ _) <- modules
<tr>
<td>#{show name}
<td>#{filePathToText fn}
<td>#{_formatTime time}
|]
where
getPureScriptCompiledR :: [Text] -> PureScriptHandler TypedContent
getPureScriptCompiledR [] = do
me <- getYesod
liftIO $ ensureWatchStarted me
getPureScriptInfo me
getPureScriptCompiledR p = do
me <- getYesod
liftIO $ ensureWatchStarted me
let jsModulePath = T.intercalate "." p
let jsModuleName = if T.isSuffixOf ".js" jsModulePath
then T.dropEnd 3 jsModulePath
else jsModulePath
compileResult <- liftIO $ compilePureScriptFile me jsModuleName
case compileResult of
Left err -> do
case ypsoErrorDivId (pssOptions me) of
Nothing -> do
let errbs = TE.encodeUtf8 err
return (TypedContent "text/plain" (toContent errbs))
Just _id -> do
let _errtxt = TL.fromStrict err
let _errjs = createJavaScriptError (TL.fromStrict _id) _errtxt
return (TypedContent "text/javascript" (toContent _errjs))
Right _js -> do
let _jsbs = TE.encodeUtf8 _js
return (TypedContent "application/javascript" (toContent _jsbs))
addModule :: PureScriptSite -> FSPC.FilePath -> (UTCTime, Either Text [P.Module]) -> IO ()
addModule pureScriptSite fileName eitherErrOrModules = do
CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do
let curmap = psssModules state
let newmap = M.insert fileName eitherErrOrModules curmap
let newstate = state { psssModules = newmap
, psssCompiledModules = M.empty }
return newstate
removeModule :: PureScriptSite -> FSP.FilePath -> IO ()
removeModule pureScriptSite fileName = do
CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do
let curmap = psssModules state
let newmap = M.delete fileName curmap
let newstate = state { psssModules = newmap
, psssCompiledModules = M.empty }
return newstate
relpath :: FSP.FilePath -> FSP.FilePath -> FSP.FilePath
relpath base absolute =
case FSP.stripPrefix base absolute of
Just _p -> _p
Nothing -> ".." </> (relpath (FSP.parent base) absolute)
handleFileEvent :: PureScriptSite -> SFN.Event -> IO ()
handleFileEvent pureScriptSite event = do
current <- FS.getWorkingDirectory >>= \_d -> return (FSP.collapse (_d </> "."))
let fp = relpath current (SFN.eventPath event)
let mext = FSP.extension fp
let _upsert = do
_parsed <- parseFile fp
_now <- getCurrentTime
addModule pureScriptSite fp (_now, _parsed)
case (event, mext) of
(SFN.Added _ _, Just "purs") -> _upsert
(SFN.Modified _ _, Just "purs") -> _upsert
(SFN.Removed _ _, Just "purs") -> do removeModule pureScriptSite fp
_ -> return ()
ensureWatchStarted :: PureScriptSite -> IO ()
ensureWatchStarted pureScriptSite = do
let mode = ypsoMode $ pssOptions pureScriptSite
case mode of
Dynamic -> do
CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do
case psssWatchStarted state of
False -> do
_m <- parseSiteFiles pureScriptSite
startWatchThread pureScriptSite
return (state { psssWatchStarted = True
, psssModules = _m
, psssCompiledModules = M.empty })
_ -> return state
Static -> error "YPS mode is Static, can't start watch thread"
startWatchThread :: PureScriptSite -> IO ()
startWatchThread pureScriptSite = do
_ <- C.forkIO $ do
let opts = pssOptions pureScriptSite
let dirs = ypsoSourceDirectories opts
SFN.withManager $ \mgr -> do
forM_ dirs $ \dir -> do
SFN.watchTree mgr (FSPC.fromText dir) (const True) $ \e -> do
catch
(handleFileEvent pureScriptSite e)
(\_e -> do
let msg = show (_e :: SomeException)
TIO.putStrLn $ T.concat ["exception in handleFileEvent: ", T.pack msg])
forever $ do
C.threadDelay (12 * 3600 * 1000 * 1000)
return ()
matchPath :: Text -> FSP.FilePath -> Bool
matchPath pattern path = case FSPC.toText path of
Left _t -> False
Right _t -> _t =~ pattern
matchPathAny :: [Text] -> FSP.FilePath -> Bool
matchPathAny patterns path = any (flip matchPath path) patterns
matchPathNone :: [Text] -> FSP.FilePath -> Bool
matchPathNone ignores path = not $ matchPathAny ignores path
findFiles :: [Text] -> FSPC.FilePath -> IO [FSPC.FilePath]
findFiles ignores dir = do
allNames <- FS.listDirectory dir
let goodNames = filter (matchPathNone ignores) $ filter (flip notElem [".", ".."]) allNames
pathLists <- forM goodNames $ \n -> do
isDir <- FS.isDirectory n
if isDir
then findFiles ignores n
else do
return $ if FSP.hasExtension n "purs" then [n] else []
let paths = concat pathLists
return paths
parseFile :: FSP.FilePath -> IO (Either Text [P.Module])
parseFile fn = do
let fns = FSPC.encodeString fn
fileContents <- T.unpack <$> TE.decodeUtf8 <$> BS.readFile fns
let eem = case P.lex fns fileContents of
Right _tokens -> P.runTokenParser fns P.parseModules _tokens
Left _err -> Left _err
let r = case eem of
Left _e -> Left . T.pack . show $ _e
Right m -> Right m
return r
parseFiles :: [FSP.FilePath] -> [Text] -> IO (M.Map FSPC.FilePath (UTCTime, Either Text [P.Module]))
parseFiles dirs ignores = do
let lsActions = map (findFiles ignores) dirs
filenames <- concat <$> sequence lsActions
_time <- getCurrentTime
parseResults <- forM filenames $ \fn -> do
_parsed <- parseFile fn
return (fn, (_time, _parsed))
return $ M.fromList $ parseResults
parseSiteFiles :: PureScriptSite -> IO (M.Map FSPC.FilePath (UTCTime, Either Text [P.Module]))
parseSiteFiles pureScriptSite = parseFiles dirs ignores
where
ypso = pssOptions pureScriptSite
dirs = map FSPC.fromText $ ypsoSourceDirectories ypso :: [FSP.FilePath]
ignores = ypsoSourceIgnores ypso :: [Text]
preludeModules :: [P.Module]
preludeModules = case P.lex "" P.prelude of
Right _tokens -> case P.runTokenParser "" P.parseModules _tokens of
Right _ms -> _ms
Left _err -> []
Left _err -> []
compilePureScript :: YesodPureScriptOptions -> [Module] -> Text -> Either Text Text
compilePureScript ypso modules mainModuleName = case _result of
Left _err -> Left (T.pack _err)
Right (_js, _, _) -> Right (T.pack _js)
where
_result = P.compile modules ["yesod-purescript"] `runReaderT` _psOptions
_psOptions = P.defaultCompileOptions { P.optionsMain = Just (T.unpack mainModuleName)
, P.optionsNoPrelude = False
, P.optionsAdditional = _compileOptions
, P.optionsVerboseErrors = ypsoVerboseErrors ypso }
_compileOptions = P.CompileOptions "PS" [T.unpack mainModuleName] []
compilePureScriptFile :: PureScriptSite -> Text -> IO (Either Text Text)
compilePureScriptFile pureScriptSite moduleName = do
compileResult <- CM.modifyMVar (pssState pureScriptSite) $ \state -> do
let _m = psssCompiledModules state
case M.lookup moduleName _m of
Just (_t, _cmt) -> do
TIO.putStrLn $ T.concat ["compile result for js module \"", moduleName, "\" found in cache"]
return (state, _cmt)
Nothing -> do
TIO.putStrLn $ T.concat ["compiling js module \"", moduleName, "\""]
_time <- getCurrentTime
let _lmm = psssModules state
let _loadedModules = concat $ rights $ map snd $ M.elems _lmm
let _modules = concat [preludeModules, _loadedModules]
let compileResult = compilePureScript (pssOptions pureScriptSite) _modules moduleName
let newmap = M.insert moduleName (_time, compileResult) _m
let newstate = state { psssCompiledModules = newmap }
return (newstate, compileResult)
return compileResult
addPureScriptWidget :: YesodPureScriptOptions -> Text -> Q Exp
addPureScriptWidget ypso moduleName = do
let dirs = map FSPC.fromText $ ypsoSourceDirectories ypso
let ignores = ypsoSourceIgnores ypso
parsed <- runIO $ parseFiles dirs ignores
let parsedModules = concat $ catMaybes $ flip map (M.elems parsed) $ \(_, e) -> case e of
Left _ -> Nothing
Right _modules -> Just _modules
let modules = concat [preludeModules, parsedModules]
compiled <- case compilePureScript ypso modules moduleName of
Left _err -> fail $ "Failed to compile PureScript module \"" ++ show moduleName ++ "\": " ++ show _err
Right _js -> return _js
let thLit = litE $ stringL $ T.unpack compiled
[|toWidget $ toJavascript $ rawJS $ T.pack $(thLit)|]
yesodPureScript dev routeName ypso moduleName =
if dev then
[|addScript $ $(conE routeName) $ getPureScriptRoute $ map T.pack [$(thModuleNameStrLit)]|]
else
addPureScriptWidget ypso moduleName
where
thModuleNameStrLit = litE $ stringL $ T.unpack moduleName