{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} module Language.Fay (module Language.Fay.Types ,compileFile ,compileFromTo ,compileFromToAndGenerateHtml ,toJsName ,showCompileError) where import Language.Fay.Compiler (compileToplevelModule, compileViaStr) import Language.Fay.Print import Language.Fay.Types import Control.Monad import Data.List import Language.Haskell.Exts (prettyPrint) import Language.Haskell.Exts.Syntax import Paths_fay import System.FilePath -- | Compile the given file and write the output to the given path, or -- if nothing given, stdout. 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) (flip writeFile out) fileout Left err -> error $ showCompileError $ err -- | Compile the given file and write to the output, also generate any HTML. 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 [ "" , "" , " " ," " , unlines . map (" "++) . map makeScriptTagSrc $ configHtmlJSLibs config , " " ++ makeScriptTagSrc relativeJsPath , " " , " " , " " , " " , ""] return (Right out) where relativeJsPath = makeRelative (dropFileName fileout) fileout makeScriptTagSrc :: FilePath -> String makeScriptTagSrc = \s -> "" Left err -> return (Left err) -- | Compile the given file. compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String) compileFile config filein = do runtime <- getDataFileName "js/runtime.js" srcdir <- fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs") raw <- readFile runtime hscode <- readFile filein compileToModule filein config { configDirectoryIncludes = configDirectoryIncludes config ++ [srcdir] } raw compileToplevelModule hscode -- | Compile the given module to a runnable module. compileToModule :: (Show from,Show to,CompilesTo from to) => FilePath -> CompileConfig -> String -> (from -> Compile to) -> String -> IO (Either CompileError String) compileToModule filepath config raw with hscode = do result <- compileViaStr filepath config with hscode case result of Left err -> return (Left err) Right (PrintState{..},state) -> return $ Right $ (generate (concat (reverse psOutput)) (stateExports state) (stateModuleName state)) where generate jscode exports (ModuleName (clean -> modulename)) = unlines ["/** @constructor" ,"*/" ,"var " ++ modulename ++ " = function(){" ,raw ,jscode ,"// Exports" ,unlines (map printExport exports) ,"// Built-ins" ,"this._ = _;" ,if configExportBuiltins config then unlines ["this.$ = $;" ,"this.$fayToJs = Fay$$fayToJs;" ,"this.$jsToFay = Fay$$jsToFay;" ] else "" ,"};" ,if not (configLibrary config) then unlines [";" ,"var main = new " ++ modulename ++ "();" ,"main._(main." ++ modulename ++ "$main);" ] else "" ] clean ('.':cs) = '$' : clean cs clean (c:cs) = c : clean cs clean [] = [] -- | Print an this.x = x; export out. printExport :: QName -> String printExport name = printJSString (JsSetProp JsThis (JsNameVar name) (JsName (JsNameVar name))) -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String toJsName x = case reverse x of ('s':'h':'.': (reverse -> file)) -> file ++ ".js" _ -> x -- | Print a compile error for human consumption. showCompileError :: CompileError -> String showCompileError e = case e of ParseError _ err -> err UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es UnsupportedMatchSyntax m -> "unsupported match/binding syntax: " ++ prettyPrint m UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d UnsupportedOperator qop -> "unsupported operator syntax: " ++ prettyPrint qop UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs UnsupportedGuardedAlts ga -> "unsupported guarded alts: " ++ prettyPrint ga EmptyDoBlock -> "empty `do' block" UnsupportedModuleSyntax{} -> "unsupported module syntax (may be supported later)" LetUnsupported -> "let not supported here" InvalidDoBlock -> "invalid `do' block" RecursiveDoUnsupported -> "recursive `do' isn't supported" FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d FfiFormatBadChars cs -> "invalid characters for FFI format string: " ++ show cs FfiFormatNoSuchArg i -> "no such argument in FFI format string: " ++ show i FfiFormatIncompleteArg -> "incomplete `%' syntax in FFI format string" FfiFormatInvalidJavaScript code err -> "invalid JavaScript code in FFI format string:\n" ++ err ++ "\nin " ++ code UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i Couldn'tFindImport i places -> "could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++ "searched in these places: " ++ intercalate ", " places UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname