yesod-purescript 0.0.4.1 → 0.0.4.2
raw patch · 3 files changed
+119/−73 lines, 3 filesdep +regex-tdfadep +regex-tdfa-text
Dependencies added: regex-tdfa, regex-tdfa-text
Files
- Yesod/PureScript.hs +112/−71
- Yesod/PureScript/Data.hs +4/−1
- yesod-purescript.cabal +3/−1
Yesod/PureScript.hs view
@@ -16,6 +16,7 @@ PureScriptSite, YesodPureScript, YesodPureScriptOptions(..),+ addPureScriptWidget, createYesodPureScriptSite, defaultYesodPureScriptOptions, getPureScriptRoute@@ -25,6 +26,7 @@ -- 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)@@ -33,12 +35,15 @@ 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 System.FilePath ((</>)) import Text.Julius+import Text.Regex.TDFA ((=~))+import Text.Regex.TDFA.Text () import Yesod.Core ( HandlerT , Route , TypedContent (TypedContent)@@ -49,6 +54,7 @@ , shamlet , toContent , toTypedContent+ , toWidget , yesodSubDispatch ) import qualified Control.Concurrent as C import qualified Control.Concurrent.MVar as CM@@ -63,10 +69,10 @@ 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 @@ -97,6 +103,7 @@ defaultYesodPureScriptOptions :: YesodPureScriptOptions defaultYesodPureScriptOptions = YesodPureScriptOptions { ypsoSourceDirectories = ["purs", "bower_components"]+ , ypsoSourceIgnores = [] , ypsoErrorDivId = Nothing , ypsoVerboseErrors = False , ypsoMode = Dynamic@@ -163,13 +170,17 @@ _ -> Nothing -- (fn, [module])- let fnsmodules = mapMaybe _justSndRight (M.toAscList moduleMap) :: [(Text, (UTCTime, [Module]))]+ let fnsmodules = mapMaybe _justSndRight (M.toAscList moduleMap) :: [(FSP.FilePath, (UTCTime, [Module]))] -- (fileName, error)- let fnerrs = mapMaybe _justSndLeft (M.toAscList moduleMap) :: [(Text, (UTCTime, Text))]+ 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>@@ -196,7 +207,7 @@ <tbody> $forall (fn, (time, err)) <- fnerrs <tr>- <td>#{fn}+ <td>#{filePathToText fn} <td>#{err} <td>#{_formatTime time} @@ -218,7 +229,7 @@ $forall (Module name _ _) <- modules <tr> <td>#{show name}- <td>#{fn}+ <td>#{filePathToText fn} <td>#{_formatTime time} |] where@@ -262,7 +273,7 @@ -- 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 -> FSPC.FilePath -> (UTCTime, Either Text [P.Module]) -> IO () addModule pureScriptSite fileName eitherErrOrModules = do CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do let curmap = psssModules state@@ -276,7 +287,7 @@ -- | Executed when file disappears from watched dirs, -- removes module from PureScriptSite's state.-removeModule :: PureScriptSite -> Text -> IO ()+removeModule :: PureScriptSite -> FSP.FilePath -> IO () removeModule pureScriptSite fileName = do CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do let curmap = psssModules state@@ -286,28 +297,20 @@ 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)+ _parsed <- parseFile fp _now <- getCurrentTime- addModule pureScriptSite (fp2t fp) (_now, _parsed)+ 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 (fp2t fp)- _ -> do- -- ignore this event- return ()- where- fp2t fp = case FSPC.toText fp of- Left _ -> error "invalid path"- Right _t -> _t+ (SFN.Removed _ _, Just "purs") -> do removeModule pureScriptSite fp+ _ -> return () -- | Start file-watching stuff if not already started.@@ -319,7 +322,7 @@ CM.modifyMVar_ (pssState pureScriptSite) $ \state -> do case psssWatchStarted state of False -> do- _m <- parseAllFiles pureScriptSite+ _m <- parseSiteFiles pureScriptSite startWatchThread pureScriptSite return (state { psssWatchStarted = True , psssModules = _m@@ -349,62 +352,95 @@ 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+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- let p = dirp </> n- isDir <- D.doesDirectoryExist p+ isDir <- FS.isDirectory n if isDir- then findFiles (T.pack p)- else return $ if isSuffixOf ".purs" p then [T.pack p] else []- let paths = (concat pathLists)+ 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 :: Text -> IO (Either Text [P.Module])+parseFile :: FSP.FilePath -> 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+ 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- -- TIO.putStrLn $ T.concat ["parsed \"", fn, "\""] 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.--- 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+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.@@ -412,11 +448,6 @@ -- 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@@ -428,19 +459,29 @@ _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 _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)|]
Yesod/PureScript/Data.hs view
@@ -11,6 +11,7 @@ import Yesod.Core import qualified Data.Map.Strict as M+import qualified Filesystem.Path as FSP import qualified Language.PureScript as P @@ -27,6 +28,8 @@ ypsoMode :: Mode, -- | Source directories to look for ".purs" files. ypsoSourceDirectories :: [Text],+ -- | Ignores, list of regexps that prevent parsing.+ ypsoSourceIgnores :: [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.@@ -45,7 +48,7 @@ -- | 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])),+ psssModules :: M.Map FSP.FilePath (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
yesod-purescript.cabal view
@@ -1,5 +1,5 @@ name: yesod-purescript-version: 0.0.4.1+version: 0.0.4.2 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@@ -29,6 +29,8 @@ , fsnotify , parsec , purescript >= 0.6.3 && < 0.7+ , regex-tdfa+ , regex-tdfa-text , shakespeare >= 2 , text , time