fay 0.21.2.1 → 0.22.0.0

raw patch · 10 files changed

+182/−121 lines, 10 filesdep ~language-ecmascriptPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: language-ecmascript

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• fay.cabal +2/−2
• src/Fay.hs +20/−20
• src/Fay/Compiler.hs +4/−5
• src/Fay/Compiler/Print.hs +72/−79
• src/Fay/Config.hs +3/−0
• src/Fay/Types.hs +63/−15
• src/main/Main.hs +3/−0
• tests/ListEq.hs +7/−0
• tests/ListEq.res +3/−0

@@ -2,6 +2,11 @@  See full history at: <https://github.com/faylang/fay/commits> +## 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`.

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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

@@ -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)

@@ -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 <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 [])

@@ -0,0 +1,7 @@+module ListEq where++main :: Fay ()+main = do+  print $ []      == []+  print $ [1,2,3] == [1,2,3]+  print $ ["a"]   == ["b"]

@@ -0,0 +1,3 @@+true+true+false