------------------------------------------------------------------ -- | -- Program : jsmwpp -- Copyright : (c) Dmitry Golubovsky, 2009 -- License : BSD-style -- -- Maintainer : golubovsky@gmail.com -- Stability : experimental -- Portability : portable -- -- -- JSMW preprocessor ------------------------------------------------------------------ module Main where import Prelude hiding (putStrLn, getContents) import Data.Maybe import Data.List import Control.Monad import Control.Monad.Reader import Control.Monad.Maybe import System.IO (openFile, stdin, stdout, stderr, Handle, IOMode (..), hFlush) import System.Exit import System.IO.UTF8 import System.Environment.UTF8 import Language.Haskell.Exts import Data.DateTime -- Parse the command line arguments. If called without arguments, -- filter from stdin to stdout. -- With one argument, first is the filename, output to stdout. -- With two arguments, the first is returned as the first -- element of the tuple, the second is input file. -- With three and more, the first is returned as the first element of the tuple, -- the second is input file, the third is output file. The rest is ignored. parseArgs :: IO (String, Handle, Handle) parseArgs = do args <- getArgs let hyph h f m = if f == "-" then return h else openFile f m fname r f = if r == "-" then return f else return r case args of [] -> return ("", stdin, stdout) [fi] -> liftM3 (,,) (fname fi "") (hyph stdin fi ReadMode) (return stdout) [fn, fi] -> liftM3 (,,) (return fn) (hyph stdin fi ReadMode) (return stdout) (fn:fi:fo:_) -> liftM3 (,,) (return fn) (hyph stdin fi ReadMode) (hyph stdout fo WriteMode) main = do (s, i, o) <- parseArgs ts <- getCurrentTime >>= return . toSeconds f <- hGetContents i >>= return . parseFileContentsWithMode defaultParseMode {parseFilename = s} case f of ParseFailed x y -> hPutStrLn o $ prettyPrint x ++ " " ++ y ParseOk m -> case pp ts m of Just mm -> do hPutStrLn o $ prettyPrint mm hFlush o exitWith ExitSuccess Nothing -> return () exitWith . ExitFailure $ (-1) -- Preprocess a module. If preprocessing was successful, Just new module returns, -- otherwise Nothing. pp :: Integer -> Module -> Maybe Module pp t m = addImport t m >>= funCalls t -- Add import declarations for BrownPLT.Javascript.Syntax and BrownPLT.Javascript.PrettyPrint. -- These declarations will be added qualified based on the current time stamp. addImport :: Integer -> Module -> Maybe Module addImport t (Module sl mn ops mbwt mbex imps decls) = let tc = show t qimp md ab = ImportDecl { importLoc = sl ,importModule = ModuleName md ,importQualified = True ,importSrc = False ,importPkg = Nothing ,importAs = Just $ ModuleName ab ,importSpecs = Nothing} simp (ModuleName md) = (qimp md "") {importQualified = False ,importAs = Nothing} aimps = zipWith qimp ["BrownPLT.JavaScript.Syntax", "BrownPLT.JavaScript.PrettyPrint"] ["S" ++ tc, "P" ++ tc] mism = map ModuleName ["Language.JSMW"] mimps = map simp (mism \\ map importModule imps) in Just $ Module sl mn ops mbwt mbex (imps ++ aimps ++ mimps) decls -- Transform each qualifying function into a function call and function body. -- The function call will be given the same type signature, but will render into -- a Javascript expression to call the function with such name. -- The function body will render into a Javascript expression encoding -- the function itself. funCalls :: Integer -> Module -> Maybe Module funCalls t m@(Module sl mn ops mbwt Nothing imps decls) = Just m funCalls t m@(Module sl mn ops mbwt (Just exps) imps decls) = let ists (TypeSig _ _ _) = True ists _ = False isexp (Ident x) = EVar (UnQual (Ident x)) `elem` exps isexp _ = False qts2name (TypeSig _ ns t) | qualFunType t = zip (filter isexp ns) (repeat t) qts2name _ = [] qfts = concatMap qts2name $ filter ists decls isqfun (FunBind [Match _ fn _ _ _ _]) = fn `elem` (map fst qfts) isqfun _ = False qfuns = filter isqfun decls decls' = filter (not . isqfun) decls ++ map (transFun qfts t) qfuns exps' = exps in Just $ Module sl mn ops mbwt (Just exps') imps decls' -- Generate function's body out of its binding. The body is a FunctionStmt that renders -- to a function body. Names of formal parameters are preserved. funBody :: Type -> Integer -> Decl -> [Decl] funBody ftyp t (FunBind [Match msl fnm pts@([PTuple pps]) mbt rhs bnds]) = [FunBind [Match msl fnm' [] Nothing rhs' (BDecls [])] ,TypeSig msl [fnm''] ftyp ,FunBind [Match msl fnm'' pts mbt rhs bnds]] where tc = show t ud = unQid "undefined" qjs n = Qual (ModuleName $ "S" ++ tc) (Ident n) fnm' = modName (++ "_body") fnm fnm'' = modName (++ "_fun_" ++ tc) fnm patvn (PVar n) = n patvn _ = error $ "non-variable pattern in function binding of: " ++ nameStr fnm pvr vn = foldl1 App [Con $ qjs "VarRef", ud, Paren $ vstr vn] vstr vn = foldl1 App [Con $ qjs "Id", ud, Lit $ String vn] rhs' = UnGuardedRhs $ foldl1 App [Con $ qjs "FunctionStmt" ,ud ,Paren $ vstr $ nameStr fnm ,List $ map (vstr . nameStr . patvn) pps ,gblk] gblk = Paren (App (unQid "getBlock") rjsmw) rjsmw = Paren $ foldl1 App [unQid "runJSMWWith", unQid "nullContainer", Lit $ Int 0, funfun] funfun = Paren $ foldl1 App [Var $ UnQual fnm'' ,Tuple $ map (pvr . nameStr . patvn) pps] funBody ftyp t z = [] -- Transform body of a function to Javascript expression rendering -- as a call to that function. transFun :: [(Name, Type)] -> Integer -> Decl -> Decl transFun x t m@(FunBind [Match msl fnm [pp@(PVar _)] mbt rhs bnds]) = transFun x t (FunBind [Match msl fnm [PTuple [pp]] mbt rhs bnds]) transFun x t m@(FunBind [Match msl fnm pts@([PTuple pps]) mbt rhs bnds]) = FunBind [Match msl fnm pts mbt rhs' bnds'] where ftyp = fromJust (lookup fnm x) bnds' = BDecls (funBody ftyp t m) tc = show t ud = unQid "undefined" apud x = App x ud qjs n = Qual (ModuleName $ "S" ++ tc) (Ident n) bvc = Var . UnQual $ modName (++ "_body") fnm rhs' = UnGuardedRhs $ Do $ map Qualifier [ App (unQid "__use") bvc ,InfixApp (unQid "once") (QVarOp $ UnQual $ Symbol "=<<") (App (unQid "return") (Paren fcex))] fcex = foldl1 App [apud $ Con $ qjs "CallExpr", Paren fun, List fparms] fun = App (apud $ Con $ qjs "VarRef") $ Paren ((App (apud $ Con $ qjs "Id") (Lit $ String $ nameStr fnm))) patvn (PVar n) = n patvn _ = error $ "non-variable pattern in function binding of: " ++ nameStr fnm fparms = map pat2parm pps pat2parm p = let n = patvn p in InfixApp (Var $ UnQual n) (QVarOp $ UnQual $ Symbol "/\\") ud transFun x t z = z -- Utility: modify a Name. modName :: (String -> String) -> Name -> Name modName nfn (Ident s) = Ident $ nfn s modName nfn (Symbol s) = Symbol $ nfn s -- Utility: check if a function's type qualifies for transformation. -- To qualify, the function has to be exported, and to have return type -- JSMW x y (Expression z), and arguments tupled, each argument should be -- an Expression. qualFunType :: Type -> Bool qualFunType (TyForall _ _ t) = qualFunType t qualFunType (TyFun (TyTuple Boxed ats) rts) = all atqual ats && rtqual rts where atqual (TyApp (TyCon (UnQual (Ident "Expression"))) _) = True atqual (TyParen t) = atqual t atqual _ = False -- rtqual (TyApp (TyApp (TyApp (TyCon (UnQual (Ident "JSMW"))) (TyCon (Special UnitCon))) _) t) | atqual t = True rtqual (TyApp (TyApp (TyApp (TyCon (UnQual (Ident "JSMW"))) _) _) t) | atqual t = True rtqual _ = False qualFunType (TyFun at rts) = qualFunType (TyFun (TyTuple Boxed [at]) rts) qualFunType _ = False -- Utility: build an unqualified identifier. unQid :: String -> Exp unQid = Var . UnQual . Ident -- Utility: build an unqualified symbolic name unQsym :: String -> Exp unQsym = Var . UnQual . Symbol -- Utility: extract a string from a Name nameStr :: Name -> String nameStr (Ident s) = s nameStr (Symbol s) = s