module Web.Apiary.PureScript.Internal where
import qualified System.FilePath.Glob as G
import qualified System.IO.UTF8 as U
import qualified Language.PureScript as P
import Control.Monad.Apiary.Action(ActionT, contentType, string, bytes)
import Control.Exception(Exception, throwIO, try)
import Control.Applicative((<$>))
import Web.Apiary(MonadIO(..))
import Data.Apiary.Extension(Extension)
import Data.Default.Class(Default(def))
import Data.IORef(IORef, newIORef, readIORef, atomicModifyIORef')
import Data.Typeable(Typeable)
import qualified Data.HashMap.Strict as H
import qualified Text.Parsec.Error as P
data PureScriptException
= ParseError P.ParseError
| CompileError String
deriving (Show, Typeable)
instance Exception PureScriptException
defaultPatterns :: [G.Pattern]
defaultPatterns = map G.compile
[ "src/**/*.purs"
, "bower_components/purescript-*/src/**/*.purs"
]
data PureScriptConfig = PureScriptConfig
{ libraryPatterns :: [G.Pattern]
, libraryBaseDir :: FilePath
, development :: Bool
, initialCompiles :: [FilePath]
, pureScriptPrefix :: [String]
, pureScriptOptions :: P.Options P.Compile
}
instance Default PureScriptConfig where
def = PureScriptConfig
defaultPatterns
"."
False
[]
["Generated by apiary-purescript. purescript version: " ++ "0.6.3"]
P.defaultCompileOptions
{ P.optionsMain = Just "Main" }
data PureScript = PureScript
{ pscConfig :: PureScriptConfig
, compiled :: IORef (H.HashMap FilePath String)
}
instance Extension PureScript
makePureScript :: PureScriptConfig -> IO PureScript
makePureScript conf = do
ir <- mapM (\p -> (p,) <$> compile conf p) (initialCompiles conf)
p <- PureScript conf <$> newIORef (H.fromList ir)
return p
compile :: PureScriptConfig -> FilePath -> IO String
compile opt p = do
mods <- G.globDir (libraryPatterns opt) (libraryBaseDir opt)
>>= mapM (\f -> (f,) <$> U.readFile f) . (p:) . concat . fst
case P.parseModulesFromFiles id $ ("prelude", P.prelude) : mods of
Left l -> throwIO (ParseError l)
Right ms -> case P.compile (pureScriptOptions opt) (map snd ms) (pureScriptPrefix opt) of
Left l -> throwIO (CompileError l)
Right (js,_,_) -> return js
pureScript :: MonadIO m => PureScript -> FilePath -> ActionT exts prms 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 -> string r
Left e | development (pscConfig env) -> do
bytes "console.log(\""
string $ pr (e :: PureScriptException)
bytes "\")"
| otherwise -> bytes "console.log(\"PureScript error.\");"
where
pr = concatMap esc . show
esc '"' = "\\\""
esc '\'' = "\\'"
esc '\\' = "\\\\"
esc '/' = "\\/"
esc '<' = "\\x3c"
esc '>' = "\\x3e"
esc '\n' = "\\n"
esc c = [c]