{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Yesod.PureScript (
PureScriptSite,
YesodPureScript,
YesodPureScriptOptions(..),
createYesodPureScriptSite,
defaultYesodPureScriptOptions,
getPureScriptRoute
)
where
-- PureScript Yesod Subsite
-- goal is to serve eg ./purs/foo.purs file at /purs/foo.js url.
import Control.Exception (catch, SomeException)
import Control.Monad (forever, forM, forM_)
import Control.Monad.IO.Class (liftIO)
import Data.Either (rights)
import Data.List (isSuffixOf)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Formatting
import Formatting.Time
import Language.PureScript (Module(Module))
import Prelude
import System.FilePath ((</>))
import Text.Julius
import Yesod.Core ( HandlerT
, Route
, TypedContent (TypedContent)
, Yesod
, YesodSubDispatch
, getYesod
, mkYesodSubDispatch
, shamlet
, toContent
, toTypedContent
, yesodSubDispatch )
import qualified Control.Concurrent as C
import qualified Control.Concurrent.MVar as CM
import qualified Data.Aeson.Types as AesonTypes
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 T
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.Directory as D
import qualified System.FSNotify as SFN
import qualified System.IO.UTF8 as U
import Yesod.PureScript.Data
-- | Things that are Yesod master can also be YesodPureScript master.
class Yesod master => YesodPureScript master
-- | All things that are "YesodPureScript master", are also this other thing,
-- because they /nobody knows, because TH/.
instance YesodPureScript master => YesodSubDispatch PureScriptSite (HandlerT master IO) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesPureScriptSite)
-- | YesodPureScriptOptions thing is also Data.Default.Default, because it has "def",
-- which is defaultYesodPureScriptOptions.
instance DD.Default YesodPureScriptOptions where
def = defaultYesodPureScriptOptions
-- | Shortcut type for handlers of this subsite.
type PureScriptHandler a = (YesodPureScript master) => HandlerT PureScriptSite (HandlerT master IO) a
-- | Default options for YesodPureScript.
-- Needed when creating PureScriptSite.
-- Please don't create YesodPureScriptOptions by calling constructor directly,
-- so I can add more options without breaking your code.
defaultYesodPureScriptOptions :: YesodPureScriptOptions
defaultYesodPureScriptOptions = YesodPureScriptOptions
{ ypsoSourceDirectories = ["purs", "bower_components"]
, ypsoErrorDivId = Nothing
, ypsoVerboseErrors = False
, ypsoMode = Dynamic
, ypsoCompileOptions = [] }
-- | Create pure script site.
-- Initialises MVar of compiled modules to empty map.
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 }
-- | For convenience: turns a path as list into a route.
getPureScriptRoute :: [Text] -> Route PureScriptSite
getPureScriptRoute p = PureScriptCompiledR p
-- | Create JS error report that tries to insert itself into parent page.
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
-- map of filename to either err module
moduleMap <- liftIO $ CM.withMVar (pssState site) $ \state -> return (psssModules state)
-- this is to filter map items whose values are tuples of (a0, Either ...),
-- and return those items with keys as tuples of (key, (a0, unboxed right)).
-- so this is pattern match on snd of tuple that either gives tuple of unboxed right in just or nothing...
let _justSndRight (_k, (_t, _mv)) = case _mv of
Right _v -> Just (_k, (_t, _v))
_ -> Nothing
-- similar to _justSndRight above, but returns value from Left (or nothing)
let _justSndLeft (_k, (_t, _mv)) = case _mv of
Left _v -> Just (_k, (_t, _v))
_ -> Nothing
-- (fn, [module])
let fnsmodules = mapMaybe _justSndRight (M.toAscList moduleMap) :: [(Text, (UTCTime, [Module]))]
-- (fileName, error)
let fnerrs = mapMaybe _justSndLeft (M.toAscList moduleMap) :: [(Text, (UTCTime, Text))]
let _formatTime _t = format (dateDash % " " % hms) _t _t
return $ toTypedContent $ [shamlet|
$doctype 5
<html>
<style>
body {
font-family: sans-serif;
font-size: 10pt;
}
<body>
<h1>yesod-purescript 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>#{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>#{fn}
<td>#{_formatTime time}
|]
where
-- | This is the main handler, "entry point" for YesodPureScript.
-- It takes a path to module as a list of Text, then it parses and
-- compiles stuff and returns results to client.
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 -- foo.bar.baz[.js]
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 = T.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 = T.encodeUtf8 _js
return (TypedContent "application/javascript" (toContent _jsbs))
-- | Called by file-watching thread after loading module from purs file.
-- Updates in-memory cache of modules.
-- Result of compilation is either textual representation of parse errors or module.
-- Cache of loaded modules is key-ed by purs filename - this way we can efficiently handle
-- file deletions or renames.
addModule :: PureScriptSite -> Text -> (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
-- For now re-loading of module causes cache all compiled modules to be
-- dropped.
let newstate = state { psssModules = newmap
, psssCompiledModules = M.empty }
return newstate
-- | Executed when file disappears from watched dirs,
-- removes module from PureScriptSite's state.
removeModule :: PureScriptSite -> Text -> 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
-- | Executed on file change. Updates loaded modules MVar-ed in PureScriptSite.
handleFileEvent :: PureScriptSite -> SFN.Event -> IO ()
handleFileEvent pureScriptSite event = do
let fp = SFN.eventPath event
let mext = FSP.extension fp
let _upsert = do
_parsed <- parseFile (fp2t fp)
_now <- getCurrentTime
addModule pureScriptSite (fp2t fp) (_now, _parsed)
case (event, mext) of
(SFN.Added _ _, Just "purs") -> _upsert
(SFN.Modified _ _, Just "purs") -> _upsert
(SFN.Removed _ _, Just "purs") -> do
removeModule pureScriptSite (fp2t fp)
_ -> do
-- ignore this event
return ()
where
fp2t fp = case FSPC.toText fp of
Left _ -> error "invalid path"
Right _t -> _t
-- | Start file-watching stuff if not already started.
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 <- parseAllFiles 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"
-- | Creates thread that watches input dirs and fires events on files.
-- This way modified files are instantly loaded, making dev setup more responsive.
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
-- XXX: catching all is bad
let msg = show (_e :: SomeException)
TIO.putStrLn $ T.concat ["exception in handleFileEvent: ", T.pack msg])
forever $ do
C.threadDelay (12 * 3600 * 1000 * 1000)
return ()
-- | Take human-readable dir name, find '*.purs' files recursively.
findFiles :: Text -> IO [Text]
findFiles dir = do
let dirp = T.unpack dir
allNames <- D.getDirectoryContents dirp
let goodNames = filter (flip notElem [".", ".."]) allNames
pathLists <- forM goodNames $ \n -> do
let p = dirp </> n
isDir <- D.doesDirectoryExist p
if isDir
then findFiles (T.pack p)
else return $ if isSuffixOf ".purs" p then [T.pack p] else []
let paths = (concat pathLists)
return paths
-- | High level parse interface for PureScript.
-- Takes file path as Text, returns either error as Text or parsed modules.
-- Note: PureScript file can define more than one module.
parseFile :: Text -> IO (Either Text [P.Module])
parseFile fn = do
-- TIO.putStrLn $ T.concat ["parsing \"", fn, "\""]
fileContents <- U.readFile (T.unpack fn)
let eem = case P.lex (T.unpack fn) fileContents of
Right _tokens -> P.runTokenParser (T.unpack fn) P.parseModules _tokens
Left _err -> Left _err
let r = case eem of
Left _e -> Left . T.pack . show $ _e
Right m -> Right m
-- TIO.putStrLn $ T.concat ["parsed \"", fn, "\""]
return r
-- | Parse modules, return map of path -> parse result: either parse error or parsed modules.
-- This beautiful code tries to make sure that paths are absolute.
-- Current impl uses Filesystem.FilePath in hopes that it's faster than String-based impl and
-- that it handles edge cases better.
parseAllFiles :: PureScriptSite -> IO (M.Map Text (UTCTime, Either Text [P.Module]))
parseAllFiles pureScriptSite = do
let sourceDirs = ypsoSourceDirectories $ pssOptions pureScriptSite
let lsActions = map (\d -> findFiles d) sourceDirs
dirsFiles <- sequence lsActions
let relFileNames = map FSPC.fromText $ concat dirsFiles
cwd <- FS.getWorkingDirectory
let absFileNames = map (FSP.append cwd) relFileNames
mParseResults <- forM absFileNames $ \afn -> do
case FSPC.toText afn of
Left _ -> return Nothing
Right _t -> do
_time <- getCurrentTime
_parsed <- parseFile _t
return $ Just (_t, (_time, _parsed))
let parseResults = catMaybes mParseResults
return $ M.fromList $ parseResults
-- | Takes PureScriptSite and module name and tries to compile given module in "--main <module>" mode.
-- PureScriptSite contains parsed modules.
-- Compiled module is stored (cached) in PureScriptSite's state with time of compilation.
-- Only compile result is returned.
-- Cached and returned result of compilation has type of Text.
compilePureScriptFile :: PureScriptSite -> Text -> IO (Either Text Text)
compilePureScriptFile pureScriptSite moduleName = do
let compileOptions = P.CompileOptions "PS" [T.unpack moduleName] []
let psOptions = P.defaultCompileOptions { P.optionsMain = Just (T.unpack moduleName)
, P.optionsNoPrelude = False
, P.optionsAdditional = compileOptions
, P.optionsVerboseErrors = ypsoVerboseErrors (pssOptions pureScriptSite) }
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
-- No cached compile result in map, need to actually compile.
let _lmm = psssModules state
let _preludeModules = case P.lex "" P.prelude of
Right _tokens -> case P.runTokenParser "" P.parseModules _tokens of
Right _ms -> _ms
Left _err -> []
Left _err -> []
let _loadedModules = concat $ rights $ map snd $ M.elems _lmm
let _modules = concat [_preludeModules, _loadedModules]
let compileResultRaw = P.compile psOptions _modules ["yesod-purescript"]
let compileResult = case compileResultRaw of
Left errStr -> Left (T.pack errStr)
Right (_js, _, _) -> Right (T.pack _js)
let newmap = M.insert moduleName (_time, compileResult) _m
let newstate = state { psssCompiledModules = newmap }
return (newstate, compileResult)
return compileResult