{-# 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(..),
addPureScriptWidget,
createYesodPureScriptSite,
defaultYesodPureScriptOptions,
getPureScriptRoute
)
where
-- PureScript Yesod Subsite
-- goal is to serve eg ./purs/foo.purs file at /purs/foo.js url.
import Control.Applicative ((<$>))
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 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
, 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.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.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"]
, ypsoSourceIgnores = []
, 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) :: [(FSP.FilePath, (UTCTime, [Module]))]
-- (fileName, error)
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 {
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>#{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
-- | 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 -> 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
-- 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 -> 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
-- | 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 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 ()
-- | 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 <- 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"
-- | 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 ()
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
-- | Take directory FilePath, find '*.purs' files recursively.
findFiles :: [Text] -> FSPC.FilePath -> IO [FSPC.FilePath]
findFiles ignores dir = do
allNames <- FS.listDirectory dir -- listdir foo will return foo/bar if bar is in foo, path not just name
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
-- | 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 :: FSP.FilePath -> IO (Either Text [P.Module])
parseFile fn = do
let fns = FSPC.encodeString fn
fileContents <- U.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
-- | Find files in directories and parse them.
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
-- | Parse modules, return map of path -> parse result: either parse error or parsed modules.
-- Current impl uses Filesystem.FilePath in hopes that it's faster than String-based impl and
-- that it handles edge cases better.
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 -> []
-- | Compile PureScript modules in "--main <module>" mode.
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 _psOptions modules ["yesod-purescript"]
_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] []
-- | 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
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 _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
-- | PureScript Template Haskell
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
-- parsed is a crazy struct and for now we need only list of modules
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 -- this is string literal we can insert at TH call site
[|toWidget $ toJavascript $ rawJS $ T.pack $(thLit)|]