module Fay
(module Fay.Types
,compileFile
,compileFileWithState
,compileFromTo
,compileFromToAndGenerateHtml
,toJsName
,showCompileError
,getRuntime)
where
import Fay.Compiler
import Fay.Compiler.Misc (printSrcLoc)
import Fay.Compiler.Packages
import Fay.Types
import Control.Applicative
import Control.Monad
import Data.List
import Language.Haskell.Exts (prettyPrint)
import Language.Haskell.Exts.Syntax
import Paths_fay
import System.FilePath
compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO ()
compileFromTo config filein fileout = do
result <- maybe (compileFile config filein)
(compileFromToAndGenerateHtml config filein)
fileout
case result of
Right out -> maybe (putStrLn out) (`writeFile` out) fileout
Left err -> error $ showCompileError err
compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError String)
compileFromToAndGenerateHtml config filein fileout = do
result <- compileFile config { configFilePath = Just filein } filein
case result of
Right out -> do
when (configHtmlWrapper config) $
writeFile (replaceExtension fileout "html") $ unlines [
"<!doctype html>"
, "<html>"
, " <head>"
," <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"
, unlines . map ((" "++) . makeScriptTagSrc) $ configHtmlJSLibs config
, " " ++ makeScriptTagSrc relativeJsPath
, " </script>"
, " </head>"
, " <body>"
, " </body>"
, "</html>"]
return (Right out)
where relativeJsPath = makeRelative (dropFileName fileout) fileout
makeScriptTagSrc :: FilePath -> String
makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"
Left err -> return (Left err)
compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)
compileFile config filein = either Left (Right . fst) <$> compileFileWithState config filein
compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,CompileState))
compileFileWithState config filein = do
runtime <- getRuntime
hscode <- readFile filein
raw <- readFile runtime
config' <- resolvePackages config
compileToModule filein config' raw (compileToplevelModule filein) hscode
compileToModule :: (Show from,Show to,CompilesTo from to)
=> FilePath
-> CompileConfig -> String -> (from -> Compile to) -> String
-> IO (Either CompileError (String,CompileState))
compileToModule filepath config raw with hscode = do
result <- compileViaStr filepath config with hscode
return $ case result of
Left err -> Left err
Right (PrintState{..},state,_) ->
Right ( generateWrapped (concat $ reverse psOutput)
(stateModuleName state)
, state
)
where
generateWrapped jscode (ModuleName modulename) =
unlines $ filter (not . null)
[if configExportRuntime config then raw else ""
,jscode
,if not (configLibrary config)
then unlines [";"
,"Fay$$_(" ++ modulename ++ ".main);"
]
else ""
]
toJsName :: String -> String
toJsName x = case reverse x of
('s':'h':'.': (reverse -> file)) -> file ++ ".js"
_ -> x
showCompileError :: CompileError -> String
showCompileError e = case e of
ParseError pos err -> err ++ " at line: " ++ show (srcLine pos) ++ " column: " ++ show (srcColumn pos)
UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d
UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es
UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr
UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p
UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i
UnsupportedLet -> "let not supported here"
UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d
UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit
UnsupportedModuleSyntax m -> "unsupported module syntax" ++ prettyPrint m
UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat
UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt
UnsupportedRecursiveDo -> "recursive `do' isn't supported"
UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs
UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt
UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m
EmptyDoBlock -> "empty `do' block"
InvalidDoBlock -> "invalid `do' block"
FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d
FfiFormatBadChars srcloc cs -> printSrcLoc srcloc ++ ": invalid characters for FFI format string: " ++ show cs
FfiFormatNoSuchArg srcloc i -> printSrcLoc srcloc ++ ": no such argument in FFI format string: " ++ show i
FfiFormatIncompleteArg srcloc -> printSrcLoc srcloc ++ ": incomplete `%' syntax in FFI format string"
FfiFormatInvalidJavaScript srcloc code err ->
printSrcLoc srcloc ++ ":" ++
"\ninvalid JavaScript code in FFI format string:\n"
++ err ++ "\nin " ++ code
Couldn'tFindImport i places ->
"could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++
"searched in these places: " ++ intercalate ", " places
UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname
GHCError s -> "ghc: " ++ s
getRuntime :: IO String
getRuntime = getDataFileName "js/runtime.js"