diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ See full history at: +## 0.22.0.0 + +* Add a `--pretty-thunks` flag and compiler option that replaces `Fay$$_` and `Fay$$$` with `_` and `$` respectively. Consider this a development flag since it may clash with JS libraries (notably jQuery and underscore) +* Allow `language-ecmascript 0.17.*` + #### 0.21.2.1 (2014-11-10) * Hide all packages by default when typechecking. This avoids conflicting with packages that haven't been specified on the command-line with `--package`, e.g. the `text` package when you import `Data.Text`. diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,5 @@ name: fay -version: 0.21.2.1 +version: 0.22.0.0 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, @@ -124,7 +124,7 @@ , haskell-names >= 0.3.1 && < 0.5 , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3 , haskell-src-exts >= 1.16 && < 1.17 - , language-ecmascript >= 0.15 && < 0.17 + , language-ecmascript >= 0.15 && < 0.18 , mtl < 2.3 , process < 1.3 , safe < 0.4 diff --git a/src/Fay.hs b/src/Fay.hs --- a/src/Fay.hs +++ b/src/Fay.hs @@ -27,6 +27,7 @@ import Fay.Compiler.Misc (ioWarn, printSrcSpanInfo) import Fay.Compiler.Packages import Fay.Compiler.Prelude +import Fay.Compiler.Print import Fay.Compiler.Typecheck import Fay.Config import qualified Fay.Exts as F @@ -128,30 +129,29 @@ -> Config -> String -> (F.Module -> Compile [JsStmt]) -> String -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileToModule filepath config raw with hscode = do - result <- compileViaStr filepath config printState with hscode + result <- compileViaStr filepath config with hscode return $ case result of Left err -> Left err - Right (ps,state,_) -> - Right ( generateWrapped (concat . reverse $ psOutput ps) - (stateModuleName state) - , if null (psMappings ps) then Nothing else Just (psMappings ps) + Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) -> + Right ((concat . reverse . pwOutput $ pw) + , if null (pwMappings pw) then Nothing else Just (pwMappings pw) , 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,true);" - ] - else "" - ] - printState = defaultPrintState - { psPretty = configPrettyPrint config - , psLine = length (lines raw) + 3 - } + where + pw = execPrinter (runtime <> aliases <> printer <> main) pr + runtime = whenP (configExportRuntime config) $ + write raw + aliases = whenP (configPrettyThunks config) $ + write . unlines $ [ "var $ = Fay$$$;" + , "var _ = Fay$$_;" + , "var __ = Fay$$__;" + ] + main = whenP (not $ configLibrary config) $ + write $ "Fay$$_(" ++ modulename ++ ".main, true);\n" + pr = defaultPrintReader + { prPrettyThunks = configPrettyThunks config + , prPretty = configPrettyPrint config + } -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -44,7 +44,7 @@ import Control.Monad.Error import Control.Monad.RWS -import Control.Monad.State + import qualified Data.Set as S import Language.Haskell.Exts.Annotated hiding (name) import Language.Haskell.Names @@ -57,16 +57,15 @@ :: FilePath -> Config - -> PrintState -> (F.Module -> Compile [JsStmt]) -> String - -> IO (Either CompileError (PrintState,CompileState,CompileWriter)) -compileViaStr filepath cfg printState with from = do + -> IO (Either CompileError (Printer,CompileState,CompileWriter)) +compileViaStr filepath cfg with from = do rs <- defaultCompileReader cfg runTopCompile rs defaultCompileState (parseResult (throwError . uncurry ParseError) - (fmap (\x -> execState (runPrinter (printJS x)) printState) . with) + (fmap printJS . with) (parseFay filepath from)) -- | Compile the top-level Fay module. diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -22,7 +22,6 @@ import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Monad.State import Data.Aeson.Encode import qualified Data.ByteString.Lazy.UTF8 as UTF8 import Language.Haskell.Exts.Annotated hiding (alt, name, op, sym) @@ -33,11 +32,11 @@ -- | Print the JS to a flat string. printJSString :: Printable a => a -> String -printJSString x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState +printJSString x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultPrintReader -- | Print the JS to a pretty string. printJSPretty :: Printable a => a -> String -printJSPretty x = concat . reverse . psOutput $ execState (runPrinter (printJS x)) defaultPrintState { psPretty = True } +printJSPretty x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultPrintReader{ prPretty = True } -- | Print literals. These need some special encoding for -- JS-format literals. Could use the Text.JSON library. @@ -88,7 +87,7 @@ -- | Print a list of statements. instance Printable [JsStmt] where - printJS = mapM_ printJS + printJS = mconcat . map printJS -- | Print a single statement. instance Printable JsStmt where @@ -102,9 +101,9 @@ name +> " = " +> expr +> ";" +> newline printJS (JsSetProp name prop expr) = name +> "." +> prop +> " = " +> expr +> ";" +> newline - printJS (JsSetQName msrcloc name expr) = do - maybe (return ()) mapping msrcloc - name +> " = " +> expr +> ";" +> newline + printJS (JsSetQName msrcloc name expr) = + maybe mempty mapping msrcloc + <> (name +> " = " +> expr +> ";" +> newline) printJS (JsSetConstructor name expr) = printCons name +> " = " +> expr +> ";" +> newline +> -- The unqualifiedness here is bad. @@ -117,9 +116,11 @@ "if (" +> exp +> ") {" +> newline +> indented (printJS thens) +> "}" +> - (unless (null elses) $ " else {" +> - indented (printJS elses) +> - "}") +> newline + (if (null elses) + then mempty + else " else {" +> + indented (printJS elses) +> + "}") +> newline printJS (JsEarlyReturn exp) = "return " +> exp +> ";" +> newline printJS (JsThrow exp) = @@ -137,7 +138,7 @@ -- | Print an expression. instance Printable JsExp where - printJS (JsSeq es) = "(" +> intercalateM "," (map printJS es) +> ")" + printJS (JsSeq es) = "(" +> mintercalate "," (map printJS es) +> ")" printJS (JsRawExp e) = write e printJS (JsName name) = printJS name printJS (JsThrowExp exp) = @@ -151,7 +152,7 @@ printJS (JsParen exp) = "(" +> exp +> ")" printJS (JsList exps) = - "[" +> intercalateM "," (map printJS exps) +> printJS "]" + "[" +> mintercalate "," (map printJS exps) +> "]" printJS (JsNew name args) = "new " +> JsApp (JsName name) args printJS (JsIndex i exp) = @@ -176,28 +177,26 @@ printJS (JsInstanceOf exp classname) = exp +> " instanceof " +> classname printJS (JsObj assoc) = - "{" +> intercalateM "," (map cons assoc) +> "}" + "{" +> mintercalate "," (map cons assoc) +> "}" where cons (key,value) = "\"" +> key +> "\": " +> value printJS (JsLitObj assoc) = - "{" +> intercalateM "," (map cons assoc) +> "}" - where - cons :: (N.Name, JsExp) -> Printer () - cons (key,value) = "\"" +> key +> "\": " +> value + "{" +> mintercalate "," (map cons assoc) +> "}" + where cons (key,value) = "\"" +> key +> "\": " +> value printJS (JsFun nm params stmts ret) = "function" - +> maybe (return ()) ((" " +>) . printJS . ident) nm + +> maybe mempty ((" " +>) . printJS . ident) nm +> "(" - +> intercalateM "," (map printJS params) + +> mintercalate "," (map printJS params) +> "){" +> newline +> indented (stmts +> case ret of Just ret' -> "return " +> ret' +> ";" +> newline - Nothing -> return ()) + Nothing -> mempty) +> "}" printJS (JsApp op args) = (if isFunc op then JsParen op else op) +> "(" - +> (intercalateM "," (map printJS args)) + +> mintercalate "," (map printJS args) +> ")" where isFunc JsFun{..} = True; isFunc _ = False printJS (JsNegApp args) = @@ -219,38 +218,40 @@ case name of JsNameVar qname -> printJS qname JsThis -> write "this" - JsThunk -> write "Fay$$$" - JsForce -> write "Fay$$_" - JsApply -> write "Fay$$__" + JsThunk -> writeThunkish "Fay$$$" "$" + JsForce -> writeThunkish "Fay$$_" "_" + JsApply -> writeThunkish "Fay$$__" "__" JsParam i -> write ("$p" ++ show i) JsTmp i -> write ("$tmp" ++ show i) JsConstructor qname -> printCons qname JsBuiltIn qname -> "Fay$$" +> printJS qname JsParametrizedType -> write "type" JsModuleName (ModuleName _ m) -> write m + where writeThunkish ugly pretty = askP $ \pr -> + write $ if prPrettyThunks pr then pretty else ugly -- | Print a constructor name given a QName. -printCons :: N.QName -> Printer () +printCons :: N.QName -> Printer printCons (UnQual _ n) = printConsName n printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n printCons (Special {}) = error "qname2String Special" -- | Print an unqualified name. -printConsUnQual :: N.QName -> Printer () +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 +printConsName :: N.Name -> Printer +printConsName = (write "_" <>) . printJS -- | Just write out strings. instance Printable String where printJS = write -- | A printer is a printable. -instance Printable (Printer ()) where +instance Printable Printer where printJS = id -------------------------------------------------------------------------------- @@ -299,63 +300,55 @@ -- | Print the given printer indented. -indented :: Printer a -> Printer () -indented p = do - PrintState{..} <- get - if psPretty - then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 } - void p - modify $ \s -> s { psIndentLevel = psIndentLevel } - else void p +indented :: Printer -> Printer +indented p = askP $ \PrintReader{..} -> + if prPretty + then addToIndentLevel 1 <> p <> addToIndentLevel (-1) + else p + where addToIndentLevel d = modifyP (\s@PrintState{..} -> s { psIndentLevel = psIndentLevel + d } ) -- | Output a newline. -newline :: Printer () -newline = do - PrintState{..} <- get - when psPretty $ do - write "\n" - modify $ \s -> s { psNewline = True } +newline :: Printer +newline = askP $ \PrintReader{..} -> + whenP prPretty $ write "\n" <> (modifyP $ \s -> s { psNewline = True }) --- | Write out a string, updating the current position information. -write :: String -> Printer () -write x = do - PrintState{..} <- get - let out = if psNewline then replicate (2*psIndentLevel) ' ' ++ x else x - modify $ \s -> s { psOutput = out : psOutput - , psLine = psLine + additionalLines - , psColumn = if additionalLines > 0 - then length (concat (take 1 (reverse srclines))) - else psColumn + length x - , psNewline = False - } - return (error "Nothing to return for writer string.") - where srclines = lines x +-- | Write out a string, updating the current position information. +write :: String -> Printer +write x = p <> q + where p = getP $ \PrintState{..} -> + let out = if psNewline + then replicate (2*psIndentLevel) ' ' ++ x + else x + in tellP mempty { pwOutput = [out] } + q = modifyP $ \s@PrintState{..} -> + s { psLine = psLine + additionalLines + , psColumn = if additionalLines > 0 + then length (concat (take 1 (reverse srclines))) + else psColumn + length x + , psNewline = False + } + 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 - } +-- | Generate a mapping from the Haskell location to the current point in the output. +mapping :: SrcSpan -> Printer +mapping SrcSpan{..} = + getP $ \PrintState{..} -> + let m = Mapping { mapGenerated = Pos (fromIntegral (psLine)) + (fromIntegral (psColumn)) + , mapOriginal = Just (Pos (fromIntegral srcSpanStartLine) + (fromIntegral srcSpanStartColumn - 1)) + , mapSourceFile = Just srcSpanFilename + , mapName = Nothing + } + in tellP $ mempty { pwMappings = [m] } --- | Intercalate monadic action. -intercalateM :: String -> [Printer a] -> Printer () -intercalateM _ [] = return () -intercalateM _ [x] = void x -intercalateM str (x:xs) = do - void x - write str - intercalateM str xs +-- | Intercalate monoids. +mintercalate :: String -> [Printer] -> Printer +mintercalate str xs = mconcat $ intersperse (write str) xs -- | Concatenate two printables. -(+>) :: (Printable a, Printable b) => a -> b -> Printer () -pa +> pb = printJS pa >> printJS pb +(+>) :: (Printable a, Printable b) => a -> b -> Printer +pa +> pb = printJS pa <> printJS pb diff --git a/src/Fay/Config.hs b/src/Fay/Config.hs --- a/src/Fay/Config.hs +++ b/src/Fay/Config.hs @@ -23,6 +23,7 @@ , configTypecheckOnly , configRuntimePath , configOptimizeNewtypes + , configPrettyThunks ) , defaultConfig , defaultConfigWithSandbox @@ -72,6 +73,7 @@ , configTypecheckOnly :: Bool -- ^ Only invoke GHC for typechecking, don't produce any output , configRuntimePath :: Maybe FilePath , configOptimizeNewtypes :: Bool -- ^ Optimize away newtype constructors? + , configPrettyThunks :: Bool -- ^ Use pretty thunk names? } deriving (Show) @@ -101,6 +103,7 @@ , configRuntimePath = Nothing , configSourceMap = False , configOptimizeNewtypes = True + , configPrettyThunks = False } defaultConfigWithSandbox :: IO Config diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -20,7 +20,16 @@ ,FundamentalType(..) ,PrintState(..) ,defaultPrintState + ,PrintReader(..) + ,defaultPrintReader + ,PrintWriter(..) ,Printer(..) + ,execPrinter + ,askP + ,getP + ,modifyP + ,tellP + ,whenP ,SerializeContext(..) ,ModulePath (unModulePath) ,mkModulePath @@ -41,7 +50,6 @@ import Control.Monad.Error (ErrorT, MonadError) import Control.Monad.Identity (Identity) import Control.Monad.RWS -import Control.Monad.State import Data.Map (Map) import Data.Set (Set) import Distribution.HaskellSuite.Modules @@ -114,33 +122,73 @@ liftModuleT :: ModuleT Symbols IO a -> Compile a liftModuleT = Compile . lift . lift + +-- | Global options of the printer +data PrintReader = PrintReader + { prPretty :: Bool -- ^ Are we to pretty print? + , prPrettyThunks :: Bool -- ^ Use pretty thunk names? + } + +defaultPrintReader :: PrintReader +defaultPrintReader = PrintReader False False + + +-- | Output of printer +data PrintWriter = PrintWriter + { pwMappings :: [Mapping] -- ^ Source mappings. + , pwOutput :: [String] -- ^ The current output. TODO: Make more efficient. + } + + +-- | Reverse concatenation (generated output need to be reversed) +instance Monoid PrintWriter where + mempty = PrintWriter [] [] + mappend (PrintWriter a b) (PrintWriter x y) = PrintWriter (x ++ a) (y ++ b) + -- | The state of the pretty printer. data PrintState = PrintState - { psPretty :: Bool -- ^ Are we to pretty print? - , psLine :: Int -- ^ The current line. + { psLine :: Int -- ^ The current line. , psColumn :: Int -- ^ Current column. - , psMappings :: [Mapping] -- ^ Source mappings. , psIndentLevel :: Int -- ^ Current indentation level. - , psOutput :: [String] -- ^ The current output. TODO: Make more efficient. , psNewline :: Bool -- ^ Just outputted a newline? } -- | Default state. defaultPrintState :: PrintState -defaultPrintState = PrintState False 0 0 [] 0 [] False +defaultPrintState = PrintState 0 0 0 False --- | The printer monad. -newtype Printer a = Printer { runPrinter :: State PrintState a } - deriving - ( Applicative - , Functor - , Monad - , MonadState PrintState - ) +-- | The printer. +newtype Printer = Printer + { runPrinter :: RWS PrintReader PrintWriter PrintState () + } +execPrinter :: Printer -> PrintReader -> PrintWriter +execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState + +-- | monadic functions +askP :: (PrintReader -> Printer) -> Printer +askP f = Printer $ ask >>= (\r -> runPrinter (f r)) + +getP :: (PrintState -> Printer) -> Printer +getP f = Printer $ get >>= (\s -> runPrinter (f s)) + +modifyP :: (PrintState -> PrintState) -> Printer +modifyP f = Printer $ modify f + +tellP :: PrintWriter -> Printer +tellP = Printer . tell + +whenP :: Bool -> Printer -> Printer +whenP b p = if b then p else mempty + + +instance Monoid Printer where + mempty = Printer $ return () + mappend (Printer p) (Printer q) = Printer (p >> q) + -- | Print some value. class Printable a where - printJS :: a -> Printer () + printJS :: a -> Printer -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a) diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -42,6 +42,7 @@ , optSourceMap :: Bool , optFiles :: [String] , optNoOptimizeNewtypes :: Bool + , optPrettyThunks :: Bool } -- | Main entry point. @@ -70,6 +71,7 @@ , configRuntimePath = optRuntimePath opts , configSourceMap = optSourceMap opts , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts + , configPrettyThunks = optPrettyThunks opts } if optVersion opts then runCommandVersion @@ -121,6 +123,7 @@ <*> switch (long "sourcemap" <> help "Produce a source map in .map") <*> many (argument (ReadM ask) (metavar "...")) <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types") + <*> switch (long "pretty-thunks" <> help "Use pretty thunk names") where strsOption :: Mod OptionFields [String] -> Parser [String] strsOption m = option (ReadM . fmap (wordsBy (== ',')) $ ask) (m <> value []) diff --git a/tests/ListEq.hs b/tests/ListEq.hs new file mode 100644 --- /dev/null +++ b/tests/ListEq.hs @@ -0,0 +1,7 @@ +module ListEq where + +main :: Fay () +main = do + print $ [] == [] + print $ [1,2,3] == [1,2,3] + print $ ["a"] == ["b"] diff --git a/tests/ListEq.res b/tests/ListEq.res new file mode 100644 --- /dev/null +++ b/tests/ListEq.res @@ -0,0 +1,3 @@ +true +true +false