yesod-purescript (empty) → 0.0.4.1
raw patch · 5 files changed
+579/−0 lines, 5 filesdep +aesondep +basedep +containerssetup-changed
Dependencies added: aeson, base, containers, data-default, directory, filepath, formatting, fsnotify, parsec, purescript, shakespeare, system-fileio, system-filepath, template-haskell, text, time, transformers, utf8-string, yesod-core
Files
- LICENSE +20/−0
- Setup.hs +6/−0
- Yesod/PureScript.hs +446/−0
- Yesod/PureScript/Data.hs +65/−0
- yesod-purescript.cabal +42/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Maciej Pietrzak, https://github.com/mpietrzak/yesod-purescript++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Yesod/PureScript.hs view
@@ -0,0 +1,446 @@+{-# 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+
+ Yesod/PureScript/Data.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Yesod.PureScript.Data+where+++import Control.Concurrent (MVar)+import Data.Text (Text)+import Data.Time (UTCTime)+import Yesod.Core++import qualified Data.Map.Strict as M+import qualified Language.PureScript as P+++data Mode = Dynamic | Static+++-- | Per-module compile options.+data CompileOptions = CompileOptions { coMain :: Maybe Text }+++-- | Options for Yesod PureScript.+data YesodPureScriptOptions = YesodPureScriptOptions {+ -- | Mode of compilation: dynamic or static.+ ypsoMode :: Mode,+ -- | Source directories to look for ".purs" files.+ ypsoSourceDirectories :: [Text],+ -- | Defines what and how to compile.+ ypsoCompileOptions :: [CompileOptions],+ -- | Optionally specifies div id in parent page that will be used to display compilation error if any.+ -- This is because usually resulting JS is loaded by HTML page, and it might+ -- save a time (esp for trivial errors) if error is displayed directly in HTML.+ ypsoErrorDivId :: Maybe Text,+ -- | Option passed to PureScript compiler, makes errors verbose.+ ypsoVerboseErrors :: Bool+ }+++-- | This is meant to be stored in synchronized variable.+data PureScriptSiteState = PureScriptSiteState {+ -- | A flag telling us if compiler subthread is running.+ psssWatchStarted :: Bool,++ -- | Results of file parsing, time and either errors as text or list of modules,+ -- keyed by file path.+ psssModules :: M.Map Text (UTCTime, (Either Text [P.Module])),++ -- | Cached modules compiled with "module" and "main" options to Text.+ -- Result of compilation is either compile error(s) as Text or+ -- the Text of compiled module.+ -- Values in map are tuples of time of compilation attempt and compilation result.+ psssCompiledModules :: M.Map Text (UTCTime, (Either Text Text))+ }+++-- | Yesod sub site for PureScript.+data PureScriptSite = PureScriptSite { pssState :: MVar PureScriptSiteState+ , pssOptions :: YesodPureScriptOptions }+++mkYesodSubData "PureScriptSite" [parseRoutes|+/*Texts PureScriptCompiledR GET+|]
+ yesod-purescript.cabal view
@@ -0,0 +1,42 @@+name: yesod-purescript+version: 0.0.4.1+synopsis: PureScript integration for Yesod+description: PureScript is an awesome statically typed language that compiles to JS and runs in your browser, and this module makes it easier to use PureScript in Yesod.+homepage: https://github.com/mpietrzak/yesod-purescript+license: MIT+license-file: LICENSE+author: Maciej Pietrzak+maintainer: mpietrzak@gmail.com+category: Web, Yesod+build-type: Simple+cabal-version: >=1.8+stability: experimental++source-repository head+ type: git+ location: https://github.com/mpietrzak/yesod-purescript++library+ exposed-modules: Yesod.PureScript+ other-modules: Yesod.PureScript.Data+ build-depends: aeson >= 0.8+ , base >= 4 && < 5+ , containers+ , data-default+ , directory+ , filepath+ , formatting+ , fsnotify+ , parsec+ , purescript >= 0.6.3 && < 0.7+ , shakespeare >= 2+ , text+ , time+ , system-filepath+ , system-fileio+ , template-haskell+ , transformers+ , utf8-string+ , yesod-core+ ghc-options: -Wall+