Add a --pretty-thunks flag

Author: michalseweryn

src/Fay.hs

@@ -138,12 +138,20 @@ compileToModule filepath config raw with hscode = do
             , state
             )
       where
-        pw = execPrinter (runtime <> printer <> main) pr
+        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 { prPretty = configPrettyPrint config }
+        pr = defaultPrintReader
+          { prPrettyThunks = configPrettyThunks config
+          , prPretty       = configPrettyPrint config
+          }
 
 -- | Convert a Haskell filename to a JS filename.
 toJsName :: String -> String

src/Fay/Compiler/Print.hs

@@ -36,7 +36,7 @@ printJSString x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultP
 
 -- | Print the JS to a pretty string.
 printJSPretty :: Printable a => a -> String
-printJSPretty x = concat . reverse . pwOutput $ execPrinter (printJS x) defaultPrintReader { prPretty = 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.
@@ -218,15 +218,17 @@ instance Printable JsName where
     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

src/Fay/Config.hs

@@ -23,6 +23,7 @@ module Fay.Config
       , configTypecheckOnly
       , configRuntimePath
       , configOptimizeNewtypes
+      , configPrettyThunks
       )
   , defaultConfig
   , defaultConfigWithSandbox
@@ -72,6 +73,7 @@ data Config = Config
   , 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 @@ defaultConfig = addConfigPackage "fay-base"
     , configRuntimePath        = Nothing
     , configSourceMap          = False
     , configOptimizeNewtypes   = True
+    , configPrettyThunks       = False
     }
 
 defaultConfigWithSandbox :: IO Config

src/Fay/Types.hs

@@ -126,10 +126,11 @@ 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
+defaultPrintReader = PrintReader False False
 
 
 -- | Output of printer

src/main/Main.hs

@@ -42,6 +42,7 @@ data FayCompilerOptions = FayCompilerOptions
   , optSourceMap          :: Bool
   , optFiles              :: [String]
   , optNoOptimizeNewtypes :: Bool
+  , optPrettyThunks       :: Bool
   }
 
 -- | Main entry point.
@@ -70,6 +71,7 @@ main = do
           , configRuntimePath      = optRuntimePath opts
           , configSourceMap        = optSourceMap opts
           , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts
+          , configPrettyThunks     = optPrettyThunks opts
           }
   if optVersion opts
     then runCommandVersion
@@ -121,6 +123,7 @@ options = FayCompilerOptions
   <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")
   <*> many (argument (ReadM ask) (metavar "<hs-file>..."))
   <*> 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 [])