diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Hirotomo Moriwaki + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apiary-purescript.cabal b/apiary-purescript.cabal new file mode 100644 --- /dev/null +++ b/apiary-purescript.cabal @@ -0,0 +1,42 @@ +name: apiary-purescript +version: 0.14.0 +synopsis: purescript compiler for apiary web framework. +description: + example: +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/apiary +Bug-reports: https://github.com/philopon/apiary/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Web +build-type: Simple +stability: experimental +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Web.Apiary.PureScript + Web.Apiary.PureScript.Explicit + other-modules: Web.Apiary.PureScript.Internal + build-depends: base >=4.6 && <4.8 + , template-haskell + , apiary >=0.14 && <0.15 + , purescript >=0.5 && <0.6 + , filepath >=1.3 && <1.4 + , utf8-string >=0.3 && <0.4 + , text >=1.1 && <1.2 + , bytestring >=0.10 && <0.11 + , unordered-containers >=0.2 && <0.3 + , reflection >=1.4 && <1.6 + , parsec >=3.1 && <3.2 + , Glob >=0.7 && <0.8 + + hs-source-dirs: src + ghc-options: -O2 -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/philopon/apiary.git diff --git a/src/Web/Apiary/PureScript.hs b/src/Web/Apiary/PureScript.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/PureScript.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE FlexibleContexts #-} + +module Web.Apiary.PureScript + ( I.PureScriptConfig(..) + , HasPureScript + , withPureScript + , pureScript + ) where + +import Web.Apiary +import qualified Web.Apiary.PureScript.Internal as I +import Data.Reflection + +type HasPureScript = Given I.PureScript + +withPureScript :: MonadIO m => I.PureScriptConfig + -> (HasPureScript => m a) -> m a +withPureScript conf m = I.withPureScript conf $ \p -> give p m + +pureScript :: (MonadIO m, HasPureScript) => FilePath -> ActionT m () +pureScript = I.pureScript given diff --git a/src/Web/Apiary/PureScript/Explicit.hs b/src/Web/Apiary/PureScript/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/PureScript/Explicit.hs @@ -0,0 +1,8 @@ +module Web.Apiary.PureScript.Explicit + ( PureScriptConfig(..) + , PureScript + , withPureScript + , pureScript + ) where + +import Web.Apiary.PureScript.Internal diff --git a/src/Web/Apiary/PureScript/Internal.hs b/src/Web/Apiary/PureScript/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/PureScript/Internal.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Web.Apiary.PureScript.Internal where + +import System.FilePath +import qualified System.FilePath.Glob as G +import qualified System.IO.UTF8 as U + +import Language.Haskell.TH +import qualified Language.PureScript as P + +import Control.Exception +import Control.Applicative + +import Web.Apiary + +import Data.IORef +import Data.Typeable +import qualified Data.HashMap.Strict as H +import qualified Text.Parsec.Error as P +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC + +import qualified Paths_apiary_purescript as Path + +data PureScriptException + = ParseError P.ParseError + | CompileError String + deriving (Show, Typeable) +instance Exception PureScriptException + +purescriptDatadir :: FilePath +purescriptDatadir = takeDirectory $(stringE =<< runIO Path.getDataDir) "purescript-" ++ VERSION_purescript + +defaultPatterns :: [G.Pattern] +defaultPatterns = map G.compile + [ "src/**/*.purs" + , "bower_components/purescript-*/src/**/*.purs" + , "bower_components/purescript-*/src/**/*.purs.hs" + ] + +data PureScriptConfig = PureScriptConfig + { libraryPatterns :: [G.Pattern] + , libraryBaseDir :: FilePath + , preludePath :: FilePath + , development :: Bool + , initialCompiles :: [FilePath] + , pureScriptOptions :: P.Options + } + +instance Default PureScriptConfig where + def = PureScriptConfig + defaultPatterns + "." + defaultPreludePath + False + [] + P.defaultOptions + { P.optionsMain = Just "Main" + , P.optionsBrowserNamespace = Just "PS" + } + +data PureScript = PureScript + { pscConfig :: PureScriptConfig + , compiled :: IORef (H.HashMap FilePath L.ByteString) + } + +withPureScript :: MonadIO m => PureScriptConfig -> (PureScript -> m b) -> m b +withPureScript conf m = do + ir <- liftIO $ mapM (\p -> (p,) <$> compile conf p) (initialCompiles conf) + p <- liftIO $ PureScript conf <$> newIORef (H.fromList ir) + m p + +defaultPreludePath :: FilePath +defaultPreludePath = purescriptDatadir "prelude/prelude.purs" + +readPscInput :: FilePath -> IO [P.Module] +readPscInput p = do + txt <- U.readFile p + case P.runIndentParser p P.parseModules txt of + Left e -> throwIO $ ParseError e + Right r -> return r + +pscModules :: PureScriptConfig -> IO [P.Module] +pscModules conf = do + mods <- liftIO $ do + concat . fst <$> G.globDir (libraryPatterns conf) (libraryBaseDir conf) + let prel = preludePath conf + concat `fmap` mapM readPscInput (prel : mods) + +compile :: PureScriptConfig -> FilePath -> IO L.ByteString +compile opt p = do + mods <- pscModules opt + mn <- readPscInput p + case P.compile (pureScriptOptions opt) $ mn ++ mods of + Left l -> throwIO (CompileError l) + Right (js, _, _) -> return . T.encodeUtf8 $ T.pack js + +pureScript :: MonadIO m => PureScript -> FilePath -> ActionT m () +pureScript env p = do + contentType "text/javascript" + s <- liftIO . try $ + if development (pscConfig env) + then compile (pscConfig env) p + else (H.lookup p <$> readIORef (compiled env)) >>= \case + Nothing -> do + r <- compile (pscConfig env) p + atomicModifyIORef' (compiled env) ((,()) . H.insert p r) + return r + Just r -> return r + case s of + Right r -> lbs r + Left e | development (pscConfig env) -> + lbs . LC.pack $ "alert(\"" ++ pr (e::PureScriptException) ++ "\")" + + | otherwise -> lbs "alert(\"PureScript error.\");" + where + pr = concatMap esc . show + esc '"' = "\\\"" + esc '\'' = "\\'" + esc '\\' = "\\\\" + esc '/' = "\\/" + esc '<' = "\\x3c" + esc '>' = "\\x3e" + esc '\n' = "\\n" + esc c = [c]