fay 0.18.0.0 → 0.18.0.1
raw patch · 20 files changed
+178/−123 lines, 20 filesdep +sourcemapdep ~haskell-namesdep ~haskell-packagesdep ~optparse-applicative
Dependencies added: sourcemap
Dependency ranges changed: haskell-names, haskell-packages, optparse-applicative
Files
- fay.cabal +5/−5
- js/runtime.js +3/−4
- src/Fay.hs +29/−9
- src/Fay/Compiler.hs +25/−21
- src/Fay/Compiler/Config.hs +1/−0
- src/Fay/Compiler/Decl.hs +24/−13
- src/Fay/Compiler/Exp.hs +1/−2
- src/Fay/Compiler/FFI.hs +2/−2
- src/Fay/Compiler/InitialPass.hs +1/−1
- src/Fay/Compiler/Misc.hs +33/−25
- src/Fay/Compiler/Optimizer.hs +1/−7
- src/Fay/Compiler/Pattern.hs +1/−1
- src/Fay/Compiler/Print.hs +27/−5
- src/Fay/Compiler/State.hs +4/−4
- src/Fay/Types.hs +4/−11
- src/main/Main.hs +5/−4
- src/tests/Test/Compile.hs +5/−5
- tests/Compile/StrictWrapper.hs +6/−1
- tests/Compile/StrictWrapper.res +1/−0
- tests/ExportQualified_Import.hs +0/−3
fay.cabal view
@@ -1,5 +1,5 @@ name: fay-version: 0.18.0.0+version: 0.18.0.1 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad,@@ -412,12 +412,11 @@ , directory , filepath , ghc-paths- , haskell-packages- , haskell-names >= 0.3 && < 0.4+ , haskell-names >= 0.3.1 && < 0.4+ , haskell-packages >= 0.2.3.1 , haskell-src-exts >= 1.14 , language-ecmascript >= 0.15 && < 1.0 , mtl- , optparse-applicative >= 0.5 , pretty-show >= 1.6 , process , safe@@ -431,6 +430,7 @@ , unordered-containers , utf8-string , vector+ , sourcemap executable fay hs-source-dirs: src/main@@ -451,7 +451,7 @@ , haskell-src-exts >= 1.14 , language-ecmascript >= 0.15 && < 1.0 , mtl- , optparse-applicative >= 0.5+ , optparse-applicative >= 0.6 && < 0.7 , process , safe , split
js/runtime.js view
@@ -260,7 +260,7 @@ } jsObj = arr; } else {- var fayToJsFun = fayObj && fayObj.constructor && Fay$$fayToJsHash[fayObj.constructor.name];+ var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance]; jsObj = fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj; } }@@ -582,10 +582,9 @@ return lit1 === lit2; } while (true); } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&- lit1.constructor === lit2.constructor) {+ lit1.instance === lit2.instance) { for(var x in lit1) {- if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&- Fay$$equal(lit1[x],lit2[x])))+ if(!Fay$$equal(lit1[x],lit2[x])) return false; } return true;
src/Fay.hs view
@@ -29,11 +29,16 @@ import Control.Applicative import Control.Monad+import Data.Aeson (encode)+import qualified Data.ByteString.Lazy as L+import Data.Default import Data.List import Language.Haskell.Exts.Annotated (prettyPrint) import Language.Haskell.Exts.Annotated.Syntax import Language.Haskell.Exts.SrcLoc import Paths_fay+import SourceMap (generate)+import SourceMap.Types import System.FilePath -- | Compile the given file and write the output to the given path, or@@ -50,15 +55,15 @@ (compileFromToAndGenerateHtml cfg filein) fileout case result of- Right out -> maybe (putStrLn out) (`writeFile` out) fileout+ Right (out,_) -> maybe (putStrLn out) (`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 :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError (String,[Mapping])) compileFromToAndGenerateHtml config filein fileout = do result <- compileFile config { configFilePath = Just filein } filein case result of- Right out -> do+ Right (out,mappings) -> do when (configHtmlWrapper config) $ writeFile (replaceExtension fileout "html") $ unlines [ "<!doctype html>"@@ -72,18 +77,29 @@ , " <body>" , " </body>" , "</html>"]- return (Right out)++ when (configSourceMap config) $ do+ L.writeFile (replaceExtension fileout "map") $+ encode $+ generate SourceMapping+ { smFile = fileout+ , smSourceRoot = Nothing+ , smMappings = mappings+ }++ return (Right (if configSourceMap config then sourceMapHeader ++ out else out,mappings)) where relativeJsPath = makeRelative (dropFileName fileout) fileout makeScriptTagSrc :: FilePath -> String makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"+ sourceMapHeader = "//@ sourceMappingURL=" ++ replaceExtension fileout "map" ++ "\n" Left err -> return (Left err) -- | Compile the given file.-compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)-compileFile config filein = either Left (Right . fst) <$> compileFileWithState config filein+compileFile :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping]))+compileFile config filein = fmap (\(src,maps,_) -> (src,maps)) <$> compileFileWithState config filein -- | Compile a file returning the state.-compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,CompileState))+compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping],CompileState)) compileFileWithState config filein = do runtime <- getConfigRuntime config hscode <- readFile filein@@ -94,14 +110,15 @@ -- | Compile the given module to a runnable module. compileToModule :: FilePath -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String- -> IO (Either CompileError (String,CompileState))+ -> IO (Either CompileError (String,[Mapping],CompileState)) compileToModule filepath config raw with hscode = do- result <- compileViaStr filepath config with hscode+ result <- compileViaStr filepath config printState with hscode return $ case result of Left err -> Left err Right (PrintState{..},state,_) -> Right ( generateWrapped (concat $ reverse psOutput) (stateModuleName state)+ , psMappings , state ) where@@ -115,6 +132,9 @@ ] else "" ]+ printState = def { psPretty = configPrettyPrint config+ , psLine = length (lines raw) + 3+ } -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String
src/Fay/Compiler.hs view
@@ -43,7 +43,7 @@ import Control.Monad.Error import Control.Monad.RWS import Control.Monad.State-import Data.Default (def)+ import Data.Maybe import qualified Data.Set as S import Language.Haskell.Exts.Annotated hiding (name)@@ -55,21 +55,21 @@ -- | Compile a Haskell source string to a JavaScript source string. compileViaStr+ :: FilePath -> CompileConfig+ -> PrintState -> (F.Module -> Compile [JsStmt]) -> String -> IO (Either CompileError (PrintState,CompileState,CompileWriter))-compileViaStr filepath cfg with from = do+compileViaStr filepath cfg printState with from = do rs <- defaultCompileReader cfg runTopCompile rs defaultCompileState (parseResult (throwError . uncurry ParseError)- (fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with)+ (fmap (\x -> execState (runPrinter (printJS x)) printState) . with) (parseFay filepath from)) - where printConfig = def { psPretty = configPrettyPrint cfg }- -- | Compile the top-level Fay module. compileToplevelModule :: FilePath -> F.Module -> Compile [JsStmt] compileToplevelModule filein mod@Module{} = do@@ -81,24 +81,27 @@ either throwError warn res initialPass filein -- Reset imports after initialPass so the modules can be imported during code generation.- startCompile compileFileWithSource filein+ (hstmts, fstmts) <- startCompile compileFileWithSource filein+ return (hstmts++fstmts) compileToplevelModule _ m = throwError $ UnsupportedModuleSyntax "compileToplevelModule" m -------------------------------------------------------------------------------- -- Compilers -- | Compile a source string.-compileModuleFromContents :: String -> Compile [JsStmt]+compileModuleFromContents :: String -> Compile ([JsStmt], [JsStmt]) compileModuleFromContents = compileFileWithSource "<interactive>" -- | Compile given the location and source string.-compileFileWithSource :: FilePath -> String -> Compile [JsStmt]+compileFileWithSource :: FilePath -> String -> Compile ([JsStmt], [JsStmt]) compileFileWithSource filepath contents = do- (stmts,st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource contents+ ((hstmts,fstmts),st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource contents modify $ \s -> s { stateImported = stateImported st , stateJsModulePaths = stateJsModulePaths st }- maybeOptimize $ stmts ++ writerCons wr ++ makeTranscoding wr+ hstmts' <- maybeOptimize $ hstmts ++ writerCons wr ++ makeTranscoding wr+ fstmts' <- maybeOptimize fstmts+ return (hstmts', fstmts') where makeTranscoding :: CompileWriter -> [JsStmt] makeTranscoding CompileWriter{..} =@@ -113,13 +116,13 @@ else stmts -- | Compile a parse HSE module.-compileModuleFromAST :: [JsStmt] -> F.Module -> Compile [JsStmt]-compileModuleFromAST imported mod''@(Module _ _ pragmas _ _) = do+compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt])+compileModuleFromAST (hstmts0, fstmts0) mod''@(Module _ _ pragmas _ _) = do res <- io $ desugar mod'' case res of Left err -> throwError err Right mod' -> do- mod@(Module _ _ _ _ decls) <- annotateModule Haskell2010 [] $ mod'+ mod@(Module _ _ _ _ decls) <- annotateModule Haskell2010 defaultExtensions $ mod' let modName = unAnn $ F.moduleName mod modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas }@@ -130,14 +133,15 @@ modulePaths <- createModulePath modName extExports <- generateExports strictExports <- generateStrictExports- let stmts = imported ++ modulePaths ++ current ++ extExports ++ strictExports+ let hstmts = hstmts0 ++ modulePaths ++ current ++ extExports+ fstmts = fstmts0 ++ strictExports return $ if exportStdlibOnly then if anStdlibModule modName- then stmts- else []+ then (hstmts, fstmts)+ else ([], []) else if not exportStdlib && anStdlibModule modName- then []- else stmts+ then ([], [])+ else (hstmts, fstmts) compileModuleFromAST _ mod = throwError $ UnsupportedModuleSyntax "compileModuleFromAST" mod @@ -187,7 +191,7 @@ maybe [] (map (exportExp modName) . S.toList) <$> gets (getNonLocalExportsWithoutNewtypes modName) where exportExp :: N.ModuleName -> N.QName -> JsStmt- exportExp m v = JsSetQName (changeModule m v) $ case findPrimOp v of+ exportExp m v = JsSetQName Nothing (changeModule m v) $ case findPrimOp v of Just p -> JsName $ JsNameVar p -- TODO add test case for this case, is it needed at all? Nothing -> JsName $ JsNameVar v @@ -206,10 +210,10 @@ else return [] where exportExp :: N.ModuleName -> N.QName -> JsStmt- exportExp m v = JsSetQName (changeModule' ("Strict." ++) $ changeModule m v) $ JsName $ JsNameVar $ changeModule' ("Strict." ++) v+ exportExp m v = JsSetQName Nothing (changeModule' ("Strict." ++) $ changeModule m v) $ JsName $ JsNameVar $ changeModule' ("Strict." ++) v exportExp' :: N.QName -> JsStmt- exportExp' name = JsSetQName (changeModule' ("Strict." ++) name) $ serialize (JsName (JsNameVar name))+ exportExp' name = JsSetQName Nothing (changeModule' ("Strict." ++) name) $ serialize (JsName (JsNameVar name)) serialize :: JsExp -> JsExp serialize n = JsApp (JsRawExp "Fay$$fayToJs") [JsRawExp "['automatic']", n]
src/Fay/Compiler/Config.hs view
@@ -66,4 +66,5 @@ , configStrict = [] , configTypecheckOnly = False , configRuntimePath = Nothing+ , configSourceMap = False }
src/Fay/Compiler/Decl.hs view
@@ -15,8 +15,7 @@ import Fay.Compiler.Pattern import Fay.Compiler.State import Fay.Data.List.Extra-import Fay.Exts (convertFieldDecl,- fieldDeclNames)+import Fay.Exts (convertFieldDecl, fieldDeclNames) import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.Scoped as S import Fay.Types@@ -55,6 +54,16 @@ ClassDecl{} -> return [] InstDecl {} -> return [] -- FIXME: Ignore. DerivDecl{} -> return []+ DefaultDecl{} -> return []+ RulePragmaDecl{} -> return []+ DeprPragmaDecl{} -> return []+ WarnPragmaDecl{} -> return []+ InlineSig{} -> return []+ InlineConlikeSig{} -> return []+ SpecSig{} -> return []+ SpecInlineSig{} -> return []+ InstSig{} -> return []+ AnnPragma{} -> return [] _ -> throwError (UnsupportedDeclaration decl) @@ -66,14 +75,14 @@ -- | Compile a top-level pattern bind. compilePatBind :: Bool -> Maybe S.Type -> S.Decl -> Compile [JsStmt] compilePatBind toplevel sig pat = case pat of- PatBind _ (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing ->+ PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing -> case ffiExp rhs of Just formatstr -> case sig of Just sig -> compileFFI ident formatstr sig Nothing -> throwError (FfiNeedsTypeSig pat)- _ -> compileUnguardedRhs toplevel ident rhs- PatBind _ (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->- compileUnguardedRhs toplevel ident (Let S.noI bdecls rhs)+ _ -> compileUnguardedRhs toplevel srcloc ident rhs+ PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->+ compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs) PatBind _ pat Nothing (UnGuardedRhs _ rhs) _bdecls -> do exp <- compileExp rhs name <- withScopedTmpJsName return@@ -83,10 +92,10 @@ _ -> throwError (UnsupportedDeclaration pat) -- | Compile a normal simple pattern binding.-compileUnguardedRhs :: Bool -> S.Name -> S.Exp -> Compile [JsStmt]-compileUnguardedRhs toplevel ident rhs = do+compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt]+compileUnguardedRhs toplevel srcloc ident rhs = do body <- compileExp rhs- bind <- bindToplevel toplevel ident (thunk body)+ bind <- bindToplevel toplevel (Just (srcInfoSpan (S.srcSpanInfo srcloc))) ident (thunk body) return [bind] -- | Compile a data declaration (or a GADT, latter is converted to former).@@ -143,17 +152,18 @@ fields added <- gets (addedModulePath mp) if added- then return . JsSetQName qname $ JsApp (JsName $ JsBuiltIn "objConcat")- [func, JsName $ JsNameVar qname]+ then return . JsSetQName Nothing qname $ JsApp (JsName $ JsBuiltIn "objConcat")+ [func, JsName $ JsNameVar qname] else do modify $ addModulePath mp- return $ JsSetQName qname func+ return $ JsSetQName Nothing qname func -- Creates getters for a RecDecl's values makeAccessors :: [S.Name] -> Compile [JsStmt] makeAccessors fields = forM fields $ \(unAnn -> name) -> bindToplevel toplevel+ Nothing name (JsFun Nothing [JsNameVar "x"]@@ -167,9 +177,10 @@ compileFunCase _toplevel [] = return [] compileFunCase toplevel (InfixMatch l pat name pats rhs binds : rest) = compileFunCase toplevel (Match l name (pat:pats) rhs binds : rest)-compileFunCase toplevel matches@(Match _ name argslen _ _:_) = do+compileFunCase toplevel matches@(Match srcloc name argslen _ _:_) = do pats <- fmap optimizePatConditions (mapM compileCase matches) bind <- bindToplevel toplevel+ (Just (srcInfoSpan (S.srcSpanInfo srcloc))) name (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner)) (stmtsThunk (concat pats ++ basecase))
src/Fay/Compiler/Exp.hs view
@@ -293,9 +293,8 @@ updateStmt _ u = error ("updateStmt: " ++ show u) wildcardFields l = case l of- Scoped (RecExpWildcard es) _ -> map (unQualify . gname2Qname . origGName) . map fst $ es+ Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es _ -> []- -- | Compile a record update. compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp
src/Fay/Compiler/FFI.hs view
@@ -35,7 +35,7 @@ import Language.ECMAScript3.Parser as JS import Language.ECMAScript3.Syntax import Language.Haskell.Exts.Annotated (SrcSpanInfo,- prettyPrint)+ prettyPrint,srcInfoSpan) import Language.Haskell.Exts.Annotated.Syntax import Prelude hiding (exp, mod) import Safe@@ -70,7 +70,7 @@ compileFFI' :: N.Type -> Compile [JsStmt] compileFFI' sig' = do fun <- compileFFIExp loc (Just name) formatstr sig'- stmt <- bindToplevel True name fun+ stmt <- bindToplevel True (Just (srcInfoSpan loc)) name fun return [stmt] name = unAnn name'
src/Fay/Compiler/InitialPass.hs view
@@ -57,7 +57,7 @@ Right dmod -> do let (Module _ _ _ _ decls) = dmod -- This can only return one element since we only compile one module.- ([exports],_) <- HN.getInterfaces Haskell2010 [] [dmod]+ ([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [dmod] modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } forM_ decls scanTypeSigs forM_ decls scanRecordDecls
src/Fay/Compiler/Misc.hs view
@@ -61,24 +61,27 @@ tryResolveName (unAnn -> Qual () (ModuleName () "$Prelude") n) = Just $ Qual () (ModuleName () "Prelude") n tryResolveName q@(Qual _ (ModuleName _ "Fay$") _) = Just $ unAnn q tryResolveName (Qual (Scoped ni _) _ _) = case ni of- GlobalValue n -> replaceWithBuiltIns . gname2Qname . origGName $ origName n+ GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n _ -> Nothing -- TODO should LocalValue just return the name for qualified imports? tryResolveName q@(UnQual (Scoped ni _) (unAnn -> name)) = case ni of- GlobalValue n -> replaceWithBuiltIns . gname2Qname . origGName $ origName n+ GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n LocalValue _ -> Just $ UnQual () name ScopeError _ -> resolvePrimOp q _ -> Nothing -gname2Qname :: GName -> N.QName-gname2Qname g = case g of- GName "" s -> UnQual () $ mkName s- GName m s -> Qual () (ModuleName () m) $ mkName s+origName2QName :: OrigName -> N.QName+origName2QName = gname2Qname . origGName where- mkName s@(x:_)- | isAlpha x || x == '_' = Ident () s- | otherwise = Symbol () s- mkName "" = error "mkName \"\""+ gname2Qname :: GName -> N.QName+ gname2Qname g = case g of+ GName "" s -> UnQual () $ mkName s+ GName m s -> Qual () (ModuleName () m) $ mkName s+ where+ mkName s@(x:_)+ | isAlpha x || x == '_' = Ident () s+ | otherwise = Symbol () s+ mkName "" = error "mkName \"\"" replaceWithBuiltIns :: N.QName -> Maybe N.QName replaceWithBuiltIns n = findPrimOp n <|> return n@@ -124,12 +127,12 @@ qualifyQName (unAnn -> n) = return n -- | Make a top-level binding.-bindToplevel :: Bool -> Name a -> JsExp -> Compile JsStmt-bindToplevel toplevel (unAnn -> name) expr =+bindToplevel :: Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt+bindToplevel toplevel msrcloc (unAnn -> name) expr = if toplevel then do mod <- gets stateModuleName- return $ JsSetQName (Qual () mod name) expr+ return $ JsSetQName msrcloc (Qual () mod name) expr else return $ JsVar (JsNameVar $ UnQual () name) expr -- | Force an expression in a thunk.@@ -310,20 +313,25 @@ -- | The parse mode for Fay. parseMode :: ParseMode parseMode = defaultParseMode- { extensions = map EnableExtension- [GADTs- ,ExistentialQuantification- ,StandaloneDeriving- ,PackageImports- ,EmptyDataDecls- ,TypeOperators- ,RecordWildCards- ,NamedFieldPuns- ,FlexibleContexts- ,FlexibleInstances- ,KindSignatures]+ { extensions = defaultExtensions , fixities = Just (preludeFixities ++ baseFixities) } shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn++defaultExtensions :: [Extension]+defaultExtensions = map EnableExtension+ [GADTs+ ,ExistentialQuantification+ ,StandaloneDeriving+ ,PackageImports+ ,EmptyDataDecls+ ,TypeOperators+ ,RecordWildCards+ ,NamedFieldPuns+ ,FlexibleContexts+ ,FlexibleInstances+ ,KindSignatures+ ] ++ map DisableExtension+ [ImplicitPrelude]
src/Fay/Compiler/Optimizer.hs view
@@ -48,14 +48,13 @@ inlineMonad = map go where go stmt = case stmt of JsVar name exp -> JsVar name (inline exp)- JsMappedVar a name exp -> JsMappedVar a name (inline exp) JsIf exp stmts stmts' -> JsIf (inline exp) (map go stmts) (map go stmts') JsEarlyReturn exp -> JsEarlyReturn (inline exp) JsThrow exp -> JsThrow (inline exp) JsWhile exp stmts -> JsWhile (inline exp) (map go stmts) JsUpdate name exp -> JsUpdate name (inline exp) JsSetProp a b exp -> JsSetProp a b (inline exp)- JsSetQName a exp -> JsSetQName a (inline exp)+ JsSetQName s a exp -> JsSetQName s a (inline exp) JsSetModule a exp -> JsSetModule a (inline exp) JsSetConstructor a exp -> JsSetConstructor a (inline exp) JsSetPropExtern a b exp -> JsSetPropExtern a b (inline exp)@@ -120,7 +119,6 @@ tco :: [JsStmt] -> [JsStmt] tco = map inStmt where inStmt stmt = case stmt of- JsMappedVar srcloc name exp -> JsMappedVar srcloc name (inject name exp) JsVar name exp -> JsVar name (inject name exp) e -> e inject name exp = case exp of@@ -216,7 +214,6 @@ applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where transform = f funcs uncurryInStmt stmt = case stmt of- JsMappedVar srcloc name exp -> JsMappedVar srcloc name <$> transform exp JsVar name exp -> JsVar name <$> transform exp JsEarlyReturn exp -> JsEarlyReturn <$> transform exp JsIf op ithen ielse -> JsIf <$> transform op@@ -227,7 +224,6 @@ -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity] collectFuncs = (++ prim) . concatMap collectFunc where- collectFunc (JsMappedVar _ name exp) = collectFunc (JsVar name exp) collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)] where arity = expArity exp collectFunc _ = []@@ -247,8 +243,6 @@ uncurryBinding stmts qname = listToMaybe (mapMaybe funBinding stmts) where funBinding stmt = case stmt of- JsMappedVar srcloc (JsNameVar name) body- | name == qname -> JsMappedVar srcloc (JsNameVar (renameUncurried name)) <$> uncurryIt body JsVar (JsNameVar name) body | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body _ -> Nothing
src/Fay/Compiler/Pattern.hs view
@@ -73,7 +73,7 @@ wildcardFields :: S.X -> [N.QName] wildcardFields l = case l of- Scoped (RecPatWildcard es) _ -> map (unQualify . gname2Qname . origGName) es+ Scoped (RecPatWildcard es) _ -> map (unQualify . origName2QName) es _ -> [] -- | Compile a literal value from a pattern match.
src/Fay/Compiler/Print.hs view
@@ -27,8 +27,9 @@ import Data.Default import Data.List import Data.String-import Language.Haskell.Exts.Annotated.Syntax+import Language.Haskell.Exts.Annotated import Prelude hiding (exp)+import SourceMap.Types -------------------------------------------------------------------------------- -- Printing@@ -104,10 +105,13 @@ name +> " = " +> expr +> ";" +> newline printJS (JsSetProp name prop expr) = name +> "." +> prop +> " = " +> expr +> ";" +> newline- printJS (JsSetQName name expr) =+ printJS (JsSetQName msrcloc name expr) = do+ maybe (return ()) mapping msrcloc name +> " = " +> expr +> ";" +> newline printJS (JsSetConstructor name expr) =- printCons name +> " = " +> expr +> ";" +> newline+ printCons name +> " = " +> expr +> ";" +> newline +>+ -- The unqualifiedness here is bad.+ printCons name +> ".prototype.instance = \"" +> printConsUnQual name +> "\";" +> newline printJS (JsSetModule mp expr) = mp +> " = " +> expr +> ";" +> newline printJS (JsSetPropExtern name prop expr) =@@ -129,8 +133,6 @@ "}" +> newline printJS JsContinue = printJS "continue;" +> newline- printJS (JsMappedVar _ name expr) =- "var " +> name +> " = " +> expr +> ";" +> newline -- | Print a module path. instance Printable ModulePath where@@ -236,6 +238,12 @@ printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n printCons (Special {}) = error "qname2String Special" +-- | Print an unqualified name.+printConsUnQual :: N.QName -> Printer ()+printConsUnQual (UnQual _ x) = printJS x+printConsUnQual (Qual _ _ n) = printJS n+printConsUnQual (Special {}) = error "printConsUnqual Special"+ -- | Print a constructor name given a Name. Helper for printCons. printConsName :: N.Name -> Printer () printConsName n = write "_" >> printJS n@@ -329,6 +337,20 @@ where srclines = lines x additionalLines = length (filter (=='\n') x)++-- | Generate a mapping from the Haskell location to the current point in the output.+mapping :: SrcSpan -> Printer ()+mapping SrcSpan{..} = do+ modify $ \s -> s { psMappings = m s : psMappings s }+ return ()++ where m ps = Mapping { mapGenerated = Pos (fromIntegral (psLine ps))+ (fromIntegral (psColumn ps))+ , mapOriginal = Just (Pos (fromIntegral srcSpanStartLine)+ (fromIntegral srcSpanStartColumn - 1))+ , mapSourceFile = Just srcSpanFilename+ , mapName = Nothing+ } -- | Intercalate monadic action. intercalateM :: String -> [Printer a] -> Printer ()
src/Fay/Compiler/State.hs view
@@ -18,7 +18,7 @@ getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName) getNonLocalExportsWithoutNewtypes modName cs = fmap ( S.filter (not . isLocal)- . S.map (gname2Qname . origGName . sv_origName)+ . S.map (origName2QName . sv_origName) . S.filter (not . (`isNewtype` cs)) . (\(Symbols exports _) -> exports) )@@ -29,7 +29,7 @@ getLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName) getLocalExportsWithoutNewtypes modName cs = fmap ( S.filter isLocal- . S.map (gname2Qname . origGName . sv_origName)+ . S.map (origName2QName . sv_origName) . S.filter (not . (`isNewtype` cs)) . (\(Symbols exports _) -> exports) )@@ -42,8 +42,8 @@ isNewtype s cs = case s of SymValue{} -> False SymMethod{} -> False- SymSelector { sv_typeName } -> not . (`isNewtypeDest` cs) . gname2Qname . origGName $ sv_typeName- SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . gname2Qname . origGName $ sv_typeName+ SymSelector { sv_typeName } -> not . (`isNewtypeDest` cs) . origName2QName $ sv_typeName+ SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . origName2QName $ sv_typeName -- | Is this *resolved* name a new type destructor? isNewtypeDest :: N.QName -> CompileState -> Bool
src/Fay/Types.hs view
@@ -21,7 +21,6 @@ ,FundamentalType(..) ,PrintState(..) ,Printer(..)- ,Mapping(..) ,SerializeContext(..) ,ModulePath (unModulePath) ,mkModulePath@@ -48,6 +47,7 @@ import Distribution.HaskellSuite.Modules import Language.Haskell.Exts.Annotated import Language.Haskell.Names (Symbols)+import SourceMap.Types -------------------------------------------------------------------------------- -- Compiler types@@ -62,6 +62,7 @@ , configDirectoryIncludes :: [(Maybe String, FilePath)] -- ^ Possibly a fay package name, and a include directory. , configPrettyPrint :: Bool -- ^ Pretty print the JS output? , configHtmlWrapper :: Bool -- ^ Output a HTML file including the produced JS.+ , configSourceMap :: Bool -- ^ Output a source map file as outfile.map. , configHtmlJSLibs :: [FilePath] -- ^ Any JS files to link to in the HTML. , configLibrary :: Bool -- ^ Don't invoke main in the produced JS. , configWarn :: Bool -- ^ Warn on dubious stuff, not related to typechecking.@@ -169,19 +170,12 @@ liftModuleT :: ModuleT Symbols IO a -> Compile a liftModuleT = Compile . lift . lift --- | A source mapping.-data Mapping = Mapping- { mappingName :: String -- ^ The name of the mapping.- , mappingFrom :: SrcLoc -- ^ The original source location.- , mappingTo :: SrcLoc -- ^ The new source location.- } deriving (Show)- -- | The state of the pretty printer. data PrintState = PrintState { psPretty :: Bool -- ^ Are we to pretty print? , psLine :: Int -- ^ The current line. , psColumn :: Int -- ^ Current column.- , psMapping :: [Mapping] -- ^ Source mappings.+ , psMappings :: [Mapping] -- ^ Source mappings. , psIndentLevel :: Int -- ^ Current indentation level. , psOutput :: [String] -- ^ The current output. TODO: Make more efficient. , psNewline :: Bool -- ^ Just outputted a newline?@@ -241,14 +235,13 @@ -- | Statement type. data JsStmt = JsVar JsName JsExp- | JsMappedVar SrcLoc JsName JsExp | JsIf JsExp [JsStmt] [JsStmt] | JsEarlyReturn JsExp | JsThrow JsExp | JsWhile JsExp [JsStmt] | JsUpdate JsName JsExp | JsSetProp JsName JsName JsExp- | JsSetQName N.QName JsExp+ | JsSetQName (Maybe SrcSpan) N.QName JsExp | JsSetModule ModulePath JsExp | JsSetConstructor N.QName JsExp | JsSetPropExtern JsName JsName JsExp
src/main/Main.hs view
@@ -15,6 +15,7 @@ import Data.Maybe import Data.Version (showVersion) import Options.Applicative+import Options.Applicative.Types import System.Environment -- | Options and help.@@ -43,6 +44,7 @@ , optStrict :: [String] , optTypecheckOnly :: Bool , optRuntimePath :: Maybe FilePath+ , optSourceMap :: Bool } -- | Main entry point.@@ -69,6 +71,7 @@ , configStrict = optStrict opts , configTypecheckOnly = optTypecheckOnly opts , configRuntimePath = optRuntimePath opts+ , configSourceMap = optSourceMap opts } if optVersion opts then runCommandVersion@@ -118,10 +121,8 @@ <> help "Generate strict and uncurried exports for the supplied modules. Simplifies calling Fay from JS") <*> switch (long "typecheck-only" <> help "Only invoke GHC for typechecking, don't produce any output") <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")-- where strsOption m =- nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])-+ <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")+ where strsOption m = nullOption (m <> reader (ReadM . Right . wordsBy (== ',')) <> value []) -- | Make incompatible options. incompatible :: Monad m
src/tests/Test/Compile.hs view
@@ -37,8 +37,8 @@ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp case res of Left err -> error (show err)- Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" .- isJust . lookup (ModuleName () "RecordImport_Export") $ stateImported r+ Right (_,_,r) -> assertBool "RecordImport_Export was not added to stateImported" .+ isJust . lookup (ModuleName () "RecordImport_Export") $ stateImported r fp :: FilePath fp = "tests/RecordImport_Import.hs"@@ -49,7 +49,7 @@ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/Records.hs" case res of Left err -> error (show err)- Right (_,r) ->+ Right (_,_,r) -> -- TODO order should not matter assertEqual "stateRecordTypes mismatch" [ ("Compile.Records.T", ["Compile.Records.:+"])@@ -63,7 +63,7 @@ res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/ImportRecords.hs" case res of Left err -> error (show err)- Right (_,r) ->+ Right (_,_,r) -> -- TODO order should not matter assertEqual "stateRecordTypes mismatch" [ ("Compile.Records.T",["Compile.Records.:+"])@@ -87,7 +87,7 @@ case_strictWrapper = do whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs"- (\a b -> either a b res) (assertFailure . show) $ \js -> do+ (\a b -> either a b res) (assertFailure . show) $ \(js,_) -> do writeFile "tests/Compile/StrictWrapper.js" js (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] "" when (err /= "") $ assertFailure err
tests/Compile/StrictWrapper.hs view
@@ -1,4 +1,4 @@-module StrictWrapper (f,g,h) where+module StrictWrapper (f,g,h,r) where import FFI import Prelude@@ -14,8 +14,13 @@ h :: R -> R h (R i) = R (i + 1) +r :: R+r = R 2++-- You should probably not use the strict wrapper from Fay, this is just for the sake of the test. main :: Fay () main = do ffi "console.log(Strict.StrictWrapper.f(1,2))" :: Fay () ffi "console.log(Strict.StrictWrapper.g({instance:'R',i:1}))" :: Fay () ffi "console.log(Strict.StrictWrapper.h({instance:'R',i:1}))" :: Fay ()+ ffi "console.log(Strict.StrictWrapper.r)" :: Fay ()
tests/Compile/StrictWrapper.res view
@@ -1,3 +1,4 @@ 3 1 { instance: 'R', i: 2 }+{ instance: 'R', i: 2 }
tests/ExportQualified_Import.hs view
@@ -1,6 +1,3 @@ module ExportQualified_Import where import ExportQualified_Export--x :: X-x = undefined