packages feed

fay 0.18.1.3 → 0.24.2.0

raw patch · 269 files changed

Files

CHANGELOG.md view
@@ -2,18 +2,345 @@  See full history at: <https://github.com/faylang/fay/commits> +### 0.24.2.0 (2021-01-10)++* Drop GHC 8.0 support.+* Cabal upgraded to 2.0 spec-version.+* Travis CI refactored to allow cabal-install 3.2.0.0 builds.++### 0.24.1.1 (2021-01-08)++* Relax boundaries for aeson, tasty, base-compat. Allow builds for Gentoo (#469).++### 0.24.1.0 (2020-03-26)++* GHC 8.10.1 support.++#### 0.24.0.5 (2020-03-10)++* GHC 8.8 support.++#### 0.24.0.4 (2019-12-03)++* Fixes stack nix integration broken.++#### 0.24.0.3 (2019-04-29)++* Dependency updates including GHC-8.6 support.+* Added stack compatibility.++#### 0.24.0.2++* Fix dependent compilation fail when building project with stack (#457).++#### 0.24.0.1++* Dependency updates incl GHC 8.4 support++## 0.24.0.0++* Add the option to generate typescript output, thanks to Junji Hashimoto.++### 0.23.2.0++* GHC 8.2 support+* Use traverse-with-class 1.0.*, and as a result drop support for GHC < 8.++#### 0.23.1.16++* Fix build on GHC 7.4++#### 0.23.1.15++* Allow optparse-applicative 0.13.*.++#### 0.23.1.14++* Fix a compilation error introduced in 0.23.1.13.++#### 0.23.1.13++* Add support for haskell-src-exts 1.18.1.++#### 0.23.1.12++* Fix compilation on GHC < 7.8.++#### 0.23.1.11++* Tighten some impossible lower bounds we can't support.++#### 0.23.1.10++* Don't compile with `-fprof-auto` by default.++#### 0.23.1.9++* Allow and require `haskell-src-exts 1.17.*`++#### 0.23.1.8++* Allow `vector 0.11.*`++#### 0.23.1.7++* Fix panic when compiling irrefutable pattern matches on lists (thanks Christopher Parks)++#### 0.23.1.6++* Allow `syb 0.5.*`++#### 0.23.1.5++* Allow `aeson 0.9.*`++#### 0.23.1.4++* Fix compilation on at least GHC 7.6 (maybe older versions as well...)++#### 0.23.1.3++* Inline parts of `haskell-names 0.4.1` and `haskell-packages` to drop transitive dependencies on Cabal and other packages.++#### 0.23.1.2++* Allow filepath 1.4.*++#### 0.23.1.1++* Allow do let bindings of newtypes.++### 0.23.1.0++* Add `--show-ghc-calls` and `configShowGhcCalls` to print invocations to GHC.++#### 0.23.0.1++* Allow `mtl-compat 0.2.*` and `transformers-compat 0.4.*"`.++## 0.23.0.0++New features:++* GHC 7.10 support+* Add a `--pretty-operators` flag to replace the escaped operator names with their actual names - By Michal Seweryn+* Add a `--pretty-all` flag that enables `--pretty`, `--pretty-operators`, and `--pretty-thunks` - By Michal Seweryn+* De/serialize type variables as 'automatic'. You no longer have to annotate FFI functions with Automatic, this is now the default. If you need the old behavior, use Ptr. For most existing cases this change shouldn't change anything. - By Zachary Mason++Example output with `--pretty-all`:+```javascript+Main.main = new $(function(){+  return _(_(Prelude["$"])(Prelude.print))(_(_(Prelude["++"])(Main.g))(Fay$$list("b")));+});+```+++API changes - By Michal Seweryn:++* Export CompileResult from Fay.Types+* Export PrintReader and PrintWriter, and reducing number of PrintState fields (these are moved to PrinterReader and PrintWriter)+* In the meanwhile PrintWriter field type changed - output is now stored as ShowS - tests run faster now+* Replace monadic functions (askP, getP, ...) with higher level ones: indented, askIf, newline, write, mapping. askIf is pretty much like previous askP, but works like if-then-else.+* Internally we are now using `ExceptT` instead of `ErrorT`. This fixes deprecation warnings when using `transformers 0.4.*`.++Bug fixes:+* Defer automatic_function fayToJs call until after argument application - by Zachary Mason++Dependency bumps:+* Allow `utf8-string 1.0.*`+* Allow `time == 1.5.*`++## 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`.++### 0.21.2 (2014-10-21)++* Previously all package imports were ignored, now we only ignore `"base"` package imports.++### 0.21.1 (2014-10-21)++* Lots of additions to in `fay-base` adding the following modules:+  * Data.Var - Mutable variables, Reactive variables, and reactive signals+  * Unsafe.Coerce+  * Data.Text (fay-text will be updated to reuse this module)+  * Data.Time+  * Data.Ord, Data.Function, Data.Maybe, Data.List, Data.Either+  * Data.Defined and Data.Nullable+  * Data.Mutex - Simple mutexes+  * Control.Exception+  * Data.LocalStorage+  * Data.MutMap - Mutable maps++The introduction of `Data.Var` required some additions to fay's runtime.++#### 0.21.0.2 (2014-10-19)++* Fallback to ghc and ghc-pkg in PATH if not available from GHC.Paths++#### 0.21.0.1 (2014-10-12)++* Update to `optparse-applicative == 0.11.*`++## 0.21.0.0 (2014-10-11)++* Errors are now properly thrown from `encodeFay`. Changes the type signature to `encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value`+* Update to `haskell-src-exts == 1.16.*`, This changes the type signature of `readerCompileLit` to `:: S.Sign -> S.Literal -> Compile JsExp`+* Fixes `ghc-pkg describe` stdout errors not always being printed++### 0.20.2.0 (2014-09-14)++* Config option to disable optimizations of newtypes, treating them as+  normal data types. This can be triggered by setting+  `configOptimizeNewtypes = False` or passing+  `--no-optimized-newtypes`.++#### 0.20.1.4 (2014-09-04)++* Update to `optparse-applicative == 0.10.*`++#### 0.20.1.3 (2014-08-29)++* Test suite is no longer built by default, cabal install with `-ftest` to enable.++#### 0.20.1.2 (2014-08-18)++* Updated homepage URLs, fay-lang.org was 301'd++#### 0.20.1.1 (2014-06-17)++* Don't cache the `main` thunk in the generated `main` call.++### 0.20.1.0 (2014-06-14)++* Add default case for UTCTime in Fay.Convert using the aeson instances. Note that this serializes to a json string so you won't be able to deserialize it as a separate type (such as Date) when using `Automatic` in Fay.++* Added `Fay.Config.defaultConfigWithSandbox` that reads the `HASKELL_PACKAGE_SANDBOX` environment variable. Client libraries can use this instead of manually reading from `getEnvironment`.++#### 0.20.0.4 (2014-05-23)++* Allow `optparse-applicative 0.9.*`++#### 0.20.0.3 (2014-05-09)++* Allow `mtl 2.2.*`++#### 0.20.0.2 (2014-05-08)++* Allow `haskell-names 0.4.*`++#### 0.20.0.1 (2014-05-08)++* Allow `transformers >= 0.4.1 && < 0.5`++## 0.20.0.0 (2014-04-29)++* Adds support for LambdaCase and MultiWayIf++* Modules have moved around a lot and several modules have been un-exposed. From now on you will probably only need to deal with at most `Fay` (which re-exports a lot of things), `Fay.Config`, `Fay.Types.CompileError`, `Fay.Convert`, and `Fay.Types.CompileResult`. Please let us know if you would like us to expose more things++* Config:+  * `CompileConfig` has been renamed to `Config` and is now located in `Fay.Config`.+  * `CompileConfig` has become a temporary type alias for `Config`.+  * `Fay.Compiler.Config` is deprecated, import `Fay` or `Fay.Config` instead.+  * The `data-default` instance for `Config` is deprecated, use `defaultConfig` instead.++* compiling+  * `compileFileWithState` is deprecated, use `compileFileWithResult` which returns a `Fay.Types.CompileResult` instead. As a consequence `CompileState` is also deprecated from public consumption.+  * `compileFile`, `compileFromToAndGenerateHtml` no longer return a triple with the sourcemap, use `compileFileWithResult` if you want access to this.++* Importing `Fay.Types` has been deprecated, import `Fay` instead.++* `readFromFay` has been rewritten using `syb` instead of `pretty-show` (Thanks to Michael Sloan and Chris Done)+  * This introduces the following breaking changes:+    * `readFromFay` has a `Data` constraint instead of `Show`.+    * Drops support for Rational and Integer (see below for migration steps). The reason is that neither was serialized in a way that would roundtrip for all values. Also, for similar reasons, fromRational is potentially divergent for aeson's new use of the Scientific type.+  * And adds the following features:+    * You can now write custom `Show` instances targeting GHC for types shared with Fay.+    * Better performance.+    * Allows the serialization and deserialization to be customized on a per-type basis, via encodeFay and decodeFay.+  * To migrate code using Rational or Integer, use encodeFay and pass an argument e.g. `(\f x -> maybe (f x) myIntegerToValueConversion (cast x))` and likewise to decodeFay.++Bugfixes:++* Mltiple guards on a pattern in a case expression skipped everything but the first guard. To fix this an optimization we had on pattern conditions was disabled.++Dependency bumps:++* Allow Cabal 1.20 and 1.21++Internal:++* Test cases are now using `tasty` instead of `test-framework`. To run cases in parallel use `fay-tests --num-threads=N` (see `fay-tests --help` for more info).+* Added a test group for desugaring.++#### 0.19.2.1 (2014-04-14)++* Allow `haskell-src-exts 1.15.*`++### 0.19.2 (2014-04-10)++* Fixes a bug where arrays used with empty data decls would be deserialized into a Fay list instead of kept as is.++#### 0.19.1.2 (2014-04-07)++* Fix optimizations that were not applied and add codegen test cases.++#### 0.19.1.1 (2014-03-17)++* Allow `optparse-applicative 0.8.*`++### 0.19.1 (2014-03-13)++* Added Data.Char to fay-base++Dependency bumps:+* Allow `Cabal 1.19.*`+* Allow `process 1.2.*`++#### 0.19.0.2 (2014-01-30)++Bugfixes:+* Don't export transcoding information for fay-base packages when compiling with --no-stdlib+* Better error messages when forgetting the type signature in an FFI declaration++#### 0.19.0.1 (2014-01-15)++Dependency bumps:+* Allow `aeson 0.7.*`++## 0.19 (2014-01-14)++* Made import Prelude is implicit, but note that RebindableSyntax implies NoImplicitPrelude.+* Allow FFI declarations in let and where statements: `let f :: X; f = ffi "..."` and `where f :: X; f = ffi "..."`++Bugfixes:+* Removed extra </script> tag that was generated by --html-wrapper+* FFI expressions in top level declarations now produce identical code to a normal top level FFI declaration+* Don't export Data.Ratio and Debug.Trace when using --no-stdlib++Dependency bumps:+* Allow text 1.1+* Allow attoparsec 0.11++ **Note: 0.18.0.1 added source mappings returned by `Fay:compileFile` and friends meaning it should have been a major bump. Sorry about this!** -### 0.18.1.3 (2013-12-14)+#### 0.18.1.3 (2013-12-14)  * Add parsing of Integer to Fay.Convert (note that the runtime doesn't have arbitrary precision Integers) * Allow text 1.0.* -### 0.18.1.2 (2013-11-26)+#### 0.18.1.2 (2013-11-26)  * Add support for indirect application of newtypes (such as `p = NewType; foo = p x` and `bar = NewType $ y`) -### 0.18.1.1 (2013-11-22)+#### 0.18.1.1 (2013-11-22)  * Fix a bug where records with the same name as top level modules wouldn't be initialized correctly. * Fail when using enum syntax on unsupported literal types (for instance ['a'..'z'])@@ -66,8 +393,8 @@  New features: * Support for qualified imports. Note: You still can't have multiple constructors with the same name in the FFI since the `instance` field in the serialization is still unqualified.-* `Automatic` transcoding now works for functions. See [[Calling Fay From JavaScript]]-* `--strict modulename[, ..]` generates strict and transcoding wrappers for a module's exports. See [[Calling Fay From JavaScript]]+* `Automatic` transcoding now works for functions. See [Calling Fay From JavaScript](https://github.com/faylang/fay/wiki/Calling-Fay-from-JavaScript)+* `--strict modulename[, ..]` generates strict and transcoding wrappers for a module's exports. See [Calling Fay From JavaScript](https://github.com/faylang/fay/wiki/Calling-Fay-from-JavaScript) * `--typecheck-only` just runs the GHC type checker with the appropriate Fay flags. * `--runtime-path FILEPATH` allows you to supply a custom runtime. Probably only useful for debugging.
Setup.hs view
@@ -7,24 +7,10 @@ import Distribution.PackageDescription import Distribution.Simple -main = do+main =   defaultMainWithHooks simpleUserHooks-    { preConf = \_args _flags -> do putStrLn reminder-                                    return emptyHookedBuildInfo-    , postInst = (\_ _ _ _ -> putStrLn fayBaseReminder)+    { postInst = \_ _ _ _ -> putStrLn fayBaseReminder     }--reminder =-  "                                                                               \n\-  \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n\-  \                                                                               \n\-  \  REMEMBER: This compiler is in flux, supercalifragelistic style. You should   \n\-  \            read the CHANGELOG for this release as the changes probably        \n\-  \            affect you.                                                        \n\-  \                                                                               \n\-  \                                                                               \n\-  \                                                                               \n\-  \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n"  fayBaseReminder =   "                                                                               \n\
+ examples/D3TreeSample.hs view
@@ -0,0 +1,96 @@+module D3TreeSample where++import FFI+import Data.Char++data Event+data D3SvgCanvas+data D3SvgDiagonal+data D3SvgLink+data D3SvgNode+data D3LayoutTree+data D3LayoutTreeNodes+data D3LayoutTreeLinks++--------- D3: A JavaScript visualization library for HTML and SVG. http://d3js.org+--------- Usage example with Fay++--------- JSON FEED++data JsonTree = JsonNode { name :: String, children :: JsonForest }+type JsonForest = [JsonTree]++unfoldTree :: (Int -> (String, [Int])) -> Int -> JsonTree+unfoldTree f b = let (a, bs) = f b in JsonNode a (unfoldForest f bs)++unfoldForest :: (Int -> (String, [Int])) -> [Int] -> JsonForest+unfoldForest f = map (unfoldTree f)++createJson :: Int -> JsonTree+createJson = unfoldTree (\n -> ([chr (n + ord 'a')], replicate n (n-1)))++--------- FFI++addWindowEvent :: String -> (Event -> Fay ()) -> Fay ()+addWindowEvent = ffi "window.addEventListener(%1, %2)"++createSvgCanvas :: Int -> Int -> Fay D3SvgCanvas+createSvgCanvas = ffi "d3.select('#viz')\+                                        \.append('svg:svg').attr('width', %1).attr('height', %2)\+                                        \.append('svg:g').attr('transform', 'translate(40, 40)')"++createTree :: Int -> Int -> Fay D3LayoutTree+createTree = ffi "d3.layout.tree().size([%1,%2])"++createDiagonal :: Fay D3SvgDiagonal+createDiagonal = ffi "d3.svg.diagonal().projection(function(d) { return [d.x, d.y]; })"++createNodes :: D3LayoutTree -> JsonTree -> Fay D3LayoutTreeNodes+createNodes = ffi "%1.nodes(%2)"++createLinks :: D3LayoutTree -> D3LayoutTreeNodes -> Fay D3LayoutTreeLinks+createLinks = ffi "%1.links(%2)"++displayLinks :: D3SvgCanvas -> D3LayoutTreeLinks -> D3SvgDiagonal -> Fay D3SvgLink+displayLinks = ffi "%1.selectAll('pathlink').data(%2)\+                                                     \.enter().append('svg:path')\+                                                     \.attr('class', 'link')\+                                                     \.attr('d', %3)"++displayNodes :: D3SvgCanvas -> D3LayoutTreeNodes -> Fay D3SvgNode+displayNodes = ffi "%1.selectAll('g.node').data(%2)\+                                                   \.enter().append('svg:g')\+                                                   \.attr('transform', \+                                                   \function(d) { return 'translate(' + d.x + ',' + d.y + ')'; })"++addDotToNodes :: D3SvgNode -> Double -> Fay ()+addDotToNodes = ffi "%1.append('svg:circle').attr('r', %2)"++addTextToNodes :: D3SvgNode -> Fay()+addTextToNodes = ffi "%1.append('svg:text')\+                                           \.attr('dx', function(d) { return d.children ? -8 : 8; })\+                                           \.attr('dy', 3)\+                                           \.attr('text-anchor', function(d) { return d.children ? 'end' : 'start'; })\+                                           \.text(function(d) { return d.name; })"++--------- START++d3TreeSample :: Event -> Fay()+d3TreeSample event = do+    svgCanvas <- createSvgCanvas 800 600+    d3Tree <- createTree 600 300+    diagonal <- createDiagonal++    nodes <- createNodes d3Tree (createJson 4)+    links <- createLinks d3Tree nodes++    svgLink <- displayLinks svgCanvas links diagonal+    svgNode <- displayNodes svgCanvas nodes++    addDotToNodes svgNode 2.5+    addTextToNodes svgNode+++main :: Fay ()+main = do+    addWindowEvent "load" d3TreeSample
+ examples/D3TreeSample.html view
@@ -0,0 +1,18 @@+<!doctype html>+<html>+  <head>+    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+    <script src="https://cdnjs.cloudflare.com/ajax/libs/d3/3.5.5/d3.min.js" charset="utf-8"></script>+    <script type="text/javascript" src="D3TreeSample.js"></script>+    <style>+      .link {+      fill: none;+      stroke: #ccc;+      stroke-width: 2.5px;+      }+   </style>+  </head>+  <body>+    <div id="viz"></div>+  </body>+</html>
examples/calc.hs view
@@ -32,7 +32,7 @@                                       return ()                               else do setVal (show n) display                                       writeRef appendMore True)-      getInput = getVal display >>= (return . parseDouble 10)+      getInput = getVal display >>= (return . parseDouble)       operator op = do         calculate         num <- getInput@@ -104,8 +104,8 @@ -------------------------------------------------------------------------------- -- Utilities -parseDouble :: Int -> String -> Double-parseDouble = ffi "parseFloat(%2,%1) || 0"+parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1) || 0"  -------------------------------------------------------------------------------- -- Refs
examples/calc.html view
@@ -10,7 +10,7 @@   <body>     <h1>Calc</h1>     <p>A clone of <a href="http://trelford.com/PitCalculatorApp.htm">Pit's calculator app</a></p>-    <p>JS generated by <a href="http://fay-lang.org/">Fay</a>, a Haskell+    <p>JS generated by <a href="https://github.com/faylang/fay/wiki">Fay</a>, a Haskell     subset. <a href="https://github.com/faylang/fay/blob/master/examples/calc.hs">Source code</a></p>   </body> </html>
examples/json.hs view
@@ -1,5 +1,3 @@-- module Console where  import           FFI@@ -11,10 +9,12 @@ myData :: MyData myData = MyData { xVar = pack "asdfasd", yVar = 9 } - main = do 	jsonSerialized <- toJSON myData 	jsonDeserialized <- toMyData jsonSerialized+	-- The "instance" field below is required for reliable parsing.+	-- If your JSON source doesn't have an "instance" field, you can+	-- add one like this: ffi "%1['instance']='MyData',%1" :: Json -> MyData 	fromStringData <- toMyData "{\"xVar\":3,\"yVar\":-1,\"instance\":\"MyData\"}" 	print' jsonSerialized
examples/oscillator.hs view
@@ -1,12 +1,9 @@ {-# LANGUAGE EmptyDataDecls    #-}-{-# LANGUAGE NoImplicitPrelude #-}  module RingOscillator (main) where  import FFI-import Prelude - -- System parameters. -- data Params = Params { alpha :: Double@@ -419,14 +416,6 @@ zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e :                                                 zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = []--mapM :: (a -> Fay b) -> [a] -> Fay [b]-mapM m (x:xs) = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs)))-mapM _ [] = return []--forM :: [a] -> (a -> Fay b) -> Fay [b]-forM (x:xs) m = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs)))-forM [] _ = return []  replicateM :: Int -> Fay a -> Fay [a] replicateM n x = sequence (replicate n x)
fay.cabal view
@@ -1,5 +1,6 @@+cabal-version:       2.0 name:                fay-version:             0.18.1.3+version:             0.24.2.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,@@ -7,18 +8,13 @@                      .                      /Documentation/                      .-                     See <http://fay-lang.org/>+                     See <https://github.com/faylang/fay/wiki>                      .                      /Examples/                      .                      See the examples directory and <https://github.com/faylang/fay/wiki#fay-in-the-wild>                      .-                     /Release Notes/-                     .-                     See <https://github.com/faylang/fay/blob/master/CHANGELOG.md>-                     .-                     See full history at: <https://github.com/faylang/fay/commits>-homepage:            http://fay-lang.org/+homepage:            https://github.com/faylang/fay/wiki bug-reports:         https://github.com/faylang/fay/issues license:             BSD3 license-file:        LICENSE@@ -27,13 +23,14 @@ copyright:           2012 Chris Done, Adam Bergmark category:            Development, Web, Fay build-type:          Custom-cabal-version:       >=1.8-data-files:          js/runtime.js-                     src/Fay/FFI.hs+Tested-with:         GHC ==8.4.4 || ==8.6.5 || ==8.8.3+data-files:+  src/Fay/FFI.hs extra-source-files:+  CHANGELOG.md   LICENSE   README.md-  CHANGELOG.md+  src/haskell-names/LICENSE   -- Examples   examples/*.hs   examples/*.html@@ -70,102 +67,158 @@   type: git   location: https://github.com/faylang/fay.git +flag test+  description:       Build the fay-tests executable+  manual:            True+  default:           False++custom-setup+  setup-depends:+      base+    , Cabal+ library-  hs-source-dirs:    src-  exposed-modules:     Fay-                     , Fay.Compiler-                     , Fay.Compiler.Config-                     , Fay.Control.Monad.Extra-                     , Fay.Control.Monad.IO-                     , Fay.Convert-                     , Fay.Data.List.Extra-                     , Fay.Exts-                     , Fay.Exts.Scoped-                     , Fay.Exts.NoAnnotation-                     , Fay.FFI-                     , Fay.System.Directory.Extra-                     , Fay.System.Process.Extra-                     , Fay.Types-  other-modules:       Fay.Compiler.Decl-                     , Fay.Compiler.Defaults-                     , Fay.Compiler.Desugar-                     , Fay.Compiler.Exp-                     , Fay.Compiler.FFI-                     , Fay.Compiler.GADT-                     , Fay.Compiler.Import-                     , Fay.Compiler.InitialPass-                     , Fay.Compiler.Misc-                     , Fay.Compiler.Optimizer-                     , Fay.Compiler.Packages-                     , Fay.Compiler.Pattern-                     , Fay.Compiler.PrimOp-                     , Fay.Compiler.Print-                     , Fay.Compiler.QName-                     , Fay.Compiler.State-                     , Fay.Compiler.Typecheck-                     , Paths_fay-  ghc-options:       -O2 -Wall -fno-warn-name-shadowing-  build-depends:     base                 >= 4       && < 5-                   , Cabal                              < 1.19-                   , aeson                              < 0.7-                   , attoparsec                         < 0.11-                   , bytestring                         < 0.11-                   , containers                         < 0.6-                   , cpphs                              < 1.19-                   , data-default                       < 0.6-                   , directory                          < 1.3-                   , filepath                           < 1.4-                   , ghc-paths                          < 0.2-                   , haskell-names        >= 0.3.1   && < 0.4-                   , haskell-packages     >= 0.2.3.1 && < 0.3-                   , haskell-src-exts     >= 1.14    && < 1.15-                   , language-ecmascript  >= 0.15    && < 1.0-                   , mtl                                < 2.2-                   , pretty-show          >= 1.6     && < 1.7-                   , process                            < 1.2-                   , safe                               < 0.4-                   , split                              < 0.3-                   , syb                                < 0.5-                   , text                               < 1.1-                   , time                               < 1.5-                   , uniplate             >= 1.6.11  && < 1.7-                   , unordered-containers               < 0.3-                   , utf8-string                        < 0.4-                   , vector                             < 0.11-                   , sourcemap                          < 0.2+  default-language:  Haskell2010                           +  ghc-options:       -O2 -Wall+  hs-source-dirs:+    src+    src/haskell-names+  autogen-modules:+    Paths_fay+  exposed-modules:+    Fay+    Fay.Compiler+    Fay.Compiler.Desugar+    Fay.Compiler.Parse+    Fay.Compiler.Prelude+    Fay.Config+    Fay.Convert+    Fay.FFI+    Fay.Types+    Fay.Types.CompileError+    Fay.Types.CompileResult+  other-modules:+    Fay.Compiler.Decl+    Fay.Compiler.Defaults+    Fay.Compiler.Desugar.Name+    Fay.Compiler.Desugar.Types+    Fay.Compiler.Exp+    Fay.Compiler.FFI+    Fay.Compiler.GADT+    Fay.Compiler.Import+    Fay.Compiler.InitialPass+    Fay.Compiler.Misc+    Fay.Compiler.ModuleT+    Fay.Compiler.Optimizer+    Fay.Compiler.Packages+    Fay.Compiler.Pattern+    Fay.Compiler.PrimOp+    Fay.Compiler.Print+    Fay.Compiler.QName+    Fay.Compiler.State+    Fay.Compiler.Typecheck+    Fay.Exts+    Fay.Exts.NoAnnotation+    Fay.Exts.Scoped+    Fay.Runtime+    Fay.Types.FFI+    Fay.Types.Js+    Fay.Types.ModulePath+    Fay.Types.Printer+    Language.Haskell.Names+    Language.Haskell.Names.Annotated+    Language.Haskell.Names.Exports+    Language.Haskell.Names.GetBound+    Language.Haskell.Names.GlobalSymbolTable+    Language.Haskell.Names.Imports+    Language.Haskell.Names.LocalSymbolTable+    Language.Haskell.Names.ModuleSymbols+    Language.Haskell.Names.Open.Base+    Language.Haskell.Names.Open.Derived+    Language.Haskell.Names.Open.Instances+    Language.Haskell.Names.RecordWildcards+    Language.Haskell.Names.Recursive+    Language.Haskell.Names.ScopeUtils+    Language.Haskell.Names.SyntaxUtils+    Language.Haskell.Names.Types+    Paths_fay+  build-depends:+      base >= 4.9 && < 4.15+    , base-compat >= 0.10 && < 0.12+    , aeson > 0.6 && < 1.6+    , bytestring >= 0.9 && < 0.11+    , containers >= 0.4 && < 0.7+    , data-default >= 0.2 && < 0.8+    , data-lens-light == 0.1.*+    , directory >= 1.1 && < 1.4+    , filepath >= 1.3 && < 1.5+    , ghc-paths == 0.1.*+    , haskell-src-exts >= 1.20+    , language-ecmascript >= 0.15 && < 0.20+    , mtl >= 2.1 && < 2.3+    , mtl-compat >= 0.1 && < 0.3+    , process >= 1.1 && < 1.7+    , safe >= 0.2 && < 0.4+    , sourcemap == 0.1.*+    , split >= 0.1 && < 0.3+    , spoon >= 0.1 && < 0.4+    , syb >= 0.3 && < 0.8+    , text >= 0.11 && < 1.3+    , time >= 1.4 && < 1.10+    , transformers >= 0.3 && < 0.6+    , transformers-compat >= 0.3 && < 0.7+    , traverse-with-class >= 1.0 && < 1.1+    , uniplate >= 1.6.11 && < 1.7+    , unordered-containers == 0.2.*+    , utf8-string >= 0.1 && < 1.1+    , vector < 0.13+    , shakespeare < 2.1 +  if impl(ghc < 7.8)+    build-depends: tagged+ executable fay+  default-language:  Haskell2010                              hs-source-dirs:    src/main   ghc-options:       -O2 -Wall-  ghc-prof-options:  -fprof-auto   main-is:           Main.hs-  build-depends:     base-                   , fay-                   , data-default-                   , optparse-applicative >= 0.6     && < 0.8-                   , split+  build-depends:+      base+    , fay+    , mtl+    , optparse-applicative >= 0.11 && < 0.16+    , split+  other-modules:+    Paths_fay  executable fay-tests-  hs-source-dirs:    src/tests+  default-language:  Haskell2010                              ghc-options:       -O2 -Wall -threaded -with-rtsopts=-N-  ghc-prof-options:  -fprof-auto+  hs-source-dirs:    src/tests   main-is:           Tests.hs-  other-modules:     Test.CommandLine-                     Test.Compile-                     Test.Convert-                     Test.Util-  build-depends:     base-                   , fay-                   , HUnit                              < 1.3-                   , aeson-                   , attoparsec-                   , bytestring-                   , data-default-                   , directory-                   , filepath-                   , haskell-src-exts-                   , test-framework                     < 0.9-                   , test-framework-hunit               < 0.4-                   , test-framework-th                  < 0.3-                   , text-                   , utf8-string+  if flag(test)+    other-modules:+      Test.CommandLine+      Test.Compile+      Test.Convert+      Test.Desugar+      Test.Util+      Paths_fay+    build-depends:+        base+      , aeson+      , attoparsec+      , bytestring+      , containers+      , directory+      , fay+      , filepath+      , haskell-src-exts+      , random >= 1.0 && < 1.3+      , tasty >= 0.9 && < 1.5+      , tasty-hunit >= 0.8 && < 0.11+      , tasty-th == 0.1.*+      , text+      , utf8-string+  else+    buildable:         False
− js/runtime.js 
@@ -1,750 +0,0 @@-/*******************************************************************************- * Misc.- */--// Workaround for missing functionality in IE 8 and earlier.-if( Object.create === undefined ) {-  Object.create = function( o ) {-    function F(){}-    F.prototype = o;-    return new F();-  };-}--// Insert properties of b in place into a.-function Fay$$objConcat(a,b){-  for (var p in b) if (b.hasOwnProperty(p)){-    a[p] = b[p];-  }-  return a;-}--/*******************************************************************************- * Thunks.- */--// Force a thunk (if it is a thunk) until WHNF.-function Fay$$_(thunkish,nocache){-  while (thunkish instanceof Fay$$$) {-    thunkish = thunkish.force(nocache);-  }-  return thunkish;-}--// Apply a function to arguments (see method2 in Fay.hs).-function Fay$$__(){-  var f = arguments[0];-  for (var i = 1, len = arguments.length; i < len; i++) {-    f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]);-  }-  return f;-}--// Thunk object.-function Fay$$$(value){-  this.forced = false;-  this.value = value;-}--// Force the thunk.-Fay$$$.prototype.force = function(nocache) {-  return nocache ?-    this.value() :-    (this.forced ?-     this.value :-     (this.value = this.value(), this.forced = true, this.value));-};---function Fay$$seq(x) {-  return function(y) {-    Fay$$_(x,false);-    return y;-  }-}--function Fay$$seq$36$uncurried(x,y) {-  Fay$$_(x,false);-  return y;-}--/*******************************************************************************- * Monad.- */--function Fay$$Monad(value){-  this.value = value;-}--// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.-// >>-function Fay$$then(a){-  return function(b){-    return Fay$$bind(a)(function(_){-      return b;-    });-  };-}--// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.-// >>-function Fay$$then$36$uncurried(a,b){-  return Fay$$bind$36$uncurried(a,function(_){ return b; });-}--// >>=-// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.-function Fay$$bind(m){-  return function(f){-    return new Fay$$$(function(){-      var monad = Fay$$_(m,true);-      return Fay$$_(f)(monad.value);-    });-  };-}--// >>=-// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.-function Fay$$bind$36$uncurried(m,f){-  return new Fay$$$(function(){-    var monad = Fay$$_(m,true);-    return Fay$$_(f)(monad.value);-  });-}--// This is used directly from Fay, but can be rebound or shadowed.-function Fay$$$_return(a){-  return new Fay$$Monad(a);-}--// Allow the programmer to access thunk forcing directly.-function Fay$$force(thunk){-  return function(type){-    return new Fay$$$(function(){-      Fay$$_(thunk,type);-      return new Fay$$Monad(Fay$$unit);-    })-  }-}--// This is used directly from Fay, but can be rebound or shadowed.-function Fay$$return$36$uncurried(a){-  return new Fay$$Monad(a);-}--// Unit: ().-var Fay$$unit = null;--/*******************************************************************************- * Serialization.- * Fay <-> JS. Should be bijective.- */--// Serialize a Fay object to JS.-function Fay$$fayToJs(type,fayObj){-  var base = type[0];-  var args = type[1];-  var jsObj;-  if(base == "action") {-    // A nullary monadic action. Should become a nullary JS function.-    // Fay () -> function(){ return ... }-    return function(){-      return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);-    };--  }-  else if(base == "function") {-    // A proper function.-    return function(){-      var fayFunc = fayObj;-      var return_type = args[args.length-1];-      var len = args.length;-      // If some arguments.-      if (len > 1) {-        // Apply to all the arguments.-        fayFunc = Fay$$_(fayFunc,true);-        // TODO: Perhaps we should throw an error when JS-        // passes more arguments than Haskell accepts.--        // Unserialize the JS values to Fay for the Fay callback.-        if (args == "automatic_function")-        {-          for (var i = 0; i < arguments.length; i++) {-            fayFunc = Fay$$fayToJs(["automatic"], Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true));-          }-          return fayFunc;-        }--        for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-          fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);-        }-        // Finally, serialize the Fay return value back to JS.-        var return_base = return_type[0];-        var return_args = return_type[1];-        // If it's a monadic return value, get the value instead.-        if(return_base == "action") {-          return Fay$$fayToJs(return_args[0],fayFunc.value);-        }-        // Otherwise just serialize the value direct.-        else {-          return Fay$$fayToJs(return_type,fayFunc);-        }-      } else {-        throw new Error("Nullary function?");-      }-    };--  }-  else if(base == "string") {-    return Fay$$fayToJs_string(fayObj);-  }-  else if(base == "list") {-    // Serialize Fay list to JavaScript array.-    var arr = [];-    fayObj = Fay$$_(fayObj);-    while(fayObj instanceof Fay$$Cons) {-      arr.push(Fay$$fayToJs(args[0],fayObj.car));-      fayObj = Fay$$_(fayObj.cdr);-    }-    return arr;-  }-  else if(base == "tuple") {-    // Serialize Fay tuple to JavaScript array.-    var arr = [];-    fayObj = Fay$$_(fayObj);-    var i = 0;-    while(fayObj instanceof Fay$$Cons) {-      arr.push(Fay$$fayToJs(args[i++],fayObj.car));-      fayObj = Fay$$_(fayObj.cdr);-    }-    return arr;-  }-  else if(base == "defined") {-    fayObj = Fay$$_(fayObj);-    return fayObj instanceof Fay.FFI._Undefined-      ? undefined-      : Fay$$fayToJs(args[0],fayObj.slot1);-  }-  else if(base == "nullable") {-    fayObj = Fay$$_(fayObj);-    return fayObj instanceof Fay.FFI._Null-      ? null-      : Fay$$fayToJs(args[0],fayObj.slot1);-  }-  else if(base == "double" || base == "int" || base == "bool") {-    // Bools are unboxed.-    return Fay$$_(fayObj);-  }-  else if(base == "ptr" || base == "unknown")-    return fayObj;-  else if(base == "automatic" && fayObj instanceof Function) {-    return Fay$$fayToJs(["function", "automatic_function"], fayObj);-  }-  else if(base == "automatic" || base == "user") {-    fayObj = Fay$$_(fayObj);--    if(fayObj instanceof Fay$$Cons || fayObj === null){-      // Serialize Fay list to JavaScript array.-      var arr = [];-      while(fayObj instanceof Fay$$Cons) {-        arr.push(Fay$$fayToJs(["automatic"],fayObj.car));-        fayObj = Fay$$_(fayObj.cdr);-      }-      return arr;-    } else {-      var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];-      return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;-    }-  }--  throw new Error("Unhandled Fay->JS translation type: " + base);-}--// Stores the mappings from fay types to js objects.-// This will be populated by compiled modules.-var Fay$$fayToJsHash = {};--// Specialized serializer for string.-function Fay$$fayToJs_string(fayObj){-  // Serialize Fay string to JavaScript string.-  var str = "";-  fayObj = Fay$$_(fayObj);-  while(fayObj instanceof Fay$$Cons) {-    str += Fay$$_(fayObj.car);-    fayObj = Fay$$_(fayObj.cdr);-  }-  return str;-};-function Fay$$jsToFay_string(x){-  return Fay$$list(x)-};--// Special num/bool serializers.-function Fay$$jsToFay_int(x){return x;}-function Fay$$jsToFay_double(x){return x;}-function Fay$$jsToFay_bool(x){return x;}--function Fay$$fayToJs_int(x){return Fay$$_(x);}-function Fay$$fayToJs_double(x){return Fay$$_(x);}-function Fay$$fayToJs_bool(x){return Fay$$_(x);}--// Unserialize an object from JS to Fay.-function Fay$$jsToFay(type,jsObj){-  var base = type[0];-  var args = type[1];-  var fayObj;-  if(base == "action") {-    // Unserialize a "monadic" JavaScript return value into a monadic value.-    return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));-  }-  else if(base == "function") {-    // Unserialize a function from JavaScript to a function that Fay can call.-    // So-    //-    //    var f = function(x,y,z){ … }-    //-    // becomes something like:-    //-    //    function(x){-    //      return function(y){-    //        return function(z){-    //          return new Fay$$$(function(){-    //            return Fay$$jsToFay(f(Fay$$fayTojs(x),-    //                                  Fay$$fayTojs(y),-    //                                  Fay$$fayTojs(z))-    //    }}}}};-    var returnType = args[args.length-1];-    var funArgs = args.slice(0,-1);--    if (jsObj.length > 0) {-      var makePartial = function(args){-        return function(arg){-          var i = args.length;-          var fayArg = Fay$$fayToJs(funArgs[i],arg);-          var newArgs = args.concat([fayArg]);-          if(newArgs.length == funArgs.length) {-            return new Fay$$$(function(){-              return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));-            });-          } else {-            return makePartial(newArgs);-          }-        };-      };-      return makePartial([]);-    }-    else-      return function (arg) {-        return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));-      };-  }-  else if(base == "string") {-    // Unserialize a JS string into Fay list (String).-    // This is a special case, when String is explicit in the type signature,-    // with `Automatic' a string would not be decoded.-    return Fay$$list(jsObj);-  }-  else if(base == "list") {-    // Unserialize a JS array into a Fay list ([a]).-    var serializedList = [];-    for (var i = 0, len = jsObj.length; i < len; i++) {-      // Unserialize each JS value into a Fay value, too.-      serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));-    }-    // Pop it all in a Fay list.-    return Fay$$list(serializedList);-  }-  else if(base == "tuple") {-    // Unserialize a JS array into a Fay tuple ((a,b,c,...)).-    var serializedTuple = [];-    for (var i = 0, len = jsObj.length; i < len; i++) {-      // Unserialize each JS value into a Fay value, too.-      serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i]));-    }-    // Pop it all in a Fay list.-    return Fay$$list(serializedTuple);-  }-  else if(base == "defined") {-    return jsObj === undefined-      ? new Fay.FFI._Undefined()-      : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));-  }-  else if(base == "nullable") {-    return jsObj === null-      ? new Fay.FFI._Null()-      : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));-  }-  else if(base == "int") {-    // Int are unboxed, so there's no forcing to do.-    // But we can do validation that the int has no decimal places.-    // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"-    fayObj = Math.round(jsObj);-    if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";-    return fayObj;-  }-  else if (base == "double" ||-           base == "bool" ||-           base ==  "ptr" ||-           base ==  "unknown") {-    return jsObj;-  }-  else if(base == "automatic" && jsObj instanceof Function) {-    var type = [["automatic"]];-    for (var i = 0; i < jsObj.length; i++)-      type.push(["automatic"]);-    return Fay$$jsToFay(["function", type], jsObj);-  }-  else if(base == "automatic" || base == "user") {-    if (jsObj && jsObj['instance']) {-      var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];-      return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;-    }-    else if (jsObj instanceof Array) {-      var list = null;-      for (var i = jsObj.length - 1; i >= 0; i--) {-        list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);-      }-      return list;-    }-    else-      return jsObj;-  }--  throw new Error("Unhandled JS->Fay translation type: " + base);-}--// Stores the mappings from js objects to fay types.-// This will be populated by compiled modules.-var Fay$$jsToFayHash = {};--/*******************************************************************************- * Lists.- */--// Cons object.-function Fay$$Cons(car,cdr){-  this.car = car;-  this.cdr = cdr;-}--// Make a list.-function Fay$$list(xs){-  var out = null;-  for(var i=xs.length-1; i>=0;i--)-    out = new Fay$$Cons(xs[i],out);-  return out;-}--// Built-in list cons.-function Fay$$cons(x){-  return function(y){-    return new Fay$$Cons(x,y);-  };-}--// List index.-// `list' is already forced by the time it's passed to this function.-// `list' cannot be null and `index' cannot be out of bounds.-function Fay$$index(index,list){-  for(var i = 0; i < index; i++) {-    list = Fay$$_(list.cdr);-  }-  return list.car;-}--// List length.-// `list' is already forced by the time it's passed to this function.-function Fay$$listLen(list,max){-  for(var i = 0; list !== null && i < max + 1; i++) {-    list = Fay$$_(list.cdr);-  }-  return i == max;-}--/*******************************************************************************- * Numbers.- */--// Built-in *.-function Fay$$mult(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) * Fay$$_(y);-    });-  };-}--function Fay$$mult$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) * Fay$$_(y);-  });--}--// Built-in +.-function Fay$$add(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) + Fay$$_(y);-    });-  };-}--// Built-in +.-function Fay$$add$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) + Fay$$_(y);-  });--}--// Built-in -.-function Fay$$sub(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) - Fay$$_(y);-    });-  };-}-// Built-in -.-function Fay$$sub$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) - Fay$$_(y);-  });--}--// Built-in /.-function Fay$$divi(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) / Fay$$_(y);-    });-  };-}--// Built-in /.-function Fay$$divi$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) / Fay$$_(y);-  });--}--/*******************************************************************************- * Booleans.- */--// Are two values equal?-function Fay$$equal(lit1, lit2) {-  // Simple case-  lit1 = Fay$$_(lit1);-  lit2 = Fay$$_(lit2);-  if (lit1 === lit2) {-    return true;-  }-  // General case-  if (lit1 instanceof Array) {-    if (lit1.length != lit2.length) return false;-    for (var len = lit1.length, i = 0; i < len; i++) {-      if (!Fay$$equal(lit1[i], lit2[i])) return false;-    }-    return true;-  } else if (lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons) {-    do {-      if (!Fay$$equal(lit1.car,lit2.car))-        return false;-      lit1 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr);-      if (lit1 === null || lit2 === null)-        return lit1 === lit2;-    } while (true);-  } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&-             lit1.instance === lit2.instance) {-    for(var x in lit1) {-      if(!Fay$$equal(lit1[x],lit2[x]))-        return false;-    }-    return true;-  } else {-    return false;-  }-}--// Built-in ==.-function Fay$$eq(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$equal(x,y);-    });-  };-}--function Fay$$eq$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$equal(x,y);-  });--}--// Built-in /=.-function Fay$$neq(x){-  return function(y){-    return new Fay$$$(function(){-      return !(Fay$$equal(x,y));-    });-  };-}--// Built-in /=.-function Fay$$neq$36$uncurried(x,y){--  return new Fay$$$(function(){-    return !(Fay$$equal(x,y));-  });--}--// Built-in >.-function Fay$$gt(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) > Fay$$_(y);-    });-  };-}--// Built-in >.-function Fay$$gt$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) > Fay$$_(y);-  });--}--// Built-in <.-function Fay$$lt(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) < Fay$$_(y);-    });-  };-}---// Built-in <.-function Fay$$lt$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) < Fay$$_(y);-  });--}---// Built-in >=.-function Fay$$gte(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) >= Fay$$_(y);-    });-  };-}--// Built-in >=.-function Fay$$gte$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) >= Fay$$_(y);-  });--}--// Built-in <=.-function Fay$$lte(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) <= Fay$$_(y);-    });-  };-}--// Built-in <=.-function Fay$$lte$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) <= Fay$$_(y);-  });--}--// Built-in &&.-function Fay$$and(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) && Fay$$_(y);-    });-  };-}--// Built-in &&.-function Fay$$and$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) && Fay$$_(y);-  });-  ;-}--// Built-in ||.-function Fay$$or(x){-  return function(y){-    return new Fay$$$(function(){-      return Fay$$_(x) || Fay$$_(y);-    });-  };-}--// Built-in ||.-function Fay$$or$36$uncurried(x,y){--  return new Fay$$$(function(){-    return Fay$$_(x) || Fay$$_(y);-  });--}--/*******************************************************************************- * Mutable references.- */--// Make a new mutable reference.-function Fay$$Ref(x){-  this.value = x;-}--// Write to the ref.-function Fay$$writeRef(ref,x){-  ref.value = x;-}--// Get the value from the ref.-function Fay$$readRef(ref,x){-  return ref.value;-}--/*******************************************************************************- * Dates.- */-function Fay$$date(str){-  return window.Date.parse(str);-}--/*******************************************************************************- * Application code.- */
src/Fay.hs view
@@ -1,48 +1,51 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE ViewPatterns          #-}  -- | Main library entry point.  module Fay-  (module Fay.Types+  (module Fay.Config+  ,CompileError (..)+  ,CompileState (..)+  ,CompileResult (..)   ,compileFile   ,compileFileWithState+  ,compileFileWithResult   ,compileFromTo   ,compileFromToAndGenerateHtml   ,toJsName+  ,toTsName   ,showCompileError-  ,getConfigRuntime-  ,getRuntime+  ,readConfigRuntime   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler import           Fay.Compiler.Misc                      (ioWarn, printSrcSpanInfo) import           Fay.Compiler.Packages import           Fay.Compiler.Typecheck+import           Fay.Config+import           Fay.Runtime import qualified Fay.Exts                               as F import           Fay.Types -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        (prettyPrint)+import           Language.Haskell.Exts.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 -- if nothing given, stdout.-compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO ()+compileFromTo :: Config -> FilePath -> Maybe FilePath -> IO () compileFromTo cfg filein fileout =   if configTypecheckOnly cfg   then do@@ -54,15 +57,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,[Mapping]))+-- | Compile the given file and write to the output, also generates HTML and sourcemap files if configured.+compileFromToAndGenerateHtml :: Config -> FilePath -> FilePath -> IO (Either CompileError String) compileFromToAndGenerateHtml config filein fileout = do-  result <- compileFile config { configFilePath = Just filein } filein-  case result of-    Right (out,mappings) -> do+  mres <- compileFileWithResult config { configFilePath = Just filein } filein+  case mres of+    Right res -> do       when (configHtmlWrapper config) $         writeFile (replaceExtension fileout "html") $ unlines [             "<!doctype html>"@@ -71,22 +74,23 @@           ,"    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"           , unlines . map (("    "++) . makeScriptTagSrc) $ configHtmlJSLibs config           , "    " ++ makeScriptTagSrc relativeJsPath-          , "    </script>"           , "  </head>"           , "  <body>"           , "  </body>"           , "</html>"] -      when (configSourceMap config) $ do-        L.writeFile (replaceExtension fileout "map") $-          encode $-            generate SourceMapping-              { smFile = fileout-              , smSourceRoot = Nothing-              , smMappings = mappings-              }+      case (configSourceMap config, resSourceMappings res) of+        (True, Just mappings) ->+          L.writeFile (replaceExtension fileout "map") $+            encode $+              generate SourceMapping+                { smFile       = fileout+                , smSourceRoot = Nothing+                , smMappings   = mappings+                }+        _ -> return () -      return (Right (if configSourceMap config then sourceMapHeader ++ out else out,mappings))+      return $ Right (if configSourceMap config then sourceMapHeader ++ resOutput res else resOutput res)             where relativeJsPath = makeRelative (dropFileName fileout) fileout                   makeScriptTagSrc :: FilePath -> String                   makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"@@ -94,46 +98,60 @@     Left err -> return (Left err)  -- | Compile the given file.-compileFile :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping]))-compileFile config filein = fmap (\(src,maps,_) -> (src,maps)) <$> compileFileWithState config filein+compileFile :: Config -> FilePath -> IO (Either CompileError String)+compileFile config filein = fmap (\(src,_,_) -> src) <$> compileFileWithState config filein --- | Compile a file returning the state.-compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping],CompileState))+-- | Compile a file returning additional generated metadata.+compileFileWithResult :: Config -> FilePath -> IO (Either CompileError CompileResult)+compileFileWithResult config filein = do+  res <- compileFileWithState config filein+  return $ do+    (s,m,st) <- res+    return CompileResult+      { resOutput         = s+      , resImported       = map (first F.moduleNameString) $ stateImported st+      , resSourceMappings = m+      }++-- | Compile a file returning the resulting internal state of the compiler.+-- Don't use this directly, it's only exposed for the test suite.+compileFileWithState :: Config -> FilePath -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileFileWithState config filein = do-  runtime <- getConfigRuntime config+  raw <- readConfigRuntime config   hscode <- readFile filein-  raw <- readFile runtime   config' <- resolvePackages config   compileToModule filein config' raw (compileToplevelModule filein) hscode  -- | Compile the given module to a runnable module. compileToModule :: FilePath-                -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String-                -> IO (Either CompileError (String,[Mapping],CompileState))+                -> 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 (PrintState{..},state,_) ->-      Right ( generateWrapped (concat $ reverse psOutput)-                              (stateModuleName state)-            , psMappings+    Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) ->+      Right ( pwOutputString 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);"-                       ]-          else ""-      ]-    printState = def { psPretty = configPrettyPrint config-                     , psLine = length (lines raw) + 3-                     }+      where+        pw = execPrinter (runtime <> aliases <> printer <> main) pr+        runtime = if configExportRuntime config then write raw else mempty+        aliases = if configPrettyThunks config+                  then write . unlines $ [ "var $ = Fay$$$;"+                                         , "var _ = Fay$$_;"+                                         , "var __ = Fay$$__;"+                                         ]+                  else mempty+        main = if not (configLibrary config)+               then write $ "Fay$$_(" ++ modulename ++ ".main, true);\n"+               else mempty+        pr = defaultPrintReader+          { prPrettyThunks    = configPrettyThunks config+          , prPretty          = configPrettyPrint config+          , prPrettyOperators = configPrettyOperators config+          }  -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String@@ -141,6 +159,12 @@   ('s':'h':'.': (reverse -> file)) -> file ++ ".js"   _ -> x +-- | Convert a Haskell filename to a TypeScript filename.+toTsName :: String -> String+toTsName x = case reverse x of+  ('s':'h':'.': (reverse -> file)) -> file ++ ".ts"+  _ -> x+ -- | Print a compile error for human consumption. showCompileError :: CompileError -> String showCompileError e = case e of@@ -163,13 +187,13 @@     err ++ " at line: " ++ show (srcLine pos) ++ " column:" ++     "\n" ++ show (srcColumn pos)   ShouldBeDesugared s              -> "Expected this to be desugared (this is a bug): " ++ s-  UnableResolveQualified qname     -> "unable to resolve qualified names " ++ prettyPrint qname+  UnableResolveQualified qname     -> "unable to resolve qualified names (this might be a bug):" ++ prettyPrint qname   UnsupportedDeclaration d         -> "unsupported declaration: " ++ prettyPrint d   UnsupportedEnum{}                -> "only Int is allowed in enum expressions"   UnsupportedExportSpec es         -> "unsupported export specification: " ++ prettyPrint es   UnsupportedExpression expr       -> "unsupported expression syntax: " ++ prettyPrint expr   UnsupportedFieldPattern p        -> "unsupported field pattern: " ++ prettyPrint p-  UnsupportedImport i              -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i+  UnsupportedImport i              -> "unsupported import syntax: " ++ prettyPrint i   UnsupportedLet                   -> "let not supported here"   UnsupportedLetBinding d          -> "unsupported let binding: " ++ prettyPrint d   UnsupportedLiteral lit           -> "unsupported literal syntax: " ++ prettyPrint lit@@ -183,9 +207,8 @@  -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists.-getConfigRuntime :: CompileConfig -> IO String-getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg---- | Get the default JS runtime source.-getRuntime :: IO String-getRuntime = getDataFileName "js/runtime.js"+readConfigRuntime :: Config -> IO String+readConfigRuntime cfg =+  case configRuntimePath cfg of+    Just path -> readFile path+    Nothing -> return $ getRuntimeSource cfg
src/Fay/Compiler.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-}@@ -19,7 +20,8 @@   ,parseFay)   where -import           Fay.Compiler.Config+import           Fay.Compiler.Prelude+ import           Fay.Compiler.Decl import           Fay.Compiler.Defaults import           Fay.Compiler.Desugar@@ -29,26 +31,23 @@ import           Fay.Compiler.InitialPass        (initialPass) import           Fay.Compiler.Misc import           Fay.Compiler.Optimizer+import           Fay.Compiler.Parse import           Fay.Compiler.PrimOp             (findPrimOp) import           Fay.Compiler.QName import           Fay.Compiler.State import           Fay.Compiler.Typecheck-import           Fay.Control.Monad.IO+import           Fay.Config import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS-import           Control.Monad.State+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (gets, modify) -import           Data.Maybe import qualified Data.Set                        as S-import           Language.Haskell.Exts.Annotated hiding (name)-import           Language.Haskell.Names-import           Prelude                         hiding (mod)+import           Language.Haskell.Exts hiding (name)+import           Language.Haskell.Names          (annotateModule)  -------------------------------------------------------------------------------- -- Top level entry points@@ -57,17 +56,16 @@ compileViaStr    :: FilePath-  -> CompileConfig-  -> PrintState+  -> Config   -> (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 (mconcat . map printJS) . with)                           (parseFay filepath from))  -- | Compile the top-level Fay module.@@ -95,18 +93,23 @@ -- | Compile given the location and source string. compileFileWithSource :: FilePath -> String -> Compile ([JsStmt], [JsStmt]) compileFileWithSource filepath contents = do-  ((hstmts,fstmts),st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource contents+  exportStdlib <- config configExportStdlib+  ((hstmts,fstmts),st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource desugar contents   modify $ \s -> s { stateImported      = stateImported      st                    , stateJsModulePaths = stateJsModulePaths st                    }-  hstmts' <- maybeOptimize $ hstmts ++ writerCons wr ++ makeTranscoding wr+  hstmts' <- maybeOptimize $ hstmts ++ writerCons wr ++ makeTranscoding exportStdlib (stateModuleName st) wr   fstmts' <- maybeOptimize fstmts   return (hstmts', fstmts')   where-    makeTranscoding :: CompileWriter -> [JsStmt]-    makeTranscoding CompileWriter{..} =-      let fay2js = if null writerFayToJs then [] else fayToJsHash writerFayToJs-          js2fay = if null writerJsToFay then [] else jsToFayHash writerJsToFay+    makeTranscoding :: Bool -> ModuleName a -> CompileWriter -> [JsStmt]+    makeTranscoding exportStdlib moduleName CompileWriter{..} =+      let fay2js = if null writerFayToJs || (anStdlibModule moduleName && not exportStdlib)+                     then []+                     else fayToJsHash writerFayToJs+          js2fay = if null writerJsToFay || (anStdlibModule moduleName && not exportStdlib)+                     then []+                     else jsToFayHash writerJsToFay       in fay2js ++ js2fay     maybeOptimize :: [JsStmt] -> Compile [JsStmt]     maybeOptimize stmts = do@@ -117,62 +120,52 @@  -- | Compile a parse HSE module. 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 defaultExtensions $ mod'-      let modName = unAnn $ F.moduleName mod-      modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas-                       }-      current <- compileDecls True decls+compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do+  ~mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod'+  let modName = unAnn $ F.moduleName mod+  modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas+                   }+  current <- compileDecls True decls -      exportStdlib     <- config configExportStdlib-      exportStdlibOnly <- config configExportStdlibOnly-      modulePaths      <- createModulePath modName-      extExports       <- generateExports-      strictExports    <- generateStrictExports-      let hstmts = hstmts0 ++ modulePaths ++ current ++ extExports-          fstmts = fstmts0 ++ strictExports-      return $ if exportStdlibOnly-        then if anStdlibModule modName-                then (hstmts, fstmts)-                else ([], [])-        else if not exportStdlib && anStdlibModule modName-                then ([], [])-                else (hstmts, fstmts)+  exportStdlib     <- config configExportStdlib+  exportStdlibOnly <- config configExportStdlibOnly+  modulePaths      <- createModulePath modName+  extExports       <- generateExports+  strictExports    <- generateStrictExports+  let hstmts = hstmts0 ++ modulePaths ++ current ++ extExports+      fstmts = fstmts0 ++ strictExports+  return $ if exportStdlibOnly+    then if anStdlibModule modName+            then (hstmts, fstmts)+            else ([], [])+    else if not exportStdlib && anStdlibModule modName+            then ([], [])+            else (hstmts, fstmts) compileModuleFromAST _ mod = throwError $ UnsupportedModuleSyntax "compileModuleFromAST" mod   -------------------------------------------------------------------------------- -- Misc compilation --- | Check if the given language pragmas are all present.-hasLanguagePragmas :: [String] -> [F.ModulePragma] -> Bool-hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas-  where-    flattenPragmas :: [F.ModulePragma] -> [String]-    flattenPragmas ps = concat $ map pragmaName ps-    pragmaName (LanguagePragma _ q) = map unname q-    pragmaName _ = []- -- | For a module A.B, generate -- | var A = {}; -- | A.B = {}; createModulePath :: ModuleName a -> Compile [JsStmt] createModulePath (unAnn -> m) = do   cfg <- config id-  reg <- liftM concat . mapM modPath . mkModulePaths $ m+  let isTs = configTypeScript cfg+  reg <- fmap concat . mapM (modPath isTs) . mkModulePaths $ m   strict <-     if shouldExportStrictWrapper m cfg-      then liftM concat . mapM modPath . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m+      then fmap concat . mapM (modPath isTs) . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m        else return []   return $ reg ++ strict   where-    modPath :: ModulePath -> Compile [JsStmt]-    modPath mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of-     [n] -> [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]+    modPath :: Bool -> ModulePath -> Compile [JsStmt]+    modPath isTs mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of+     [n] -> if isTs+              then [JsMapVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]+              else [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])]      _   -> [JsSetModule mp (JsObj [])]      whenImportNotGenerated :: ModulePath -> (ModulePath -> [JsStmt]) -> Compile [JsStmt]@@ -221,4 +214,4 @@ -- | Is the module a standard module, i.e., one that we'd rather not -- output code for if we're compiling separate files. anStdlibModule :: ModuleName a -> Bool-anStdlibModule (ModuleName _ name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data"]+anStdlibModule (ModuleName _ name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data","Data.Ratio","Debug.Trace","Data.Char"]
− src/Fay/Compiler/Config.hs 
@@ -1,70 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}---- | Configuration functions.--module Fay.Compiler.Config where--import           Fay.Types--import           Data.Default-import           Data.Maybe-import           Language.Haskell.Exts.Annotated (ModuleName (..))---- | Get all include directories without the package mapping.-configDirectoryIncludePaths :: CompileConfig -> [FilePath]-configDirectoryIncludePaths = map snd . configDirectoryIncludes---- | Get all include directories not included through packages.-nonPackageConfigDirectoryIncludePaths :: CompileConfig -> [FilePath]-nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . configDirectoryIncludes---- | Add a mapping from (maybe) a package to a source directory-addConfigDirectoryInclude :: Maybe String -> FilePath -> CompileConfig -> CompileConfig-addConfigDirectoryInclude pkg fp cfg = cfg { configDirectoryIncludes = (pkg, fp) : configDirectoryIncludes cfg }---- | Add several include directories.-addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> CompileConfig -> CompileConfig-addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps---- | Add several include directories without package references.-addConfigDirectoryIncludePaths :: [FilePath] -> CompileConfig -> CompileConfig-addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps---- | Add a package to compilation-addConfigPackage :: String -> CompileConfig -> CompileConfig-addConfigPackage pkg cfg = cfg { configPackages = pkg : configPackages cfg }---- | Add several packages to compilation-addConfigPackages :: [String] -> CompileConfig -> CompileConfig-addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps--shouldExportStrictWrapper :: ModuleName a -> CompileConfig -> Bool-shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs---- | Default configuration.-instance Default CompileConfig where-  def = addConfigPackage "fay-base"-    CompileConfig-    { configOptimize           = False-    , configFlattenApps        = False-    , configExportRuntime      = True-    , configExportStdlib       = True-    , configExportStdlibOnly   = False-    , configDirectoryIncludes  = []-    , configPrettyPrint        = False-    , configHtmlWrapper        = False-    , configHtmlJSLibs         = []-    , configLibrary            = False-    , configWarn               = True-    , configFilePath           = Nothing-    , configTypecheck          = True-    , configWall               = False-    , configGClosure           = False-    , configPackageConf        = Nothing-    , configPackages           = []-    , configBasePath           = Nothing-    , configStrict             = []-    , configTypecheckOnly      = False-    , configRuntimePath        = Nothing-    , configSourceMap          = False-    }
src/Fay/Compiler/Decl.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE ViewPatterns          #-} @@ -8,45 +8,39 @@  module Fay.Compiler.Decl where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Exp import           Fay.Compiler.FFI import           Fay.Compiler.GADT import           Fay.Compiler.Misc import           Fay.Compiler.Pattern import           Fay.Compiler.State-import           Fay.Data.List.Extra import           Fay.Exts                        (convertFieldDecl, fieldDeclNames) import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS-import           Language.Haskell.Exts.Annotated+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (gets, modify)+import           Language.Haskell.Exts hiding (binds, loc, name) +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}+ -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]-compileDecls toplevel decls = case decls of-  [] -> return []-  (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind)-                                                    (compileDecls toplevel decls)-  (decl:decls) -> appendM (compileDecl toplevel decl)-                          (compileDecls toplevel decls)--  where-    appendM m n = do x <- m-                     xs <- n-                     return (x ++ xs)+compileDecls toplevel = fmap concat . mapM (compileDecl toplevel)  -- | Compile a declaration. compileDecl :: Bool -> S.Decl -> Compile [JsStmt] compileDecl toplevel decl = case decl of-  pat@PatBind{} -> compilePatBind toplevel Nothing pat+  pat@PatBind{} -> compilePatBind toplevel pat   FunBind _ matches -> compileFunCase toplevel matches   DataDecl _ (DataType _ ) _ (mkTyVars -> tyvars) constructors _ -> compileDataDecl toplevel tyvars constructors   GDataDecl _ (DataType _) _l (mkTyVars -> tyvars) _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls)-  DataDecl _ (NewType _) _ _ _ _ -> return []+  DataDecl _ (NewType _) _  head' constructors _ ->+    ifOptimizeNewtypes (return [])+                       (compileDataDecl toplevel (mkTyVars head') constructors)   -- Just ignore type aliases and signatures.   TypeDecl {} -> return []   TypeSig  {} -> return []@@ -68,23 +62,34 @@   mkTyVars :: S.DeclHead -> [S.TyVarBind]-mkTyVars (DHead _ _ binds) = binds-mkTyVars (DHInfix _ t1 _ t2) = [t1, t2]-mkTyVars (DHParen _ dh) = mkTyVars dh+mkTyVars x = go x []+  where+    go (DHead _ _) = id+    go (DHInfix _ r _) = (r:)+    go (DHParen _ dh) = go dh+    go (DHApp _ dh r) = go dh . (r:)  -- | Compile a top-level pattern bind.-compilePatBind :: Bool -> Maybe S.Type -> S.Decl -> Compile [JsStmt]-compilePatBind toplevel sig patDecl = case patDecl of-  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 patDecl-      _ -> compileUnguardedRhs toplevel srcloc ident rhs+compilePatBind :: Bool -> S.Decl -> Compile [JsStmt]+compilePatBind toplevel patDecl = case patDecl of+  PatBind _ (PVar _ name')+    (UnGuardedRhs _+      (ExpTypeSig _+        (App _ (Var _ (UnQual _ (Ident _ "ffi")))+                (Lit _ (String _ formatstr _)))+      sig)) Nothing ->+    let name = unAnn name'+        loc = S.srcSpanInfo $ ann name'+    in do+      fun <- compileFFIExp loc (Just name) formatstr sig+      stmt <- bindToplevel toplevel (Just (srcInfoSpan loc)) name fun+      return [stmt]+  PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) Nothing ->+      compileUnguardedRhs toplevel srcloc ident rhs   -- TODO: Generalize to all patterns-  PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) ->+  PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) (Just bdecls) ->     compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs)-  PatBind _ pat Nothing (UnGuardedRhs _ rhs) _bdecls -> case pat of+  PatBind _ pat (UnGuardedRhs _ rhs) _bdecls -> case pat of     PList {} -> compilePatBind' pat rhs     PTuple{} -> compilePatBind' pat rhs     PApp  {} -> compilePatBind' pat rhs@@ -95,10 +100,22 @@     compilePatBind' pat rhs = do       exp <- compileExp rhs       name <- withScopedTmpJsName return-      [JsIf t b1 []] <- compilePat (JsName name) pat []-      let err = [throw ("Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])]-      return [JsVar name exp, JsIf t b1 err]+      m <- compilePat (JsName name) pat []+      m2 <- interleavePatternMatchFailures m pat m+      return (JsVar name exp : m2) +    interleavePatternMatchFailures :: [JsStmt] -> S.Pat -> [JsStmt] -> Compile [JsStmt]+    interleavePatternMatchFailures original pat = walk+      where+        walk m = case m of+          [JsIf t b1 []] -> do+            b2 <- walk b1+            return [JsIf t b2 err]+          [JsVar n exp2] -> return [JsVar n exp2]+          stmt:stmts -> (stmt:) <$> walk stmts+          [] -> error $ "Fay bug! Can't compile pat bind for pattern: " ++ show original+        err = [throw ("Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])]+ -- | Compile a normal simple pattern binding. compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt] compileUnguardedRhs toplevel srcloc ident rhs = do@@ -146,7 +163,7 @@         JsSetConstructor qname $           JsFun (Just $ JsConstructor qname)                 fields-                (for fields $ \field -> JsSetProp JsThis field (JsName field))+                (flip fmap fields $ \field -> JsSetProp JsThis field (JsName field))                 Nothing      -- Creates a function to initialize the record by regular application@@ -191,18 +208,23 @@                        (Just (srcInfoSpan (S.srcSpanInfo srcloc)))                        name                        (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner))-                              (stmtsThunk (concat pats ++ basecase))+                              (stmtsThunk $ deleteAfterReturn (concat pats ++ basecase))                               args)   return [bind]   where+    deleteAfterReturn :: [JsStmt] -> [JsStmt]+    deleteAfterReturn [] = []+    deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+    deleteAfterReturn (x:xs) = x:deleteAfterReturn xs+     args = zipWith const uniqueNames argslen      isWildCardMatch (Match _ _ pats          _ _) = all isWildCardPat pats     isWildCardMatch (InfixMatch _ pat _ pats _ _) = all isWildCardPat (pat:pats)      compileCase :: S.Match -> Compile [JsStmt]-    compileCase (InfixMatch l pat name pats rhs binds) =-      compileCase $ Match l name (pat:pats) rhs binds+    compileCase (InfixMatch l pat nm pats rhs binds) =+      compileCase $ Match l nm (pat:pats) rhs binds     compileCase match@(Match _ _ pats rhs _) = do       whereDecls' <- whereDecls match       rhsform <- compileRhs rhs
src/Fay/Compiler/Defaults.hs view
@@ -4,21 +4,21 @@  module Fay.Compiler.Defaults where -import           Fay.Compiler.Config-import           Fay.Compiler.Decl   (compileDecls)-import           Fay.Compiler.Exp    (compileLit)+import           Fay.Compiler.Decl (compileDecls)+import           Fay.Compiler.Exp  (compileLit)+import           Fay.Config import           Fay.Types import           Paths_fay -import           Data.Map            as M-import           Data.Set            as S+import           Data.Map          as M+import           Data.Set          as S  -- | The data-files source directory. faySourceDir :: IO FilePath faySourceDir = getDataFileName "src/"  -- | The default compiler reader value.-defaultCompileReader :: CompileConfig -> IO CompileReader+defaultCompileReader :: Config -> IO CompileReader defaultCompileReader config = do   srcdir <- faySourceDir   return CompileReader
src/Fay/Compiler/Desugar.hs view
@@ -1,70 +1,59 @@-{-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}+-- | Desugars a reasonable amount of syntax to reduce duplication in code generation.+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE MonoLocalBinds        #-}  module Fay.Compiler.Desugar-  (desugar+  ( desugar+  , desugar'+  , desugarExpParen+  , desugarPatParen   ) where +import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar.Name+import           Fay.Compiler.Desugar.Types+import           Fay.Compiler.Misc               (ffiExp, hasLanguagePragma)+import           Fay.Compiler.QName              (unQual, unname) import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types                       (CompileError (..)) -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.Reader-import           Data.Data                       (Data)+import           Control.Monad.Except            (throwError)+import           Control.Monad.Reader            (asks) import qualified Data.Generics.Uniplate.Data     as U-import           Data.Maybe-import           Data.Typeable                   (Typeable)-import           Language.Haskell.Exts.Annotated hiding (binds, loc)-import           Prelude                         hiding (exp)---- Types--data DesugarReader = DesugarReader { readerNameDepth :: Int }--newtype Desugar a = Desugar-  { unDesugar :: (ReaderT DesugarReader-                       (ErrorT CompileError IO))-                       a-  } deriving ( MonadReader DesugarReader-             , MonadError CompileError-             , MonadIO-             , Monad-             , Functor-             , Applicative-             )--runDesugar :: Desugar a -> IO (Either CompileError a)-runDesugar m = runErrorT (runReaderT (unDesugar m) (DesugarReader 0))---- | Generate a temporary, SCOPED name for testing conditions and--- such. We don't have name tracking yet, so instead we use this.-withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar a) -> Desugar a-withScopedTmpName l f = do-  n <- asks readerNameDepth-  local (\r -> DesugarReader $ readerNameDepth r + 1) $-   f $ Ident l $ "$gen" ++ show n--+import           Language.Haskell.Exts hiding (binds, loc, name)  -- | Top level, desugar a whole module possibly returning errors-desugar :: (Data l, Typeable l) => Module l -> IO (Either CompileError (Module l))-desugar md = runDesugar $+desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l))+desugar = desugar' "$gen"++-- | Desugar with the option to specify a prefix for generated names.+-- Useful if you want to provide valid haskell names that HSE can print.+desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l))+desugar' prefix emptyAnnotation md = runDesugar prefix emptyAnnotation $       checkEnum md   >>  desugarSection md   >>= desugarListComp-  >>= return . desugarTupleCon+  >>= desugarTupleCon   >>= return . desugarPatParen   >>= return . desugarFieldPun   >>= return . desugarPatFieldPun   >>= desugarDo   >>= desugarTupleSection---- | Desugaring+  >>= desugarImplicitPrelude+  >>= desugarFFITypeSigs+  >>= desugarLCase+  >>= return . desugarMultiIf+  >>= return . desugarInfixOp+  >>= return . desugarInfixPat+  >>= return . desugarExpParen+{-# ANN desugar' "HLint: ignore Use <$>" #-} -desugarSection :: (Data l, Typeable l) => Module l -> Desugar (Module l)+-- | (a `f`) => \b -> a `f` b+--   (`f` b) => \a -> a `f` b+desugarSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarSection = transformBiM $ \ex -> case ex of   LeftSection  l e q -> withScopedTmpName l $ \tmp ->       return $ Lambda l [PVar l tmp] (InfixApp l e q (Var l (UnQual l tmp)))@@ -72,13 +61,13 @@       return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)   _ -> return ex -desugarDo :: (Data l, Typeable l) => Module l -> Desugar (Module l)+-- | Convert do notation into binds and thens.+desugarDo :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarDo = transformBiM $ \ex -> case ex of   Do _ stmts -> maybe (throwError EmptyDoBlock) return $ foldl desugarStmt' Nothing (reverse stmts)   _ -> return ex --- | Convert do notation into binds and thens.-desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l)+desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l) desugarStmt' inner stmt =   maybe initStmt subsequentStmt inner   where@@ -101,39 +90,55 @@       Just $ InfixApp s                       exp                       (QVarOp s $ UnQual s $ Symbol s ">>=")-                      (Lambda s [pat] (inner'))+                      (Lambda s [pat] inner')  -- | (,)  => \x y   -> (x,y) --   (,,) => \x y z -> (x,y,z) -- etc-desugarTupleCon :: (Data l, Typeable l) => Module l -> Module l-desugarTupleCon = transformBi $ \ex -> case ex of-  Var _ (Special _ t@TupleCon{}) -> fromTupleCon ex t-  Con _ (Special _ t@TupleCon{}) -> fromTupleCon ex t-  _ -> ex+desugarTupleCon :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarTupleCon md = do+  prefix <- asks readerTmpNamePrefix+  return $ flip transformBi md $ \ex -> case ex of+    Var _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t+    Con _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t+    _ -> ex   where-    fromTupleCon :: Exp l -> SpecialCon l -> Exp l-    fromTupleCon e s = fromMaybe e $ case s of+    fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l+    fromTupleCon prefix e s = fromMaybe e $ case s of       TupleCon l b n -> Just $ Lambda l params body         where           -- It doesn't matter if these variable names shadow anything since           -- this lambda won't have inner scopes.-          names  = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..]+          names  = take n $ unscopedTmpNames l prefix           params = PVar l <$> names           body   = Tuple l b (Var l . UnQual l <$> names)       _ -> Nothing -desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar (Module l)-desugarTupleSection = transformBiM $ \ex -> case ex of-  TupleSection l _ mes -> do-    (names, lst) <- genSlotNames l mes (varNames l)-    return $ Lambda l (map (PVar l) names) (Tuple l Unboxed lst)+-- | \case { ... } => \foo -> case foo of { ... }+desugarLCase :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarLCase = transformBiM $ \ex -> case ex of+  LCase l alts -> withScopedTmpName l $ \n -> return $ Lambda l [PVar l n] (Case l (Var l (UnQual l n)) alts)   _ -> return ex++-- | if | p -> x | q -> y => case () of _ | p -> x | q -> y+desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l+desugarMultiIf = transformBi $ \ex -> case ex of+  MultiIf l alts -> Case l (Con l (Special l (UnitCon l)))+                           [Alt l (PWildCard l) (GuardedRhss l alts) Nothing]+  _ -> ex++-- | (a,) => \b -> (a,b)+desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarTupleSection md = do+  prefix <- asks readerTmpNamePrefix+  flip transformBiM md $ \ex -> case ex of+    TupleSection l _ mes -> do+      (names, lst) <- genSlotNames l mes (unscopedTmpNames l prefix)+      return $ Lambda l (map (PVar l) names) (Tuple l Boxed lst)+    _ -> return ex   where-    varNames :: l -> [Name l]-    varNames l = map (\i -> Ident l ("$gen_" ++ show i)) [0::Int ..] -    genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar ([Name l], [Exp l])+    genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l])     genSlotNames _ [] _ = return ([], [])     genSlotNames l (Nothing : rest) ns = do       -- it's safe to use head/tail here because ns is an infinite list@@ -149,19 +154,20 @@   PParen _ p -> p   _ -> pt +-- | {a} => {a=a} for R{a} expressions desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarFieldPun = transformBi $ \f -> case f of-  FieldPun l n -> let dn = UnQual l n in FieldUpdate l dn (Var l dn)+  FieldPun l n -> FieldUpdate l n (Var l n)   _ -> f +-- | {a} => {a=a} for R{a} patterns desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarPatFieldPun = transformBi $ \pf -> case pf of-  -- {a} => {a=a} for R{a}-  PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n)+  PFieldPun l n -> PFieldPat l n (PVar l (unQual n))   _             -> pf  -- | Desugar list comprehensions.-desugarListComp :: (Data l, Typeable l) => Module l -> Desugar (Module l)+desugarListComp :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarListComp = transformBiM $ \ex -> case ex of     ListComp l exp stmts -> desugarListComp' l exp stmts     _ -> return ex@@ -187,7 +193,7 @@ -- syntax to GHC.Base.Enum instead of using our Enum class so we check -- for obviously incorrect usages and throw an error on them. This can -- only checks literals, but it helps a bit.-checkEnum :: (Data l, Typeable l) => Module l -> Desugar ()+checkEnum :: (Data l, Typeable l) => Module l -> Desugar l () checkEnum = mapM_ f . universeBi   where     f ex = case ex of@@ -197,8 +203,8 @@       e@(EnumFromThenTo _ e1 e2 e3) -> checkIntOrUnknown e [e1,e2,e3]       _ -> return () -    checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar ()-    checkIntOrUnknown exp es = when (not $ any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp)+    checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l ()+    checkIntOrUnknown exp es = unless (any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp)     isIntOrUnknown :: Exp l -> Bool     isIntOrUnknown e = case e of       Con            {} -> False@@ -211,6 +217,138 @@       EnumFromThen   {} -> False       EnumFromThenTo {} -> False       _                 -> True++-- | Adds an explicit import Prelude statement when appropriate.+desugarImplicitPrelude :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarImplicitPrelude m =+    if preludeNotNeeded+        then return m+        else addPrelude m+  where+    preludeNotNeeded = hasExplicitPrelude m ||+                       hasLanguagePragma "NoImplicitPrelude" (getPragmas m)++    getPragmas :: (Data l, Typeable l) => Module l -> [ModulePragma l]+    getPragmas = universeBi++    getImportDecls :: Module l -> [ImportDecl l]+    getImportDecls (Module _ _ _ decls _) = decls+    getImportDecls _ = []++    setImportDecls :: [ImportDecl l] -> Module l -> Module l+    setImportDecls decls (Module a b c _ d) = Module a b c decls d+    setImportDecls _ mod = mod++    hasExplicitPrelude :: Module l -> Bool+    hasExplicitPrelude = any isPrelude . getImportDecls++    isPrelude :: ImportDecl l -> Bool+    isPrelude decl = case importModule decl of+      ModuleName _ name -> name == "Prelude"++    addPrelude :: Module l -> Desugar l (Module l)+    addPrelude mod = do+      let decls = getImportDecls mod+      prelude <- getPrelude+      return $ setImportDecls (prelude : decls) mod++    getPrelude :: Desugar l (ImportDecl l)+    getPrelude = do+      noInfo <- asks readerNoInfo+      return $ ImportDecl noInfo (ModuleName noInfo "Prelude") False False False Nothing Nothing Nothing++desugarFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarFFITypeSigs = desugarToplevelFFITypeSigs >=> desugarBindsTypeSigs++-- | For each toplevel FFI pattern binding, search the module for the relevant+-- type declaration; if found, add a type signature to the ffi expression.+-- e.g.+--  foo :: Int+--  foo = ffi "3"+-- becomes+--  foo :: Int+--  foo = ffi "3" :: Int+desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarToplevelFFITypeSigs m = case m of+  Module a b c d decls -> do+    decls' <- addFFIExpTypeSigs decls+    return $ Module a b c d decls'+  _ -> return m++desugarBindsTypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l)+desugarBindsTypeSigs = transformBiM $ \(BDecls srcInfo decls) -> do+  decls' <- addFFIExpTypeSigs decls+  return $ BDecls srcInfo decls'++addFFIExpTypeSigs :: (Data l, Typeable l) => [Decl l] -> Desugar l [Decl l]+addFFIExpTypeSigs decls = do+  let typeSigs = getTypeSigs decls+  sequence $ go typeSigs decls+  where+  -- | Create a lookup list mapping names to types, for all the types declared+  -- through standalone (ie: not in an expression) type signatures at this+  -- scope level.+  getTypeSigs ds = [ (unname n, typ) | TypeSig _ names typ <- ds, n <- names ]++  go typeSigs = map (addTypeSig typeSigs)++  addTypeSig typeSigs decl = case decl of+    (PatBind loc pat rhs binds) ->+      case getUnguardedRhs rhs of+        Just (srcInfo, rhExp) ->+          if isFFI rhExp+            then do+              rhExp' <- addSigToExp typeSigs decl rhExp+              return $ PatBind loc pat (UnGuardedRhs srcInfo rhExp') binds+            else return decl+        _ -> return decl+    _ -> return decl++  getUnguardedRhs rhs = case rhs of+    (UnGuardedRhs srcInfo exp) -> Just (srcInfo, exp)+    _ -> Nothing++  isFFI = isJust . ffiExp++  -- | Adds an explicit type signature to an expression (which is assumed to+  -- be the RHS of a declaration). This should only need to be called for FFI+  -- function declarations.+  -- Arguments:+  --  sigs:  List of toplevel type signatures+  --  decl:  The declaration, which should be a PatBind.+  --  rhExp: Expression comprising the RHS of the declaration+  addSigToExp typeSigs decl rhExp = case getTypeFor typeSigs decl of+    Just typ -> do+      noInfo <- asks readerNoInfo+      return $ ExpTypeSig noInfo rhExp typ+    Nothing -> return rhExp++  getTypeFor typeSigs decl = case decl of+    (PatBind _ (PVar _ name) _ _) -> lookup (unname name) typeSigs+    _ -> Nothing++-- | a `op` b => op a b+-- a + b => (+) a b+-- for expressions+desugarInfixOp :: (Data l, Typeable l) => Module l -> Module l+desugarInfixOp = transformBi $ \ex -> case ex of+  InfixApp l e1 oper e2 -> App l (App l (getOp oper) e1) e2+    where+      getOp (QVarOp l' o) = Var l' o+      getOp (QConOp l' o) = Con l' o+  _ -> ex++-- | a : b => (:) a b for patterns+desugarInfixPat :: (Data l, Typeable l) => Module l -> Module l+desugarInfixPat = transformBi $ \pt -> case pt of+  PInfixApp l p1 iop p2 -> PApp l iop [p1, p2]+  _ -> pt++-- | (a) => a for patterns+desugarExpParen :: (Data l, Typeable l) => Module l -> Module l+desugarExpParen = transformBi $ \ex -> case ex of+  Paren _ e -> e+  _ -> ex  transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a transformBi = U.transformBi
+ src/Fay/Compiler/Desugar/Name.hs view
@@ -0,0 +1,29 @@+-- | Generate names while desugaring.+module Fay.Compiler.Desugar.Name+  ( withScopedTmpName+  , unscopedTmpNames+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar.Types++import           Control.Monad.Reader            (asks, local)+import           Language.Haskell.Exts (Name (..))++-- | Generate a temporary, SCOPED name for testing conditions and+-- such. We don't have name tracking yet, so instead we use this.+withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar l a) -> Desugar l a+withScopedTmpName l f = do+  prefix <- asks readerTmpNamePrefix+  n <- asks readerNameDepth+  local (\r -> r { readerNameDepth = n + 1 }) $+    f $ tmpName l prefix n++-- | Generates temporary names where the scope doesn't matter.+unscopedTmpNames :: l -> String -> [Name l]+unscopedTmpNames l prefix = map (tmpName l prefix) [0..]++-- | Don't call this directly, use withScopedTmpName or unscopedTmpNames instead.+tmpName :: l -> String -> Int -> Name l+tmpName l prefix n = Ident l $ prefix ++ show n
+ src/Fay/Compiler/Desugar/Types.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}++-- | The transformer stack used during desugaring.++module Fay.Compiler.Desugar.Types+  ( DesugarReader (..)+  , Desugar+  , runDesugar+  ) where++import           Fay.Types            (CompileError (..))++#if __GLASGOW_HASKELL__ < 710+import           Control.Applicative+#endif+import           Control.Monad.Except+import           Control.Monad.Reader++data DesugarReader l = DesugarReader+  { readerNameDepth     :: Int+  , readerNoInfo        :: l+  , readerTmpNamePrefix :: String+  }++newtype Desugar l a = Desugar+  { unDesugar :: (ReaderT (DesugarReader l)+                       (ExceptT CompileError IO))+                       a+  } deriving ( MonadReader (DesugarReader l)+             , MonadError CompileError+             , MonadIO+             , Monad+             , Functor+             , Applicative+             )++runDesugar :: String -> l -> Desugar l a -> IO (Either CompileError a)+runDesugar tmpNamePrefix emptyAnnotation m =+    runExceptT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))
src/Fay/Compiler/Exp.hs view
@@ -1,6 +1,6 @@-{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeSynonymInstances  #-} {-# LANGUAGE ViewPatterns          #-}@@ -14,60 +14,60 @@   ,compileLit   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.FFI                (compileFFIExp) import           Fay.Compiler.Misc import           Fay.Compiler.Pattern import           Fay.Compiler.Print import           Fay.Compiler.QName-import           Fay.Data.List.Extra+import           Fay.Config import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Exts.Scoped                 (noI) import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (asks, gets) import qualified Data.Char                       as Char-import           Language.Haskell.Exts.Annotated-import           Language.Haskell.Names+import           Language.Haskell.Exts hiding (alt, binds, name, op)+import           Language.Haskell.Names          (NameInfo (RecExpWildcard), Scoped (Scoped))  -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp-compileExp exp = case exp of-  Paren _ exp                        -> compileExp exp+compileExp e = case e of   Var _ qname                        -> compileVar qname-  Lit _ lit                          -> compileLit lit+  Lit s lit                          -> compileLit (Signless s) lit+  App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e   App _ exp1 exp2                    -> compileApp exp1 exp2   NegApp _ exp                       -> compileNegApp exp-  InfixApp _ exp1 op exp2            -> compileInfixApp exp1 op exp2   Let _ (BDecls _ decls) exp         -> compileLet decls exp   List _ []                          -> return JsNull   List _ xs                          -> compileList xs   Tuple _ _boxed xs                  -> compileList xs   If _ cond conseq alt               -> compileIf cond conseq alt   Case _ exp alts                    -> compileCase exp alts-  Con _ (UnQual _ (Ident _ "True"))  -> return (JsLit (JsBool True))-  Con _ (UnQual _ (Ident _ "False")) -> return (JsLit (JsBool False))+  Con _ (UnQual _ (Ident _ "True"))  -> return $ JsLit (JsBool True)+  Con _ (UnQual _ (Ident _ "False")) -> return $ JsLit (JsBool False)   Con _ qname                        -> compileVar qname   Lambda _ pats exp                  -> compileLambda pats exp   EnumFrom _ i                       -> compileEnumFrom i   EnumFromTo _ i i'                  -> compileEnumFromTo i i'   EnumFromThen _ a b                 -> compileEnumFromThen a b   EnumFromThenTo _ a b z             -> compileEnumFromThenTo a b z-  RecConstr _ name fieldUpdates      -> compileRecConstr name fieldUpdates-  RecUpdate _ rec  fieldUpdates      -> compileRecUpdate rec fieldUpdates-  ListComp {}                        -> shouldBeDesugared exp-  Do {}                              -> shouldBeDesugared exp-  LeftSection {}                     -> shouldBeDesugared exp-  RightSection {}                    -> shouldBeDesugared exp-  TupleSection {}                    -> shouldBeDesugared exp-  ExpTypeSig _ exp sig               ->-    case ffiExp exp of-      Nothing -> compileExp exp-      Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig--  exp -> throwError (UnsupportedExpression exp)+  RecConstr _ name fieldUpdates      -> compileRecConstr e name fieldUpdates+  RecUpdate _ rec  fieldUpdates      -> compileRecUpdate e rec fieldUpdates+  ExpTypeSig _ exp sig               -> case ffiExp exp of+    Nothing -> compileExp exp+    Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig+  ListComp {}                        -> shouldBeDesugared e+  Do {}                              -> shouldBeDesugared e+  LeftSection {}                     -> shouldBeDesugared e+  RightSection {}                    -> shouldBeDesugared e+  TupleSection {}                    -> shouldBeDesugared e+  Paren {}                           -> shouldBeDesugared e+  InfixApp {}                        -> shouldBeDesugared e+  exp -> throwError $ UnsupportedExpression exp  -- | Compile variable. compileVar :: S.QName -> Compile JsExp@@ -75,35 +75,42 @@ compileVar qname = do     nc <- lookupNewtypeConst qname     nd <- lookupNewtypeDest qname-    if (nc /= Nothing || nd /= Nothing)+    if isJust nc || isJust nd       then -- variable is either a newtype constructor or newtype destructor,            -- replace it with identity function            return idFun-      else do-        qname <- unsafeResolveName qname-        return (JsName (JsNameVar qname))+      else JsName . JsNameVar <$> unsafeResolveName qname   where     idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1))  -- | Compile Haskell literal.-compileLit :: S.Literal -> Compile JsExp-compileLit lit = case lit of-  Char _ ch _      -> return (JsLit (JsChar ch))-  Int _ integer _   -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME:-  Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational)))+compileLit :: S.Sign -> S.Literal -> Compile JsExp+compileLit sign lit = case lit of+  Char _ ch _       -> return (JsLit (JsChar ch))+  Int _ integer _   -> return (JsLit (JsInt (fromIntegral (applySign integer)))) -- FIXME:+  Frac _ rational _ -> return (JsLit (JsFloating (fromRational (applySign rational))))   String _ string _ -> do     fromString <- gets stateUseFromString-    if fromString-      then return (JsLit (JsStr string))-      else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)])-  lit           -> throwError (UnsupportedLiteral lit)+    return $ if fromString+      then JsLit (JsStr string)+      else JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]+  _                 -> throwError $ UnsupportedLiteral lit+  where+    applySign :: Num a => a -> a+    applySign = case sign of+      Signless _ -> id+      Negative _ -> negate  -- | Compile simple application. compileApp :: S.Exp -> S.Exp -> Compile JsExp compileApp exp1@(Con _ q) exp2 =-  maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q+  ifOptimizeNewtypes+    (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q)+    (compileApp' exp1 exp2) compileApp exp1@(Var _ q) exp2 =-  maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q+  ifOptimizeNewtypes+    (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q)+    (compileApp' exp1 exp2) compileApp exp1 exp2 =   compileApp' exp1 exp2 @@ -119,9 +126,9 @@     -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)})     -- Which might be OK for speed, but increases the JS stack a fair bit.     method1 :: JsExp -> S.Exp -> Compile JsExp-    method1 exp1 exp2 =-      JsApp <$> (forceFlatName <$> return exp1)-            <*> fmap return (compileExp exp2)+    method1 e1 e2 =+      JsApp <$> (forceFlatName <$> return e1)+            <*> fmap return (compileExp e2)       where         forceFlatName name = JsApp (JsName JsForce) [name] @@ -130,9 +137,9 @@     -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05))     -- Which should be much better for the stack and readability, but probably not great for speed.     method2 :: JsExp -> S.Exp -> Compile JsExp-    method2 exp1 exp2 = fmap flatten $-      JsApp <$> return exp1-            <*> fmap return (compileExp exp2)+    method2 e1 e2 = fmap flatten $+      JsApp <$> return e1+            <*> fmap return (compileExp e2)       where         flatten (JsApp op args) =          case op of@@ -144,21 +151,6 @@ compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e --- | Compile an infix application, optimizing the JS cases.-compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp-compileInfixApp exp1 ap exp2 = case exp1 of-  Con _ q -> do-    newtypeConst <- lookupNewtypeConst q-    case newtypeConst of-      Just _ -> compileExp exp2-      Nothing -> normalApp-  _ -> normalApp-  where-    normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2)-    op = getOp ap-    getOp (QVarOp _ op) = op-    getOp (QConOp _ op) = op- -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp compileLet decls exp = do@@ -171,10 +163,10 @@ compileLetDecl decl = do   compileDecls <- asks readerCompileDecls   case decl of-    decl@PatBind{} -> compileDecls False [decl]-    decl@FunBind{} -> compileDecls False [decl]-    TypeSig{}      -> return []-    _              -> throwError (UnsupportedLetBinding decl)+    PatBind{} -> compileDecls False [decl]+    FunBind{} -> compileDecls False [decl]+    TypeSig{} -> return []+    _         -> throwError $ UnsupportedLetBinding decl  -- | Compile a list expression. compileList :: [S.Exp] -> Compile JsExp@@ -191,55 +183,57 @@  -- | Compile case expressions. compileCase :: S.Exp -> [S.Alt] -> Compile JsExp-compileCase exp alts = do-  exp <- compileExp exp+compileCase e alts = do+  exp <- compileExp e   withScopedTmpJsName $ \tmpName -> do-    pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts+    pats <- optimizePatConditions <$> mapM (compilePatAlt (JsName tmpName)) alts+    let (xx,flag) = deleteAfterReturn (concat pats)     return $       JsApp (JsFun Nothing                    [tmpName]-                   (concat pats)-                   (if any isWildCardAlt alts+                   xx+                   (if (flag || any isWildCardAlt alts)                        then Nothing                        else Just (throwExp "unhandled case" (JsName tmpName))))             [exp]+  where+    deleteAfterReturn :: [JsStmt] -> ([JsStmt],Bool)+    deleteAfterReturn [] = ([],False)+    deleteAfterReturn (x@(JsEarlyReturn _):_) = ([x],True)+    deleteAfterReturn (x:xs) = ((x:xx),flag)+      where (xx,flag) = deleteAfterReturn xs  -- | Compile the given pattern against the given expression. compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt]-compilePatAlt exp alt@(Alt _ pat rhs wheres) = case wheres of-  Just (BDecls _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt)-  Just (IPBinds _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt)-  _ -> do+compilePatAlt exp a@(Alt _ pat rhs wheres) = case wheres of+  Just (BDecls  _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a+  Just (IPBinds _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a+  _                        -> do     alt <- compileGuardedAlt rhs     compilePat exp pat [alt]  -- | Compile a guarded alt.-compileGuardedAlt :: S.GuardedAlts -> Compile JsStmt+compileGuardedAlt :: S.Rhs -> Compile JsStmt compileGuardedAlt alt =   case alt of-    UnGuardedAlt _ exp -> JsEarlyReturn <$> compileExp exp-    GuardedAlts _ alts -> compileGuards (map altToRhs alts)-   where-    altToRhs (GuardedAlt l s e) = GuardedRhs l s e+    UnGuardedRhs _ exp -> JsEarlyReturn <$> compileExp exp+    GuardedRhss _ alts -> compileGuards alts  -- | Compile guards compileGuards :: [S.GuardedRhs] -> Compile JsStmt-compileGuards ((GuardedRhs _ (Qualifier _ (Var _ (UnQual _ (Ident _ "otherwise"))):_) exp):_) =-  (\e -> JsIf (JsLit $ JsBool True) [JsEarlyReturn e] []) <$> compileExp exp compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) =   makeIf <$> fmap force (compileExp guard)          <*> compileExp exp          <*> if null rest then return [] else do            gs' <- compileGuards rest            return [gs']-    where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss+    where makeIf gs e = JsIf gs [JsEarlyReturn e]  compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss noI $ rhss  -- | Compile a lambda. compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp-compileLambda pats exp = do-  exp   <- compileExp exp+compileLambda pats = compileExp >=> \exp -> do   stmts <- generateStatements exp   case stmts of     [JsEarlyReturn fun@JsFun{}] -> return fun@@ -250,9 +244,13 @@         generateStatements exp =           foldM (\inner (param,pat) -> do                   stmts <- compilePat (JsName param) pat inner-                  return [JsEarlyReturn (JsFun Nothing [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)])+                  return [JsEarlyReturn (JsFun Nothing [param] (deleteAfterReturn $ stmts ++ [unhandledcase param | not allfree]) Nothing)])                 [JsEarlyReturn exp]                 (reverse (zip uniqueNames pats))+        deleteAfterReturn :: [JsStmt] -> [JsStmt]+        deleteAfterReturn [] = []+        deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+        deleteAfterReturn (x:xs) = x:deleteAfterReturn xs  -- | Compile [e1..] arithmetic sequences. compileEnumFrom :: S.Exp -> Compile JsExp@@ -290,36 +288,36 @@  -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS.-compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp-compileRecConstr name fieldUpdates = do+compileRecConstr :: S.Exp -> S.QName -> [S.FieldUpdate] -> Compile JsExp+compileRecConstr origExp name fieldUpdates = do   -- var obj = new $_Type()   let unQualName = withIdent lowerFirst . unQualify $ unAnn name   qname <- unsafeResolveName name   let record = JsVar (JsNameVar unQualName) (JsNew (JsConstructor qname) [])-  setFields <- liftM concat (forM fieldUpdates (updateStmt name))+  setFields <- concat <$> forM fieldUpdates (updateStmt name)   return $ JsApp (JsFun Nothing [] (record:setFields) (Just . JsName . JsNameVar . withIdent lowerFirst . unQualify $ unAnn name)) []   where     -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt]     updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do       exp <- compileExp value       return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp]-    updateStmt o (FieldWildcard (wildcardFields -> fields)) = do-      return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o)+    updateStmt o (FieldWildcard (wildcardFields -> fields)) =+      return $ flip fmap fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o)                                                     (JsNameVar fieldName)                                                     (JsName $ JsNameVar fieldName)     -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))-    updateStmt _ u = error ("updateStmt: " ++ show u)+    updateStmt _ _ = throwError $ UnsupportedExpression origExp      wildcardFields l = case l of-      Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es+      Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName . fst) es       _ -> []     lowerFirst :: String -> String     lowerFirst "" = ""     lowerFirst (x:xs) = '_' : Char.toLower x : xs  -- | Compile a record update.-compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp-compileRecUpdate rec fieldUpdates = do+compileRecUpdate :: S.Exp -> S.Exp -> [S.FieldUpdate] -> Compile JsExp+compileRecUpdate origExp rec fieldUpdates = do   record <- force <$> compileExp rec   let copyName = UnQual () $ Ident () "$_record_to_update"       copy = JsVar (JsNameVar copyName)@@ -332,14 +330,14 @@       JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value     updateExp _ f@FieldPun{} = shouldBeDesugared f     -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)-    updateExp _ FieldWildcard{} = error "unsupported update: FieldWildcard"+    updateExp _ FieldWildcard{} = throwError $ UnsupportedExpression origExp  -- | Make a Fay list. makeList :: [JsExp] -> JsExp makeList exps = JsApp (JsName $ JsBuiltIn "list") [JsList exps]  -- | Optimize short literal [e1..e3] arithmetic sequences.-optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp+optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp optEnumFromTo cfg (JsLit f) (JsLit t) =   if configOptimize cfg   then case (f,t) of@@ -348,14 +346,14 @@     _ -> Nothing   else Nothing     where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> Maybe JsExp-          strict litfn f t =-            if fromEnum t - fromEnum f < maxStrictASLen-            then Just . makeList . map (JsLit . litfn) $ enumFromTo f t+          strict litfn fr to =+            if fromEnum to - fromEnum fr < maxStrictASLen+            then Just . makeList . map (JsLit . litfn) $ enumFromTo fr to             else Nothing optEnumFromTo _ _ _ = Nothing  -- | Optimize short literal [e1,e2..e3] arithmetic sequences.-optEnumFromThenTo :: CompileConfig -> JsExp -> JsExp -> JsExp -> Maybe JsExp+optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp optEnumFromThenTo cfg (JsLit fr) (JsLit th) (JsLit to) =   if configOptimize cfg   then case (fr,th,to) of@@ -364,10 +362,10 @@     _ -> Nothing   else Nothing     where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> a -> Maybe JsExp-          strict litfn fr th to =-            if (fromEnum to - fromEnum fr) `div`-               (fromEnum th - fromEnum fr) + 1 < maxStrictASLen-            then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr th to+          strict litfn fr' th' to' =+            if (fromEnum to' - fromEnum fr') `div`+               (fromEnum th' - fromEnum fr') + 1 < maxStrictASLen+            then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr' th' to'             else Nothing optEnumFromThenTo _ _ _ _ = Nothing
src/Fay/Compiler/FFI.hs view
@@ -1,106 +1,89 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections     #-} {-# LANGUAGE ViewPatterns      #-}-{-# OPTIONS -Wall #-}  -- | Compile FFI definitions.  module Fay.Compiler.FFI   (emitFayToJs   ,emitJsToFay-  ,compileFFI   ,compileFFIExp   ,jsToFayHash   ,fayToJsHash   ,typeArity   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc-import           Fay.Compiler.Print                     (printJSString)+import           Fay.Compiler.Print           (printJSString) import           Fay.Compiler.QName-import           Fay.Exts.NoAnnotation                  (unAnn)-import qualified Fay.Exts.NoAnnotation                  as N-import qualified Fay.Exts.Scoped                        as S+import           Fay.Exts.NoAnnotation        (unAnn)+import qualified Fay.Exts.NoAnnotation        as N+import qualified Fay.Exts.Scoped              as S import           Fay.Types -import           Control.Applicative                    ((<$>), (<*>))-import           Control.Arrow                          ((***))-import           Control.Monad.Error-import           Control.Monad.Writer-import           Data.Char+import           Control.Monad.Except         (throwError)+import           Control.Monad.Writer         (tell) import           Data.Generics.Schemes-import           Data.List-import           Data.Maybe-import           Data.String-import           Language.ECMAScript3.Parser            as JS+import           Language.ECMAScript3.Parser  as JS import           Language.ECMAScript3.Syntax-import           Language.Haskell.Exts.Annotated        (SrcSpanInfo,-                                                         prettyPrint,srcInfoSpan)-import           Language.Haskell.Exts.Annotated.Syntax-import           Prelude                                hiding (exp, mod)-import           Safe+import           Language.Haskell.Exts        (SrcSpanInfo, prettyPrint)+import           Language.Haskell.Exts.Syntax --- | Compile an FFI call.-compileFFI :: S.Name  -- ^ Name of the to-be binding.-           -> String -- ^ The format string.-           -> S.Type   -- ^ Type signature.-           -> Compile [JsStmt]-compileFFI name' formatstr sig =+-- | Compile an FFI expression (also used when compiling top level definitions).+compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp+compileFFIExp loc (fmap unAnn -> nameopt) formatstr sig' =   -- substitute newtypes with their child types before calling   -- real compileFFI-  compileFFI' =<< rmNewtys sig-+  compileFFI' . unAnn =<< rmNewtys sig'   where     rmNewtys :: S.Type -> Compile N.Type-    rmNewtys (TyForall _ b c t) = TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t-    rmNewtys (TyFun _ t1 t2)    = TyFun () <$> rmNewtys t1 <*> rmNewtys t2-    rmNewtys (TyTuple _ b tl)   = TyTuple () b <$> mapM rmNewtys tl-    rmNewtys (TyList _ t)       = TyList () <$> rmNewtys t-    rmNewtys (TyApp _ t1 t2)    = TyApp () <$> rmNewtys t1 <*> rmNewtys t2-    rmNewtys t@TyVar{}          = return (unAnn t)-    rmNewtys (TyCon _ qname)    = do-      newty <- lookupNewtypeConst qname-      return $ case newty of-                 Nothing     -> TyCon () (unAnn qname)-                 Just (_,ty) -> ty-    rmNewtys (TyParen _ t)      = TyParen () <$> rmNewtys t-    rmNewtys (TyInfix _ t1 q t2)= flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2-    rmNewtys (TyKind _ t k)     = flip (TyKind ()) (unAnn k) <$> rmNewtys t--    compileFFI' :: N.Type -> Compile [JsStmt]-    compileFFI' sig' = do-      fun <- compileFFIExp loc (Just name) formatstr sig'-      stmt <- bindToplevel True (Just (srcInfoSpan loc)) name fun-      return [stmt]--    name = unAnn name'-    loc = S.srcSpanInfo $ ann name'---- | Compile an FFI expression (also used when compiling top level definitions).-compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> (Type a) -> Compile JsExp-compileFFIExp loc (fmap unAnn -> nameopt) formatstr (unAnn -> sig) = do-  let name = fromMaybe "<exp>" nameopt-  inner <- formatFFI loc formatstr (zip params funcFundamentalTypes)-  case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of-    Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err))-    Right exp  -> do-      config' <- config id-      when (configGClosure config') $ warnDotUses loc inner exp-      return (body inner)+    rmNewtys typ = case typ of+      TyForall _ b c t  -> TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t+      TyFun _ t1 t2     -> TyFun () <$> rmNewtys t1 <*> rmNewtys t2+      TyTuple _ b tl    -> TyTuple () b <$> mapM rmNewtys tl+      TyList _ t        -> TyList () <$> rmNewtys t+      TyApp _ t1 t2     -> TyApp () <$> rmNewtys t1 <*> rmNewtys t2+      t@TyVar{}         -> return $ unAnn t+      TyCon _ qname     -> maybe (TyCon () (unAnn qname)) snd <$> lookupNewtypeConst qname+      TyParen _ t       -> TyParen () <$> rmNewtys t+      TyInfix _ t1 q t2 -> flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2+      TyKind _ t k      -> flip (TyKind ()) (unAnn k) <$> rmNewtys t+      TyPromoted {}     -> return $ unAnn typ+      TyParArray _ t    -> TyParArray () <$> rmNewtys t+      TyEquals _ t1 t2  -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2+      TySplice {}       -> return $ unAnn typ+      TyBang _ bt unp t -> TyBang () (unAnn bt) (unAnn unp) <$> rmNewtys t+      TyWildCard {}     -> error "TyWildCard not supported"+      TyQuasiQuote {}   -> error "TyQuasiQuote not supported"+      TyUnboxedSum {}   -> error "TyUnboxedSum not supported" -  where-    body inner = foldr wrapParam (wrapReturn inner) params-    wrapParam pname inner = JsFun Nothing [pname] [] (Just inner)-    params = zipWith const uniqueNames [1..typeArity sig]-    wrapReturn :: String -> JsExp-    wrapReturn inner = thunk $-      case lastMay funcFundamentalTypes of-        -- Returns a “pure” value;-        Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)-        -- Base case:-        Nothing -> JsRawExp inner-    funcFundamentalTypes = functionTypeArgs sig-    returnType = last funcFundamentalTypes+    compileFFI' :: N.Type -> Compile JsExp+    compileFFI' sig = do+      let name = fromMaybe "<exp>" nameopt+      inner <- formatFFI loc formatstr (zip params funcFundamentalTypes)+      case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of+        Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err))+        Right exp  -> do+          config' <- config id+          when (configGClosure config') $ warnDotUses loc inner exp+          return (body inner)+      where+        body inner = foldr wrapParam (wrapReturn inner) params+        wrapParam pname inner = JsFun Nothing [pname] [] (Just inner)+        params = zipWith const uniqueNames [1..typeArity sig]+        wrapReturn :: String -> JsExp+        wrapReturn inner = thunk $+          case lastMay funcFundamentalTypes of+            -- Returns a “pure” value;+            Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner)+            -- Base case:+            Nothing -> JsRawExp inner+        funcFundamentalTypes = functionTypeArgs sig+        returnType = last funcFundamentalTypes  -- | Warn about uses of naked x.y which will not play nicely with Google Closure. warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()@@ -130,7 +113,7 @@     globalNames = ["Math","console","JSON"]  -- | Make a Fay→JS encoder.-emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], BangType d)] -> Compile ()+emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile () emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do   qname <- qualify name   let ctrName = printJSString $ unQual qname@@ -147,7 +130,7 @@     obj = JsVar obj_ $       JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))] -    fieldStmts :: [(Int,(N.Name,N.BangType))] -> [JsStmt]+    fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt]     fieldStmts [] = []     fieldStmts ((i,fieldType):fts) =       JsVar obj_v field :@@ -163,11 +146,11 @@     obj_ = JsNameVar "obj_"      -- Declare/encode Fay→JS field-    declField :: Int -> (N.Name,N.BangType) -> (String,JsExp)+    declField :: Int -> (N.Name,N.Type) -> (String,JsExp)     declField i (fname,typ) =       (prettyPrint fname       ,fayToJs (SerializeUserArg i)-               (argType (bangType typ))+               (argType typ)                (JsGetProp (JsName transcodingObjForced)                           (JsNameVar (UnQual () fname)))) @@ -211,13 +194,6 @@       TyCon _ (UnQual _ user)   -> UserDefined user []       _ -> UnknownType --- | Extract the type.-bangType :: N.BangType -> N.Type-bangType typ = case typ of-  BangedTy _ ty   -> ty-  UnBangedTy _ ty -> ty-  UnpackedTy _ ty -> ty- -- | Expand a type application. expandApp :: N.Type -> [N.Type] expandApp (TyParen _ t) = expandApp t@@ -353,7 +329,7 @@ jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]]  -- | Make a JS→Fay decoder.-emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],BangType d)] -> Compile ()+emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],Type d)] -> Compile () emitJsToFay (unAnn -> name) (map unAnn -> tyvars) (map (unAnn *** unAnn) . explodeFields -> fieldTypes) = do   qname <- qualify name   tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] })@@ -364,10 +340,10 @@             (Just $ JsNew (JsConstructor qname)                           (map (decodeField . getIndex name tyvars) fieldTypes))     -- Decode JS→Fay field-    decodeField :: (Int,(N.Name,N.BangType)) -> JsExp+    decodeField :: (Int,(N.Name,N.Type)) -> JsExp     decodeField (i,(fname,typ)) =       jsToFay (SerializeUserArg i)-              (argType (bangType typ))+              (argType typ)               (JsGetPropExtern (JsName transcodingObj)                                (prettyPrint fname)) @@ -376,9 +352,9 @@ argTypes = JsNameVar "argTypes"  -- | Get the index of a name from the set of type variables bindings.-getIndex :: Name a -> [TyVarBind b] -> (Name c,BangType d) -> (Int,(N.Name,N.BangType))+getIndex :: Name a -> [TyVarBind b] -> (Name c,Type d) -> (Int,(N.Name,N.Type)) getIndex (unAnn -> name) (map unAnn -> tyvars) (unAnn -> sname,unAnn -> ty) =-  case bangType ty of+  case ty of     TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of       Nothing -> error $ "unknown type variable " ++ prettyPrint tyname ++                          " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," ++
src/Fay/Compiler/GADT.hs view
@@ -4,18 +4,18 @@   (convertGADT   ) where -import           Language.Haskell.Exts.Annotated hiding (binds, name)+import           Language.Haskell.Exts hiding (name)  -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a convertGADT d = case d of-  GadtDecl s name typ -> QualConDecl s tyvars context-                           (ConDecl s name (convertFunc typ))+  GadtDecl s name tyvars context Nothing typ ->+    QualConDecl s tyvars context (ConDecl s name (convertFunc typ))+  GadtDecl s name tyvars context (Just fs) _typ ->+    QualConDecl s tyvars context (RecDecl s name fs)   where-    tyvars = Nothing-    context = Nothing-    convertFunc :: Type a -> [BangType a]+    convertFunc :: Type a -> [Type a]     convertFunc (TyCon _ _) = []-    convertFunc (TyFun s x xs) = UnBangedTy s x : convertFunc xs+    convertFunc (TyFun _ x xs) = x : convertFunc xs     convertFunc (TyParen _ x) = convertFunc x     convertFunc _ = []
src/Fay/Compiler/Import.hs view
@@ -1,27 +1,28 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections     #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Handles finding imports and compiling them recursively. -- This is done for each full AST traversal the copmiler does -- which at this point is InitialPass's preprocessing -- and Compiler's code generation module Fay.Compiler.Import-  (startCompile-  ,compileWith+  ( startCompile+  , compileWith   ) where -import           Fay.Compiler.Config+import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc-import           Fay.Control.Monad.IO+import           Fay.Compiler.Parse+import           Fay.Config import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn) import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS-import           Language.Haskell.Exts.Annotated hiding (name, var)-import           Prelude                         hiding (mod, read)+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (ask, get, gets, lift, listen, modify)+import           Language.Haskell.Exts hiding (name) import           System.Directory import           System.FilePath @@ -33,13 +34,14 @@  -- | Compile a module compileWith-  :: Monoid a+  :: (Monoid a, Semigroup a)   => FilePath   -> (a -> F.Module -> Compile a)   -> (FilePath -> String -> Compile a)+  -> (F.X -> F.Module -> IO (Either CompileError F.Module))   -> String   -> Compile (a, CompileState, CompileWriter)-compileWith filepath with compileModule from = do+compileWith filepath with compileModule before from = do   rd <- ask   st <- get   res <- Compile . lift . lift $@@ -47,7 +49,9 @@       rd       st       (parseResult (throwError . uncurry ParseError)-                   (\mod@(Module _ _ _ imports _) -> do+                   (\mod' -> do+                     ~mod@(Module _ _ _ imports _) <-+                       either throwError return =<< io (before F.noI mod')                      res <- foldr (<>) mempty <$> mapM (compileImport compileModule) imports                      modify $ \s -> s { stateModuleName = unAnn $ F.moduleName mod }                      with res mod@@ -94,9 +98,9 @@   -> F.ImportDecl   -> Compile a compileImport compileModule i = case i of-  -- Package imports are ignored since they are used for some trickery in fay-base.-  ImportDecl _ _    _ _ Just{}  _ _ -> return mempty-  ImportDecl _ name _ _ Nothing _ _ -> compileModuleFromName compileModule name+  -- Trickery in fay-base needs this special case+  ImportDecl _ _    _ _ _ (Just "base") _ _ -> return mempty+  ImportDecl _ name _ _ _ _ _ _ -> compileModuleFromName compileModule name  -- | Find an import's filepath and contents from its module name. findImport :: [FilePath] -> ModuleName a -> Compile (FilePath,String)
src/Fay/Compiler/InitialPass.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -7,24 +8,22 @@   (initialPass   ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Desugar import           Fay.Compiler.GADT import           Fay.Compiler.Import import           Fay.Compiler.Misc-import           Fay.Control.Monad.IO-import           Fay.Data.List.Extra+import           Fay.Compiler.Parse import qualified Fay.Exts                        as F import           Fay.Exts.NoAnnotation           (unAnn)-import qualified Fay.Exts.NoAnnotation           as N import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (modify) import qualified Data.Map                        as M-import           Language.Haskell.Exts.Annotated hiding (name, var)-import qualified Language.Haskell.Names          as HN-import           Prelude                         hiding (mod, read)+import           Language.Haskell.Exts hiding (name)+import qualified Language.Haskell.Names          as HN (getInterfaces)  -- | Preprocess and collect all information needed during code generation. initialPass :: FilePath -> Compile ()@@ -33,7 +32,7 @@ -- | Preprocess a module given its filepath and content. preprocessFileWithSource :: FilePath -> String -> Compile () preprocessFileWithSource filepath contents = do-  (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource contents+  (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource desugar contents   -- This is the state we want to keep   modify $ \s -> s { stateRecords     = stateRecords     st                    , stateRecordTypes = stateRecordTypes st@@ -50,18 +49,15 @@  -- | Preprocess from an AST preprocessAST :: () -> F.Module -> Compile ()-preprocessAST () mod'@Module{} = do-  res <- io $ desugar mod'-  case res of-    Left err -> throwError err-    Right dmod -> do-      let (Module _ _ _ _ decls) = dmod-      -- This can only return one element since we only compile one module.-      ([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [dmod]-      modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s }-      forM_ decls scanTypeSigs-      forM_ decls scanRecordDecls-      forM_ decls scanNewtypeDecls+preprocessAST () mod@(Module _ _ _ _ decls) = do+  -- This can only return one element since we only compile one module.+  ~([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod]+  modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s }+  forM_ decls scanTypeSigs+  forM_ decls scanRecordDecls+  ifOptimizeNewtypes+    (forM_ decls scanNewtypeDecls)+    (return ()) preprocessAST () mod = throwError $ UnsupportedModuleSyntax "preprocessAST" mod  --------------------------------------------------------------------------------@@ -80,32 +76,43 @@   RecDecl _ cname [FieldDecl _ [dname] ty] -> addNewtype cname (Just dname) ty   x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x   where-    getBangTy :: F.BangType -> N.Type-    getBangTy (BangedTy _ t)   = unAnn t-    getBangTy (UnBangedTy _ t) = unAnn t-    getBangTy (UnpackedTy _ t) = unAnn t-     addNewtype cname dname ty = do       qcname <- qualify cname       qdname <- case dname of                   Nothing -> return Nothing                   Just n  -> Just <$> qualify n       modify (\cs@CompileState{stateNewtypes=nts} ->-               cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts})+               cs{stateNewtypes=(qcname,qdname,unAnn ty):nts}) compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q +{-# ANN scanRecordDecls ("HLint: ignore Redundant flip" :: String) #-} -- | Add record declarations to the state scanRecordDecls :: F.Decl -> Compile () scanRecordDecls decl = do   case decl of-    DataDecl _loc DataType{} _ctx (F.declHeadName -> name) qualcondecls _deriv -> do-      let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)-      addRecordTypeState name ns+    DataDecl _loc ty _ctx (F.declHeadName -> name) qualcondecls _deriv -> do+      let addIt = let ns = flip fmap qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)+                  in addRecordTypeState name ns+      case ty of+        DataType{} -> addIt+        NewType{} -> ifOptimizeNewtypes+                       (return ())+                       addIt     _ -> return ()    case decl of-    DataDecl _ DataType{} _ _ constructors _ -> dataDecl constructors-    GDataDecl _ DataType{} _ _ _ decls _ -> dataDecl (map convertGADT decls)+    DataDecl _ ty _ _ constructors _ ->+      case ty of+        DataType{} -> dataDecl constructors+        NewType{} -> ifOptimizeNewtypes+                       (return ())+                       (dataDecl constructors)+    GDataDecl _ ty _ _ _ decls _ ->+      case ty of+        DataType{} -> dataDecl (map convertGADT decls)+        NewType{} -> ifOptimizeNewtypes+                       (return ())+                       (dataDecl (map convertGADT decls))     _ -> return ()    where@@ -121,7 +128,7 @@     -- | Collect record definitions and store record name and field names.     -- A ConDecl will have fields named slot1..slotN     dataDecl :: [F.QualConDecl] -> Compile ()-    dataDecl constructors = do+    dataDecl constructors =       forM_ constructors $ \(QualConDecl _ _ _ condecl) ->         case condecl of           ConDecl _ name types -> do
src/Fay/Compiler/Misc.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE ViewPatterns      #-}@@ -7,30 +8,27 @@  module Fay.Compiler.Misc where +import           Fay.Compiler.Prelude++import           Fay.Compiler.ModuleT            (runModuleT) import           Fay.Compiler.PrimOp-import           Fay.Control.Monad.IO-import qualified Fay.Exts                          as F-import           Fay.Exts.NoAnnotation             (unAnn)-import qualified Fay.Exts.NoAnnotation             as N-import qualified Fay.Exts.Scoped                   as S+import           Fay.Compiler.QName              (unname)+import           Fay.Config+import qualified Fay.Exts                        as F+import           Fay.Exts.NoAnnotation           (unAnn)+import qualified Fay.Exts.NoAnnotation           as N+import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.RWS-import           Data.Char                         (isAlpha)-import           Data.List-import qualified Data.Map                          as M-import           Data.Maybe-import           Data.String-import           Data.Version                      (parseVersion)-import           Distribution.HaskellSuite.Modules-import           Language.Haskell.Exts.Annotated   hiding (name)-import           Language.Haskell.Names-import           Prelude                           hiding (exp, mod)+import           Control.Monad.Except            (runExceptT, throwError)+import           Control.Monad.RWS               (asks, gets, modify, runRWST)+import           Data.Version                    (parseVersion)+import           Language.Haskell.Exts hiding (name)+import           Language.Haskell.Names          (GName (GName), NameInfo (GlobalValue, LocalValue, ScopeError),+                                                  OrigName, Scoped (Scoped), origGName, origName) import           System.IO-import           System.Process                    (readProcess)-import           Text.ParserCombinators.ReadP      (readP_to_S)+import           System.Process                  (readProcess)+import           Text.ParserCombinators.ReadP    (readP_to_S)  -- | Wrap an expression in a thunk. thunk :: JsExp -> JsExp@@ -113,7 +111,7 @@     Just (cname,_,ty) -> return $ Just (cname,ty)  -- | Qualify a name for the current module.-qualify :: Name a -> Compile (N.QName)+qualify :: Name a -> Compile N.QName qualify (Ident _ name) = do   modulename <- gets stateModuleName   return (Qual () modulename (Ident () name))@@ -153,19 +151,21 @@   ParseFailed srcloc msg -> die (srcloc,msg)  -- | Get a config option.-config :: (CompileConfig -> a) -> Compile a+config :: (Config -> a) -> Compile a config f = asks (f . readerConfig)  -- | Optimize pattern matching conditions by merging conditions in common.+-- TODO This is buggy and no longer used. Fails on tests/case3 optimizePatConditions :: [[JsStmt]] -> [[JsStmt]]-optimizePatConditions = concatMap merge . groupBy sameIf where+optimizePatConditions = id+  {- concatMap merge . groupBy sameIf where   sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2   sameIf _ _ = False   merge xs@([JsIf cond _ _]:_) =     [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]]   merge noifs = noifs   getIfConsequent [JsIf _ cons _] = cons-  getIfConsequent other = other+  getIfConsequent other = other -}  -- | Throw a JS exception. throw :: String -> JsExp -> JsStmt@@ -215,7 +215,7 @@ warn "" = return () warn w = config id >>= io . (`ioWarn` w) -ioWarn :: CompileConfig -> String -> IO ()+ioWarn :: Config -> String -> IO () ioWarn _ "" = return () ioWarn cfg w =   when (configWall cfg) $@@ -237,7 +237,7 @@ typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes  recToFields :: S.QName -> Compile [N.Name]-recToFields con = do+recToFields con =   case tryResolveName con of     Nothing -> return []     Just c -> fromMaybe [] . lookup c <$> gets stateRecords@@ -268,72 +268,31 @@   -> CompileState   -> Compile a   -> IO (Either CompileError (a,CompileState,CompileWriter))-runTopCompile reader' state' m = fst <$> runModuleT (runErrorT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty+runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state'))  -- | Runs compilation for a single module. runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a-runCompileModule reader' state' m = runErrorT (runRWST (unCompile m) reader' state')+runCompileModule reader' state' m = runExceptT (runRWST (unCompile m) reader' state') --- | Parse some Fay code.-parseFay :: Parseable ast => FilePath -> String -> ParseResult ast-parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP+shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a+shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn --- | Apply incredibly simplistic CPP handling. It only recognizes the following:------ > #if FAY--- > #ifdef FAY--- > #ifndef FAY--- > #else--- > #endif------ Note that this implementation replaces all removed lines with blanks, so--- that line numbers remain accurate.-applyCPP :: String -> String-applyCPP =-    unlines . loop NoCPP . lines+-- | Check if the given language pragmas are all present.+hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool+hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas   where-    loop _ [] = []-    loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest-    loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest-    loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest-    loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest-    loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest-    loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest-    loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest--    toInclude NoCPP = True-    toInclude (CPPIf x state') = x && toInclude state'-    toInclude (CPPElse x state') = x && toInclude state'---- | The CPP's parsing state.-data CPPState = NoCPP-              | CPPIf Bool CPPState-              | CPPElse Bool CPPState---- | The parse mode for Fay.-parseMode :: ParseMode-parseMode = defaultParseMode-  { extensions = defaultExtensions-  , fixities = Just (preludeFixities ++ baseFixities)-  }+    flattenPragmas :: [ModulePragma l] -> [String]+    flattenPragmas = concatMap pragmaName+    pragmaName (LanguagePragma _ q) = map unname q+    pragmaName _ = [] -shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a-shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn+hasLanguagePragma :: String -> [ModulePragma l] -> Bool+hasLanguagePragma pr = hasLanguagePragmas [pr] -defaultExtensions :: [Extension]-defaultExtensions = map EnableExtension-  [EmptyDataDecls-  ,ExistentialQuantification-  ,FlexibleContexts-  ,FlexibleInstances-  ,GADTs-  ,KindSignatures-  ,NamedFieldPuns-  ,PackageImports-  ,RecordWildCards-  ,StandaloneDeriving-  ,TupleSections-  ,TypeFamilies-  ,TypeOperators-  ] ++ map DisableExtension-  [ImplicitPrelude]+-- | if then else for when 'configOptimizeNewtypes'.+ifOptimizeNewtypes :: Compile a -> Compile a -> Compile a+ifOptimizeNewtypes then' else' = do+  optimize <- config configOptimizeNewtypes+  if optimize+     then then'+     else else'
+ src/Fay/Compiler/ModuleT.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeSynonymInstances       #-}+module Fay.Compiler.ModuleT+  (+  -- * Module monad+  -- | When you need to resolve modules, you work in a 'ModuleT' monad (or+  -- another monad that is an instance of 'MonadModule') and use the+  -- 'getModuleInfo' function.+  --+  -- It finds an installed module by its name and reads (and caches) its+  -- info from the info file. Then you run a 'ModuleT' monadic action+  -- using 'evalModuleT' or 'runModuleT'.+  --+  -- To run a 'ModuleT' action you'll also need to provide the set of+  -- packages (represented by their 'InstalledPackageInfo') in which to+  -- search for modules. You can get such a set from either+  -- 'getInstalledPackages' or 'readPackagesInfo', depending on your use+  -- case.+    ModuleT+  , getModuleInfo+  , runModuleT+  , MonadModule (..)+  -- * Module names+  , ModName (..)+  ) where++import           Fay.Compiler.Prelude++import           Control.Monad.Reader+import           Control.Monad.State+import qualified Data.Char            as Char (isAlphaNum, isUpper)+import qualified Data.Map             as Map++-- ModuleName extracted from Cabal, (c) 2008 Duncan Coutts, Licensed as BSD3+newtype ModuleName = ModuleName [String]+  deriving (Eq, Ord, Show)++fromString :: String -> ModuleName+fromString string+  | all validModuleComponent components' = ModuleName components'+  | otherwise                            = error $ "ModuleName.fromString: invalid module name " ++ show string++  where+    components' = split string++    split cs = case break (=='.') cs of+      (chunk,[])     -> [chunk]+      (chunk,_:rest) -> chunk : split rest++    validModuleComponent :: String -> Bool+    validModuleComponent []     = False+    validModuleComponent (c:cs) = Char.isUpper c+                           && all validModuleChar cs++    validModuleChar :: Char -> Bool+    validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''+++-- | This class defines the interface that is used by 'getModuleInfo', so+-- that you can use it in monads other than 'ModuleT'.+--+-- You don't typically have to define your own instances of this class, but+-- here are a couple of cases when you might:+--+-- * A pure (non-'MonadIO') mockup module monad for testing purposes+--+-- * A transformer over 'ModuleT'+--+-- * You need a more complex way to retrieve the module info+class Monad m => MonadModule m where+  -- | The type of module info+  type ModuleInfo m+  lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))+  insertInCache :: ModName n => n -> ModuleInfo m -> m ()++  -- | Read the module info, given a list of search paths and the module+  -- name+  readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)++-- | Different libraries (Cabal, haskell-src-exts, ...) use different types+-- to represent module names. Hence this class.+class ModName n where+  modToString :: n -> String++instance ModName String where+  modToString = id++-- | Convert module name from arbitrary representation to Cabal's one+convertModuleName :: ModName n => n -> ModuleName+convertModuleName = fromString . modToString++-- | Tries to find the module in the current set of packages, then find the+-- module's info file, and reads and caches its contents.+--+-- Returns 'Nothing' if the module could not be found in the current set of+-- packages. If the module is found, but something else goes wrong (e.g.+-- there's no info file for it), an exception is thrown.+getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))+getModuleInfo = lookupInCache++-- | A standard module monad transformer.+--+-- @i@ is the type of module info, @m@ is the underlying monad.+newtype ModuleT i m a =+  ModuleT+    (StateT (Map.Map ModuleName i)+            (ReaderT ([FilePath] -> ModuleName -> m i) m) a)+  deriving (Functor, Applicative, Monad)++instance MonadTrans (ModuleT i) where+  lift = ModuleT . lift . lift++instance MonadIO m => MonadIO (ModuleT i m) where+  liftIO = ModuleT . liftIO++instance (Functor m, Monad m) => MonadModule (ModuleT i m) where+  type ModuleInfo (ModuleT i m) = i+  lookupInCache n = ModuleT $ Map.lookup (convertModuleName n) <$> get+  insertInCache n i = ModuleT $ modify $ Map.insert (convertModuleName n) i+  readModuleInfo dirs mod' =+    lift =<< ModuleT ask <*> pure dirs <*> pure (convertModuleName mod')++-- | Run a 'ModuleT' action+runModuleT+  :: (Monad m, Monoid i)+  => ModuleT i m a -- ^ the monadic action to run+  -> m (a, Map.Map ModuleName i)+  -- ^ return value, plus all cached module infos (that is, the initial set+  -- plus all infos that have been read by the action itself)+runModuleT (ModuleT a) =+  runReaderT (runStateT a Map.empty) (\_ _ -> return mempty)
src/Fay/Compiler/Optimizer.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards     #-} {-# LANGUAGE TupleSections     #-}@@ -6,20 +8,15 @@  module Fay.Compiler.Optimizer where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc import           Fay.Types -import           Control.Applicative-import           Control.Arrow                   (first)-import           Control.Monad.Error-import           Control.Monad.State-import           Control.Monad.Writer-import           Data.List-import           Data.Maybe+import           Control.Monad.State             (State, modify, runState)+import           Control.Monad.Writer            (runWriter, tell) import qualified Fay.Exts.NoAnnotation           as N-import           Language.Haskell.Exts.Annotated hiding (app, name, op)--import           Prelude                         hiding (exp)+import           Language.Haskell.Exts hiding (app, name, op)  -- | The arity of a function. Arity here is defined to be the number -- of arguments that can be directly uncurried from a curried lambda@@ -120,6 +117,7 @@ tco = map inStmt where   inStmt stmt = case stmt of     JsVar name exp -> JsVar name (inject name exp)+    JsSetQName l name exp -> JsSetQName l name (inject (JsNameVar name) exp)     e -> e   inject name exp = case exp of     JsFun nm params [] (Just (JsNew JsThunk [JsFun _ [] stmts ret])) ->@@ -211,10 +209,11 @@ -- | Apply the given function to the top-level expressions in the -- given statement. applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt-applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where+applyToExpsInStmt funcs f = uncurryInStmt where   transform = f funcs   uncurryInStmt stmt = case stmt of     JsVar name exp              -> JsVar name <$> transform exp+    JsSetQName l name exp       -> JsSetQName l name <$> transform exp     JsEarlyReturn exp           -> JsEarlyReturn <$> transform exp     JsIf op ithen ielse         -> JsIf <$> transform op                                         <*> mapM uncurryInStmt ithen@@ -224,7 +223,7 @@ -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity] collectFuncs = (++ prim) . concatMap collectFunc where-  collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)]+  collectFunc (JsSetQName _ name exp) | arity > 0 = [(name,arity)]     where arity = expArity exp   collectFunc _ = []   prim = map (first (Qual () (ModuleName () "Fay$"))) (unary ++ binary)@@ -245,6 +244,8 @@     funBinding stmt = case stmt of       JsVar (JsNameVar name) body         | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body+      JsSetQName l name body+        | name == qname -> JsSetQName l (renameUncurried name) <$> uncurryIt body       _ -> Nothing      uncurryIt = Just . go [] where
src/Fay/Compiler/Packages.hs view
@@ -1,32 +1,27 @@-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections     #-} -- | Dealing with Cabal packages in Fay's own special way.- module Fay.Compiler.Packages where -import           Fay.Compiler.Config-import           Fay.Control.Monad.Extra-import           Fay.System.Process.Extra-import           Fay.Types+import           Fay.Compiler.Prelude++import           Fay.Config import           Paths_fay -import           Control.Applicative-import           Control.Monad-import           Data.List-import           Data.Maybe import           Data.Version import           GHC.Paths import           System.Directory import           System.FilePath+import           System.Environment  -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources.-resolvePackages :: CompileConfig -> IO CompileConfig+resolvePackages :: Config -> IO Config resolvePackages config =   foldM resolvePackage config (configPackages config)  -- | Resolve package.-resolvePackage :: CompileConfig -> String -> IO CompileConfig+resolvePackage :: Config -> String -> IO Config resolvePackage config name = do   desc <- describePackage (configPackageConf config) name   case packageVersion desc of@@ -40,9 +35,12 @@       exists <- mapM doesSourceDirExist includes       if or exists          then return (addConfigDirectoryIncludes (map (Just nameVer,) includes) config)-         else error $ "unable to find (existing) package's share dir: " ++ name ++ "\n" ++-                      "tried: " ++ unlines includes ++ "\n" ++-                      "but none of them seem to have Haskell files in them."+         else error $ concat+                [ "unable to find (existing) package's share dir: ", name, "\n"+                , "tried: ", unlines includes, "\n"+                , "but none of them seem to have Haskell files in them.\n"+                , "If you are using a sandbox you need to specify the HASKELL_PACKAGE_SANDBOX environment variable or use --package-conf."+                ]  -- | Does a directory exist and does it contain any Haskell sources? doesSourceDirExist :: FilePath -> IO Bool@@ -57,12 +55,24 @@ -- | Describe the given package. describePackage :: Maybe FilePath -> String -> IO String describePackage db name = do-  result <- readAllFromProcess ghc_pkg args ""+  exists <- doesFileExist ghc_pkg+  stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL")+  let command = if exists+        then if (isInfixOf ".stack" ghc_pkg || stackInNixShell)+             then "stack"+             else ghc_pkg+        else "ghc-pkg"+      extraArgs = case command of+        "stack" -> ["exec","--","ghc-pkg"]+        _       -> []+      args = extraArgs ++ ["describe",name] ++ ["--expand-env-vars", "-v2"]+             ++ ["--package-db=" ++ db' | Just db' <- [db]]+  when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL")+  result <- readAllFromProcess command args ""+  when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1")   case result of-    Left  (err,_out) -> error $ "ghc-pkg describe error:\n" ++ err+    Left  (err,out) -> error $ "ghc-pkg describe error:\n" ++ err ++ "\n" ++ out     Right (_err,out) -> return out--  where args = ["describe",name] ++ ["-f" ++ db' | Just db' <- [db]]  -- | Get the package version from the package description. packageVersion :: String -> Maybe String
+ src/Fay/Compiler/Parse.hs view
@@ -0,0 +1,69 @@+module Fay.Compiler.Parse+  ( parseFay+  , defaultExtensions+  ) where++import           Language.Haskell.Exts++-- | Parse some Fay code.+parseFay :: Parseable ast => FilePath -> String -> ParseResult ast+parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP++-- | Apply incredibly simplistic CPP handling. It only recognizes the following:+--+-- > #if FAY+-- > #ifdef FAY+-- > #ifndef FAY+-- > #else+-- > #endif+--+-- Note that this implementation replaces all removed lines with blanks, so+-- that line numbers remain accurate.+applyCPP :: String -> String+applyCPP =+    unlines . loop NoCPP . lines+  where+    loop _ [] = []+    loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest+    loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest+    loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest+    loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest+    loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest+    loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest+    loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest++    toInclude NoCPP = True+    toInclude (CPPIf x state') = x && toInclude state'+    toInclude (CPPElse x state') = x && toInclude state'++-- | The CPP's parsing state.+data CPPState = NoCPP+              | CPPIf Bool CPPState+              | CPPElse Bool CPPState++-- | The parse mode for Fay.+parseMode :: ParseMode+parseMode = defaultParseMode+  { extensions = defaultExtensions+  , fixities = Just (preludeFixities ++ baseFixities)+  }++defaultExtensions :: [Extension]+defaultExtensions = map EnableExtension+  [EmptyDataDecls+  ,ExistentialQuantification+  ,FlexibleContexts+  ,FlexibleInstances+  ,GADTs+  ,ImplicitPrelude+  ,KindSignatures+  ,LambdaCase+  ,MultiWayIf+  ,NamedFieldPuns+  ,PackageImports+  ,RecordWildCards+  ,StandaloneDeriving+  ,TupleSections+  ,TypeFamilies+  ,TypeOperators+  ]
src/Fay/Compiler/Pattern.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -6,6 +6,8 @@  module Fay.Compiler.Pattern where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Misc import           Fay.Compiler.QName import           Fay.Exts.NoAnnotation           (unAnn)@@ -13,11 +15,10 @@ import qualified Fay.Exts.Scoped                 as S import           Fay.Types -import           Control.Applicative-import           Control.Monad.Error-import           Control.Monad.Reader-import           Language.Haskell.Exts.Annotated-import           Language.Haskell.Names+import           Control.Monad.Except            (throwError)+import           Control.Monad.Reader            (ask)+import           Language.Haskell.Exts hiding (name)+import           Language.Haskell.Names          (NameInfo (RecPatWildcard), Scoped (Scoped))  -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]@@ -26,17 +27,17 @@   PApp _ cons pats  -> do     newty <- lookupNewtypeConst cons     case newty of-      Nothing -> compilePApp cons pats exp body+      Nothing -> compilePApp pat cons pats exp body       Just _  -> compileNewtypePat pats exp body-  PLit _ literal    -> compilePLit exp literal body-  PParen{}          -> shouldBeDesugared pat+  PLit _ sign lit   -> compilePLit exp sign lit body   PWildCard _       -> return body-  pat@PInfixApp{}   -> compileInfixPat exp pat body   PList _ pats      -> compilePList pats body exp   PTuple _ _bx pats -> compilePList pats body exp-  PAsPat _ name pat -> compilePAsPat exp name pat body+  PAsPat _ name pt  -> compilePAsPat exp name pt body   PRec _ name pats  -> compilePatFields exp name pats body-  pat               -> throwError (UnsupportedPattern pat)+  PParen{}          -> shouldBeDesugared pat+  PInfixApp{}       -> shouldBeDesugared pat+  _                 -> throwError (UnsupportedPattern pat)  -- | Compile a pattern variable e.g. x. compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt]@@ -46,7 +47,7 @@ -- | Compile a record field pattern. compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do-  c <- liftM (++ body) (compilePats' [] pats)+  c <- (++ body) <$> compilePats' [] pats   qname <- unsafeResolveName name   return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]   where@@ -77,10 +78,10 @@         _ -> []  -- | Compile a literal value from a pattern match.-compilePLit :: JsExp -> S.Literal -> [JsStmt] -> Compile [JsStmt]-compilePLit exp literal body = do+compilePLit :: JsExp -> S.Sign -> S.Literal -> [JsStmt] -> Compile [JsStmt]+compilePLit exp sign literal body = do   c <- ask-  lit <- readerCompileLit c literal+  lit <- readerCompileLit c sign literal   return [JsIf (equalExps exp lit)                body                []]@@ -107,13 +108,26 @@ compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps  -- | Compile a pattern application.-compilePApp :: S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]-compilePApp cons pats exp body = do+compilePApp :: S.Pat -> S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePApp origPat cons pats exp body = do   let forcedExp = force exp   let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []]   case cons of     -- Special-casing on the booleans.     Special _ (UnitCon _) -> return (JsExpStmt forcedExp : body)+    Special _ Cons{} -> case pats of+      [left, right] ->+        withScopedTmpJsName $ \tmpName -> do+          let forcedList = JsName tmpName+              x = JsGetProp forcedList (JsNameVar "car")+              xs = JsGetProp forcedList (JsNameVar "cdr")+          rightMatch <- compilePat xs right body+          leftMatch <- compilePat x left rightMatch+          return [JsVar tmpName (force exp)+                 ,JsIf (JsInstanceOf forcedList (JsBuiltIn "Cons"))+                       leftMatch+                       []]+      _ -> throwError $ UnsupportedPattern origPat     UnQual _ (Ident _ "True")   -> boolIf True     UnQual _ (Ident _ "False")  -> boolIf False     -- Everything else, generic:@@ -123,8 +137,8 @@         Nothing -> error $ "Constructor '" ++ prettyPrint n ++ "' could not be resolved"         Just _ -> do           recordFields <- map (UnQual ()) <$> recToFields n-          substmts <- foldM (\body (field,pat) ->-                                 compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)+          substmts <- foldM (\bd (field,pat) ->+                                 compilePat (JsGetProp forcedExp (JsNameVar field)) pat bd)                       body                       (reverse (zip recordFields pats))           qcons <- unsafeResolveName cons@@ -138,30 +152,13 @@   return [JsIf (JsEq (force exp) JsNull) body []] compilePList pats body exp = do   let forcedExp = force exp-  stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index"))-                                                     [JsLit (JsInt i),forcedExp])-                                              pat-                                              body)+  stmts <- foldM (\bd (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index"))+                                                   [JsLit (JsInt i),forcedExp])+                                            pat+                                            bd)         body         (reverse (zip [0..] pats))   let patsLen = JsLit (JsInt (length pats))   return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen])                stmts                []]---- | Compile an infix pattern (e.g. cons and tuples.)-compileInfixPat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]-compileInfixPat exp pat@(PInfixApp _ left (Special _ cons) right) body = case cons of-  Cons _ ->-    withScopedTmpJsName $ \tmpName -> do-      let forcedExp = JsName tmpName-          x = JsGetProp forcedExp (JsNameVar "car")-          xs = JsGetProp forcedExp (JsNameVar "cdr")-      rightMatch <- compilePat xs right body-      leftMatch <- compilePat x left rightMatch-      return [JsVar tmpName (force exp)-             ,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons"))-                   leftMatch-                   []]-  _ -> throwError (UnsupportedPattern pat)-compileInfixPat _ pat _ = throwError (UnsupportedPattern pat)
+ src/Fay/Compiler/Prelude.hs view
@@ -0,0 +1,67 @@+-- | Re-exports of base functionality. Note that this module is just+-- used inside the compiler. It's not compiled to JavaScript.+-- Based on the base-extended package (c) 2013 Simon Meier, licensed as BSD3.+{-# LANGUAGE NoImplicitPrelude #-}+module Fay.Compiler.Prelude+  ( module Prelude.Compat -- Partial++  -- * Control modules+  , module Control.Applicative+  , module Control.Arrow -- Partial+  , module Control.Monad.Compat++  -- * Data modules+  , module Data.Char -- Partial+  , module Data.Data -- Partial+  , module Data.Either+  , module Data.Function+  , module Data.List.Compat -- Partial+  , module Data.Maybe+  , module Data.Monoid -- Partial+  , module Data.Ord+  , module Data.Traversable++  -- * Safe+  , module Safe++  -- * Additions+  , anyM+  , io+  , readAllFromProcess+  ) where++import           Control.Applicative+import           Control.Arrow        (first, second, (&&&), (***), (+++), (|||))+import           Control.Monad.Compat hiding (guard)+import           Data.Char            hiding (GeneralCategory (..))+import           Data.Data            (Data (..), Typeable)+import           Data.Either+import           Data.Function        (on)+import           Data.List.Compat+import           Data.Maybe+import           Data.Monoid          (Monoid (..))+import           Data.Ord+import           Data.Traversable+import           Prelude.Compat       hiding (exp, mod)+import           Safe++import           Control.Monad.Except hiding (filterM)+import           System.Exit+import           System.Process++-- | Alias of liftIO, I hate typing it. Hate reading it.+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Do any of the (monadic) predicates match?+anyM :: (Functor m, Applicative m, Monad m) => (a -> m Bool) -> [a] -> m Bool+anyM p l = not . null <$> filterM p l++-- | Read from a process returning both std err and out.+readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String))+readAllFromProcess program flags input = do+  (code,out,err) <- readProcessWithExitCode program flags input+  return $ case code of+    ExitFailure 127 -> Left ("cannot find executable " ++ program, "")+    ExitFailure _   -> Left (err, out)+    ExitSuccess     -> Right (err, out)
src/Fay/Compiler/PrimOp.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns      #-} @@ -21,13 +22,14 @@   , resolvePrimOp   ) where +import           Fay.Compiler.Prelude+ import           Fay.Exts.NoAnnotation           (unAnn) import qualified Fay.Exts.NoAnnotation           as N  import           Data.Map                        (Map) import qualified Data.Map                        as M-import           Language.Haskell.Exts.Annotated hiding (binds, name)-import           Prelude                         hiding (mod)+import           Language.Haskell.Exts  -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a
src/Fay/Compiler/Print.hs view
@@ -1,214 +1,200 @@-{-# OPTIONS -fno-warn-orphans        #-}-{-# OPTIONS -fno-warn-unused-do-bind #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns         #-}---- | Simple code (non-pretty) printing.------ No clever printing is done here. If you want pretty printing, use a--- JS pretty printer. The output should be passed directly to a JS--- compressor, anyway.+{-# OPTIONS -fno-warn-orphans     #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Code printers. Can be used to produce both pretty and not+-- pretty output. -- -- Special constructors and symbols in Haskell are encoded to -- JavaScript appropriately.- module Fay.Compiler.Print where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.PrimOp-import qualified Fay.Exts.NoAnnotation                  as N import           Fay.Types -import           Control.Monad-import           Control.Monad.State-import           Data.Aeson.Encode-import qualified Data.ByteString.Lazy.UTF8              as UTF8-import           Data.Default-import           Data.List-import           Data.String-import           Language.Haskell.Exts.Annotated-import           Prelude                                hiding (exp)-import           SourceMap.Types+import           Data.Aeson+import qualified Data.ByteString.Lazy.UTF8       as UTF8+import           Language.Haskell.Exts hiding (alt, name, op, sym)  -------------------------------------------------------------------------------- -- Printing  -- | Print the JS to a flat string. printJSString :: Printable a => a -> String-printJSString x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def+printJSString x = pwOutputString (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)) def { psPretty = True }+printJSPretty x = pwOutputString (execPrinter (printJS x) defaultPrintReader{ prPretty = True }) --- | Print literals. These need some special encoding for--- JS-format literals. Could use the Text.JSON library.+-- | Encode String to JS-format lterals. Could use the+-- Text.JSON library.+toJsStringLit :: String -> String+toJsStringLit = UTF8.toString . encode++-- | Print literals. instance Printable JsLit where-  printJS typ = write $-    let u8 = UTF8.toString . encode . UTF8.fromString-    in case typ of-      (JsChar char)    -> u8 [char]-      (JsStr str)      -> u8 str+  printJS typ = write $ case typ of+      (JsChar char)    -> toJsStringLit [char]+      (JsStr str)      -> toJsStringLit str       (JsInt int)      -> show int       (JsFloating rat) -> show rat       (JsBool b)       -> if b then "true" else "false"  -- | Print (and properly encode to JS) a qualified name.-instance Printable N.QName where+instance Printable (QName l) where   printJS qname =     case qname of-      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" +> name-      Qual _ moduleName name -> moduleName +> "." +> name+      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" <> printJS name+      Qual _ moduleName name -> printJS moduleName <> printProp name       UnQual _ name -> printJS name       Special _ con -> printJS con +-- | Prints pretty operators.+-- prPrettyOperator flag determines the way of accessing operators (e.g. `($)`) and+-- identifiers with apostrophes (e.g. `length'`). If prPrettyOperators is set true,+-- then these will be accessed with square brackets (e.g. Prelude["$"] or+-- Prelude["length'"]). Otherwise special characters will be escaped and accessed+-- with dot (e.g. Prelude.$36$ or Prelude.length$39$). Alphanumeric_ identifiers are+-- always accessed with dot operator (e.g. Prelude.length)+printProp :: Name l -> Printer+printProp name = askIf prPrettyOperators pretty ugly+  where pretty = if all (`elem` allowedNameChars) nameString then dot else brackets+        ugly = dot+        dot = "." <> printJS name+        brackets = "[" <> write (toJsStringLit nameString) <> "]"+        nameString = case name of+          Ident _ s  -> s+          Symbol _ s -> s+ -- | Print module name.-instance Printable N.ModuleName where-  printJS (ModuleName _ "Fay$") =-    write "Fay$"+instance Printable (ModuleName l) where+  printJS (ModuleName _ "Fay$") = "Fay$"   printJS (ModuleName _ moduleName) = write $ go moduleName-     where go ('.':xs) = '.' : go xs           go (x:xs) = normalizeName [x] ++ go xs           go [] = [] +-- | Print (and properly encode) a name.+instance Printable (Name l) where+  printJS = write . encodeName++ -- | Print special constructors (tuples, list, etc.)-instance Printable N.SpecialCon where+instance Printable (SpecialCon l) where   printJS specialCon =     printJS $ fayBuiltin () $       case specialCon of         UnitCon _ -> "unit"         Cons    _ -> "cons"-        _       -> error $ "Special constructor not supported: " ++ show specialCon+        _         -> error $ "Special constructor not supported: " +++                   show (void specialCon) --- | Print (and properly encode) a name.-instance Printable N.Name where-  printJS name = write $-    case name of-      Ident  _ idn -> encodeName idn-      Symbol _ sym -> encodeName sym  -- | Print a list of statements.-instance Printable [JsStmt] where-  printJS = mapM_ printJS+printStmts :: [JsStmt] -> Printer+printStmts = mconcat . map printJS  -- | Print a single statement. instance Printable JsStmt where   printJS (JsExpStmt e) =-    printJS e +> ";" +> newline+    printJS e <> ";" <> newline   printJS (JsBlock stmts) =-    "{ " +> stmts +> "}"+    "{ " <> printStmts stmts <> "}"+  printJS (JsMapVar name expr) =+    "var " <> printJS name <> " : {[key: string]: any;} = " <> printJS expr <> ";" <> newline   printJS (JsVar name expr) =-    "var " +> name +> " = " +> expr +> ";" +> newline+    "var " <> printJS name <> " = " <> printJS expr <> ";" <> newline   printJS (JsUpdate name expr) =-    name +> " = " +> expr +> ";" +> newline+    printJS name <> " = " <> printJS 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 name <> "." <> printJS prop <> " = " <> printJS expr <> ";" <> newline+  printJS (JsSetQName msrcloc name expr) =+    maybe mempty mapping msrcloc <> printJS name <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetConstructor name expr) =-    printCons name +> " = " +> expr +> ";" +> newline +>+    printCons name <> " = " <> printJS expr <> ";" <> newline <>     -- The unqualifiedness here is bad.-    printCons name +> ".prototype.instance = \"" +> printConsUnQual name +> "\";" +> newline+    printCons name <> ".prototype.instance = \"" <> printConsUnQual name <> "\";" <> newline   printJS (JsSetModule mp expr) =-    mp +> " = " +> expr +> ";" +> newline+    printJS mp <> " = " <> printJS expr <> ";" <> newline   printJS (JsSetPropExtern name prop expr) =-    name +> "['" +> prop +> "'] = " +> expr +> ";" +> newline-  printJS (JsIf exp thens elses) =-    "if (" +> exp +> ") {" +> newline +>-    indented (printJS thens) +>-    "}" +>-    (when (length elses > 0) $ " else {" +>-    indented (printJS elses) +>-    "}") +> newline-  printJS (JsEarlyReturn exp) =-    "return " +> exp +> ";" +> newline-  printJS (JsThrow exp) = do-    "throw " +> exp +> ";" +> newline+    printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ";" <> newline+  printJS (JsIf expr thens elses) =+    "if (" <> printJS expr <> ") {" <> newline <>+    indented (printStmts thens) <>+    "}" <>+    (if null elses+      then mempty+      else " else {" <> newline <>+           indented (printStmts elses) <>+           "}") <> newline+  printJS (JsEarlyReturn expr) =+    "return " <> printJS expr <> ";" <> newline+  printJS (JsThrow expr) =+    "throw " <> printJS expr <> ";" <> newline   printJS (JsWhile cond stmts) =-    "while (" +> cond +> ") {"  +> newline +>-    indented (printJS stmts) +>-    "}" +> newline-  printJS JsContinue =-    printJS "continue;" +> newline+    "while (" <> printJS cond <> ") {" <> newline <>+    indented (printStmts stmts) <>+    "}" <> newline+  printJS JsContinue = "continue;" <> newline  -- | Print a module path. instance Printable ModulePath where-  printJS (unModulePath -> l) = write $ intercalate "." l+  printJS = write . intercalate "." . unModulePath  -- | 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) =-    "(function(){ throw (" +> exp +> "); })()"-  printJS JsNull =-    printJS "null"-  printJS JsUndefined =-    printJS "undefined"-  printJS (JsLit lit) =-    printJS lit-  printJS (JsParen exp) =-    "(" +> exp +> ")"-  printJS (JsList exps) =-    "[" +> intercalateM "," (map printJS exps) +> printJS "]"-  printJS (JsNew name args) =-    "new " +> (JsApp (JsName name) args)-  printJS (JsIndex i exp) =-    "(" +> exp +> ")[" +> show i +> "]"-  printJS (JsEq exp1 exp2) =-    exp1 +> " === " +> exp2-  printJS (JsNeq exp1 exp2) =-    exp1 +> " !== " +> exp2-  printJS (JsGetProp exp prop) = exp +> "." +> prop-  printJS (JsLookup exp1 exp2) =-    exp1 +> "[" +> exp2 +> "]"+  printJS (JsThrowExp expr) = "(function(){ throw (" <> printJS expr <> "); })()"+  printJS JsNull = "null"+  printJS JsUndefined = "undefined"+  printJS (JsLit lit) = printJS lit+  printJS (JsParen expr) = "(" <> printJS expr <> ")"+  printJS (JsList exprs) = "[" <> mintercalate "," (map printJS exprs) <> "]"+  printJS (JsNew name args) = "new " <> printJS (JsApp (JsName name) args)+  printJS (JsIndex i expr) = "(" <> printJS expr <> ")[" <> write (show i) <> "]"+  printJS (JsEq expr1 expr2) = printJS expr1 <> " === " <> printJS expr2+  printJS (JsNeq expr1 expr2) = printJS expr1 <> " !== " <> printJS expr2+  printJS (JsGetProp expr prop) = printJS expr <> "." <> printJS prop+  printJS (JsLookup expr1 expr2) = printJS expr1 <> "[" <> printJS expr2 <> "]"   printJS (JsUpdateProp name prop expr) =-    "(" +> name +> "." +> prop +> " = " +> expr +> ")"-  printJS (JsInfix op x y) =-    x +> " " +> op +> " " +> y-  printJS (JsGetPropExtern exp prop) =-    exp +> "[" +> (JsLit . JsStr) prop +> "]"+    "(" <> printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ")"+  printJS (JsInfix op x y) = printJS x <> " " <> write op <> " " <> printJS y+  printJS (JsGetPropExtern expr prop) =+    printJS expr <> "[" <> write (toJsStringLit prop) <> "]"   printJS (JsUpdatePropExtern name prop expr) =-    "(" +> name +> "['" +> prop +> "'] = " +> expr +> ")"+    "(" <> printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ")"   printJS (JsTernaryIf cond conseq alt) =-    cond +> " ? " +> conseq +> " : " +> alt-  printJS (JsInstanceOf exp classname) =-    exp +> " instanceof " +> classname+    printJS cond <> " ? " <> printJS conseq <> " : " <> printJS alt+  printJS (JsInstanceOf expr classname) =+    printJS expr <> " instanceof " <> printJS classname   printJS (JsObj assoc) =-    "{" +> (intercalateM "," (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) = write (toJsStringLit key) <> ": " <> printJS value+  printJS (JsLitObj assoc) = "{" <> mintercalate "," (map cons assoc) <> "}"+      where cons (key,value) = "\"" <> printJS key <> ": " <> printJS value   printJS (JsFun nm params stmts ret) =        "function"-    +> maybe (return ()) ((" " +>) . printJS . ident) nm-    +> "("-    +> (intercalateM "," (map printJS params))-    +> "){" +> newline-    +> indented (stmts +>+    <> maybe mempty ((" " <>) . printJS . ident) nm+    <> "("+    <> mintercalate "," (map printJS params)+    <> "){" <> newline+    <> indented (printStmts stmts <>                  case ret of-                   Just ret' -> "return " +> ret' +> ";" +> newline-                   Nothing   -> return ())-    +> "}"+                   Just ret' -> "return " <> printJS ret' <> ";" <> newline+                   Nothing   -> mempty)+    <> "}"   printJS (JsApp op args) =-    (if isFunc op then JsParen op else op)-    +> "("-    +> (intercalateM "," (map printJS args))-    +> ")"-     where isFunc JsFun{..} = True; isFunc _ = False-  printJS (JsNegApp args) =-      "(-(" +> printJS args +> "))"-  printJS (JsAnd a b) =-      printJS a +> "&&" +> printJS b-  printJS (JsOr a b) =-      printJS a +> "||" +> printJS b+    printJS (case op of JsFun {} -> JsParen op; _ -> op)+    <> "("+    <> mintercalate "," (map printJS args)+    <> ")"+  printJS (JsNegApp args) = "(-(" <> printJS args <> "))"+  printJS (JsAnd a b) = printJS a <> "&&" <> printJS b+  printJS (JsOr a b) = printJS a <> "||" <> printJS b  -- | Unqualify a JsName. ident :: JsName -> JsName@@ -221,40 +207,32 @@   printJS name =     case name of       JsNameVar qname     -> printJS qname-      JsThis              -> write "this"-      JsThunk             -> write "Fay$$$"-      JsForce             -> write "Fay$$_"-      JsApply             -> write "Fay$$__"-      JsParam i           -> write ("$p" ++ show i)-      JsTmp i             -> write ("$tmp" ++ show i)+      JsThis              -> "this"+      JsThunk             -> askIf prPrettyThunks "$" "Fay$$$"+      JsForce             -> askIf prPrettyThunks "_" "Fay$$_"+      JsApply             -> askIf prPrettyThunks "__" "Fay$$__"+      JsParam i           -> "$p" <> write (show i)+      JsTmp i             -> "$tmp" <> write (show i)       JsConstructor qname -> printCons qname-      JsBuiltIn qname     -> "Fay$$" +> printJS qname-      JsParametrizedType  -> write "type"+      JsBuiltIn qname     -> "Fay$$" <> printJS qname+      JsParametrizedType  -> "type"       JsModuleName (ModuleName _ m) -> write m  -- | Print a constructor name given a QName.-printCons :: N.QName -> Printer ()+printCons :: QName l -> Printer printCons (UnQual _ n) = printConsName n-printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n-printCons (Special {}) = error "qname2String Special"+printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n+printCons Special {} = error "qname2String Special"  -- | Print an unqualified name.-printConsUnQual :: N.QName -> Printer ()+printConsUnQual :: QName l -> Printer printConsUnQual (UnQual _ x) = printJS x printConsUnQual (Qual _ _ n) = printJS n-printConsUnQual (Special {}) = error "printConsUnqual Special"+printConsUnQual Special {} = error "printConsUnqual Special"  -- | Print a constructor name given a Name. Helper for printCons.-printConsName :: N.Name -> Printer ()-printConsName n = write "_" >> printJS n---- | Just write out strings.-instance Printable String where-  printJS = write---- | A printer is a printable.-instance Printable (Printer ()) where-  printJS = id+printConsName :: Name l -> Printer+printConsName = ("_" <>) . printJS  -------------------------------------------------------------------------------- -- Name encoding@@ -276,91 +254,31 @@   -- The problem only occurs if there is a module A.B and a constructor B in module A.    ++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"] +allowedNameChars :: String+allowedNameChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"  -- | Encode a Haskell name to JavaScript.-encodeName :: String -> String+encodeName :: Name l -> String+ -- | This is a hack for names generated in the Haskell AST. Should be -- removed once it's no longer needed.-encodeName ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name-encodeName name-  | name `elem` reservedWords = "$_" ++ normalizeName name-  | otherwise                 = normalizeName name+encodeName n = case n of+                 (Ident  _ idn) -> encodeString idn+                 (Symbol _ sym) -> encodeString sym+  where encodeString ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name+        encodeString name+          | name `elem` reservedWords = "$_" ++ normalizeName name+          | otherwise                 = normalizeName name  -- | Normalize the given name to JavaScript-valid names. normalizeName :: String -> String-normalizeName name =-  concatMap encodeChar name-+normalizeName = concatMap encodeChar   where-    encodeChar c | c `elem` allowed = [c]-                 | otherwise        = escapeChar c-    allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+    encodeChar c | c `elem` allowedNameChars = [c]+                 | otherwise                 = escapeChar c     escapeChar c = "$" ++ charId c ++ "$"     charId c = show (fromEnum c) ------------------------------------------------------------------------------------- Printing----- | Print the given printer indented.-indented :: Printer a -> Printer ()-indented p = do-  PrintState{..} <- get-  if psPretty-     then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 }-             p-             modify $ \s -> s { psIndentLevel = psIndentLevel }-     else p >> return ()---- | Output a newline.-newline :: Printer ()-newline = do-  PrintState{..} <- get-  when psPretty $ do-    write "\n"-    modify $ \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-        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 ()-intercalateM _ [] = return ()-intercalateM _ [x] = x >> return ()-intercalateM str (x:xs) = do-  x-  write str-  intercalateM str xs---- | Concatenate two printables.-(+>) :: (Printable a, Printable b) => a -> b -> Printer ()-pa +> pb = printJS pa >> printJS pb+-- | Intercalate monoids.+mintercalate :: String -> [Printer] -> Printer+mintercalate str xs = mconcat $ intersperse (write str) xs
src/Fay/Compiler/QName.hs view
@@ -2,7 +2,7 @@  module Fay.Compiler.QName where -import           Language.Haskell.Exts.Annotated+import           Language.Haskell.Exts  -- | Extract the module name from a qualified name. qModName :: QName a -> Maybe (ModuleName a)
src/Fay/Compiler/State.hs view
@@ -12,7 +12,7 @@ import qualified Data.Map               as M import           Data.Set               (Set) import qualified Data.Set               as S-import           Language.Haskell.Names+import           Language.Haskell.Names (sv_origName, Symbols (Symbols), SymValueInfo (SymValue, SymMethod, SymSelector, SymConstructor), OrigName, sv_typeName)  -- | Get all non local identifiers that should be exported in the JS module scope. getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)@@ -40,10 +40,10 @@ -- | Is this *resolved* name a new type constructor or destructor? isNewtype :: SymValueInfo OrigName -> CompileState -> Bool isNewtype s cs = case s of-  SymValue{}                     -> False-  SymMethod{}                    -> False-  SymSelector    { sv_typeName } -> not . (`isNewtypeDest` cs) . origName2QName $ sv_typeName-  SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . origName2QName $ sv_typeName+  SymValue{}                          -> False+  SymMethod{}                         -> False+  SymSelector    { sv_typeName = tn } -> not . (`isNewtypeDest` cs) . origName2QName $ tn+  SymConstructor { sv_typeName = tn } -> not . (`isNewtypeCons` cs) . origName2QName $ tn  -- | Is this *resolved* name a new type destructor? isNewtypeDest :: N.QName -> CompileState -> Bool@@ -61,6 +61,6 @@ addedModulePath :: ModulePath -> CompileState -> Bool addedModulePath mp CompileState { stateJsModulePaths } = mp `S.member` stateJsModulePaths -+-- | Find the type signature of a top level name findTypeSig :: N.QName -> CompileState -> Maybe N.Type findTypeSig n  = M.lookup n . stateTypeSigs
src/Fay/Compiler/Typecheck.hs view
@@ -2,17 +2,20 @@  module Fay.Compiler.Typecheck where +import           Fay.Compiler.Prelude+ import           Fay.Compiler.Defaults import           Fay.Compiler.Misc-import           Fay.System.Process.Extra+import           Fay.Config import           Fay.Types -import           Data.List-import           Data.Maybe-import qualified GHC.Paths                as GHCPaths+import qualified GHC.Paths             as GHCPaths +import           System.Directory+import           System.Environment+ -- | Call out to GHC to type-check the file.-typecheck :: CompileConfig -> FilePath -> IO (Either CompileError String)+typecheck :: Config -> FilePath -> IO (Either CompileError String) typecheck cfg fp = do   faydir <- faySourceDir   let includes = configDirectoryIncludes cfg@@ -29,8 +32,7 @@         return [flag ++ '=' : pk]   let flags =           [ "-fno-code"-          , "-XNoImplicitPrelude"-          , "-hide-package base"+          , "-hide-all-packages"           , "-cpp", "-pgmPcpphs", "-optP--cpp"           , "-optP-C" -- Don't let hse-cpp remove //-style comments.           , "-DFAY=1"@@ -38,7 +40,21 @@           , "Language.Fay.DummyMain"           , "-i" ++ intercalate ":" includeDirs           , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages-  res <- readAllFromProcess GHCPaths.ghc flags ""+  exists <- doesFileExist GHCPaths.ghc+  stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL")+  let ghcPath = if exists+        then if (isInfixOf ".stack" GHCPaths.ghc || stackInNixShell)+             then "stack"+             else GHCPaths.ghc+        else "ghc"+      extraFlags = case ghcPath of+        "stack" -> ["exec","--","ghc"]+        _       -> []+  when (configShowGhcCalls cfg) $+    putStrLn . unwords $ ghcPath : (extraFlags ++ flags)+  when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL")+  res <- readAllFromProcess ghcPath (extraFlags ++ flags) ""+  when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1")   either (return . Left . GHCError . fst) (return . Right . fst) res    where     wallF | configWall cfg = ["-Wall"]
+ src/Fay/Config.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE NoImplicitPrelude #-}+-- | Configuring the compiler+module Fay.Config+  ( Config+      ( configOptimize+      , configFlattenApps+      , configExportRuntime+      , configExportStdlib+      , configExportStdlibOnly+      , configPrettyPrint+      , configHtmlWrapper+      , configSourceMap+      , configHtmlJSLibs+      , configLibrary+      , configWarn+      , configFilePath+      , configTypecheck+      , configWall+      , configGClosure+      , configPackageConf+      , configBasePath+      , configStrict+      , configTypecheckOnly+      , configRuntimePath+      , configOptimizeNewtypes+      , configPrettyThunks+      , configPrettyOperators+      , configShowGhcCalls+      , configTypeScript+      )+  , defaultConfig+  , defaultConfigWithSandbox+  , configDirectoryIncludes+  , configDirectoryIncludePaths+  , nonPackageConfigDirectoryIncludePaths+  , addConfigDirectoryInclude+  , addConfigDirectoryIncludes+  , addConfigDirectoryIncludePaths+  , configPackages+  , addConfigPackage+  , addConfigPackages+  , shouldExportStrictWrapper+  ) where++import           Fay.Compiler.Prelude++import           Data.Default+import           Data.Maybe                      ()+import           Language.Haskell.Exts (ModuleName (..))+import           System.Environment++-- | Configuration of the compiler.+-- The fields with a leading underscore+data Config = Config+  { configOptimize           :: Bool                        -- ^ Run optimizations+  , configFlattenApps        :: Bool                        -- ^ Flatten function application?+  , configExportRuntime      :: Bool                        -- ^ Export the runtime?+  , configExportStdlib       :: Bool                        -- ^ Export the stdlib?+  , configExportStdlibOnly   :: Bool                        -- ^ Export /only/ the stdlib?+  , _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.+  , configFilePath           :: Maybe FilePath              -- ^ File path to output to.+  , configTypecheck          :: Bool                        -- ^ Typecheck with GHC.+  , configWall               :: Bool                        -- ^ Typecheck with -Wall.+  , configGClosure           :: Bool                        -- ^ Run Google Closure on the produced JS.+  , configPackageConf        :: Maybe FilePath              -- ^ The package config e.g. packages-6.12.3.+  , _configPackages          :: [String]                    -- ^ Included Fay packages.+  , configBasePath           :: Maybe FilePath              -- ^ Custom source location for fay-base+  , configStrict             :: [String]                    -- ^ Produce strict and uncurried JavaScript callable wrappers for all+                                                            --   exported functions with type signatures in the given module+  , 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?+  , configPrettyOperators    :: Bool                        -- ^ Use pretty operators?+  , configShowGhcCalls       :: Bool                        -- ^ Print commands sent to GHC?+  , configTypeScript         :: Bool                        -- ^ Output a TypeScript file.+  } deriving (Show)++defaultConfig :: Config+defaultConfig = addConfigPackage "fay-base"+  Config+    { configOptimize           = False+    , configFlattenApps        = False+    , configExportRuntime      = True+    , configExportStdlib       = True+    , configExportStdlibOnly   = False+    , _configDirectoryIncludes = []+    , configPrettyPrint        = False+    , configHtmlWrapper        = False+    , configHtmlJSLibs         = []+    , configLibrary            = False+    , configWarn               = True+    , configFilePath           = Nothing+    , configTypecheck          = True+    , configWall               = False+    , configGClosure           = False+    , configPackageConf        = Nothing+    , _configPackages          = []+    , configBasePath           = Nothing+    , configStrict             = []+    , configTypecheckOnly      = False+    , configRuntimePath        = Nothing+    , configSourceMap          = False+    , configOptimizeNewtypes   = True+    , configPrettyThunks       = False+    , configPrettyOperators    = False+    , configShowGhcCalls       = False+    , configTypeScript         = False+    }++defaultConfigWithSandbox :: IO Config+defaultConfigWithSandbox = do+  packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  return defaultConfig { configPackageConf = packageConf }++-- | Default configuration.+instance Default Config where+  def = defaultConfig++-- | Reading _configDirectoryIncludes is safe to do.+configDirectoryIncludes :: Config -> [(Maybe String, FilePath)]+configDirectoryIncludes = _configDirectoryIncludes++-- | Get all include directories without the package mapping.+configDirectoryIncludePaths :: Config -> [FilePath]+configDirectoryIncludePaths = map snd . _configDirectoryIncludes++-- | Get all include directories not included through packages.+nonPackageConfigDirectoryIncludePaths :: Config -> [FilePath]+nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . _configDirectoryIncludes++-- | Add a mapping from (maybe) a package to a source directory+addConfigDirectoryInclude :: Maybe String -> FilePath -> Config -> Config+addConfigDirectoryInclude pkg fp cfg = cfg { _configDirectoryIncludes = (pkg, fp) : _configDirectoryIncludes cfg }++-- | Add several include directories.+addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> Config -> Config+addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps++-- | Add several include directories without package references.+addConfigDirectoryIncludePaths :: [FilePath] -> Config -> Config+addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps++-- | Reading _configPackages is safe to do.+configPackages :: Config -> [String]+configPackages = _configPackages++-- | Add a package to compilation+addConfigPackage :: String -> Config -> Config+addConfigPackage pkg cfg = cfg { _configPackages = pkg : _configPackages cfg }++-- | Add several packages to compilation+addConfigPackages :: [String] -> Config -> Config+addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps+++-- | Should a strict wrapper be generated for this module?+shouldExportStrictWrapper :: ModuleName a -> Config -> Bool+shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs
− src/Fay/Control/Monad/Extra.hs 
@@ -1,31 +0,0 @@--- | Extra monadic functions.--module Fay.Control.Monad.Extra where--import           Control.Monad-import           Data.Maybe---- | Word version of flip (>>=).-bind :: (Monad m) => (a -> m b) -> m a -> m b-bind = flip (>>=)---- | When the value is Just.-whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) m = m a-whenJust Nothing  _ = return ()---- | Wrap up a form in a Maybe.-just :: Functor m => m a -> m (Maybe a)-just = fmap Just---- | Flip of mapMaybe.-forMaybe :: [a] -> (a -> Maybe b) -> [b]-forMaybe = flip mapMaybe---- | Monadic version of maybe.-maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a-maybeM nil cons a = maybe (return nil) cons a---- | Do any of the (monadic) predicates match?-anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool-anyM p l = return . not . null =<< filterM p l
− src/Fay/Control/Monad/IO.hs 
@@ -1,9 +0,0 @@--- | Alias of MonadIO.--module Fay.Control.Monad.IO where--import           Control.Monad.Trans---- | Alias of liftIO, I hate typing it. Hate reading it.-io :: MonadIO m => IO a -> m a-io = liftIO
src/Fay/Convert.hs view
@@ -1,234 +1,252 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE PatternGuards      #-}-{-# LANGUAGE TupleSections      #-}-{-# OPTIONS -fno-warn-type-defaults #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE PatternGuards       #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}  -- | Convert a Haskell value to a (JSON representation of a) Fay value.  module Fay.Convert   (showToFay-  ,readFromFay)+  ,readFromFay+  ,readFromFay'+  ,encodeFay+  ,decodeFay)   where -import           Control.Applicative-import           Control.Monad-import           Control.Monad.State+import           Fay.Compiler.Prelude++import           Control.Monad.State   (evalStateT, get, lift, put)+import           Control.Spoon import           Data.Aeson-import           Data.Attoparsec.Number-import           Data.Char+import           Data.Aeson.Types      (parseEither) import           Data.Data-import           Data.Function import           Data.Generics.Aliases-import           Data.HashMap.Strict    (HashMap)-import qualified Data.HashMap.Strict    as Map-import           Data.Maybe-import           Data.Text              (Text)-import qualified Data.Text              as Text-import           Data.Vector            (Vector)-import qualified Data.Vector            as Vector-import           Numeric-import           Safe-import qualified Text.Show.Pretty       as Show+import           Data.HashMap.Strict   (HashMap)+import qualified Data.HashMap.Strict   as Map+import           Data.Text             (Text)+import qualified Data.Text             as Text+import           Data.Time.Clock       (UTCTime)+import           Data.Vector           (Vector)+import qualified Data.Vector           as Vector  -------------------------------------------------------------------------------- -- The conversion functions. --- | Convert a Haskell value to a value representing a Fay value.-showToFay :: Show a => a -> Maybe Value-showToFay = Show.reify >=> convert where-  convert value = case value of-    -- Special cases-    Show.Con "True" _    -> return (Bool True)-    Show.Con "False" _   -> return (Bool False)--    -- Objects/records-    Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :))-                                 (slots values)-    Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :))-                                 (mapM (uncurry keyval) fields)-    Show.InfixCons _ _ -> Nothing -- TODO https://github.com/faylang/fay/issues/316--    -- ()-    Show.Tuple [] -> return Null--    -- List types-    Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values)-    Show.List values  -> fmap (Array . Vector.fromList) (mapM convert values)--    -- Text types-    Show.String chars -> fmap string (readMay chars)-    Show.Char char    -> fmap (string.return) (readMay char)+-- | Convert a Haskell value to a Fay json value.  This can fail when primitive+--   values aren't handled by explicit cases.  'encodeFay' can be used to+--   resolve this issue.+showToFay :: Data a => a -> Maybe Value+showToFay = spoon . encodeFay id -    -- Numeric types (everything treated as a double)-    Show.Neg{}     -> double <|> int-    Show.Integer{} -> int-    Show.Float{}   -> double-    Show.Ratio{}   -> double-    where double = convertDouble value-          int = convertInt value+-- | Convert a Haskell value to a Fay json value.  This can fail when primitive+--   values aren't handled by explicit cases.  When this happens, you can add+--   additional cases via the first parameter.+--+--   The first parameter is a function that can be used to override the+--   conversion.  This usually looks like using 'extQ' to additional type-+--   specific cases.+encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value+encodeFay specialCases = specialCases $+    encodeGeneric rec+    `extQ` unit+    `extQ` Bool+    `extQ` (toJSON :: Int -> Value)+    `extQ` (toJSON :: Float -> Value)+    `extQ` (toJSON :: Double -> Value)+    `extQ` (toJSON :: UTCTime -> Value)+    `ext1Q` list+    `extQ` string+    `extQ` char+    `extQ` text+  where+    rec :: GenericQ Value+    rec = encodeFay specialCases+    unit () = Null+    list :: Data a => [a] -> Value+    list = Array . Vector.fromList . map rec+    string = String . Text.pack+    char = String . Text.pack . (:[])+    text = String -  -- Number converters-  convertDouble = fmap (Number . D) . pDouble-  convertInt = fmap (Number . I) . pInt+encodeGeneric :: GenericQ Value -> GenericQ Value+encodeGeneric rec x =+    case constrName of+      '(':(dropWhile (==',') -> ")") ->+        Array $ Vector.fromList $ gmapQ rec x+      _ -> Object $ Map.fromList $ map (first Text.pack) fields+  where+    fields =+      ("instance", String $ Text.pack constrName) :+      zip labels (gmapQ rec x)+    constrName = showConstr constr+    constr = toConstr x+    -- Note: constrFields can throw errors for non-algebraic datatypes.  These+    -- ought to be taken care of in the other cases of encodeFay.+    labels = case constrFields constr of+      [] -> map (("slot"++).show) [1::Int ..]+      ls -> ls -  -- Number parsers-  pDouble :: Show.Value -> Maybe Double-  pDouble value = case value of-    Show.Float str   -> getDouble str-    Show.Ratio x y   -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y)-    Show.Neg str     -> fmap (* (-1)) (pDouble str)-    _ -> Nothing-  pInt value = case value of-    Show.Integer str -> getInt str-    Show.Neg str     -> fmap (* (-1)) (pInt str)-    _ -> Nothing+-- | Convert a Fay json value to a Haskell value.+readFromFay :: Data a => Value -> Maybe a+readFromFay = either (const Nothing) Just . decodeFay (const id) -  -- Number readers-  getDouble :: String -> Maybe Double-  getDouble = fmap fst . listToMaybe . readFloat-  getInt :: String -> Maybe Integer-  getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt-    where charToInt c = fromEnum c - fromEnum '0'+-- | Convert a Fay json value to a Haskell value.  This is like readFromFay,+--   except it yields helpful error messages on failure.+readFromFay' :: Data a => Value -> Either String a+readFromFay' = decodeFay (const id) -  -- Utilities-  string = String . Text.pack-  slots = zipWithM keyval (map (("slot"++).show) [1::Int ..])-  keyval key val = fmap (Text.pack key,) (convert val)+-- | Convert a Fay json value to a Haskell value.+--+--   The first parameter is a function that can be used to override the+--   conversion.  This usually looks like using 'extR' to additional type-+--   specific cases.+decodeFay :: Data b+          => (forall a. Data a => Value -> Either String a -> Either String a)+          -> Value+          -> Either String b+decodeFay specialCases value = specialCases value $+    parseDataOrTuple rec value+    `extR` parseUnit value+    `extR` parseBool value+    `extR` parseInt value+    `extR` parseFloat value+    `extR` parseDouble value+    `ext1R` parseArray rec value+    `extR` parseUTCTime value+    `extR` parseString value+    `extR` parseChar value+    `extR` parseText value+  where+    rec :: GenericParser+    rec = decodeFay specialCases --- | Convert a value representing a Fay value to a Haskell value.-readFromFay :: Data a => Value -> Maybe a-readFromFay value =-  parseDataOrTuple value-  `ext1R` parseArray value-  `extR` parseDouble value-  `extR` parseInt value-  `extR` parseInteger value-  `extR` parseBool value-  `extR` parseString value-  `extR` parseChar value-  `extR` parseText value-  `extR` parseUnit value+type GenericParser = forall a. Data a => Value -> Either String a  -- | Parse a data type or record or tuple.-parseDataOrTuple :: Data a => Value -> Maybe a-parseDataOrTuple value = result where+parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a+parseDataOrTuple rec value = result where   result = getAndParse value-  typ = dataTypeOf (fromJust result)+  typ = dataTypeOf (undefined :: a)   getAndParse x =     case x of-      Object obj -> parseObject typ obj-      Array tuple -> parseTuple typ tuple-      _ -> mzero+      Object obj -> parseObject rec typ obj+      Array tuple -> parseTuple rec typ tuple+      _ -> badData value  -- | Parse a tuple.-parseTuple :: Data a => DataType -> Vector Value -> Maybe a-parseTuple typ arr =+parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a+parseTuple rec typ arr =   case dataTypeConstrs typ of-    [cons] -> evalStateT (fromConstrM (do i:next <- get+    [cons] -> evalStateT (fromConstrM (do ~(i:next) <- get                                           put next                                           value <- lift (Vector.indexM arr i)-                                          lift (readFromFay value))+                                          lift (rec value))                                       cons)                          [0..]-    _ -> Nothing+    _ -> badData (Array arr)  -- | Parse a data constructor from an object.-parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a-parseObject typ obj = listToMaybe (catMaybes choices) where-  choices = map makeConstructor constructors-  constructors = dataTypeConstrs typ-  makeConstructor cons = do-    name <- Map.lookup (Text.pack "instance") obj >>= parseString-    guard (showConstr cons == name)-    if null fields-      then makeSimple obj cons-      else makeRecord obj cons fields--      where fields = constrFields cons+parseObject :: Data a => GenericParser -> DataType -> HashMap Text Value -> Either String a+parseObject rec typ obj =+  case Map.lookup (Text.pack "instance") obj of+    Just (parseString -> Right name) ->+      case filter (\con -> showConstr con == name) (dataTypeConstrs typ) of+        [con] ->+          let fields = constrFields con+           in if null fields+                then makeSimple rec obj con+                else makeRecord rec obj con fields+        _ -> badData (Object obj)+    _ -> badData (Object obj)  -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2-makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a-makeSimple obj cons =-  evalStateT (fromConstrM (do i:next <- get+makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a+makeSimple rec obj cons =+  evalStateT (fromConstrM (do ~(i:next) <- get                               put next-                              value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj)-                              lift (readFromFay value))+                              value <- lift (lookupField obj (Text.pack ("slot" ++ show i)))+                              lift (rec value))                           cons)-             [1..]+             [(1::Integer)..]  -- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 }-makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a-makeRecord obj cons fields =-  evalStateT (fromConstrM (do key:next <- get-                              put next-                              value <- lift (Map.lookup (Text.pack key) obj)-                              lift (readFromFay value))-                          cons)-             fields+makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a+makeRecord rec obj cons =+  evalStateT $+    fromConstrM+      (do ~(key:next) <- get+          put next+          value <- lift (lookupField obj (Text.pack key))+          lift $ rec value)+      cons --- | Parse a double.-parseDouble :: Value -> Maybe Double-parseDouble value = do-  number <- parseNumber value-  case number of-    I n -> return (fromIntegral n)-    D n -> return n+lookupField :: HashMap Text Value -> Text -> Either String Value+lookupField obj key =+  justRight ("Missing field " ++ Text.unpack key ++ " in " ++ show (Object obj)) $+  Map.lookup key obj --- | Parse an int.-parseInt :: Value -> Maybe Int-parseInt value = do-  number <- parseNumber value-  case number of-    I n -> return (fromIntegral n)-    _ -> mzero+-- | Parse a float.+parseFloat :: Value -> Either String Float+parseFloat = parseEither parseJSON --- | Parse an integer.-parseInteger :: Value -> Maybe Integer-parseInteger value = do-  number <- parseNumber value-  case number of-    I n -> return n-    _ -> mzero+-- | Parse a double.+parseDouble :: Value -> Either String Double+parseDouble = parseEither parseJSON --- | Parse a number.-parseNumber :: Value -> Maybe Number-parseNumber value = case value of-  Number n -> return n-  _ -> mzero+-- | Parse an int.+parseInt :: Value -> Either String Int+parseInt = parseEither parseJSON  -- | Parse a bool.-parseBool :: Value -> Maybe Bool+parseBool :: Value -> Either String Bool parseBool value = case value of   Bool n -> return n-  _ -> mzero+  _ -> badData value  -- | Parse a string.-parseString :: Value -> Maybe String+parseString :: Value -> Either String String parseString value = case value of   String s -> return (Text.unpack s)-  _ -> mzero+  _ -> badData value +parseUTCTime :: Value -> Either String UTCTime+parseUTCTime value = case fromJSON value of+  Success t -> Right t+  Error _   -> badData value+ -- | Parse a char.-parseChar :: Value -> Maybe Char+parseChar :: Value -> Either String Char parseChar value = case value of   String s | Just (c,_) <- Text.uncons s -> return c-  _ -> mzero+  _ -> badData value  -- | Parse a Text.-parseText :: Value -> Maybe Text+parseText :: Value -> Either String Text parseText value = case value of   String s -> return s-  _ -> mzero+  _ -> badData value  -- | Parse an array.-parseArray :: Data a => Value -> Maybe [a]-parseArray value = case value of-  Array xs -> mapM readFromFay (Vector.toList xs)-  _ -> mzero+parseArray :: Data a => GenericParser -> Value -> Either String [a]+parseArray rec value = case value of+  Array xs -> mapM rec (Vector.toList xs)+  _ -> badData value  -- | Parse unit.-parseUnit :: Value -> Maybe ()+parseUnit :: Value -> Either String () parseUnit value = case value of   Null -> return ()-  _ -> mzero+  _ -> badData value++badData :: forall a. Data a => Value -> Either String a+badData value = Left $+  "Bad data in decodeFay - expected valid " +++  show (typeOf (undefined :: a)) +++  ", but got:\n" +++  show value++justRight :: b -> Maybe a -> Either b a+justRight x Nothing = Left x+justRight _ (Just y) = Right y
− src/Fay/Data/List/Extra.hs 
@@ -1,14 +0,0 @@--- | Extra list functions.--module Fay.Data.List.Extra where--import           Data.List hiding (map)-import           Prelude   hiding (map)---- | Get the union of a list of lists.-unionOf :: (Eq a) => [[a]] -> [a]-unionOf = foldr union []---- | Flip of map.-for :: (Functor f) => f a -> (a -> b) -> f b-for = flip fmap
src/Fay/Exts.hs view
@@ -1,6 +1,6 @@ module Fay.Exts where -import qualified Language.Haskell.Exts.Annotated as A+import qualified Language.Haskell.Exts as A  type X = A.SrcSpanInfo @@ -15,7 +15,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X-type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X@@ -46,7 +45,7 @@ moduleExports :: A.Module X -> Maybe (A.ExportSpecList X) moduleExports (A.Module _ (Just (A.ModuleHead _ _ _ e)) _ _ _) = e moduleExports (A.Module _ Nothing                     _ _ _) = Nothing-moduleExports m = error $ ("moduleExports: " ++ A.prettyPrint m)+moduleExports m = error $ "moduleExports: " ++ A.prettyPrint m  moduleNameString :: A.ModuleName t -> String moduleNameString (A.ModuleName _ n) = n@@ -57,7 +56,7 @@ noI :: A.SrcSpanInfo noI = A.noInfoSpan (A.mkSrcSpan A.noLoc A.noLoc) -convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.BangType a)+convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.Type a) convertFieldDecl (A.FieldDecl _ ns b) = (ns, b)  fieldDeclNames :: A.FieldDecl a -> [A.Name a]@@ -65,6 +64,7 @@  declHeadName :: A.DeclHead a -> A.Name a declHeadName d = case d of-  A.DHead _ n _ -> n-  A.DHInfix _ _ n _ -> n+  A.DHead _ n -> n+  A.DHInfix _ _ n -> n   A.DHParen _ h -> declHeadName h+  A.DHApp _ h _ -> declHeadName h
src/Fay/Exts/NoAnnotation.hs view
@@ -2,12 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} module Fay.Exts.NoAnnotation where +import           Fay.Compiler.Prelude -import           Data.Char                       (isAlpha)-import           Data.List                       (intercalate) import           Data.List.Split                 (splitOn) import           Data.String-import qualified Language.Haskell.Exts.Annotated as A+import qualified Language.Haskell.Exts as A  type Alt = A.Alt () type BangType = A.BangType ()@@ -20,7 +19,6 @@ type FieldDecl = A.FieldDecl () type FieldUpdate = A.FieldUpdate () type GadtDecl = A.GadtDecl ()-type GuardedAlts = A.GuardedAlts () type GuardedRhs = A.GuardedRhs () type ImportDecl = A.ImportDecl () type ImportSpec = A.ImportSpec ()@@ -37,6 +35,7 @@ type QualConDecl = A.QualConDecl () type QualStmt = A.QualStmt () type Rhs = A.Rhs ()+type Sign = A.Sign () type SpecialCon = A.SpecialCon () type SrcLoc = A.SrcLoc type SrcSpan = A.SrcSpan@@ -46,7 +45,7 @@ type Type = A.Type ()  unAnn :: Functor f => f a -> f ()-unAnn = fmap (const ())+unAnn = void  -- | Helpful for some things. instance IsString (A.Name ()) where
src/Fay/Exts/Scoped.hs view
@@ -2,8 +2,8 @@  import qualified Fay.Exts                        as F -import qualified Language.Haskell.Exts.Annotated as A-import qualified Language.Haskell.Names          as HN+import qualified Language.Haskell.Exts as A+import qualified Language.Haskell.Names          as HN (Scoped (Scoped), NameInfo (None))   type X = HN.Scoped A.SrcSpanInfo@@ -19,7 +19,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X-type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X@@ -36,6 +35,7 @@ type QualConDecl = A.QualConDecl X type QualStmt = A.QualStmt X type Rhs = A.Rhs X+type Sign = A.Sign X type SpecialCon = A.SpecialCon X type SrcLoc = A.SrcLoc type Stmt = A.Stmt X
src/Fay/FFI.hs view
@@ -14,7 +14,7 @@  import           Data.String (IsString) import           Fay.Types-import           Prelude     (Bool, Char, Double, Int, Maybe, String, error)+import           Prelude     (error)  -- | Values that may be null --  Nullable x decodes to x, Null decodes to null.
+ src/Fay/Runtime.hs view
@@ -0,0 +1,842 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Fay.Runtime where++import Text.Shakespeare.Text+import Data.Text.Lazy as T+import Fay.Config++-- | Get the default runtime source.+getRuntimeSource :: Config -> String+getRuntimeSource cfg =+  let ifTs :: T.Text -> T.Text+      ifTs a = if configTypeScript cfg then a else ""+      ifTsJs :: T.Text -> T.Text -> T.Text+      ifTsJs a b = if configTypeScript cfg then a else b+  in T.unpack [lt|+/*******************************************************************************+ * Misc.+ */+#{ifTs "var Fay:{[key:string]: any;} = {};"}++// Workaround for missing functionality in IE 8 and earlier.+if( Object.create === undefined ) {+  Object.create = function( o ) {+    function F(){}+    F.prototype = o;+    return new F();+  };+}++// Insert properties of b in place into a.+function Fay$$objConcat(a,b){+  for (var p in b) if (b.hasOwnProperty(p)){+    a[p] = b[p];+  }+  return a;+}++/*******************************************************************************+ * Thunks.+ */++// Force a thunk (if it is a thunk) until WHNF.+function Fay$$_(thunkish,nocache#{ifTs "?: boolean"}){+  while (thunkish instanceof Fay$$$) {+    thunkish = thunkish.force(nocache);+  }+  return thunkish;+}++// Apply a function to arguments (see method2 in Fay.hs).+function Fay$$__(){+  var f = arguments[0];+  for (var i = 1, len = arguments.length; i < len; i++) {+    f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]);+  }+  return f;+}++// Thunk object.+function Fay$$$(value){+  this.forced = false;+  this.value = value;+}++// Force the thunk.+Fay$$$.prototype.force = function(nocache) {+  return nocache ?+    this.value() :+    (this.forced ?+     this.value :+     (this.value = this.value(), this.forced = true, this.value));+};+++function Fay$$seq(x) {+  return function(y) {+    Fay$$_(x,false);+    return y;+  }+}++function Fay$$seq$36$uncurried(x,y) {+  Fay$$_(x,false);+  return y;+}++/*******************************************************************************+ * Monad.+ */++function Fay$$Monad(value){+  this.value = value;+}++// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+function Fay$$then(a){+  return function(b){+    return Fay$$bind(a)(function(_){+      return b;+    });+  };+}++// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+function Fay$$then$36$uncurried(a,b){+  return Fay$$bind$36$uncurried(a,function(_){ return b; });+}++// >>=+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind(m){+  return function(f){+    return new Fay$$$(function(){+      var monad = Fay$$_(m,true);+      return Fay$$_(f)(monad.value);+    });+  };+}++// >>=+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind$36$uncurried(m,f){+  return new Fay$$$(function(){+    var monad = Fay$$_(m,true);+    return Fay$$_(f)(monad.value);+  });+}++// This is used directly from Fay, but can be rebound or shadowed.+function Fay$$$_return(a){+  return new Fay$$Monad(a);+}++// Allow the programmer to access thunk forcing directly.+function Fay$$force(thunk){+  return function(type){+    return new Fay$$$(function(){+      Fay$$_(thunk,type);+      return new Fay$$Monad(Fay$$unit);+    })+  }+}++// This is used directly from Fay, but can be rebound or shadowed.+function Fay$$return$36$uncurried(a){+  return new Fay$$Monad(a);+}++// Unit: ().+var Fay$$unit = null;++/*******************************************************************************+ * Serialization.+ * Fay <-> JS. Should be bijective.+ */++// Serialize a Fay object to JS.+function Fay$$fayToJs(type,fayObj){+  var base = type[0];+  var args = type[1];+  var jsObj;+  if(base == "action") {+    // A nullary monadic action. Should become a nullary JS function.+    // Fay () -> function(){ return ... }+    return function(){+      return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);+    };++  }+  else if(base == "function") {+    // A proper function.+    return function(){+      var fayFunc = fayObj;+      var return_type = args[args.length-1];+      var len = args.length;+      // If some arguments.+      if (len > 1) {+        // Apply to all the arguments.+        fayFunc = Fay$$_(fayFunc,true);+        // TODO: Perhaps we should throw an error when JS+        // passes more arguments than Haskell accepts.++        // Unserialize the JS values to Fay for the Fay callback.+        if (args == "automatic_function")+        {+          for (var i = 0; i < arguments.length; i++) {+            fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true);+          }+          return Fay$$fayToJs(["automatic"], fayFunc);+        }++        for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {+          fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);+        }+        // Finally, serialize the Fay return value back to JS.+        var return_base = return_type[0];+        var return_args = return_type[1];+        // If it's a monadic return value, get the value instead.+        if(return_base == "action") {+          return Fay$$fayToJs(return_args[0],fayFunc.value);+        }+        // Otherwise just serialize the value direct.+        else {+          return Fay$$fayToJs(return_type,fayFunc);+        }+      } else {+        throw new Error("Nullary function?");+      }+    };++  }+  else if(base == "string") {+    return Fay$$fayToJs_string(fayObj);+  }+  else if(base == "list") {+    // Serialize Fay list to JavaScript array.+    var arr = [];+    fayObj = Fay$$_(fayObj);+    while(fayObj instanceof Fay$$Cons) {+      arr.push(Fay$$fayToJs(args[0],fayObj.car));+      fayObj = Fay$$_(fayObj.cdr);+    }+    return arr;+  }+  else if(base == "tuple") {+    // Serialize Fay tuple to JavaScript array.+    var arr = [];+    fayObj = Fay$$_(fayObj);+    var i = 0;+    while(fayObj instanceof Fay$$Cons) {+      arr.push(Fay$$fayToJs(args[i++],fayObj.car));+      fayObj = Fay$$_(fayObj.cdr);+    }+    return arr;+  }+  else if(base == "defined") {+    fayObj = Fay$$_(fayObj);+    return fayObj instanceof Fay.FFI._Undefined+      ? undefined+      : Fay$$fayToJs(args[0],fayObj.slot1);+  }+  else if(base == "nullable") {+    fayObj = Fay$$_(fayObj);+    return fayObj instanceof Fay.FFI._Null+      ? null+      : Fay$$fayToJs(args[0],fayObj.slot1);+  }+  else if(base == "double" || base == "int" || base == "bool") {+    // Bools are unboxed.+    return Fay$$_(fayObj);+  }+  else if(base == "ptr")+    return fayObj;+  else if(base == "unknown")+    return Fay$$fayToJs(["automatic"], fayObj);+  else if(base == "automatic" && fayObj instanceof Function) {+    return Fay$$fayToJs(["function", "automatic_function"], fayObj);+  }+  else if(base == "automatic" || base == "user") {+    fayObj = Fay$$_(fayObj);++    if(fayObj instanceof Fay$$Cons || fayObj === null){+      // Serialize Fay list to JavaScript array.+      var arr = [];+      while(fayObj instanceof Fay$$Cons) {+        arr.push(Fay$$fayToJs(["automatic"],fayObj.car));+        fayObj = Fay$$_(fayObj.cdr);+      }+      return arr;+    } else {+      var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];+      return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;+    }+  }++  throw new Error("Unhandled Fay->JS translation type: " + base);+}++// Stores the mappings from fay types to js objects.+// This will be populated by compiled modules.+var Fay$$fayToJsHash = {};++// Specialized serializer for string.+function Fay$$fayToJs_string(fayObj){+  // Serialize Fay string to JavaScript string.+  var str = "";+  fayObj = Fay$$_(fayObj);+  while(fayObj instanceof Fay$$Cons) {+    str += Fay$$_(fayObj.car);+    fayObj = Fay$$_(fayObj.cdr);+  }+  return str;+};+function Fay$$jsToFay_string(x){+  return Fay$$list(x)+};++// Special num/bool serializers.+function Fay$$jsToFay_int(x){return x;}+function Fay$$jsToFay_double(x){return x;}+function Fay$$jsToFay_bool(x){return x;}++function Fay$$fayToJs_int(x){return Fay$$_(x);}+function Fay$$fayToJs_double(x){return Fay$$_(x);}+function Fay$$fayToJs_bool(x){return Fay$$_(x);}++// Unserialize an object from JS to Fay.+function Fay$$jsToFay(type,jsObj){+  var base = type[0];+  var args = type[1];+  var fayObj;+  if(base == "action") {+    // Unserialize a "monadic" JavaScript return value into a monadic value.+    return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));+  }+  else if(base == "function") {+    // Unserialize a function from JavaScript to a function that Fay can call.+    // So+    //+    //    var f = function(x,y,z){ … }+    //+    // becomes something like:+    //+    //    function(x){+    //      return function(y){+    //        return function(z){+    //          return new Fay$$$(function(){+    //            return Fay$$jsToFay(f(Fay$$fayTojs(x),+    //                                  Fay$$fayTojs(y),+    //                                  Fay$$fayTojs(z))+    //    }}}}};+    var returnType = args[args.length-1];+    var funArgs = args.slice(0,-1);++    if (jsObj.length > 0) {+      var makePartial = function(args){+        return function(arg){+          var i = args.length;+          var fayArg = Fay$$fayToJs(funArgs[i],arg);+          var newArgs = args.concat([fayArg]);+          if(newArgs.length == funArgs.length) {+            return new Fay$$$(function(){+              return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));+            });+          } else {+            return makePartial(newArgs);+          }+        };+      };+      return makePartial([]);+    }+    else+      return function (arg) {+        return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));+      };+  }+  else if(base == "string") {+    // Unserialize a JS string into Fay list (String).+    // This is a special case, when String is explicit in the type signature,+    // with `Automatic' a string would not be decoded.+    return Fay$$list(jsObj);+  }+  else if(base == "list") {+    // Unserialize a JS array into a Fay list ([a]).+    var serializedList = [];+    for (var i = 0, len = jsObj.length; i < len; i++) {+      // Unserialize each JS value into a Fay value, too.+      serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));+    }+    // Pop it all in a Fay list.+    return Fay$$list(serializedList);+  }+  else if(base == "tuple") {+    // Unserialize a JS array into a Fay tuple ((a,b,c,...)).+    var serializedTuple = [];+    for (var i = 0, len = jsObj.length; i < len; i++) {+      // Unserialize each JS value into a Fay value, too.+      serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i]));+    }+    // Pop it all in a Fay list.+    return Fay$$list(serializedTuple);+  }+  else if(base == "defined") {+    return jsObj === undefined+      ? new Fay.FFI._Undefined()+      : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));+  }+  else if(base == "nullable") {+    return jsObj === null+      ? new Fay.FFI._Null()+      : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));+  }+  else if(base == "int") {+    // Int are unboxed, so there's no forcing to do.+    // But we can do validation that the int has no decimal places.+    // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"+    fayObj = Math.round(jsObj);+    if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";+    return fayObj;+  }+  else if (base == "double" ||+           base == "bool" ||+           base ==  "ptr") {+    return jsObj;+  }+  else if(base == "unknown")+    return Fay$$jsToFay(["automatic"], jsObj);+  else if(base == "automatic" && jsObj instanceof Function) {+    #{ifTsJs "let type: string[][]" "var type"} = [["automatic"]];+    for (var i = 0; i < jsObj.length; i++)+      type.push(["automatic"]);+    return Fay$$jsToFay(["function", type], jsObj);+  }+  else if(base == "automatic" && jsObj instanceof Array) {+    var list = null;+    for (var i = jsObj.length - 1; i >= 0; i--) {+      list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);+    }+    return list;+  }+  else if(base == "automatic" || base == "user") {+    if (jsObj && jsObj['instance']) {+      var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];+      return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;+    }+    else+      return jsObj;+  }++  throw new Error("Unhandled JS->Fay translation type: " + base);+}++// Stores the mappings from js objects to fay types.+// This will be populated by compiled modules.+var Fay$$jsToFayHash = {};++/*******************************************************************************+ * Lists.+ */++// Cons object.+function Fay$$Cons(car,cdr){+  this.car = car;+  this.cdr = cdr;+}++// Make a list.+function Fay$$list(xs){+  var out = null;+  for(var i=xs.length-1; i>=0;i--)+    out = new Fay$$Cons(xs[i],out);+  return out;+}++// Built-in list cons.+function Fay$$cons(x){+  return function(y){+    return new Fay$$Cons(x,y);+  };+}++// List index.+// `list' is already forced by the time it's passed to this function.+// `list' cannot be null and `index' cannot be out of bounds.+function Fay$$index(index,list){+  for(var i = 0; i < index; i++) {+    list = Fay$$_(list.cdr);+  }+  return list.car;+}++// List length.+// `list' is already forced by the time it's passed to this function.+function Fay$$listLen(list,max){+  for(var i = 0; list !== null && i < max + 1; i++) {+    list = Fay$$_(list.cdr);+  }+  return i == max;+}++/*******************************************************************************+ * Numbers.+ */++// Built-in *.+function Fay$$mult(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) * Fay$$_(y);+    });+  };+}++function Fay$$mult$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) * Fay$$_(y);+  });++}++// Built-in +.+function Fay$$add(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) + Fay$$_(y);+    });+  };+}++// Built-in +.+function Fay$$add$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) + Fay$$_(y);+  });++}++// Built-in -.+function Fay$$sub(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) - Fay$$_(y);+    });+  };+}+// Built-in -.+function Fay$$sub$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) - Fay$$_(y);+  });++}++// Built-in /.+function Fay$$divi(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) / Fay$$_(y);+    });+  };+}++// Built-in /.+function Fay$$divi$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) / Fay$$_(y);+  });++}++/*******************************************************************************+ * Booleans.+ */++// Are two values equal?+function Fay$$equal(lit1, lit2) {+  // Simple case+  lit1 = Fay$$_(lit1);+  lit2 = Fay$$_(lit2);+  if (lit1 === lit2) {+    return true;+  }+  // General case+  if (lit1 instanceof Array) {+    if (lit1.length != lit2.length) return false;+    for (var len = lit1.length, i = 0; i < len; i++) {+      if (!Fay$$equal(lit1[i], lit2[i])) return false;+    }+    return true;+  } else if (lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons) {+    do {+      if (!Fay$$equal(lit1.car,lit2.car))+        return false;+      lit1 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr);+      if (lit1 === null || lit2 === null)+        return lit1 === lit2;+    } while (true);+  } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&+             lit1.instance === lit2.instance) {+    for(var x in lit1) {+      if(!Fay$$equal(lit1[x],lit2[x]))+        return false;+    }+    return true;+  } else {+    return false;+  }+}++// Built-in ==.+function Fay$$eq(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$equal(x,y);+    });+  };+}++function Fay$$eq$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$equal(x,y);+  });++}++// Built-in /=.+function Fay$$neq(x){+  return function(y){+    return new Fay$$$(function(){+      return !(Fay$$equal(x,y));+    });+  };+}++// Built-in /=.+function Fay$$neq$36$uncurried(x,y){++  return new Fay$$$(function(){+    return !(Fay$$equal(x,y));+  });++}++// Built-in >.+function Fay$$gt(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) > Fay$$_(y);+    });+  };+}++// Built-in >.+function Fay$$gt$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) > Fay$$_(y);+  });++}++// Built-in <.+function Fay$$lt(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) < Fay$$_(y);+    });+  };+}+++// Built-in <.+function Fay$$lt$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) < Fay$$_(y);+  });++}+++// Built-in >=.+function Fay$$gte(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) >= Fay$$_(y);+    });+  };+}++// Built-in >=.+function Fay$$gte$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) >= Fay$$_(y);+  });++}++// Built-in <=.+function Fay$$lte(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) <= Fay$$_(y);+    });+  };+}++// Built-in <=.+function Fay$$lte$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) <= Fay$$_(y);+  });++}++// Built-in &&.+function Fay$$and(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) && Fay$$_(y);+    });+  };+}++// Built-in &&.+function Fay$$and$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) && Fay$$_(y);+  });+  ;+}++// Built-in ||.+function Fay$$or(x){+  return function(y){+    return new Fay$$$(function(){+      return Fay$$_(x) || Fay$$_(y);+    });+  };+}++// Built-in ||.+function Fay$$or$36$uncurried(x,y){++  return new Fay$$$(function(){+    return Fay$$_(x) || Fay$$_(y);+  });++}++/*******************************************************************************+ * Mutable references.+ */++// Make a new mutable reference.+function Fay$$Ref(x){+  this.value = x;+}++// Write to the ref.+function Fay$$writeRef(ref,x){+  ref.value = x;+}++// Get the value from the ref.+function Fay$$readRef(ref){+  return ref.value;+}++/*******************************************************************************+ * Dates.+ */+function Fay$$date(str){+  return Date.parse(str);+}++/*******************************************************************************+ * Data.Var+ */++function Fay$$Ref2(val){+  this.val = val;+}++function Fay$$Sig(){+  this.handlers = [];+}++function Fay$$Var(val){+  this.val = val;+  this.handlers = [];+}++// Helper used by Fay$$setValue and for merging+function Fay$$broadcastInternal(self, val, force){+  var handlers = self.handlers;+  var exceptions = [];+  for(#{ifTsJs "let" "var"} len = handlers.length, i = 0; i < len; i++) {+    try {+      force(handlers[i][1](val), true);+    } catch (e) {+      exceptions.push(e);+    }+  }+  // Rethrow the encountered exceptions.+  if (exceptions.length > 0) {+    console.error("Encountered " + exceptions.length + " exception(s) while broadcasing a change to ", self);+    for(#{ifTsJs "let len: number" "var len"} = exceptions.length, i = 0; i < len; i++) {+      (function(exception) {+        setTimeout(function() { throw exception; }, 0);+      })(exceptions[i]);+    }+  }+}++function Fay$$setValue(self, val, force){+  if (self instanceof Fay$$Ref2) {+    self.val = val;+  } else if (self instanceof Fay$$Var) {+    self.val = val;+    Fay$$broadcastInternal(self, val, force);+  } else if (self instanceof Fay$$Sig) {+    Fay$$broadcastInternal(self, val, force);+  } else {+    throw "Fay$$setValue given something that's not a Ref2, Var, or Sig"+  }+}++function Fay$$subscribe(self, f){+  var key = {};+  self.handlers.push([key,f]);+  var searchStart = self.handlers.length - 1;+  return function(_){+    for(var i = Math.min(searchStart, self.handlers.length - 1); i >= 0; i--) {+      if(self.handlers[i][0] == key) {+        self.handlers = self.handlers.slice(0,i).concat(self.handlers.slice(i+1));+        return;+      }+    }+    return _; // This variable has to be used, otherwise Closure+              // strips it out and Fay serialization breaks.+  };+}++/*******************************************************************************+ * Application code.+ */++|]
− src/Fay/System/Directory/Extra.hs 
@@ -1,21 +0,0 @@--- | Extra directory functions.-module Fay.System.Directory.Extra where--import           Control.Monad    (forM)-import           System.Directory (doesDirectoryExist, getDirectoryContents)-import           System.FilePath  ((</>))---- | Get all files in a folder and its subdirectories.--- Taken from Real World Haskell--- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html-getRecursiveContents :: FilePath -> IO [FilePath]-getRecursiveContents topdir = do-  names <- getDirectoryContents topdir-  let properNames = filter (`notElem` [".", ".."]) names-  paths <- forM properNames $ \name -> do-    let path = topdir </> name-    isDirectory <- doesDirectoryExist path-    if isDirectory-      then getRecursiveContents path-      else return [path]-  return (concat paths)
− src/Fay/System/Process/Extra.hs 
@@ -1,15 +0,0 @@--- | Extra process functions.--module Fay.System.Process.Extra where--import           System.Exit-import           System.Process---- | Read from a process returning both std err and out.-readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String))-readAllFromProcess program flags input = do-  (code,out,err) <- readProcessWithExitCode program flags input-  return $ case code of-    ExitFailure 127 -> Left ("cannot find executable " ++ program, "")-    ExitFailure _   -> Left (err, out)-    ExitSuccess     -> Right (err, out)
src/Fay/Types.hs view
@@ -1,102 +1,73 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-} {-# LANGUAGE TypeFamilies               #-}  -- | All Fay types and instances.  module Fay.Types-  (JsStmt(..)-  ,JsExp(..)-  ,JsLit(..)-  ,JsName(..)-  ,CompileError(..)-  ,Compile(..)-  ,CompileResult-  ,CompileModule-  ,Printable(..)-  ,Fay-  ,CompileReader(..)-  ,CompileWriter(..)-  ,CompileConfig(..)-  ,CompileState(..)-  ,FundamentalType(..)-  ,PrintState(..)-  ,Printer(..)-  ,SerializeContext(..)-  ,ModulePath (unModulePath)-  ,mkModulePath-  ,mkModulePaths-  ,mkModulePathFromQName+  ( JsStmt(..)+  , JsExp(..)+  , JsLit(..)+  , JsName(..)+  , CompileError(..)+  , Compile(..)+  , CompileModule+  , Printable(..)+  , Fay+  , CompileReader(..)+  , CompileResult(..)+  , CompileWriter(..)+  , Config(..)+  , CompileState(..)+  , FundamentalType(..)+  , PrintState(..)+  , defaultPrintState+  , PrintReader(..)+  , defaultPrintReader+  , PrintWriter(..)+  , pwOutputString+  , Printer(..)+  , execPrinter+  , indented+  , askIf+  , newline+  , write+  , mapping+  , SerializeContext(..)+  , ModulePath (unModulePath)+  , mkModulePath+  , mkModulePaths+  , mkModulePathFromQName   ) where -import           Fay.Compiler.QName-import qualified Fay.Exts                          as F-import qualified Fay.Exts.NoAnnotation             as N-import qualified Fay.Exts.Scoped                   as S+import           Fay.Compiler.Prelude +import           Fay.Compiler.ModuleT+import           Fay.Config+import qualified Fay.Exts.NoAnnotation   as N+import qualified Fay.Exts.Scoped         as S+import           Fay.Types.CompileError+import           Fay.Types.CompileResult+import           Fay.Types.FFI+import           Fay.Types.Js+import           Fay.Types.ModulePath+import           Fay.Types.Printer++#if __GLASGOW_HASKELL__ < 710 import           Control.Applicative-import           Control.Monad.Error               (Error, ErrorT, MonadError)-import           Control.Monad.Identity            (Identity)-import           Control.Monad.RWS-import           Control.Monad.State-import           Data.Default-import           Data.List-import           Data.List.Split-import           Data.Map                          (Map)-import           Data.Set                          (Set)-import           Data.String-import           Distribution.HaskellSuite.Modules-import           Language.Haskell.Exts.Annotated-import           Language.Haskell.Names            (Symbols)-import           SourceMap.Types+#endif+import           Control.Monad.Except    (ExceptT, MonadError)+import           Control.Monad.Identity  (Identity)+import           Control.Monad.RWS       (MonadIO, MonadReader, MonadState, MonadWriter, RWST, lift)+import           Data.Map                (Map)+import           Data.Set                (Set)+import           Language.Haskell.Names  (Symbols)+import           Data.Semigroup          (Semigroup)  -------------------------------------------------------------------------------- -- Compiler types --- | Configuration of the compiler.-data CompileConfig = CompileConfig-  { configOptimize          :: Bool                        -- ^ Run optimizations-  , configFlattenApps       :: Bool                        -- ^ Flatten function application?-  , configExportRuntime     :: Bool                        -- ^ Export the runtime?-  , configExportStdlib      :: Bool                        -- ^ Export the stdlib?-  , configExportStdlibOnly  :: Bool                        -- ^ Export /only/ the stdlib?-  , 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.-  , configFilePath          :: Maybe FilePath              -- ^ File path to output to.-  , configTypecheck         :: Bool                        -- ^ Typecheck with GHC.-  , configWall              :: Bool                        -- ^ Typecheck with -Wall.-  , configGClosure          :: Bool                        -- ^ Run Google Closure on the produced JS.-  , configPackageConf       :: Maybe FilePath              -- ^ The package config e.g. packages-6.12.3.-  , configPackages          :: [String]                    -- ^ Included Fay packages.-  , configBasePath          :: Maybe FilePath              -- ^ Custom source location for fay-base-  , configStrict            :: [String]                    -- ^ Produce strict and uncurried wrappers for all functions with type signatures in the given module-  , configTypecheckOnly     :: Bool                        -- ^ Only invoke GHC for typechecking, don't produce any output-  , configRuntimePath       :: Maybe FilePath-  } deriving (Show)---- | The name of a module split into a list for code generation.-newtype ModulePath = ModulePath { unModulePath :: [String] }-  deriving (Eq, Ord, Show)---- | Construct the complete ModulePath from a ModuleName.-mkModulePath :: ModuleName a -> ModulePath-mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m---- | Construct intermediate module paths from a ModuleName.--- mkModulePaths "A.B" => [["A"], ["A","B"]]-mkModulePaths :: ModuleName a -> [ModulePath]-mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m---- | Converting a QName to a ModulePath is only relevant for constructors since--- they can conflict with module names.-mkModulePathFromQName :: QName a -> ModulePath-mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n-mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"- -- | State of the compiler. data CompileState = CompileState   -- TODO Change N.QName to GName? They can never be special so it would simplify.@@ -117,228 +88,56 @@   { writerCons    :: [JsStmt]         -- ^ Constructors.   , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers.   , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers.-  }-  deriving (Show)+  } deriving (Show)  -- | Simple concatenating instance.+instance Semigroup CompileWriter where+  (CompileWriter a b c) <> (CompileWriter x y z) =+    CompileWriter (a++x) (b++y) (c++z)++-- | Simple concatenating instance. instance Monoid CompileWriter where   mempty = CompileWriter [] [] []-  mappend (CompileWriter a b c) (CompileWriter x y z) =-    CompileWriter (a++x) (b++y) (c++z)+  mappend = (<>)  -- | Configuration and globals for the compiler. data CompileReader = CompileReader-  { readerConfig       :: CompileConfig -- ^ The compilation configuration.-  , readerCompileLit   :: S.Literal -> Compile JsExp+  { readerConfig       :: Config -- ^ The compilation configuration.+  , readerCompileLit   :: S.Sign -> S.Literal -> Compile JsExp   , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]   }  -- | Compile monad. newtype Compile a = Compile-  { unCompile :: (RWST CompileReader-                      CompileWriter-                      CompileState-                      (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO)))-                   a -- ^ Uns the compiler-  }-  deriving (MonadState CompileState-           ,MonadError CompileError-           ,MonadReader CompileReader-           ,MonadWriter CompileWriter-           ,MonadIO-           ,Monad-           ,Functor-           ,Applicative-           )--type CompileResult a-  = Either CompileError-           (a, CompileState, CompileWriter)+  { unCompile :: RWST CompileReader CompileWriter CompileState+                      (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO))+                      a -- ^ Uns the compiler+  } deriving+    ( Applicative+    , Functor+    , Monad+    , MonadError CompileError+    , MonadIO+    , MonadReader CompileReader+    , MonadState CompileState+    , MonadWriter CompileWriter+    ) -type CompileModule a-  = ModuleT Symbols-            IO-            (CompileResult a)+type CompileModule a = ModuleT Symbols IO (Either CompileError (a, CompileState, CompileWriter))  instance MonadModule Compile where   type ModuleInfo Compile = Symbols   lookupInCache        = liftModuleT . lookupInCache   insertInCache n m    = liftModuleT $ insertInCache n m-  getPackages          = liftModuleT $ getPackages   readModuleInfo fps n = liftModuleT $ readModuleInfo fps n  liftModuleT :: ModuleT Symbols IO a -> Compile a liftModuleT = Compile . lift . lift --- | 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.-  , 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.-instance Default PrintState where-  def = PrintState False 0 0 [] 0 [] False---- | The printer monad.-newtype Printer a = Printer { runPrinter :: State PrintState a }-  deriving (Monad,Functor,MonadState PrintState)---- | Print some value.-class Printable a where-  printJS :: a -> Printer ()---- | Error type.-data CompileError-  = Couldn'tFindImport N.ModuleName [FilePath]-  | EmptyDoBlock-  | FfiFormatBadChars SrcSpanInfo String-  | FfiFormatIncompleteArg SrcSpanInfo-  | FfiFormatInvalidJavaScript SrcSpanInfo String String-  | FfiFormatNoSuchArg SrcSpanInfo Int-  | FfiNeedsTypeSig S.Decl-  | GHCError String-  | InvalidDoBlock-  | ParseError S.SrcLoc String-  | ShouldBeDesugared String-  | UnableResolveQualified N.QName-  | UnsupportedDeclaration S.Decl-  | UnsupportedEnum N.Exp-  | UnsupportedExportSpec N.ExportSpec-  | UnsupportedExpression S.Exp-  | UnsupportedFieldPattern S.PatField-  | UnsupportedImport F.ImportDecl-  | UnsupportedLet-  | UnsupportedLetBinding S.Decl-  | UnsupportedLiteral S.Literal-  | UnsupportedModuleSyntax String F.Module-  | UnsupportedPattern S.Pat-  | UnsupportedQualStmt S.QualStmt-  | UnsupportedRecursiveDo-  | UnsupportedRhs S.Rhs-  | UnsupportedWhereInAlt S.Alt-  | UnsupportedWhereInMatch S.Match-  deriving (Show)-instance Error CompileError- -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a)-  deriving Monad------------------------------------------------------------------------------------- JS AST types---- | Statement type.-data JsStmt-  = JsVar JsName JsExp-  | JsIf JsExp [JsStmt] [JsStmt]-  | JsEarlyReturn JsExp-  | JsThrow JsExp-  | JsWhile JsExp [JsStmt]-  | JsUpdate JsName JsExp-  | JsSetProp JsName JsName JsExp-  | JsSetQName (Maybe SrcSpan) N.QName JsExp-  | JsSetModule ModulePath JsExp-  | JsSetConstructor N.QName JsExp-  | JsSetPropExtern JsName JsName JsExp-  | JsContinue-  | JsBlock [JsStmt]-  | JsExpStmt JsExp-  deriving (Show,Eq)---- | Expression type.-data JsExp-  = JsName JsName-  | JsRawExp String-  | JsSeq [JsExp]-  | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp)-  | JsLit JsLit-  | JsApp JsExp [JsExp]-  | JsNegApp JsExp-  | JsTernaryIf JsExp JsExp JsExp-  | JsNull-  | JsParen JsExp-  | JsGetProp JsExp JsName-  | JsLookup JsExp JsExp-  | JsUpdateProp JsExp JsName JsExp-  | JsGetPropExtern JsExp String-  | JsUpdatePropExtern JsExp JsName JsExp-  | JsList [JsExp]-  | JsNew JsName [JsExp]-  | JsThrowExp JsExp-  | JsInstanceOf JsExp JsName-  | JsIndex Int JsExp-  | JsEq JsExp JsExp-  | JsNeq JsExp JsExp-  | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc-  | JsObj [(String,JsExp)]-  | JsLitObj [(N.Name,JsExp)]-  | JsUndefined-  | JsAnd JsExp JsExp-  | JsOr  JsExp JsExp-  deriving (Show,Eq)---- | A name of some kind.-data JsName-  = JsNameVar N.QName-  | JsThis-  | JsParametrizedType-  | JsThunk-  | JsForce-  | JsApply-  | JsParam Integer-  | JsTmp Integer-  | JsConstructor N.QName-  | JsBuiltIn N.Name-  | JsModuleName N.ModuleName-  deriving (Eq,Show)---- | Literal value type.-data JsLit-  = JsChar Char-  | JsStr String-  | JsInt Int-  | JsFloating Double-  | JsBool Bool-  deriving (Show,Eq)---- | Just handy to have.-instance IsString JsLit where fromString = JsStr---- | These are the data types that are serializable directly to native--- JS data types. Strings, floating points and arrays. The others are:--- actions in the JS monad, which are thunks that shouldn't be forced--- when serialized but wrapped up as JS zero-arg functions, and--- unknown types can't be converted but should at least be forced.-data FundamentalType-   -- Recursive types.- = FunctionType [FundamentalType]- | JsType FundamentalType- | ListType FundamentalType- | TupleType [FundamentalType]- | UserDefined N.Name [FundamentalType]- | Defined FundamentalType- | Nullable FundamentalType- -- Simple types.- | DateType- | StringType- | DoubleType- | IntType- | BoolType- | PtrType- --  Automatically serialize this type.- | Automatic- -- Unknown.- | UnknownType-   deriving (Show)---- | The serialization context indicates whether we're currently--- serializing some value or a particular field in a user-defined data--- type.-data SerializeContext = SerializeAnywhere | SerializeUserArg Int-  deriving (Read,Show,Eq)+  deriving+    ( Applicative+    , Functor+    , Monad+    )
+ src/Fay/Types/CompileError.hs view
@@ -0,0 +1,40 @@+module Fay.Types.CompileError (CompileError (..)) where++import qualified Fay.Exts                        as F+import qualified Fay.Exts.NoAnnotation           as N+import qualified Fay.Exts.Scoped                 as S++import           Language.Haskell.Exts++-- | Error type.+data CompileError+  = Couldn'tFindImport N.ModuleName [FilePath]+  | EmptyDoBlock+  | FfiFormatBadChars SrcSpanInfo String+  | FfiFormatIncompleteArg SrcSpanInfo+  | FfiFormatInvalidJavaScript SrcSpanInfo String String+  | FfiFormatNoSuchArg SrcSpanInfo Int+  | FfiNeedsTypeSig S.Exp+  | GHCError String+  | InvalidDoBlock+  | ParseError S.SrcLoc String+  | ShouldBeDesugared String+  | UnableResolveQualified N.QName+  | UnsupportedDeclaration S.Decl+  | UnsupportedEnum N.Exp+  | UnsupportedExportSpec N.ExportSpec+  | UnsupportedExpression S.Exp+  | UnsupportedFieldPattern S.PatField+  | UnsupportedImport F.ImportDecl+  | UnsupportedLet+  | UnsupportedLetBinding S.Decl+  | UnsupportedLiteral S.Literal+  | UnsupportedModuleSyntax String F.Module+  | UnsupportedPattern S.Pat+  | UnsupportedQualStmt S.QualStmt+  | UnsupportedRecursiveDo+  | UnsupportedRhs S.Rhs+  | UnsupportedWhereInAlt S.Alt+  | UnsupportedWhereInMatch S.Match+  deriving (Show)+{-# ANN module "HLint: ignore Use camelCase" #-}
+ src/Fay/Types/CompileResult.hs view
@@ -0,0 +1,9 @@+module Fay.Types.CompileResult (CompileResult (..)) where++import           SourceMap.Types++data CompileResult = CompileResult+  { resOutput         :: String+  , resImported       :: [(String, FilePath)]+  , resSourceMappings :: Maybe [Mapping]+  } deriving Show
+ src/Fay/Types/FFI.hs view
@@ -0,0 +1,40 @@++module Fay.Types.FFI+  ( FundamentalType (..)+  , SerializeContext (..)+  ) where++import qualified Fay.Exts.NoAnnotation as N++-- | These are the data types that are serializable directly to native+-- JS data types. Strings, floating points and arrays. The others are:+-- actions in the JS monad, which are thunks that shouldn't be forced+-- when serialized but wrapped up as JS zero-arg functions, and+-- unknown types can't be converted but should at least be forced.+data FundamentalType+   -- Recursive types.+ = FunctionType [FundamentalType]+ | JsType FundamentalType+ | ListType FundamentalType+ | TupleType [FundamentalType]+ | UserDefined N.Name [FundamentalType]+ | Defined FundamentalType+ | Nullable FundamentalType+ -- Simple types.+ | DateType+ | StringType+ | DoubleType+ | IntType+ | BoolType+ | PtrType+ --  Automatically serialize this type.+ | Automatic+ -- Unknown.+ | UnknownType+   deriving (Show)++-- | The serialization context indicates whether we're currently+-- serializing some value or a particular field in a user-defined data+-- type.+data SerializeContext = SerializeAnywhere | SerializeUserArg Int+  deriving (Eq, Read, Show)
+ src/Fay/Types/Js.hs view
@@ -0,0 +1,92 @@+-- | JS AST types++module Fay.Types.Js+  ( JsStmt (..)+  , JsExp (..)+  , JsLit (..)+  , JsName (..)+  ) where++import qualified Fay.Exts.NoAnnotation           as N+import           Fay.Types.ModulePath++import           Data.String+import           Language.Haskell.Exts++-- | Statement type.+data JsStmt+  = JsVar JsName JsExp+  | JsMapVar JsName JsExp+  | JsIf JsExp [JsStmt] [JsStmt]+  | JsEarlyReturn JsExp+  | JsThrow JsExp+  | JsWhile JsExp [JsStmt]+  | JsUpdate JsName JsExp+  | JsSetProp JsName JsName JsExp+  | JsSetQName (Maybe SrcSpan) N.QName JsExp+  | JsSetModule ModulePath JsExp+  | JsSetConstructor N.QName JsExp+  | JsSetPropExtern JsName JsName JsExp+  | JsContinue+  | JsBlock [JsStmt]+  | JsExpStmt JsExp+  deriving (Show,Eq)++-- | Expression type.+data JsExp+  = JsName JsName+  | JsRawExp String+  | JsSeq [JsExp]+  | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp)+  | JsLit JsLit+  | JsApp JsExp [JsExp]+  | JsNegApp JsExp+  | JsTernaryIf JsExp JsExp JsExp+  | JsNull+  | JsParen JsExp+  | JsGetProp JsExp JsName+  | JsLookup JsExp JsExp+  | JsUpdateProp JsExp JsName JsExp+  | JsGetPropExtern JsExp String+  | JsUpdatePropExtern JsExp JsName JsExp+  | JsList [JsExp]+  | JsNew JsName [JsExp]+  | JsThrowExp JsExp+  | JsInstanceOf JsExp JsName+  | JsIndex Int JsExp+  | JsEq JsExp JsExp+  | JsNeq JsExp JsExp+  | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc+  | JsObj [(String,JsExp)]+  | JsLitObj [(N.Name,JsExp)]+  | JsUndefined+  | JsAnd JsExp JsExp+  | JsOr  JsExp JsExp+  deriving (Eq, Show)++-- | A name of some kind.+data JsName+  = JsNameVar N.QName+  | JsThis+  | JsParametrizedType+  | JsThunk+  | JsForce+  | JsApply+  | JsParam Integer+  | JsTmp Integer+  | JsConstructor N.QName+  | JsBuiltIn N.Name+  | JsModuleName N.ModuleName+  deriving (Eq, Show)++-- | Literal value type.+data JsLit+  = JsChar Char+  | JsStr String+  | JsInt Int+  | JsFloating Double+  | JsBool Bool+  deriving (Eq, Show)++-- | Just handy to have.+instance IsString JsLit where fromString = JsStr
+ src/Fay/Types/ModulePath.hs view
@@ -0,0 +1,32 @@+module Fay.Types.ModulePath+  ( ModulePath (..)+  , mkModulePath+  , mkModulePaths+  , mkModulePathFromQName+  ) where++import           Fay.Compiler.QName+import qualified Fay.Exts                        as F++import           Data.List+import           Data.List.Split+import           Language.Haskell.Exts++-- | The name of a module split into a list for code generation.+newtype ModulePath = ModulePath { unModulePath :: [String] }+  deriving (Eq, Ord, Show)++-- | Construct the complete ModulePath from a ModuleName.+mkModulePath :: ModuleName a -> ModulePath+mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m++-- | Construct intermediate module paths from a ModuleName.+-- mkModulePaths "A.B" => [["A"], ["A","B"]]+mkModulePaths :: ModuleName a -> [ModulePath]+mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m++-- | Converting a QName to a ModulePath is only relevant for constructors since+-- they can conflict with module names.+mkModulePathFromQName :: QName a -> ModulePath+mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n+mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name"
+ src/Fay/Types/Printer.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleContexts #-}+module Fay.Types.Printer+  ( PrintReader(..)+  , defaultPrintReader+  , PrintWriter(..)+  , pwOutputString+  , PrintState(..)+  , defaultPrintState+  , Printer(..)+  , Printable(..)+  , execPrinter+  , indented+  , newline+  , write+  , askIf+  , mapping+  ) where++import Fay.Compiler.Prelude++import Control.Monad.RWS               (RWS, asks, execRWS, get, modify, put, tell)+import Data.List                       (elemIndex)+import Data.Maybe                      (fromMaybe)+import Data.String+import Language.Haskell.Exts+import SourceMap.Types+import qualified Data.Semigroup as SG++-- | Global options of the printer+data PrintReader = PrintReader+  { prPretty          :: Bool      -- ^ Are we to pretty print?+  , prPrettyThunks    :: Bool      -- ^ Use pretty thunk names?+  , prPrettyOperators :: Bool      -- ^ Use pretty operators?+  }++-- | default printer options (non-pretty printing)+defaultPrintReader :: PrintReader+defaultPrintReader = PrintReader False False False++-- | Output of printer+data PrintWriter = PrintWriter+  { pwMappings    :: [Mapping] -- ^ Source mappings.+  , pwOutput      :: ShowS     -- ^ The current output.+  }++pwOutputString :: PrintWriter -> String+pwOutputString (PrintWriter _ out) = out ""++instance SG.Semigroup PrintWriter where+  (PrintWriter a b) <> (PrintWriter x y) = PrintWriter (a ++ x) (b . y)++-- | Output concatenation+instance Monoid PrintWriter where+  mempty =  PrintWriter [] id+  mappend = (<>)++-- | The state of the pretty printer.+data PrintState = PrintState+  { psLine        :: Int       -- ^ The current line.+  , psColumn      :: Int       -- ^ Current column.+  , psIndentLevel :: Int       -- ^ Current indentation level.+  , psNewline     :: Bool      -- ^ Just outputted a newline?+  }++-- | Default state.+defaultPrintState :: PrintState+defaultPrintState = PrintState 0 0 0 False++-- | The printer.+newtype Printer = Printer+  { runPrinter :: RWS PrintReader PrintWriter PrintState () }++execPrinter :: Printer -> PrintReader -> PrintWriter+execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState++instance SG.Semigroup Printer where+  (Printer p) <> (Printer q) = Printer (p >> q)++instance Monoid Printer where+  mempty = Printer $ return ()+  mappend = (<>)++-- | Print some value.+class Printable a where+  printJS :: a -> Printer++-- | Print the given printer indented.+indented :: Printer -> Printer+indented (Printer p) = Printer $ asks prPretty >>= \pretty ->+    when pretty (addToIndentLevel 1) >> p >> when pretty (addToIndentLevel (-1))+  where addToIndentLevel d = modify (\ps -> ps { psIndentLevel = psIndentLevel ps + d })++-- | Output a newline and makes next line indented when prPretty is True.+--   Does nothing when prPretty is False+newline :: Printer+newline = Printer $ asks prPretty >>= flip when writeNewline+  where writeNewline = writeRWS "\n" >> modify (\s -> s { psNewline = True })++-- | Write out a raw string, respecting the indentation+--   Note: if you pass a string with newline characters, it will print them+--   out even if prPretty is set to False. Also next line won't be indented.+--   If you want write a smart newline (that is the one which will be written+--   out only if prPretty is true, and after which the line will be indented)+--   use `newline`)+write :: String -> Printer+write = Printer . writeRWS++writeRWS :: String -> RWS PrintReader PrintWriter PrintState ()+writeRWS x = do+  ps <- get+  let out = if psNewline ps+               then replicate (2 * psIndentLevel ps) ' ' ++ x+               else x+  tell mempty { pwOutput = (out++) }++  let newLines = length (filter (== '\n') x)+  put ps { psLine    = psLine ps + newLines+         , psColumn  = fromMaybe (psColumn ps + length x) . elemIndex '\n' $ reverse x+         , psNewline = False+         }++-- | Write out a string, updating the current position information.+instance IsString Printer where+  fromString = write++-- | exec one of Printers depending on PrintReader property.+askIf :: (PrintReader -> Bool) -> Printer -> Printer -> Printer+askIf f (Printer p) (Printer q) = Printer $ asks f >>= (\b -> if b then p else q)++-- | Generate a mapping from the Haskell location to the current point in the output.+mapping :: SrcSpan -> Printer+mapping srcSpan = Printer $ get >>= \ps ->+    let m = Mapping { mapGenerated = Pos (fromIntegral (psLine ps))+                                         (fromIntegral (psColumn ps))+                    , mapOriginal = Just (Pos (fromIntegral (srcSpanStartLine srcSpan))+                                              (fromIntegral (srcSpanStartColumn srcSpan) - 1))+                    , mapSourceFile = Just (srcSpanFilename srcSpan)+                    , mapName = Nothing+                    }+    in tell $ mempty { pwMappings = [m] }
+ src/haskell-names/LICENSE view
@@ -0,0 +1,3 @@+Forked from haskell-names+Licensed as BSD3+Authors: Roman Cheplyaka, Lennart Augustsson
+ src/haskell-names/Language/Haskell/Names.hs view
@@ -0,0 +1,17 @@+module Language.Haskell.Names+  (+  -- * Core functions+    annotateModule+  , getInterfaces+  -- * Types+  , SymValueInfo(..)+  , Symbols(..)+  , Scoped(..)+  , NameInfo(..)+  , GName(..)+  , OrigName(..)+  , HasOrigName(..)+  ) where++import Language.Haskell.Names.Types (Symbols (..), SymValueInfo (..), Scoped (..), NameInfo (..), GName (..), OrigName (..), HasOrigName (..))+import Language.Haskell.Names.Recursive (getInterfaces, annotateModule)
+ src/haskell-names/Language/Haskell/Names/Annotated.hs view
@@ -0,0 +1,100 @@+-- This module uses the open recursion interface+-- ("Language.Haskell.Names.Open") to annotate the AST with binding+-- information.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards         #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+module Language.Haskell.Names.Annotated+  ( Scoped (..)+  , NameInfo (..)+  , annotate+  ) where++import           Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable  as Local+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.Open.Instances    ()+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.Types++import           Data.Lens.Light+import           Data.Proxy+import           Language.Haskell.Exts+import           Data.Typeable ( eqT, (:~:)(Refl) )++annotate+  :: forall a l .+     (Resolvable (a (Scoped l)), Functor a, Typeable l)+  => Scope -> a l -> a (Scoped l)+annotate sc = annotateRec (Proxy :: Proxy l) sc . fmap (Scoped None)++annotateRec+  :: forall a l .+     (Typeable l, Resolvable a)+  => Proxy l -> Scope -> a -> a+annotateRec _ sc a = go sc a where+  go :: forall a . Resolvable a => Scope -> a -> a+  go sc a+    | ReferenceV <- getL nameCtx sc+    , Just (Refl :: QName (Scoped l) :~: a) <- eqT+      = lookupValue (fmap sLoc a) sc <$ a+    | ReferenceT <- getL nameCtx sc+    , Just (Refl :: QName (Scoped l) :~: a) <- eqT+      = lookupType (fmap sLoc a) sc <$ a+    | BindingV <- getL nameCtx sc+    , Just (Refl :: Name (Scoped l) :~: a) <- eqT+      = Scoped ValueBinder (sLoc . ann $ a) <$ a+    | BindingT <- getL nameCtx sc+    , Just (Refl :: Name (Scoped l) :~: a) <- eqT+      = Scoped TypeBinder (sLoc . ann $ a) <$ a+    | Just (Refl :: FieldUpdate (Scoped l) :~: a) <- eqT+      = case a of+          FieldPun l n -> FieldPun l (lookupValue (sLoc <$> n) sc <$ n)+          FieldWildcard l ->+            let+              namesUnres = sc ^. wcNames+              resolve n =+                let Scoped info _ = lookupValue (sLoc l <$ UnQual () n) sc+                in info+              namesRes =+                map+                  (\f -> (wcFieldOrigName f, resolve $ wcFieldName f))+                  namesUnres+            in FieldWildcard $ Scoped (RecExpWildcard namesRes) (sLoc l)+          _ -> rmap go sc a+    | Just (Refl :: PatField (Scoped l) :~: a) <- eqT+    , PFieldWildcard l <- a+      = PFieldWildcard $+          Scoped+            (RecPatWildcard $ map wcFieldOrigName $ sc ^. wcNames)+            (sLoc l)+    | otherwise+      = rmap go sc a++lookupValue :: QName l -> Scope -> Scoped l+lookupValue qn sc = Scoped nameInfo (ann qn)+  where+    nameInfo =+      case Local.lookupValue qn $ getL lTable sc of+        Right r -> LocalValue r+        _ ->+          case Global.lookupValue qn $ getL gTable sc of+            Global.Result r -> GlobalValue r+            Global.Error e -> ScopeError e+            Global.Special -> None++lookupType :: QName l -> Scope -> Scoped l+lookupType qn sc = Scoped nameInfo (ann qn)+  where+    nameInfo =+      case Global.lookupType qn $ getL gTable sc of+        Global.Result r -> GlobalType r+        Global.Error e -> ScopeError e+        Global.Special -> None
+ src/haskell-names/Language/Haskell/Names/Exports.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoMonoLocalBinds  #-}+{-# LANGUAGE TypeFamilies      #-}+module Language.Haskell.Names.Exports+  ( processExports+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.ModuleT+import           Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ModuleSymbols+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types             (Error (..), GName (..), ModuleNameS, NameInfo (..),+                                                           Scoped (..), Symbols (..), mkTy, mkVal, st_origName)++import           Control.Monad.Writer                     (WriterT (WriterT), runWriterT)+import qualified Data.Map                                 as Map+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts++processExports+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l)+  => Global.Table+  -> Module l+  -> m (Maybe (ExportSpecList (Scoped l)), Symbols)+processExports tbl m =+  case getExportSpecList m of+    Nothing ->+      return (Nothing, moduleSymbols tbl m)+    Just exp ->+      liftM (first Just) $ resolveExportSpecList tbl exp++resolveExportSpecList+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => Global.Table+  -> ExportSpecList l+  -> m (ExportSpecList (Scoped l), Symbols)+resolveExportSpecList tbl (ExportSpecList l specs) =+  liftM (first $ ExportSpecList $ none l) $+  runWriterT $+  mapM (WriterT . resolveExportSpec tbl) specs++resolveExportSpec+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => Global.Table+  -> ExportSpec l+  -> m (ExportSpec (Scoped l), Symbols)+resolveExportSpec tbl exp =+  case exp of+    EVar l qn -> return $+      case Global.lookupValue qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let s = mkVal i+          in+            (EVar (Scoped (Export s) l)+              (Scoped (GlobalValue i) <$> qn), s)+        Global.Special {} -> error "Global.Special in export list?"+    EAbs l ns qn -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let s = mkTy i+          in+            (EAbs (Scoped (Export s) l) (noScope ns)+              (Scoped (GlobalType i) <$> qn), s)+        Global.Special {} -> error "Global.Special in export list?"+    EThingWith l (EWildcard wcl wcn) qn [] -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let+            subs = mconcat+              [ mkVal info+              | info <- allValueInfos+              , Just n' <- return $ sv_parent info+              , n' == st_origName i ]+            s = mkTy i <> subs+          in+            ( EThingWith (Scoped (Export s) l)+                         (EWildcard (Scoped (Export s) wcl) wcn)+                         (Scoped (GlobalType i) <$> qn)+                         []+            , s+            )+        Global.Special {} -> error "Global.Special in export list?"+    EThingWith _ (EWildcard _ _) _qn _cns -> error "Name resolution: CNames are not supported in wildcard exports"+    EThingWith l (NoWildcard wcl) qn cns -> return $+      case Global.lookupType qn tbl of+        Global.Error err ->+          (scopeError err exp, mempty)+        Global.Result i ->+          let+            (cns', subs) =+              resolveCNames+                (Global.toSymbols tbl)+                (st_origName i)+                (\cn -> ENotInScope (UnQual (ann cn) (unCName cn))) -- FIXME better error+                cns+            s = mkTy i <> subs+          in+            ( EThingWith (Scoped (Export s) l)+                         (NoWildcard (Scoped (Export s) wcl))+                         (Scoped (GlobalType i) <$> qn)+                         cns'+            , s+            )+        Global.Special {} -> error "Global.Special in export list?"+    EModuleContents _ (ModuleName _ mod) ->+      -- FIXME ambiguity check+      let+        filterByPrefix+          :: Ord i+          => ModuleNameS+          -> Map.Map GName (Set.Set i)+          -> Set.Set i+        filterByPrefix prefix m =+          Set.unions+            [ i | (GName { gModule = prefix' }, i) <- Map.toList m, prefix' == prefix ]++        filterEntities+          :: Ord i+          => Map.Map GName (Set.Set i)+          -> Set.Set i+        filterEntities ents =+          Set.intersection+            (filterByPrefix mod ents)+            (filterByPrefix ""  ents)++        eVals = filterEntities $ Global.values tbl+        eTyps = filterEntities $ Global.types tbl++        s = Symbols eVals eTyps+      in+        return (Scoped (Export s) <$> exp, s)+  where+    allValueInfos =+      Set.toList $ Map.foldl' Set.union Set.empty $ Global.values tbl
+ src/haskell-names/Language/Haskell/Names/GetBound.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE NoImplicitPrelude      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE UndecidableInstances   #-}+module Language.Haskell.Names.GetBound+  ( GetBound(..)+  ) where++import           Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.SyntaxUtils++import           Data.Generics.Uniplate.Data+import           Language.Haskell.Exts+++-- | Get bound value identifiers.+class GetBound a l | a -> l where+    -- | For record wildcards we need to know which fields the given+    -- constructor has. So we pass the global table for that.+    getBound :: Global.Table -> a -> [Name l]++-- XXX account for shadowing?+instance (GetBound a l) => GetBound [a] l where+    getBound ctx xs = concatMap (getBound ctx) xs++instance (GetBound a l) => GetBound (Maybe a) l where+    getBound ctx = maybe [] (getBound ctx)++instance (GetBound a l, GetBound b l) => GetBound (a, b) l where+    getBound ctx (a, b) = getBound ctx a ++ getBound ctx b++instance (Data l) => GetBound (Binds l) l where+    getBound ctx e = case e of+      BDecls _ ds -> getBound ctx ds+      IPBinds _ _ -> []  -- XXX doesn't bind regular identifiers++instance (Data l) => GetBound (Decl l) l where+    getBound ctx e = case e of+      TypeDecl{} -> []+      TypeFamDecl{} -> []+      DataDecl _ _ _ _ ds _ -> getBound ctx ds+      GDataDecl _ _ _ _ _ ds _ -> getBound ctx ds+      DataFamDecl{} -> []+      TypeInsDecl{} -> []+      DataInsDecl _ _ _ ds _ -> getBound ctx ds+      GDataInsDecl _ _ _ _ ds _ -> getBound ctx ds+      ClassDecl _ _ _ _ mds -> getBound ctx mds+      InstDecl{} -> []+      DerivDecl{} -> []+      InfixDecl{} -> []+      DefaultDecl{} -> []+      SpliceDecl{} -> []+      TypeSig{} -> []+      FunBind _ [] -> error "getBound: FunBind []"+      FunBind _ (Match _ n _ _ _ : _) -> [n]+      FunBind _ (InfixMatch _ _ n _ _ _ : _) -> [n]+      PatBind _ p _ _ -> getBound ctx p+      ForImp _ _ _ _ n _ -> [n]+      ForExp _ _ _ n _ -> [n]+      RulePragmaDecl{} -> []+      DeprPragmaDecl{} -> []+      WarnPragmaDecl{} -> []+      InlineSig{} -> []+      SpecSig{} -> []+      SpecInlineSig{} -> []+      InstSig{} -> []+      AnnPragma{} -> []+      InlineConlikeSig{} -> []+      ClosedTypeFamDecl{} -> []+      MinimalPragma{} -> []+      _ -> error "Unsupported syntax"++instance (Data l) => GetBound (QualConDecl l) l where+    getBound ctx (QualConDecl _ _ _ d) = getBound ctx d++instance (Data l) => GetBound (GadtDecl l) l where+    getBound _ctx (GadtDecl _l conName _tyvarBinds _context mbFieldDecls _ty) =+      -- GADT constructor name+      [conName] +++      -- GADT selector names+      [ fieldName+      | Just fieldDecls <- return mbFieldDecls+      , FieldDecl _l' fieldNames _fieldTy <- fieldDecls+      , fieldName <- fieldNames+      ]++instance (Data l) => GetBound (ConDecl l) l where+    getBound ctx e = case e of+      ConDecl _ n _ -> [n]+      InfixConDecl _ _ n _ -> [n]+      RecDecl _ n fs -> n : getBound ctx fs++instance (Data l) => GetBound (FieldDecl l) l where+    getBound _ctx (FieldDecl _ ns _) = ns++instance (Data l) => GetBound (ClassDecl l) l where+    getBound _ctx e = case e of+      ClsDecl _ d -> getBoundSign d+      ClsDataFam{} -> []+      ClsTyFam{} -> []+      ClsTyDef{} -> []+      ClsDefSig{} -> []++instance (Data l) => GetBound (Match l) l where+    getBound _ctx e = case e of+      Match _ n _ _ _ -> [n]+      InfixMatch _ _ n _ _ _ -> [n]++instance (Data l) => GetBound (Stmt l) l where+  getBound ctx e =+    case e of+      Generator _ pat _ -> getBound ctx pat+      LetStmt _ bnds    -> getBound ctx bnds+      RecStmt _ stmts   -> getBound ctx stmts+      Qualifier {} -> []++instance (Data l) => GetBound (QualStmt l) l where+  getBound ctx e =+    case e of+      QualStmt _ stmt -> getBound ctx stmt+      _ -> []++instance (Data l) => GetBound (Pat l) l where+  getBound gt p =+    [ n | p' <- universe $ transform dropExp p, n <- varp p' ]++    where++      varp (PVar _ n) = [n]+      varp (PAsPat _ n _) = [n]+      varp (PNPlusK _ n _) = [n]+      varp (PRec _ con fs) =+        [ n+        | -- (lazily) compute elided fields for the case when 'f' below is a wildcard+          let elidedFields = map wcFieldName $ patWcNames gt con fs+        , f <- fs+        , n <- getRecVars elidedFields f+        ]+      varp _ = []++      -- must remove nested Exp so universe doesn't descend into them+      dropExp (PViewPat _ _ x) = x+      dropExp x = x++      getRecVars :: [Name ()] -> PatField l -> [Name l]+      getRecVars _ PFieldPat {} = [] -- this is already found by the generic algorithm+      getRecVars _ (PFieldPun _ qn) = [qNameToName qn]+      getRecVars elidedFields (PFieldWildcard l) = map (l <$) elidedFields++getBoundSign :: Decl l -> [Name l]+getBoundSign (TypeSig _ ns _) = ns+getBoundSign _ = []
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude  #-}+-- | This module is designed to be imported qualified.+module Language.Haskell.Names.GlobalSymbolTable+  ( Table+  , empty+  , Result(..)+  , lookupValue+  , lookupType+  , fromLists+  , types+  , values+  , toSymbols+  ) where++import           Fay.Compiler.Prelude               hiding (empty)+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Data.Lens.Light+import qualified Data.Map                           as Map+import qualified Data.Set                           as Set+import           Language.Haskell.Exts    as HSE+import           Data.Semigroup (Semigroup)++-- | Global symbol table — contains global names+data Table =+  Table+    (Map.Map GName (Set.Set (SymValueInfo OrigName)))+    (Map.Map GName (Set.Set (SymTypeInfo  OrigName)))+    deriving (Eq, Ord, Show, Data, Typeable)++valLens :: Lens Table (Map.Map GName (Set.Set (SymValueInfo OrigName)))+valLens = lens (\(Table vs _) -> vs) (\vs (Table _ ts) -> Table vs ts)++tyLens :: Lens Table (Map.Map GName (Set.Set (SymTypeInfo OrigName)))+tyLens = lens (\(Table _ ts) -> ts) (\ts (Table vs _) -> Table vs ts)++instance Semigroup Table where+  (Table vs1 ts1) <> (Table vs2 ts2) =+    Table (j vs1 vs2) (j ts1 ts2)+    where+      j :: (Ord i, Ord k)+        => Map.Map k (Set.Set i)+        -> Map.Map k (Set.Set i)+        -> Map.Map k (Set.Set i)+      j = Map.unionWith Set.union+instance Monoid Table where+  mempty = empty+  mappend = (<>)++toGName :: QName l -> GName+toGName (UnQual _ n) = GName "" (nameToString n)+toGName (Qual _ (ModuleName _ m) n) = GName m (nameToString n)+toGName (HSE.Special _ _) = error "toGName: Special"++empty :: Table+empty = Table Map.empty Map.empty++lookupL+  :: HasOrigName i+  => Lens Table (Map.Map GName (Set.Set (i OrigName)))+  -> QName l+  -> Table+  -> Result l (i OrigName)+lookupL _ (HSE.Special {}) _ =+  Language.Haskell.Names.GlobalSymbolTable.Special+lookupL lens qn tbl =+  case Set.toList <$> (Map.lookup (toGName qn) $ getL lens tbl) of+    Nothing -> Error $ ENotInScope qn+    Just [] -> Error $ ENotInScope qn+    Just [i] -> Result i+    Just is -> Error $ EAmbiguous qn (map origName is)++data Result l a+  = Result a+  | Error (Error l)+  | Special++lookupValue :: QName l -> Table -> Result l (SymValueInfo OrigName)+lookupValue = lookupL valLens++lookupType :: QName l -> Table -> Result l (SymTypeInfo OrigName)+lookupType  = lookupL tyLens++fromMaps+  :: Map.Map GName (Set.Set (SymValueInfo OrigName))+  -> Map.Map GName (Set.Set (SymTypeInfo  OrigName))+  -> Table+fromMaps = Table++fromLists+  :: ([(GName, SymValueInfo OrigName)],+      [(GName, SymTypeInfo OrigName)])+  -> Table+fromLists (vs, ts) =+  fromMaps+    (Map.fromListWith Set.union $ map (second Set.singleton) vs)+    (Map.fromListWith Set.union $ map (second Set.singleton) ts)++values :: Table -> Map.Map GName (Set.Set (SymValueInfo OrigName))+types  :: Table -> Map.Map GName (Set.Set (SymTypeInfo  OrigName))+values = getL valLens+types = getL tyLens++toSymbols :: Table -> Symbols+toSymbols tbl =+  Symbols+    (gather $ values tbl)+    (gather $ types  tbl)+  where+    gather :: Ord a => Map.Map k (Set.Set a) -> Set.Set a+    gather = Map.foldl' Set.union Set.empty
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot view
@@ -0,0 +1,10 @@+module Language.Haskell.Names.GlobalSymbolTable where++import Data.Data++data Table deriving Typeable+instance Eq   Table+instance Ord  Table+instance Show Table+instance Data Table+
+ src/haskell-names/Language/Haskell/Names/Imports.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-} -- ModName (ModuleName l)+module Language.Haskell.Names.Imports (processImports) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.ModuleT+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Monad.Writer                     (WriterT (WriterT), runWriterT)+import           Data.Foldable                            (fold)+import           Data.Lens.Light+import qualified Data.Map                                 as Map+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts++instance ModName (ModuleName l) where+  modToString (ModuleName _ s) = s++preludeName :: String+preludeName = "Prelude"++processImports+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => ExtensionSet+  -> [ImportDecl l]+  -> m ([ImportDecl (Scoped l)], Global.Table)+processImports exts importDecls = do++  (annotated, tbl) <- runWriterT $ mapM (WriterT . processImport) importDecls++  let+    isPreludeImported = not . null $+      [ () | ImportDecl { importModule = ModuleName _ modName } <- importDecls+           , modName == preludeName ]++    importPrelude =+      ImplicitPrelude `Set.member` exts &&+      not isPreludeImported++  tbl' <-+    if not importPrelude+      then return tbl+      else do+        -- FIXME currently we don't have a way to signal an error when+        -- Prelude cannot be found+        syms <- fold `liftM` getModuleInfo preludeName+        return $ tbl <>+          computeSymbolTable+            False -- not qualified+            (ModuleName () preludeName)+            syms++  return (annotated, tbl')++processImport+  :: (MonadModule m, ModuleInfo m ~ Symbols)+  => ImportDecl l+  -> m (ImportDecl (Scoped l), Global.Table)+processImport imp = do+  mbi <- getModuleInfo (importModule imp)+  case mbi of+    Nothing ->+      let e = EModNotFound (importModule imp)+      in return (scopeError e imp, Global.empty)+    Just syms -> return $ resolveImportDecl syms imp++resolveImportDecl+  :: Symbols+  -> ImportDecl l+  -> (ImportDecl (Scoped l), Global.Table)+resolveImportDecl syms (ImportDecl l mod qual src impSafe pkg mbAs mbSpecList) =+  let+    (mbSpecList', impSyms) =+      (fmap fst &&& maybe syms snd) $+        resolveImportSpecList mod syms <$> mbSpecList+    tbl = computeSymbolTable qual (fromMaybe mod mbAs) impSyms+    info =+      case mbSpecList' of+        Just sl | Scoped (ScopeError e) _ <- ann sl ->+          ScopeError e+        _ -> Import tbl+  in+    (ImportDecl+      (Scoped info l)+      (Scoped (ImportPart syms) <$> mod)+      qual+      src+      impSafe+      pkg+      (fmap noScope mbAs)+      mbSpecList'+    , tbl)++resolveImportSpecList+  :: ModuleName l+  -> Symbols+  -> ImportSpecList l+  -> (ImportSpecList (Scoped l), Symbols)+resolveImportSpecList mod allSyms (ImportSpecList l isHiding specs) =+  let specs' = map (resolveImportSpec mod isHiding allSyms) specs+      mentionedSyms = mconcat $ rights $ map ann2syms specs'+      importedSyms = computeImportedSymbols isHiding allSyms mentionedSyms+      newAnn = Scoped (ImportPart importedSyms) l+  in+    (ImportSpecList newAnn isHiding specs', importedSyms)++-- | This function takes care of the possible 'hiding' clause+computeImportedSymbols+  :: Bool+  -> Symbols -- ^ all symbols+  -> Symbols -- ^ mentioned symbols+  -> Symbols -- ^ imported symbols+computeImportedSymbols isHiding (Symbols vs ts) mentionedSyms =+  case isHiding of+    False -> mentionedSyms+    True ->+      let+        Symbols hvs hts = mentionedSyms+        allTys = symbolMap st_origName ts+        hidTys = symbolMap st_origName hts+        allVls = symbolMap sv_origName vs+        hidVls = symbolMap sv_origName hvs+      in+        Symbols+          (Set.fromList $ Map.elems $ allVls Map.\\ hidVls)+          (Set.fromList $ Map.elems $ allTys Map.\\ hidTys)++symbolMap+  :: Ord s+  => (a -> s)+  -> Set.Set a+  -> Map.Map s a+symbolMap f is = Map.fromList [(f i, i) | i <- Set.toList is]++resolveImportSpec+  :: ModuleName l+  -> Bool+  -> Symbols+  -> ImportSpec l+  -> ImportSpec (Scoped l)+-- NB: this can be made more efficient+resolveImportSpec mod isHiding syms spec =+  case spec of+    IVar _ n ->+      let+        matches = mconcat $+          -- Strictly speaking, the isConstructor check is unnecessary+          -- because constructors are lexically different from anything+          -- else.+          [ mkVal info+          | info <- vs+          , not (isConstructor info)+          , sv_origName info ~~ n]+      in+        checkUnique+          (ENotExported Nothing n mod)+          matches+          spec+    -- FIXME think about data families etc.+    IAbs _ _ n+      | isHiding ->+          -- This is a bit special. 'C' may match both types/classes and+          -- data constructors.+          -- FIXME Still check for uniqueness?+          let+            Symbols vlMatches tyMatches =+              mconcat [ mkVal info | info <- vs, sv_origName info ~~ n]+              <>+              mconcat [ mkTy info | info <- ts, st_origName info ~~ n]+          in+            if Set.null tyMatches && Set.null vlMatches+              then+                scopeError (ENotExported Nothing n mod) spec+              else+                Scoped (ImportPart (Symbols vlMatches tyMatches)) <$> spec+      | otherwise ->+          let+            matches = mconcat+              [mkTy info | info <- ts, st_origName info ~~ n]+          in+            checkUnique+              (ENotExported Nothing n mod)+              matches+              spec+    -- FIXME+    -- What about things like:+    -- head(..)+    -- String(..)+    -- ?+    IThingAll l n ->+      let+        matches = [ info | info <- ts, st_origName info ~~ n]+        subs = mconcat+          [ mkVal info+          | n <- matches+          , info <- vs+          , Just n' <- return $ sv_parent info+          , n' == st_origName n ]+        n' =+          checkUnique+            (ENotExported Nothing n mod)+            (foldMap mkTy matches)+            n+        in+          case ann n' of+            e@(Scoped ScopeError{} _) -> IThingAll e n'+            _ ->+              IThingAll+                (Scoped+                  (ImportPart (subs <> foldMap mkTy matches))+                  l+                )+                n'++    IThingWith l n cns ->+      let+        matches = [info | info <- ts, st_origName info ~~ n]+        n' =+          checkUnique+            (ENotExported Nothing n mod)+            (foldMap mkTy matches)+            n+        typeName = st_origName $ head matches -- should be safe+        (cns', cnSyms) =+          resolveCNames+            syms+            typeName+            (\cn -> ENotExported (Just n) (unCName cn) mod)+            cns+      in+        IThingWith+          (Scoped+            (ImportPart (cnSyms <> foldMap mkTy matches))+            l+          )+          n'+          cns'+  where+    (~~) :: OrigName -> Name l -> Bool+    OrigName { origGName = GName { gName = n } } ~~ n' = n == nameToString n'++    isConstructor :: SymValueInfo n -> Bool+    isConstructor SymConstructor {} = True+    isConstructor _ = False++    vs = Set.toList $ syms^.valSyms+    ts = Set.toList $ syms^.tySyms++ann2syms :: Annotated a => a (Scoped l) -> Either (Error l) (Symbols)+ann2syms a =+  case ann a of+    Scoped (ScopeError e) _ -> Left e+    Scoped (ImportPart syms) _ -> Right syms+    _ -> Left $ EInternal "ann2syms"++checkUnique+  :: Functor f =>+  Error l ->+  Symbols ->+  f l ->+  f (Scoped l)+checkUnique notFound syms@(Symbols vs ts) f =+  case Set.size vs + Set.size ts of+    0 -> scopeError notFound f+    1 -> Scoped (ImportPart syms) <$> f+    -- there should be no clashes, and it should be checked elsewhere+    _ -> scopeError (EInternal "ambiguous import") f
+ src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs view
@@ -0,0 +1,34 @@+-- | This module is designed to be imported qualified.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+module Language.Haskell.Names.LocalSymbolTable+  ( Table+  , empty+  , lookupValue+  , addValue+  ) where++import           Fay.Compiler.Prelude               hiding (empty)+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import qualified Data.Map                           as Map+import           Language.Haskell.Exts+import           Data.Semigroup ()++-- | Local symbol table — contains locally bound names+newtype Table = Table (Map.Map NameS SrcLoc)+  deriving Semigroup++addValue :: SrcInfo l => Name l -> Table -> Table+addValue n (Table vs) =+  Table (Map.insert (nameToString n) (getPointLoc $ ann n) vs)++lookupValue :: QName l -> Table -> Either (Error l) SrcLoc+lookupValue qn@(UnQual _ n) (Table vs) =+  maybe (Left $ ENotInScope qn) Right $+    Map.lookup (nameToString n) vs+lookupValue qn _ = Left $ ENotInScope qn++empty :: Table+empty = Table Map.empty
+ src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}+module Language.Haskell.Names.ModuleSymbols+  ( moduleSymbols+  , moduleTable+  )+  where++import           Fay.Compiler.Prelude++import           Language.Haskell.Exts+import           Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Data.Lens.Light+import qualified Data.Map                                 as Map+import qualified Data.Set                                 as Set++-- | Compute module's global table. It contains both the imported entities+-- and the global entities defined in this module.+moduleTable+  :: (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> Module l+  -> Global.Table+moduleTable impTbl m =+  impTbl <>+  computeSymbolTable False (getModuleName m) (moduleSymbols impTbl m)++-- | Compute the symbols that are defined in the given module.+--+-- The import table is needed to resolve possible top-level record+-- wildcard bindings, such as+--+-- >A {..} = foo+moduleSymbols+  :: (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> Module l+  -> Symbols+moduleSymbols impTbl m =+  let (vs,ts) =+        partitionEithers $+          concatMap+            (getTopDeclSymbols impTbl $ getModuleName m)+            (getModuleDecls m)+  in+    setL valSyms (Set.fromList vs) $+    setL tySyms  (Set.fromList ts) mempty++type TypeName = GName+type ConName = Name ()+type SelectorName = Name ()+type Constructors = [(ConName, [SelectorName])]++-- Extract names that get bound by a top level declaration.+getTopDeclSymbols+  :: forall l . (Eq l, Data l)+  => Global.Table -- ^ the import table for this module+  -> ModuleName l+  -> Decl l+  -> [Either (SymValueInfo OrigName) (SymTypeInfo OrigName)]+getTopDeclSymbols impTbl mdl d =+  map (either (Left . fmap OrigName) (Right . fmap OrigName)) $+  case d of+    TypeDecl _ dh _ ->+      let tn = hname dh+      in  [ Right (SymType        { st_origName = tn, st_fixity = Nothing })]++    TypeFamDecl _loc dh _mrs _mk ->+      let tn = hname dh+      in  [ Right (SymTypeFam     { st_origName = tn, st_fixity = Nothing })]++    DataDecl _ dataOrNew _ dh qualConDecls _ ->+      let+        cons :: Constructors+        cons = do -- list monad+          QualConDecl _ _ _ conDecl <- qualConDecls+          case conDecl of+            ConDecl _ n _ -> return (void n, [])+            InfixConDecl _ _ n _ -> return (void n, [])+            RecDecl _ n fields ->+              return (void n , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++        dq = hname dh++        infos = constructorsToInfos dq cons++      in+        Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++    GDataDecl _ dataOrNew _ dh _ gadtDecls _ ->+      -- FIXME: We shouldn't create selectors for fields with existential type variables!+      let+        dq = hname dh++        cons :: Constructors+        cons = do -- list monad+          GadtDecl _ cn _tyvarBinds _context (fromMaybe [] -> fields) _ty <- gadtDecls+          return (void cn , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++        infos = constructorsToInfos dq cons+      in+          Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++    DataFamDecl _ _ dh _ ->+      let tn = hname dh+      in [Right (SymDataFam { st_origName = tn, st_fixity = Nothing })]++    ClassDecl _ _ dh _ mds ->+      let+        ms = getBound impTbl d+        cq = hname dh+        cdecls = fromMaybe [] mds+      in+          Right (SymClass   { st_origName = cq,       st_fixity = Nothing }) :+        [ Right (SymTypeFam { st_origName = hname dh, st_fixity = Nothing }) | ClsTyFam   _   dh _ _ <- cdecls ] +++        [ Right (SymDataFam { st_origName = hname dh, st_fixity = Nothing }) | ClsDataFam _ _ dh _ <- cdecls ] +++        [ Left  (SymMethod  { sv_origName = qname mn, sv_fixity = Nothing, sv_className = cq }) | mn <- ms ]++    FunBind _ ms ->+      let vn : _ = getBound impTbl ms+      in  [ Left  (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) ]++    PatBind _ p _ _ ->+      [ Left  (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) | vn <- getBound impTbl p ]++    ForImp _ _ _ _ fn _ ->+      [ Left  (SymValue { sv_origName = qname fn, sv_fixity = Nothing }) ]++    _ -> []+  where+    ModuleName _ smdl = mdl+    qname = GName smdl . nameToString+    hname :: DeclHead l -> GName+    hname = qname . getDeclHeadName+    dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType++    constructorsToInfos :: TypeName -> Constructors -> [SymValueInfo GName]+    constructorsToInfos ty cons = conInfos ++ selInfos+      where+        conInfos =+          [ SymConstructor { sv_origName = qname con, sv_fixity = Nothing, sv_typeName = ty }+          | (con, _) <- cons+          ]++        selectorsMap :: Map.Map SelectorName [ConName]+        selectorsMap =+          Map.unionsWith (++) . flip map cons $ \(c, fs) ->+            Map.unionsWith (++) . flip map fs $ \f ->+              Map.singleton f [c]++        selInfos =+          [ (SymSelector { sv_origName = qname f, sv_fixity = Nothing, sv_typeName = ty, sv_constructors = map qname fCons })+          | (f, fCons) <- Map.toList selectorsMap+          ]
+ src/haskell-names/Language/Haskell/Names/Open/Base.hs view
@@ -0,0 +1,152 @@+-- | This module provides a more flexible way to process Haskell code —+-- using an open-recursive traversal.+--+-- You can look at "Language.Haskell.Exts" source as an example+-- of how to use this module.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE MonoLocalBinds        #-}++module Language.Haskell.Names.Open.Base+  ( Resolvable (..)+  , intro+  , mergeLocalScopes+  , alg+  , Scope (..)+  , setWcNames+  , gTable+  , exprV+  , exprT+  , rmap+  , wcNames+  , nameCtx+  , NameContext (..)+  , initialScope+  , binderV+  , Alg (..)+  , binderT+  , defaultRtraverse+  , lTable+  ) where++import           Fay.Compiler.Prelude+import           Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable  as Local+import           Language.Haskell.Names.RecordWildcards++import           Control.Monad.Identity+import           Data.Generics.Traversable+import           Data.Lens.Light+import           GHC.Exts                                 (Constraint)+import           Language.Haskell.Exts++-- | Describes how we should treat names in the current context+data NameContext+  = BindingT+  | BindingV+  | ReferenceT+  | ReferenceV+  | Other++-- | Contains information about the node's enclosing scope. Can be+-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx', 'wcNames'.+data Scope = Scope+  { _gTable  :: Global.Table+  , _lTable  :: Local.Table+  , _nameCtx :: NameContext+  , _wcNames :: WcNames+  }++makeLens ''Scope++-- | Create an initial scope+initialScope :: Global.Table -> Scope+initialScope tbl = Scope tbl Local.empty Other []++-- | Merge local tables of two scopes. The other fields of the scopes are+-- assumed to be the same.+mergeLocalScopes :: Scope -> Scope -> Scope+mergeLocalScopes sc1 sc2 =+  modL lTable (<> sc2 ^. lTable) sc1++-- | The algebra for 'rtraverse'. It's newtype-wrapped because an implicit+-- parameter cannot be polymorphic.+newtype Alg w = Alg+  { runAlg :: forall d . Resolvable d => d -> Scope -> w d }++alg :: (?alg :: Alg w, Resolvable d) => d -> Scope -> w d+alg = runAlg ?alg++data ConstraintProxy (p :: * -> Constraint) = ConstraintProxy++defaultRtraverse+  :: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)+  => a -> Scope -> f a+defaultRtraverse a sc =+  let ?c = ConstraintProxy :: ConstraintProxy Resolvable+  in gtraverse @Resolvable (\a -> alg a sc) a++-- | A type that implements 'Resolvable' provides a way to perform+-- a shallow scope-aware traversal.++-- There is a generic implementation, 'defaultRtraverse', which is based on+-- 'GTraversable'. It can be used when there the scope of all the immediate+-- children is the same as the scope of the current node.+--+-- We use 'Typeable' here rather than a class-based approach.+-- Otherwise, hand-written instances would carry extremely long lists of+-- constraints, saying that the subterms satisfy the user-supplied class.+class Typeable a => Resolvable a where+  rtraverse+    :: (Applicative f, ?alg :: Alg f)+    => a -> Scope -> f a++instance (Typeable a, GTraversable Resolvable a) => Resolvable a where+  rtraverse = defaultRtraverse++-- | Analogous to 'gmap', but for 'Resolvable'+rmap+  :: Resolvable a+  => (forall b. Resolvable b => Scope -> b -> b)+  -> Scope -> a -> a+rmap f sc =+  let ?alg = Alg $ \a sc -> Identity (f sc a)+  in runIdentity . flip rtraverse sc++intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope+intro node sc =+  modL lTable+    (\tbl -> foldl' (flip Local.addValue) tbl $+      getBound (sc ^. gTable) node)+    sc++setNameCtx :: NameContext -> Scope -> Scope+setNameCtx = setL nameCtx++setWcNames :: WcNames -> Scope -> Scope+setWcNames = setL wcNames++binderV :: Scope -> Scope+binderV = setNameCtx BindingV++binderT :: Scope -> Scope+binderT = setNameCtx BindingT++exprV :: Scope -> Scope+exprV = setNameCtx ReferenceV++exprT :: Scope -> Scope+exprT = setNameCtx ReferenceT
+ src/haskell-names/Language/Haskell/Names/Open/Derived.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}+module Language.Haskell.Names.Open.Derived where++import           Data.Generics.Traversable.TH+import           Language.Haskell.Exts++deriveGTraversable ''ModuleName+deriveGTraversable ''SpecialCon+deriveGTraversable ''QName+deriveGTraversable ''Name+deriveGTraversable ''Boxed+deriveGTraversable ''IPName+deriveGTraversable ''QOp+deriveGTraversable ''Op+deriveGTraversable ''CName+deriveGTraversable ''Module+deriveGTraversable ''ModuleHead+deriveGTraversable ''ExportSpecList+deriveGTraversable ''ExportSpec+deriveGTraversable ''ImportDecl+deriveGTraversable ''ImportSpecList+deriveGTraversable ''ImportSpec+deriveGTraversable ''Assoc+deriveGTraversable ''Decl+deriveGTraversable ''Annotation+deriveGTraversable ''DataOrNew+deriveGTraversable ''DeclHead+deriveGTraversable ''InstHead+deriveGTraversable ''InstRule+deriveGTraversable ''Deriving+deriveGTraversable ''Binds+deriveGTraversable ''IPBind+deriveGTraversable ''Match+deriveGTraversable ''QualConDecl+deriveGTraversable ''ConDecl+deriveGTraversable ''FieldDecl+deriveGTraversable ''GadtDecl+deriveGTraversable ''ClassDecl+deriveGTraversable ''InstDecl+deriveGTraversable ''BangType+deriveGTraversable ''Rhs+deriveGTraversable ''GuardedRhs+deriveGTraversable ''Type+deriveGTraversable ''TyVarBind+deriveGTraversable ''FunDep+deriveGTraversable ''Context+deriveGTraversable ''Asst+deriveGTraversable ''Literal+deriveGTraversable ''Exp+deriveGTraversable ''XName+deriveGTraversable ''XAttr+deriveGTraversable ''Bracket+deriveGTraversable ''Splice+deriveGTraversable ''Safety+deriveGTraversable ''CallConv+deriveGTraversable ''ModulePragma+deriveGTraversable ''Tool+deriveGTraversable ''Activation+deriveGTraversable ''Rule+deriveGTraversable ''RuleVar+deriveGTraversable ''WarningText+deriveGTraversable ''Pat+deriveGTraversable ''PXAttr+deriveGTraversable ''RPatOp+deriveGTraversable ''RPat+deriveGTraversable ''PatField+deriveGTraversable ''Stmt+deriveGTraversable ''QualStmt+deriveGTraversable ''FieldUpdate+deriveGTraversable ''Alt+deriveGTraversable ''Promoted+deriveGTraversable ''BooleanFormula+deriveGTraversable ''TypeEqn+deriveGTraversable ''Overlap+deriveGTraversable ''Sign+deriveGTraversable ''Namespace+deriveGTraversable ''Role+deriveGTraversable ''PatternSynDirection+deriveGTraversable ''Unpackedness+deriveGTraversable ''ResultSig+deriveGTraversable ''InjectivityInfo+deriveGTraversable ''DerivStrategy+deriveGTraversable ''MaybePromotedName
+ src/haskell-names/Language/Haskell/Names/Open/Instances.hs view
@@ -0,0 +1,361 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ImplicitParams        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE UndecidableInstances  #-}++-- MonoLocalBinds extension prevents premature generalization, which+-- results in the "default" instance being picked.+{-# LANGUAGE MonoLocalBinds        #-}+module Language.Haskell.Names.Open.Instances () where++import           Fay.Compiler.Prelude+import           Language.Haskell.Names.GetBound+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.Open.Derived    ()+import           Language.Haskell.Names.RecordWildcards+import           Language.Haskell.Names.Types++import           Data.Lens.Light+import qualified Data.Traversable                       as T+import           Language.Haskell.Exts++c :: Applicative w => c -> w c+c = pure++(<|)+  :: (Applicative w, Resolvable b, ?alg :: Alg w)+  => w (b -> c) -> (b, Scope) -> w c+(<|) k (b, sc) = k <*> alg b sc+infixl 4 <|++(-:) :: Scope -> a -> (a, Scope)+sc -: b = (b, sc)+infix 5 -:++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Decl l) where+  rtraverse e sc =+    case e of+      -- N.B. We do not add pat to the local scope.+      --+      -- If this is a top-level binding, then we shouldn't do so, lest+      -- global values are marked as local.+      -- (see https://github.com/haskell-suite/haskell-names/issues/35)+      --+      -- If this is a local binding, then we have already introduced these+      -- variables when processing the enclosing Binds.+      PatBind l pat rhs mbWhere ->+        let+          scWithWhere = intro mbWhere sc+        in+        c PatBind+          <| sc                -: l+          <| sc                -: pat+          <| exprV scWithWhere -: rhs+          <| sc                -: mbWhere+      -- FunBind consists of Matches, which we handle below anyway.+      TypeSig l names ty ->+        c TypeSig+          <| sc       -: l+          <| exprV sc -: names+          <| sc       -: ty+      _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Type l) where+  rtraverse e sc = defaultRtraverse e (exprT sc)++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (DeclHead l) where+  rtraverse e sc =+    case e of+      DHead l name ->+        c DHead+          <| sc -: l+          <| binderT sc -: name+      DHInfix l v1 name ->+        c DHInfix+          <| sc -: l+          <| sc -: v1+          <| binderT sc -: name+      _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (ConDecl l) where+  rtraverse e sc =+    case e of+      ConDecl l name tys ->+        c ConDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: tys+      InfixConDecl l t1 name t2 ->+        c InfixConDecl+          <| sc -: l+          <| sc -: t1+          <| binderV sc -: name+          <| sc -: t2+      RecDecl l name fields ->+        c RecDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: fields+++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (FieldDecl l) where+  rtraverse e sc =+    case e of+      FieldDecl l name tys ->+        c FieldDecl+          <| sc -: l+          <| binderV sc -: name+          <| sc -: tys++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Pat l) where+  rtraverse e sc =+    case e of+      PVar l name ->+        c PVar+          <| sc         -: l+          <| binderV sc -: name+      PNPlusK l name i ->+        c PNPlusK+          <| sc         -: l+          <| binderV sc -: name+          <| sc         -: i+      PInfixApp l pat1 name pat2 ->+        c PInfixApp+          <| sc       -: l+          <| sc       -: pat1+          <| exprV sc -: name+          <| sc       -: pat2+      PApp l qn pat ->+        c PApp+          <| sc       -: l+          <| exprV sc -: qn+          <| sc       -: pat+      PRec l qn pfs ->+        let+          scWc =+            setWcNames (patWcNames (sc ^. gTable) qn pfs) sc+        in+        c PRec+          <| sc       -: l+          <| exprV sc -: qn+          <| scWc     -: pfs+      PAsPat l n pat ->+        c PAsPat+          <| sc         -: l+          <| binderV sc -: n+          <| sc         -: pat+      PViewPat l exp pat ->+        c PViewPat+          <| sc       -: l+          <| exprV sc -: exp+          <| sc       -: pat+      _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (PatField l) where+  rtraverse e sc =+    case e of+      PFieldPat l qn pat ->+        c PFieldPat+          <| sc       -: l+          <| exprV sc -: qn+          <| sc       -: pat+      PFieldPun l qn ->+        c PFieldPun+          <| sc -: l+          <| exprV sc -: qn+      -- In future we might want to annotate PFieldWildcard with the names+      -- it introduces.+      PFieldWildcard {} -> defaultRtraverse e sc++-- | Chain a sequence of nodes where every node may introduce some+-- variables into scope for the subsequent nodes. Examples: patterns (see+-- note [Nested pattern scopes]), statements.+chain+  :: ( Resolvable (a l)+     , GetBound (a l) l+     , Applicative w+     , SrcInfo l+     , Data l+     , ?alg :: Alg w)+  => [a l] -> Scope -> (w [a l], Scope)+chain pats sc =+  case pats of+    [] -> (pure [], sc)+    p:ps ->+      let+        sc' = intro p sc+        p' = alg p sc+        (ps', sc'') = chain ps sc'+      in ((:) <$> p' <*> ps', sc'')++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Match l) where+  rtraverse e sc =+    case e of+      Match l name pats rhs mbWhere ->+        -- f x y z = ...+        --   where ...+        let+          (pats', scWithPats) = chain pats sc+          scWithWhere = intro mbWhere scWithPats+        in+        c Match+          <| sc                -: l+          <| binderV sc        -: name+          <*> pats' -- has been already traversed+          <| exprV scWithWhere -: rhs+          <| scWithPats        -: mbWhere+      InfixMatch l pat1 name patsRest rhs mbWhere ->+        let+          equivalentMatch = Match l name (pat1:patsRest) rhs mbWhere+          back (Match l name (pat1:patsRest) rhs mbWhere) =+            InfixMatch l pat1 name patsRest rhs mbWhere+          back _ = error "InfixMatch"+        in back <$> rtraverse equivalentMatch sc++-- NB: there is an inefficiency here (and in similar places), because we+-- call intro on the same subtree several times. Maybe tackle it later.+instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Binds l) where+  rtraverse e sc =+    case e of+      BDecls l decls ->+        let scWithBinds = intro decls sc+        in+        c BDecls+          <| sc          -: l+          <| scWithBinds -: decls+      _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Exp l) where+  rtraverse e sc =+    case e of+      Let l bnds body ->+        let scWithBinds = intro bnds sc+        in+        c Let+          <| sc          -: l+          <| scWithBinds -: bnds+          <| scWithBinds -: body++      Lambda l pats body ->+        let (pats', scWithPats) = chain pats sc+        in+        c Lambda+          <|  sc         -: l+          <*> pats'+          <|  scWithPats -: body++      ListComp l e stmts ->+        let (stmts', scWithStmts) = chain stmts sc+        in+        c ListComp+          <|  sc -: l+          <|  scWithStmts -: e+          <*> stmts'++      ParComp l e stmtss ->+        let+          (stmtss', scsWithStmts) =+            unzip $ map (\stmts -> chain stmts sc) stmtss+          scWithAllStmtss = foldl1' mergeLocalScopes scsWithStmts+        in+        c ParComp+          <|  sc -: l+          <|  scWithAllStmtss -: e+          <*> T.sequenceA stmtss'++      Proc l pat e ->+        let scWithPat = intro pat sc+        in+        c Proc+          <| sc -: l+          <| sc -: pat+          <| scWithPat -: e++      RecConstr l qn fields ->+        let+          scWc =+            setWcNames+              (expWcNames+                (sc ^. gTable)+                (sc ^. lTable)+                qn+                fields)+              sc+        in+        c RecConstr+          <| sc   -: l+          <| sc   -: qn+          <| scWc -: fields++      _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Alt l) where+  rtraverse e sc =+    case e of+      Alt l pat guardedAlts mbWhere ->+        let+          scWithPat = intro pat sc+          scWithBinds = intro mbWhere scWithPat+        in+        c Alt+          <| sc -: l+          <| sc -: pat+          <| scWithBinds -: guardedAlts+          <| scWithBinds -: mbWhere++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (GuardedRhs l) where+  rtraverse e sc =+    case e of+      GuardedRhs l stmts exp ->+        let (stmts', scWithStmts) = chain stmts sc+        in+        c GuardedRhs+          <|  sc -: l+          <*> stmts'+          <|  scWithStmts -: exp++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable [Stmt l] where+  rtraverse e sc =+    fst $ chain e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (QualStmt l) where+  rtraverse e sc =+    case e of+      QualStmt {} -> defaultRtraverse e sc+      _ -> error "haskell-names: TransformListComp is not supported yet"++{-+Note [Nested pattern scopes]+~~~~~~~~~~~~~~~~~~~~~~++When we resolve a group of patterns, their scopes nest.++Most of the time, this is not important, but there are two exceptions:+1. ScopedTypeVariables++Example: f (x :: a) (y :: a) = ...++The first 'a' is a binder, the second — a reference.++2. View patterns++An expression inside a view pattern may reference the variables bound+earlier.++Example: f x (find (< x) -> Just y) = ...+-}++-- Some road-block Resolvable instances+instance {-# OVERLAPPING #-} Typeable a => Resolvable (Scoped a) where+  rtraverse = flip $ const pure+instance {-# OVERLAPPING #-} Resolvable SrcSpan where+  rtraverse = flip $ const pure+instance {-# OVERLAPPING #-} Resolvable SrcSpanInfo where+  rtraverse = flip $ const pure++
+ src/haskell-names/Language/Haskell/Names/RecordWildcards.hs view
@@ -0,0 +1,145 @@+-- Wildcards are tricky, they deserve a module of their own+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards  #-}+{-# LANGUAGE TupleSections  #-}+module Language.Haskell.Names.RecordWildcards+  ( patWcNames+  , wcFieldName+  , WcNames+  , expWcNames+  , wcFieldOrigName+  ) where++import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable  as Local+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Control.Monad+import qualified Data.Map                                 as Map+import           Data.Maybe+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts++-- | Information about the names being introduced by a record wildcard+--+-- During resolving traversal, we always (lazily) construct this list when+-- we process PRec or RecConstr, even if it doesn't contain a wildcard.+--+-- Then, if the pattern or construction actually contains a wildcard, we use the computed value.+type WcNames = [WcField]++-- | Information about a field in the wildcard+data WcField = WcField+  { wcFieldName         :: Name ()+    -- ^ the field's simple name+  , wcFieldOrigName     :: OrigName+    -- ^ the field's original name+  , wcExistsGlobalValue :: Bool+    -- ^ whether there is a global value in scope with the same name as+    -- the field but different from the field selector+  }++getElidedFields+  :: Global.Table+  -> QName l+  -> [Name l] -- mentioned field names+  -> WcNames+getElidedFields gt con fields =+  let+    givenFieldNames :: Map.Map (Name ()) ()+    givenFieldNames =+      Map.fromList . map ((, ()) . void) $ fields++    -- FIXME must report error when the constructor cannot be+    -- resolved+    (mbConOrigName, mbTypeOrigName) =+      case Global.lookupValue con gt of+        Global.Result info@SymConstructor{} ->+          (Just $ sv_origName info, Just $ sv_typeName info)+        _ -> (Nothing, Nothing)++    allValueInfos :: Set.Set (SymValueInfo OrigName)+    allValueInfos = Set.unions $ Map.elems $ Global.values gt++    ourFieldInfos :: Set.Set (SymValueInfo OrigName)+    ourFieldInfos =+      case mbConOrigName of+        Nothing -> Set.empty+        Just conOrigName ->+          flip Set.filter allValueInfos $ \v ->+            case v of+              SymSelector { sv_constructors }+                | conOrigName `elem` sv_constructors -> True+              _ -> False++    existsGlobalValue :: Name () -> Bool+    existsGlobalValue name =+      case Global.lookupValue (UnQual () name) gt of+        Global.Result info+          | Just typeOrigName <- mbTypeOrigName+          , SymSelector {} <- info+          , sv_typeName info == typeOrigName+            -> False -- this is the field selector+          | otherwise -> True -- exists, but not this field's selector+        _ -> False -- doesn't exist or ambiguous++    ourFieldNames :: Map.Map (Name ()) WcField+    ourFieldNames =+      Map.fromList $+      map+        (+          (\orig ->+            let name = stringToName . gName . origGName $ orig in+            (name, ) $+              WcField+              { wcFieldName = name+              , wcFieldOrigName = orig+              , wcExistsGlobalValue = existsGlobalValue name+              }+          ) . sv_origName+        )+        $ Set.toList ourFieldInfos++  in Map.elems $ ourFieldNames `Map.difference` givenFieldNames++nameOfPatField :: PatField l -> Maybe (Name l)+nameOfPatField pf =+  case pf of+    PFieldPat _ qn _ -> Just $ qNameToName qn+    PFieldPun _ qn -> Just $ qNameToName qn+    PFieldWildcard {} -> Nothing++nameOfUpdField :: FieldUpdate l -> Maybe (Name l)+nameOfUpdField pf =+  case pf of+    FieldUpdate _ qn _ -> Just $ qNameToName qn+    FieldPun _ qn -> Just $ qNameToName qn+    FieldWildcard {} -> Nothing++patWcNames+  :: Global.Table+  -> QName l+  -> [PatField l]+  -> WcNames+patWcNames gt con patfs =+  getElidedFields gt con $+  mapMaybe nameOfPatField patfs++expWcNames+  :: Global.Table+  -> Local.Table+  -> QName l+  -> [FieldUpdate l]+  -> WcNames+expWcNames gt lt con patfs =+  filter isInScope $+  getElidedFields gt con $+  mapMaybe nameOfUpdField patfs+  where+    isInScope field+      | Right {} <- Local.lookupValue qn lt = True+      | otherwise = wcExistsGlobalValue field+      where+        qn = UnQual () $ wcFieldName field
+ src/haskell-names/Language/Haskell/Names/Recursive.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+module Language.Haskell.Names.Recursive+  ( computeInterfaces+  , getInterfaces+  , annotateModule+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.ModuleT+import           Language.Haskell.Names.Annotated+import           Language.Haskell.Names.Exports+import           Language.Haskell.Names.Imports+import           Language.Haskell.Names.ModuleSymbols+import           Language.Haskell.Names.Open.Base+import           Language.Haskell.Names.ScopeUtils+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Data.Data                            (Data)+import           Data.Foldable+import           Data.Graph                           (flattenSCC, stronglyConnComp)+import qualified Data.Set                             as Set+import           Language.Haskell.Exts+++-- | Take a set of modules and return a list of sets, where each sets for+-- a strongly connected component in the import graph.+-- The boolean determines if imports using @SOURCE@ are taken into account.+groupModules :: forall l . [Module l] -> [[Module l]]+groupModules modules =+  map flattenSCC $ stronglyConnComp $ map mkNode modules+  where+    mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])+    mkNode m =+      ( m+      , dropAnn $ getModuleName m+      , map (dropAnn . importModule) $ getImports m+      )++-- | Annotate a module with scoping information. This assumes that all+-- module dependencies have been resolved and cached — usually you need+-- to run 'computeInterfaces' first, unless you have one module in+-- isolation.+annotateModule+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Eq l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> Module l -- ^ input module+  -> m (Module (Scoped l)) -- ^ output (annotated) module+annotateModule lang exts mod@(Module lm mh os is ds) = do+  let extSet = moduleExtensions lang exts mod+  (imp, impTbl) <- processImports extSet is+  let tbl = moduleTable impTbl mod+  (exp, _syms) <- processExports tbl mod++  let+    lm' = none lm+    os' = fmap noScope os+    is' = imp+    ds' = annotate (initialScope tbl) `map` ds++    mh' = flip fmap mh $ \(ModuleHead lh n mw _me) ->+      let+        lh' = none lh+        n'  = noScope n+        mw' = fmap noScope mw+        me' = exp+      in ModuleHead lh' n' mw' me'++  return $ Module lm' mh' os' is' ds'++annotateModule _ _ _ = error "annotateModule: non-standard modules are not supported"++-- | Compute interfaces for a set of mutually recursive modules and write+-- the results to the cache. Return the set of import/export errors.+findFixPoint+  :: (Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols)+  => [(Module l, ExtensionSet)]+      -- ^ module and all extensions with which it is to be compiled.+      -- Use 'moduleExtensions' to build this list.+  -> m (Set.Set (Error l))+findFixPoint mods = go mods (map (const mempty) mods) where+  go mods syms = do+    forM_ (zip syms mods) $ \(s,(m, _)) -> insertInCache (getModuleName m) s+    (syms', errors) <- liftM unzip $ forM mods $ \(m, extSet) -> do+      (imp, impTbl) <- processImports extSet $ getImports m+      let tbl = moduleTable impTbl m+      (exp, syms) <- processExports tbl m+      return (syms, foldMap getErrors imp <> foldMap getErrors exp)+    if syms' == syms+      then return $ mconcat errors+      else go mods syms'++-- | 'computeInterfaces' takes a list of possibly recursive modules and+-- computes the interface of each module. The computed interfaces are+-- written into the @m@'s cache and are available to further computations+-- in this monad.+--+-- Returns the set of import/export errors. Note that the interfaces are+-- registered in the cache regardless of whether there are any errors, but+-- if there are errors, the interfaces may be incomplete.+computeInterfaces+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> [Module l] -- ^ input modules+  -> m (Set.Set (Error l)) -- ^ errors in export or import lists+computeInterfaces lang exts =+  liftM fold . mapM findFixPoint . map supplyExtensions . groupModules+    where+    supplyExtensions = map $ \m -> (m, moduleExtensions lang exts m)++-- | Like 'computeInterfaces', but also returns a list of interfaces, one+-- per module and in the same order+getInterfaces+  :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+  => Language -- ^ base language+  -> [Extension] -- ^ global extensions (e.g. specified on the command line)+  -> [Module l] -- ^ input modules+  -> m ([Symbols], Set.Set (Error l)) -- ^ output modules, and errors in export or import lists+getInterfaces lang exts mods = do+  errs <- computeInterfaces lang exts mods+  ifaces <- forM mods $ \mod ->+    let modName = getModuleName mod in+    fromMaybe (error $ msg modName) `liftM` lookupInCache modName+  return (ifaces, errs)+  where+    msg modName = "getInterfaces: module " ++ modToString modName ++ " is not in the cache"
+ src/haskell-names/Language/Haskell/Names/ScopeUtils.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.ScopeUtils+  ( computeSymbolTable+  , noScope+  , none+  , resolveCNames+  , scopeError+  , sv_parent+  ) where++import           Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Language.Haskell.Names.SyntaxUtils+import           Language.Haskell.Names.Types++import           Data.Lens.Light+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts++scopeError :: Functor f => Error l -> f l -> f (Scoped l)+scopeError e f = Scoped (ScopeError e) <$> f++none :: l -> Scoped l+none = Scoped None++noScope :: (Annotated a) => a l -> a (Scoped l)+noScope = fmap none++sv_parent :: SymValueInfo n -> Maybe n+sv_parent (SymSelector { sv_typeName = n }) = Just n+sv_parent (SymConstructor { sv_typeName = n }) = Just n+sv_parent (SymMethod { sv_className = n }) = Just n+sv_parent _ = Nothing++computeSymbolTable+  :: Bool+    -- ^ If 'True' (\"qualified\"), then only the qualified names are+    -- inserted.+    --+    -- If 'False', then both qualified and unqualified names are insterted.+  -> ModuleName l+  -> Symbols+  -> Global.Table+computeSymbolTable qual (ModuleName _ mod) syms =+  Global.fromLists $+    if qual+      then renamed+      else renamed <> unqualified+  where+    vs = Set.toList $ syms^.valSyms+    ts = Set.toList $ syms^.tySyms+    renamed = renameSyms mod+    unqualified = renameSyms ""+    renameSyms mod = (map (rename mod) vs, map (rename mod) ts)+    rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)+    rename m v = ((origGName . origName $ v) { gModule = m }, v)++resolveCName+  :: Symbols+  -> OrigName+  -> (CName l -> Error l) -- ^ error for "not found" condition+  -> CName l+  -> (CName (Scoped l), Symbols)+resolveCName syms parent notFound cn =+  let+    vs =+      [ info+      | info <- Set.toList $ syms^.valSyms+      , let name = gName . origGName $ sv_origName info+      , nameToString (unCName cn) == name+      , Just p <- return $ sv_parent info+      , p == parent+      ]+  in+    case vs of+      [] -> (scopeError (notFound cn) cn, mempty)+      [i] -> (Scoped (GlobalValue i) <$> cn, mkVal i)+      _ -> (scopeError (EInternal "resolveCName") cn, mempty)++resolveCNames+  :: Symbols+  -> OrigName+  -> (CName l -> Error l) -- ^ error for "not found" condition+  -> [CName l]+  -> ([CName (Scoped l)], Symbols)+resolveCNames syms orig notFound =+  second mconcat . unzip . map (resolveCName syms orig notFound)
+ src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.SyntaxUtils+  ( dropAnn+  , getModuleName+  , getImports+  , getExportSpecList+  , getDeclHeadName+  , getModuleDecls+  , nameToString+  , stringToName+  , qNameToName+  , unCName+  , getErrors+  , moduleExtensions+  ) where++import           Language.Haskell.Names.Types++import           Data.Char+import           Data.Either+import           Data.Foldable+import           Data.Maybe+import qualified Data.Set                        as Set+import           Language.Haskell.Exts++dropAnn :: (Functor a) => a l -> a ()+dropAnn = fmap (const ())++getModuleName :: Module l -> ModuleName l+getModuleName (Module _ (Just (ModuleHead _ mn _ _)) _ _ _) = mn+getModuleName (XmlPage _ mn _ _ _ _ _) = mn+getModuleName (XmlHybrid _ (Just (ModuleHead _ mn _ _)) _ _ _ _ _ _ _) = mn+getModuleName m = main_mod (ann m)++getImports :: Module l -> [ImportDecl l]+getImports (Module _ _ _ is _) = is+getImports (XmlPage _ _ _ _ _ _ _) = []+getImports (XmlHybrid _ _ _ is _ _ _ _ _) = is++getModuleDecls :: Module l -> [Decl l]+getModuleDecls (Module _ _ _ _ ds) = ds+getModuleDecls (XmlPage _ _ _ _ _ _ _) = []+getModuleDecls (XmlHybrid _ _ _ _ ds _ _ _ _) = ds++getExportSpecList :: Module l -> Maybe (ExportSpecList l)+getExportSpecList m = me where ModuleHead _ _ _ me = getModuleHead m++getModuleHead :: Module l -> ModuleHead l+getModuleHead (Module _ (Just mh) _ _ _) = mh+getModuleHead (XmlHybrid _ (Just mh) _ _ _ _ _ _ _) = mh+getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (UnQual l (Ident l "main"))]))+  where l = ann m++qNameToName :: QName l -> Name l+qNameToName (UnQual _ n) = n+qNameToName (Qual _ _ n) = n+qNameToName (Special l s) = Ident l (specialConToString s)++getDeclHeadName :: DeclHead l -> Name l+getDeclHeadName dh =+  case dh of+    DHead _ n -> n+    DHInfix _ _ n -> n+    DHParen _ dh' -> getDeclHeadName dh'+    DHApp _ dh' _ -> getDeclHeadName dh'++----------------------------------------------------++nameToString :: Name l -> String+nameToString (Ident _ s) = s+nameToString (Symbol _ s) = s++stringToName :: String -> Name ()+stringToName s@(c:_) | isSymbol c = Symbol () s+stringToName s = Ident () s++specialConToString :: SpecialCon l -> String+specialConToString (UnitCon _)            = "()"+specialConToString (ListCon _)            = "[]"+specialConToString (FunCon _)             = "->"+specialConToString (TupleCon _ Boxed n)   = replicate (n-1) ','+specialConToString (TupleCon _ Unboxed n) = '#':replicate (n-1) ','+specialConToString (Cons _)               = ":"+specialConToString (UnboxedSingleCon _)   = "#"+specialConToString (ExprHole _)           = "_"++unCName :: CName l -> Name l+unCName (VarName _ n) = n+unCName (ConName _ n) = n++getErrors :: (Ord l, Foldable a) => a (Scoped l) -> Set.Set (Error l)+getErrors = foldl' f Set.empty+  where+    f errors (Scoped (ScopeError e) _) = Set.insert e errors+    f errors _ = errors++-- | Compute the extension set for the given module, based on the global+-- preferences (e.g. specified on the command line) and module's LANGUAGE+-- pragmas.+moduleExtensions+  :: Language    -- ^ base language+  -> [Extension] -- ^ global extensions+  -> Module l+  -> ExtensionSet+moduleExtensions globalLang globalExts mod =+  let+    (mbModLang, modExts) = getModuleExtensions mod+    lang = fromMaybe globalLang mbModLang+    kexts = toExtensionList lang (globalExts ++ modExts)+  in Set.fromList kexts++getModuleExtensions :: Module l -> (Maybe Language, [Extension])+getModuleExtensions mod =+  let+    names =+      [ name+      | let+          pragmas =+            case mod of+              Module _ _ pragmas _ _ -> pragmas+              XmlPage _ _ pragmas _ _ _ _ -> pragmas+              XmlHybrid _ _ pragmas _ _ _ _ _ _ -> pragmas+      , LanguagePragma _ names <- pragmas+      , Ident _ name <- names+      ]++    classified :: [Either Language Extension]+    classified =+      flip map names $ \name ->+        case (parseExtension name, classifyLanguage name) of+          (e, UnknownLanguage {}) -> Right e+          (_, l) -> Left l++    (langs, exts) = partitionEithers classified+  in+    (if null langs then Nothing else Just $ last langs, exts)
+ src/haskell-names/Language/Haskell/Names/Types.hs view
@@ -0,0 +1,293 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE NoImplicitPrelude  #-}+{-# LANGUAGE StandaloneDeriving #-}+module Language.Haskell.Names.Types+  ( Error (..)+  , ExtensionSet+  , GName (..)+  , HasOrigName (..)+  , ModuleNameS+  , NameInfo (..)+  , NameS+  , OrigName (..)+  , Scoped (..)+  , SymTypeInfo (..)+  , SymValueInfo (..)+  , Symbols (..)+  , mkTy+  , mkVal+  , ppError+  , ppGName+  , ppOrigName+  , sLoc+  , tySyms+  , valSyms+  ) where++import {-# SOURCE #-} qualified Language.Haskell.Names.GlobalSymbolTable as Global+import           Fay.Compiler.Prelude++import           Data.Foldable                            as F+import           Data.Lens.Light+import qualified Data.Set                                 as Set+import           Language.Haskell.Exts+import           Text.Printf+import qualified Data.Semigroup                           as SG++type ExtensionSet = Set.Set KnownExtension++-- | Repesents the symbol's fixity+type SymFixity = (Assoc (), Int)++-- | Information about a value-level entitity+data SymValueInfo name+    = SymValue+      { sv_origName :: name+      , sv_fixity   :: Maybe SymFixity+      }+      -- ^ value or function+    | SymMethod+      { sv_origName  :: name+      , sv_fixity    :: Maybe SymFixity+      , sv_className :: name+      }+      -- ^ class method+    | SymSelector+      { sv_origName     :: name+      , sv_fixity       :: Maybe SymFixity+      , sv_typeName     :: name+      , sv_constructors :: [name]+      }+      -- ^ record field selector+    | SymConstructor+      { sv_origName :: name+      , sv_fixity   :: Maybe SymFixity+      , sv_typeName :: name+      }+      -- ^ data constructor+    deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++-- | Information about a type-level entitity+data SymTypeInfo name+    = SymType+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type synonym+    | SymData+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ data type+    | SymNewType+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ newtype+    | SymTypeFam+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type family+    | SymDataFam+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ data family+    | SymClass+      { st_origName :: name+      , st_fixity   :: Maybe SymFixity+      }+      -- ^ type class+    deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++class HasOrigName i where+  origName :: i n -> n++instance HasOrigName SymValueInfo where+  origName = sv_origName++instance HasOrigName SymTypeInfo where+  origName = st_origName++-- | The set of symbols (entities) exported by a single module. Contains+-- the sets of value-level and type-level entities.+data Symbols = Symbols (Set.Set (SymValueInfo OrigName)) (Set.Set (SymTypeInfo OrigName))+  deriving (Eq, Ord, Show, Data, Typeable)++instance SG.Semigroup Symbols where+  (Symbols s1 t1) <> (Symbols s2 t2) =+    Symbols (s1 <> s2) (t1 <> t2)++instance Monoid Symbols where+  mempty = Symbols mempty mempty+  mappend = (<>)++valSyms :: Lens Symbols (Set.Set (SymValueInfo OrigName))+valSyms = lens (\(Symbols vs _) -> vs) (\vs (Symbols _ ts) -> Symbols vs ts)++tySyms :: Lens Symbols (Set.Set (SymTypeInfo OrigName))+tySyms = lens (\(Symbols _ ts) -> ts) (\ts (Symbols vs _) -> Symbols vs ts)++mkVal :: SymValueInfo OrigName -> Symbols+mkVal i = Symbols (Set.singleton i) mempty++mkTy :: SymTypeInfo OrigName -> Symbols+mkTy i = Symbols mempty (Set.singleton i)++-- | String representing an unqualified entity name+type NameS = String+-- | String representing a module name+type ModuleNameS = String++-- | Possibly qualified name. If the name is not qualified,+-- 'ModuleNameS' is the empty string.+data GName = GName+  { gModule :: ModuleNameS+  , gName   :: NameS+  }+  deriving (Eq, Ord, Show, Data, Typeable)++-- | Display a 'GName'+ppGName :: GName -> String+ppGName (GName mod name) = printf "%s.%s" mod name++-- # if !MIN_VERSION_Cabal(1,17,0)+-- deriving instance Typeable PackageIdentifier+-- deriving instance Data PackageIdentifier+-- deriving instance Typeable PackageName+-- deriving instance Data PackageName+-- deriving instance Data Version+-- # endif++-- | Qualified name, where 'ModuleNameS' points to the module where the+-- name was originally defined. The module part is never empty.+--+-- Also contains name and version of the package where it was defined. If+-- it's 'Nothing', then the entity is defined in the \"current\" package.+data OrigName = OrigName+  { origGName :: GName+  }+  deriving (Eq, Ord, Show, Data, Typeable)++-- | Display an 'OrigName'+ppOrigName :: OrigName -> String+ppOrigName (OrigName gname) = ppGName gname++-- | A pair of the name information and original annotation. Used as an+-- annotation type for AST.+data Scoped l = Scoped (NameInfo l) l+  deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data NameInfo l+    = GlobalValue (SymValueInfo OrigName) -- ^ global value+    | GlobalType  (SymTypeInfo  OrigName) -- ^ global type+    | LocalValue  SrcLoc -- ^ local value, and location where it is bound+    | TypeVar     SrcLoc -- ^ type variable, and location where it is bound+    | ValueBinder -- ^ here the value name is bound+    | TypeBinder  -- ^ here the type name is defined+    | Import      Global.Table+      -- ^ @import@ declaration, and the table of symbols that it+      -- introduces+    | ImportPart  Symbols+      -- ^ part of an @import@ declaration+    | Export      Symbols+      -- ^ @export@ declaration, and the symbols it exports+    | RecPatWildcard [OrigName]+      -- ^ wildcard in a record pattern. The list contains resolved names+      -- of the fields that are brought in scope by this pattern.+    | RecExpWildcard [(OrigName, NameInfo l)]+      -- ^ wildcard in a record construction expression. The list contains+      -- resolved names of the fields and information about values+      -- assigned to those fields.+    | None+      -- ^ no annotation+    | ScopeError  (Error l)+      -- ^ scope error+    deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data Error l+  = ENotInScope (QName l) -- FIXME annotate with namespace (types/values)+    -- ^ name is not in scope+  | EAmbiguous (QName l) [OrigName]+    -- ^ name is ambiguous+  | ETypeAsClass (QName l)+    -- ^ type is used where a type class is expected+  | EClassAsType (QName l)+    -- ^ type class is used where a type is expected+  | ENotExported+      (Maybe (Name l)) --+      (Name l)         --+      (ModuleName l)+    -- ^ Attempt to explicitly import a name which is not exported (or,+    -- possibly, does not even exist). For example:+    --+    -- >import Prelude(Bool(Right))+    --+    -- The fields are:+    --+    -- 1. optional parent in the import list, e.g. @Bool@ in @Bool(Right)@+    --+    -- 2. the name which is not exported+    --+    -- 3. the module which does not export the name+  | EModNotFound (ModuleName l)+    -- ^ module not found+  | EInternal String+    -- ^ internal error+  deriving (Data, Typeable, Show, Functor, Foldable, Traversable, Eq, Ord)++-- | Display an error.+--+-- Note: can span multiple lines; the trailing newline is included.+ppError :: SrcInfo l => Error l -> String+ppError e =+  case e of+    ENotInScope qn -> printf "%s: not in scope: %s\n"+      (ppLoc qn)+      (prettyPrint qn)+    EAmbiguous qn names ->+      printf "%s: ambiguous name %s\nIt may refer to:\n"+        (ppLoc qn)+        (prettyPrint qn)+      +++        F.concat (map (printf "  %s\n" . ppOrigName) names)+    ETypeAsClass qn ->+      printf "%s: type %s is used where a class is expected\n"+        (ppLoc qn)+        (prettyPrint qn)+    EClassAsType qn ->+      printf "%s: class %s is used where a type is expected\n"+        (ppLoc qn)+        (prettyPrint qn)+    ENotExported _mbParent name mod ->+      printf "%s: %s does not export %s\n"+        (ppLoc name)+        (prettyPrint mod)+        (prettyPrint name)+        -- FIXME: make use of mbParent+    EModNotFound mod ->+      printf "%s: module not found: %s\n"+        (ppLoc mod)+        (prettyPrint mod)+    EInternal s -> printf "Internal error: %s\n" s++  where+    ppLoc :: (Annotated a, SrcInfo l) => a l -> String+    ppLoc = prettyPrint . getPointLoc . ann++instance (SrcInfo l) => SrcInfo (Scoped l) where+    toSrcInfo l1 ss l2 = Scoped None $ toSrcInfo l1 ss l2+    fromSrcInfo = Scoped None . fromSrcInfo+    getPointLoc = getPointLoc . sLoc+    fileName = fileName . sLoc+    startLine = startLine . sLoc+    startColumn = startColumn . sLoc++sLoc :: Scoped l -> l+sLoc (Scoped _ l) = l
src/main/Main.hs view
@@ -1,69 +1,75 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-} -- | Main compiler executable.  module Main where  import           Fay-import           Fay.Compiler.Config-import           Paths_fay           (version)+import           Paths_fay                 (version) -import qualified Control.Exception   as E+import           Control.Applicative       ((<|>), (<$>), (<*>))+import qualified Control.Exception         as E import           Control.Monad-import           Data.Default-import           Data.List.Split     (wordsBy)+import           Control.Monad.Reader+import           Data.List.Split           (wordsBy) import           Data.Maybe-import           Data.Version        (showVersion)-import           Options.Applicative-import           Options.Applicative.Types-import           System.Environment+import           Data.Monoid               ((<>))+import           Data.Version              (showVersion)+import           Options.Applicative       (Mod, OptionFields, Parser, argument, execParser, fullDesc, header, help,+                                            helper, info, long, many, metavar, option, optional, short, strOption,+                                            switch, value)+import           Options.Applicative.Types (ReadM (ReadM))  -- | Options and help. data FayCompilerOptions = FayCompilerOptions-  { optLibrary       :: Bool-  , optFlattenApps   :: Bool-  , optHTMLWrapper   :: Bool-  , optHTMLJSLibs    :: [String]-  , optInclude       :: [String]-  , optPackages      :: [String]-  , optWall          :: Bool-  , optNoGHC         :: Bool-  , optStdout        :: Bool-  , optVersion       :: Bool-  , optOutput        :: Maybe String-  , optPretty        :: Bool-  , optOptimize      :: Bool-  , optGClosure      :: Bool-  , optPackageConf   :: Maybe String-  , optNoRTS         :: Bool-  , optNoStdlib      :: Bool-  , optPrintRuntime  :: Bool-  , optStdlibOnly    :: Bool-  , optBasePath      :: Maybe FilePath-  , optStrict        :: [String]-  , optTypecheckOnly :: Bool-  , optRuntimePath   :: Maybe FilePath-  , optSourceMap     :: Bool-  , optFiles         :: [String]+  { optBasePath           :: Maybe FilePath+  , optGClosure           :: Bool+  , optFlattenApps        :: Bool+  , optHTMLJSLibs         :: [String]+  , optHTMLWrapper        :: Bool+  , optInclude            :: [String]+  , optLibrary            :: Bool+  , optNoGHC              :: Bool+  , optNoOptimizeNewtypes :: Bool+  , optNoRTS              :: Bool+  , optNoStdlib           :: Bool+  , optOptimize           :: Bool+  , optOutput             :: Maybe String+  , optPackages           :: [String]+  , optPackageConf        :: Maybe String+  , optPrettyAll          :: Bool+  , optPretty             :: Bool+  , optPrettyOperators    :: Bool+  , optPrettyThunks       :: Bool+  , optPrintRuntime       :: Bool+  , optRuntimePath        :: Maybe FilePath+  , optSourceMap          :: Bool+  , optStdlibOnly         :: Bool+  , optStdout             :: Bool+  , optStrict             :: [String]+  , optTypecheckOnly      :: Bool+  , optVersion            :: Bool+  , optWall               :: Bool+  , optShowGhcCalls       :: Bool+  , optTypeScript         :: Bool+  , optFiles              :: [String]   }  -- | Main entry point. main :: IO () main = do-  packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  opts <- execParser parser+  config' <- defaultConfigWithSandbox+  opts    <- execParser parser   let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $-        addConfigPackages (optPackages opts) $ def+        addConfigPackages (optPackages opts) $ config'           { configOptimize         = optOptimize opts           , configFlattenApps      = optFlattenApps opts-          , configPrettyPrint      = optPretty opts+          , configPrettyPrint      = optPretty opts || optPrettyAll opts           , configLibrary          = optLibrary opts           , configHtmlWrapper      = optHTMLWrapper opts           , configHtmlJSLibs       = optHTMLJSLibs opts           , configTypecheck        = not $ optNoGHC opts           , configWall             = optWall opts           , configGClosure         = optGClosure opts-          , configPackageConf      = optPackageConf opts <|> packageConf+          , configPackageConf      = optPackageConf opts <|> configPackageConf config'           , configExportRuntime    = not (optNoRTS opts)           , configExportStdlib     = not (optNoStdlib opts)           , configExportStdlibOnly = optStdlibOnly opts@@ -72,11 +78,16 @@           , configTypecheckOnly    = optTypecheckOnly opts           , configRuntimePath      = optRuntimePath opts           , configSourceMap        = optSourceMap opts+          , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts+          , configPrettyThunks     = optPrettyThunks opts || optPrettyAll opts+          , configPrettyOperators  = optPrettyOperators opts || optPrettyAll opts+          , configShowGhcCalls     = optShowGhcCalls opts+          , configTypeScript       = optTypeScript opts           }   if optVersion opts     then runCommandVersion     else if optPrintRuntime opts-      then getConfigRuntime config >>= readFile >>= putStr+      then readConfigRuntime config >>= putStr       else do         void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"         case optFiles opts of@@ -88,41 +99,49 @@     parser = info (helper <*> options) (fullDesc <> header helpTxt)      outPutFile :: FayCompilerOptions -> String -> FilePath-    outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts+    outPutFile opts file = fromMaybe (if optTypeScript opts then toTsName file else toJsName file) $ optOutput opts  -- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions-  <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")+  <$> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+  <*> switch (long "closure" <> help "Provide help with Google Closure")   <*> switch (long "flatten-apps" <> help "flatten function applicaton")-  <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")   <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]"       <> help "javascript files to add to <head> if using option html-wrapper")+  <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript")   <*> strsOption (long "include" <> metavar "dir1[, ..]"       <> help "additional directories for include")-  <*> strsOption (long "package" <> metavar "package[, ..]"-      <> help "packages to use for compilation")-  <*> switch (long "Wall" <> help "Typecheck with -Wall")+  <*> switch (long "library" <> help "Don't automatically call main in generated JavaScript")   <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files")-  <*> switch (long "stdout" <> short 's' <> help "Output to stdout")-  <*> switch (long "version" <> help "Output version number")-  <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))-  <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")-  <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")-  <*> switch (long "closure" <> help "Provide help with Google Closure")-  <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+  <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types")   <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS")   <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")+  <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")+  <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))+  <*> strsOption (long "package" <> metavar "package[, ..]"+      <> help "packages to use for compilation")+  <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+  <*> switch (long "pretty-all" <> help "Pretty print, pretty operators and pretty thunks")+  <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")+  <*> switch (long "pretty-operators" <> help "Use pretty operators")+  <*> switch (long "pretty-thunks" <> help "Use pretty thunk names")   <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout")+  <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")+  <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")   <*> switch (long "stdlib" <> help "Only output the stdlib")-  <*> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+  <*> switch (long "stdout" <> short 's' <> help "Output to stdout")   <*> strsOption (long "strict" <> metavar "modulename[, ..]"       <> 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")-  <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")-  <*> arguments Just (metavar "<hs-file>...")-  where strsOption m = nullOption (m <> reader (ReadM . Right . wordsBy (== ',')) <> value [])+  <*> switch (long "version" <> help "Output version number")+  <*> switch (long "Wall" <> help "Typecheck with -Wall")+  <*> switch (long "show-ghc-calls" <> help "Print commands sent to ghc")+  <*> switch (long "ts" <> help "Output TypeScript instead of JavaScript")+  <*> many (argument (ReadM ask) (metavar "<hs-file>..."))+  where+    strsOption :: Mod OptionFields [String] -> Parser [String]+    strsOption m = option (ReadM . fmap (wordsBy (== ',')) $ ask) (m <> value [])  -- | Make incompatible options. incompatible :: Monad m@@ -134,10 +153,9 @@  -- | The basic help text. helpTxt :: String-helpTxt = concat-  ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"-  ,"  fay <hs-file>... processes each .hs file"-  ]+helpTxt+  =  "fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"+  ++ "  fay <hs-file>... processes each .hs file"  -- | Print the command version. runCommandVersion :: IO ()
src/tests/Test/CommandLine.hs view
@@ -2,20 +2,17 @@  module Test.CommandLine (tests) where -import           Fay.System.Process.Extra+import           Fay.Compiler.Prelude+import           Test.Util -import           Control.Applicative-import           Data.Maybe import           System.Directory import           System.Environment import           System.FilePath-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.Framework.TH-import           Test.HUnit                     (Assertion, assertBool)-import           Test.Util+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH -tests :: Test+tests :: TestTree tests = $testGroupGenerator  compileFile :: [String] -> IO (Either String String)@@ -42,4 +39,6 @@   whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment   res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] ++                       ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ])-  assertBool (fromLeft res) (isRight res)+  case res of+    Left  e -> assertFailure $ "Compilation failed: " ++ e+    Right _ -> assertBool "impossible" True
src/tests/Test/Compile.hs view
@@ -1,39 +1,31 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TemplateHaskell   #-} -module Test.Compile (tests) where+module Test.Compile (tests,runScriptFile) where  import           Fay-import           Fay.Compiler.Config-import           Fay.System.Process.Extra-import           Fay.Types                       ()+import           Fay.Compiler.Prelude -import           Control.Applicative-import           Control.Monad-import           Data.Default-import           Data.Maybe-import           Language.Haskell.Exts.Annotated-import           System.Environment-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.Framework.TH-import           Test.HUnit                      (Assertion, assertBool, assertEqual, assertFailure)-import           Test.Util+import           Language.Haskell.Exts+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH -tests :: Test+tests :: TestTree tests = $testGroupGenerator  case_imports :: Assertion case_imports = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework } fp+  cfg <- defConf+  res <- compileFile cfg fp   assertBool "Could not compile file with imports" (isRight res)  case_importedList :: Assertion case_importedList = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp+  cfg <- defConf+  res <- compileFileWithState cfg fp   case res of     Left err -> error (show err)     Right (_,_,r) -> assertBool "RecordImport_Export was not added to stateImported" .@@ -44,8 +36,8 @@  case_stateRecordTypes :: Assertion case_stateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/Records.hs"+  cfg <- defConf+  res <- compileFileWithState cfg "tests/Compile/Records.hs"   case res of     Left err -> error (show err)     Right (_,_,r) ->@@ -54,12 +46,12 @@         [ ("Compile.Records.T", ["Compile.Records.:+"])         , ("Compile.Records.R", ["Compile.Records.R","Compile.Records.S"])         ]-        (stateRecordTypes r)+        (filter (isFromMod "Compile.Records") $ stateRecordTypes r)  case_importStateRecordTypes :: Assertion case_importStateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/ImportRecords.hs"+  cfg <- defConf+  res <- compileFileWithState cfg "tests/Compile/ImportRecords.hs"   case res of     Left err -> error (show err)     Right (_,_,r) ->@@ -68,40 +60,91 @@         [ ("Compile.Records.T",["Compile.Records.:+"])         , ("Compile.Records.R",["Compile.Records.R", "Compile.Records.S"])         ]-        (stateRecordTypes r)+        (filter (isFromMod "Compile.Records") $ stateRecordTypes r) +isFromMod :: String -> (QName (),[QName ()]) -> Bool+isFromMod modName = (==) modName . getModuleName . fst+    where+        getModuleName (Qual _ (ModuleName _ n) _) = n+        getModuleName x = error $ "getModuleName: expected qualified name: " ++ show x+ case_typecheckCPP :: Assertion case_typecheckCPP = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs"+  cfg <- defConf+  res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs"   either (assertFailure . show) (const $ return ()) res  case_cppMultiLineStrings :: Assertion case_cppMultiLineStrings = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPMultiLineStrings.hs" } "tests/Compile/CPPMultiLineStrings.hs"+  cfg <- defConf+  res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/CPPMultiLineStrings.hs" } "tests/Compile/CPPMultiLineStrings.hs"   either (assertFailure . show) (const $ return ()) res  case_strictWrapper :: Assertion 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-    writeFile "tests/Compile/StrictWrapper.js" js-    (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] ""+  cfg <- defConf+  res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs"+  let isTs = configTypeScript cfg+      suffix = if isTs then ".ts" else ".js"+  (\a b -> either a b res) (assertFailure . show) $ \js -> do+    writeFile ("tests/Compile/StrictWrapper" ++ suffix) js+    (err, out) <- either id id <$> runScriptFile isTs ("tests/Compile/StrictWrapper" ++ suffix)     when (err /= "") $ assertFailure err     expected <- readFile "tests/Compile/StrictWrapper.res"     assertEqual "strictWrapper node stdout" expected out -defConf :: CompileConfig-defConf = addConfigDirectoryIncludePaths ["tests/"]-        $ def { configTypecheck = False }+assertPretty :: Config -> String -> Assertion+assertPretty cfg flagName = do+  let isTs = configTypeScript cfg+      suffix = if isTs then ".ts" else ".js"+  res <- compileFile cfg $ "tests/Compile/" ++ flagName ++ ".hs"+  case res of+    Left l  -> assertFailure $ "Should compile, but failed with: " ++ show l+    Right js -> do+      writeFile ("tests/Compile/" ++ flagName ++ suffix) js+      (err, out) <- either id id <$> runScriptFile isTs+        ("tests/Compile/" ++ flagName ++ suffix)+      when (err /= "") $ assertFailure err+      expected <- readFile $ "tests/Compile/" ++ flagName ++ ".res"+      assertEqual (flagName ++ " node stdout") expected out +case_pretty :: Assertion+case_pretty = do+  cfg <- defConf+  assertPretty cfg { configPrettyPrint = True } "pretty"++case_prettyThunks :: Assertion+case_prettyThunks = do+  cfg <- defConf+  assertPretty cfg { configPrettyThunks = True } "prettyThunks"++case_prettyOperators :: Assertion+case_prettyOperators = do+  cfg <- defConf+  assertPretty cfg { configPrettyOperators = True } "prettyOperators"+ case_charEnum :: Assertion case_charEnum = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/EnumChar.hs" } "tests/Compile/EnumChar.hs"+  cfg <- defConf+  res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/EnumChar.hs" } "tests/Compile/EnumChar.hs"   case res of     Left UnsupportedEnum{} -> return ()     Left l  -> assertFailure $ "Should have failed with UnsupportedEnum, but failed with: " ++ show l-    Right _ -> assertFailure $ "Should have failed with UnsupportedEnum, but compiled"+    Right _ -> assertFailure "Should have failed with UnsupportedEnum, but compiled"++defConf :: IO Config+defConf = do+  cfg <- defaultConfigWithSandbox+  return $ addConfigDirectoryIncludePaths ["tests/"] cfg { configTypecheck = False }++-- | Run a JS or TS file.+runScriptFile :: Bool -- ^ If a file-format is TypeScript, this is True.+              -> String -- ^ A name of script file+              -> IO (Either (String,String) (String,String))+runScriptFile True file = do+  tsc_ret <- readAllFromProcess "tsc" [file] ""+  case tsc_ret of+    Left _ -> return tsc_ret+    Right _ -> readAllFromProcess "node" [(reverse (drop 3 (reverse file))) ++ ".js" ] ""++runScriptFile False file = readAllFromProcess "node" [file] ""
src/tests/Test/Convert.hs view
@@ -3,19 +3,18 @@  module Test.Convert (tests) where +import           Fay.Convert+ import qualified Data.Aeson.Parser              as Aeson import           Data.Attoparsec.ByteString import qualified Data.ByteString                as Bytes import qualified Data.ByteString.UTF8           as UTF8 import           Data.Data-import           Data.Ratio import           Data.Text                      (Text, pack)-import           Fay.Convert-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual)+import           Test.Tasty+import           Test.Tasty.HUnit -tests :: Test+tests :: TestTree tests = testGroup "Test.Convert" [reading, showing]   where reading = testGroup "reading" $           flip map readTests $ \(ReadTest value) ->@@ -35,7 +34,7 @@ -- Test cases  -- | A test.-data Testcase = forall x. Show x => Testcase x Bytes.ByteString+data Testcase = forall x. (Show x,Data x) => Testcase x Bytes.ByteString  -- | A read test. data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x@@ -69,9 +68,10 @@ showTests =    -- Fundamental data types   [(1 :: Int) → "1"+  ,(1 :: Float) → "1.0"+  ,(1/2 :: Float) → "0.5"   ,(1 :: Double) → "1.0"   ,(1/2 :: Double) → "0.5"-  ,(1%2 :: Rational) → "0.5"   ,([1,2] :: [Int]) → "[1,2]"   ,((1,2) :: (Int,Int)) → "[1,2]"   ,"abc" → "\"abc\""@@ -122,7 +122,7 @@  -- | Labelled record. data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }-                    | LabelledRecord2 { bar :: Int, bob :: Double }+                    | LabelledRecord2 { bar :: Int, bob :: Float }   deriving (Show,Data,Typeable,Read,Eq)  -- | Order matters in unlabelled constructors.
+ src/tests/Test/Desugar.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ViewPatterns #-}+module Test.Desugar+  ( tests+  , devTest+  , parseE+  , parseM+  , des+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.Desugar+import           Fay.Compiler.Parse     (parseFay)+import           Fay.Types.CompileError (CompileError (..))++import           Language.Haskell.Exts  hiding (name)+import           Test.Tasty+import           Test.Tasty.HUnit+-- import           Text.Groom++tests :: TestTree+tests = testGroup "desugar" $ map (\(T k a b) -> testCase k $ doDesugar k a b) testDeclarations++data DesugarTest = T String String String++testDeclarations :: [DesugarTest]+testDeclarations =+  [T "LambdaCase"+     "import Prelude; f = \\gen0 -> case gen0 of { _ -> 2 }"+     "import Prelude; f = \\case { _ -> 2 }"+  ,T "MultiWayIf"+     "import Prelude; f = case () of { _ | True -> 1 | False -> 2 }"+     "import Prelude; f = if | True -> 1 | False -> 2"+  ,T "TupleCon"+     "import Prelude; f = \\gen0 gen1 gen2 -> (gen0, gen1, gen2)"+     "import Prelude; f = (,,)"+  ,T "Do"+     "import Prelude; f = (>>=) x (\\gen0 -> (>>) y z)"+     "import Prelude; f = do { gen0 <- x; y; z }"+  ,T "TupleSection"+     "import Prelude; f = \\gen0 gen1 -> (gen0,2,gen1)"+     "import Prelude; f = (,2,)"+  ,T "ImplicitPrelude1" -- Add missing Prelude import+     "import Prelude"+     ""+  ,T "ImplicitPrelude2" -- Keep existing Prelude import+     "import Prelude ()"+     "import Prelude ()"+  ,T "ImplicitPrelude3" -- Keep existing qualified import+     "import qualified Prelude"+     "import qualified Prelude"+  ,T "NoImplicitPrelude"+     "{-# LANGUAGE NoImplicitPrelude #-}"+     "{-# LANGUAGE NoImplicitPrelude #-}"+  ,T "OperatorSectionRight"+     "import Prelude; f = \\gen0 -> g gen0 x"+     "import Prelude; f = (`g` x)"+  ,T "OperatorSectionLeft"+     "import Prelude; f = \\gen0 -> g x gen0"+     "import Prelude; f = (x `g`)"+  ,T "InfixOpOp"+     "import Prelude; f = (+) x y"+     "import Prelude; f = x + y"+  ,T "InfixOpFun"+     "import Prelude; f = g x y"+     "import Prelude; f = x `g` y"+  ,T "InfixOpCons"+     "import Prelude; f = (:) x y"+     "import Prelude; f = x : y"+  ,T "ExpParen"+     "import Prelude; f = x y"+     "import Prelude; f = (x (y))"+  ,T "PatParen"+     "import Prelude; f x = y"+     "import Prelude; f (x) = y"+  ,T "PatInfixOp"+     "import Prelude; f ((:) x y) = z"+     "import Prelude; f (x : y) = z"+  ,T "PatFieldPun"+     "import Prelude; f R { x = x } = y"+     "import Prelude; f R { x } = y"+  ,T "PatField"+     "import Prelude; f = R { x = x }"+     "import Prelude; f = R { x }"+  ,T "FFITopLevel"+     "import Prelude; f :: Int; f = ffi \"1\" :: Int"+     "import Prelude; f :: Int; f = ffi \"1\""+  ,T "FFIWhere"+     "import Prelude; f = () where x :: Int; x = ffi \"1\" :: Int"+     "import Prelude; f = () where x :: Int; x = ffi \"1\""+  ]++parseAndDesugar :: String -> String -> IO (Module SrcLoc, Either CompileError (Module SrcLoc))+parseAndDesugar name s =+  case parseFay "test" s :: ParseResult (Module SrcSpanInfo) of+    ParseFailed a b -> error $ show (name, a, b)+    ParseOk (fmap srcSpanInfoToSrcLoc -> m) -> do+      d <- desugar' "gen" noLoc m+      return (m, d)+  where+    srcSpanInfoToSrcLoc :: SrcSpanInfo -> SrcLoc+    srcSpanInfoToSrcLoc = (\ss -> SrcLoc { srcFilename = srcSpanFilename ss+                                         , srcLine     = srcSpanStartLine ss+                                         , srcColumn   = srcSpanStartColumn ss+                                         }) . srcInfoSpan+doDesugar :: String -> String -> String -> Assertion+doDesugar testName a b = do+  (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll testName a b+  assertEqual "identity"  (unAnn originalExpected) (unAnn desugaredExpected)+  assertEqual "desugared" (unAnn originalExpected) (unAnn desugared        )+  assertEqual "both"      (unAnn desugared       ) (unAnn desugaredExpected)++parseAndDesugarAll :: String -> String -> String -> IO (Module SrcLoc, Module SrcLoc, Module SrcLoc)+parseAndDesugarAll testName a b = do+  (originalExpected',Right desugaredExpected) <- parseAndDesugar (testName ++ " expected") a+  (_                ,Right desugared        ) <- parseAndDesugar (testName ++ " input")    b+  -- We need to desugar parens in the original module since we+  -- strip it away in desugaring but there isn't alawys a way to construct+  -- this paren directly from a source string+  let originalExpected = desugarPatParen . desugarExpParen $ originalExpected'+  return (originalExpected, desugaredExpected, desugared)++-- When developing:++devTest :: String -> IO ()+devTest nam = do+  let (T _ a b) = fromJust (find (\(T n _ _) -> n == nam) testDeclarations)+  (originalExpected, desugaredExpected, desugared) <- parseAndDesugarAll "" a b+  if unAnn desugared == unAnn desugaredExpected && unAnn desugared == unAnn originalExpected+    then putStrLn "OK"+    else do+      putStrLn "--- originalExpected"+      g $ unAnn originalExpected+      putStrLn "--- desugaredExpected"+      g $ unAnn desugaredExpected+      putStrLn "--- desugared"+      g $ unAnn desugared+      putStrLn "--- originalExpected"+      pretty originalExpected+      putStrLn "--- desugaredExpected"+      pretty desugaredExpected+      putStrLn "--- desugared"+      pretty desugared+  when (unAnn originalExpected  /= unAnn desugaredExpected) $ putStrLn "originalExpected /= desugaredExpected"+  when (unAnn desugared         /= unAnn desugaredExpected) $ putStrLn "desugared /= desugaredExpected"+  when (unAnn desugared         /= unAnn originalExpected ) $ putStrLn "desugared /= originalExpected"+  when (unAnn desugaredExpected /= unAnn originalExpected ) $ putStrLn "desugaredExpected /= undesugared"++g :: Show a => a -> IO ()+g = print -- putStrLn . groom++unAnn :: Functor f => f a -> f ()+unAnn = void++pretty :: Module SrcLoc -> IO ()+pretty = putStrLn . prettyPrint++parseM :: String -> Module ()+parseM s = let ParseOk m = parseFay "module" s :: ParseResult (Module SrcSpanInfo) in unAnn m++parseE :: String -> Exp ()+parseE s = let ParseOk m = parseFay "exp" s :: ParseResult (Exp SrcSpanInfo) in unAnn m++des :: String -> IO ()+des s = do+  Right r <- desugar' "gen" () $ parseM s+  g r
src/tests/Test/Util.hs view
@@ -1,14 +1,14 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-} module Test.Util   ( fayPath-  , isRight-  , fromLeft+  , getRecursiveContents   ) where -import           Fay.System.Process.Extra (readAllFromProcess)+import           Fay.Compiler.Prelude -import           Control.Applicative-import           Prelude                  hiding (pred) import           System.Directory+import           System.FilePath  -- Path to the fay executable, looks in cabal-dev, dist, PATH in that order. fayPath :: IO (Maybe FilePath)@@ -20,20 +20,27 @@     usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] ""  firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)-firstWhereM pred ins = case ins of+firstWhereM p ins = case ins of   [] -> return Nothing-  a:as -> pred a >>= \b ->+  a:as -> p a >>= \b ->           if b then return (Just a)-               else firstWhereM pred as+               else firstWhereM p as  -- from the package `errors` hush :: Either a b -> Maybe b hush = either (const Nothing) Just -isRight :: Either a b -> Bool-isRight (Right _) = True-isRight (Left _) = False--fromLeft :: Either a b -> a-fromLeft (Left a) = a-fromLeft (Right _) = error "fromLeft got Right"+-- | Get all files in a folder and its subdirectories.+-- Taken from Real World Haskell+-- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html+getRecursiveContents :: FilePath -> IO [FilePath]+getRecursiveContents topdir = do+  names <- getDirectoryContents topdir+  let properNames = filter (`notElem` [".", ".."]) names+  paths <- forM properNames $ \name -> do+    let path = topdir </> name+    isDirectory <- doesDirectoryExist path+    if isDirectory+      then getRecursiveContents path+      else return [path]+  return (concat paths)
src/tests/Tests.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Generate the web site/documentation for the Fay project. --@@ -7,66 +8,113 @@  module Main where +import           Fay.Compiler.Prelude+ import           Fay-import           Fay.Compiler.Config-import           Fay.System.Directory.Extra-import           Fay.System.Process.Extra+import qualified Test.CommandLine     as Cmd+import qualified Test.Compile         as Compile+import qualified Test.Convert         as Convert+import qualified Test.Desugar         as Desugar+import           Test.Util -import           Control.Applicative-import           Data.Char-import           Data.Default-import           Data.List-import           Data.Maybe-import           Data.Ord+import           Data.Set             (Set)+import qualified Data.Set             as S import           System.Directory import           System.Environment import           System.FilePath-import qualified Test.CommandLine               as Cmd-import qualified Test.Compile                   as Compile-import qualified Test.Convert                   as C-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual, assertFailure)+import           System.Random+import           Test.Tasty+import           Test.Tasty.HUnit  -- | Main test runner. main :: IO () main = do   sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs-  let (basePath,args') = prefixed (=="-base-path") args-  compiler <- makeCompilerTests (packageConf <|> sandbox) basePath-  defaultMainWithArgs [Compile.tests, Cmd.tests, compiler, C.tests]-                      args'+  (packageConf,args)     <- prefixed (== "-package-conf") <$> getArgs+  let (basePath,args')    = prefixed (== "-base-path"   ) args+  let (testCount, args'') = first (readMay =<<) $ prefixed (== "-random") args'+  let (isTs, args''') = case args'' of+                          ("-ts":xs) -> (True,xs)+                          _ -> (False,args'')+  (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath testCount isTs+  withArgs args''' $ defaultMain $ testGroup "Fay"+    [ Desugar.tests+    , Convert.tests+    , codegen+    , Cmd.tests+    , Compile.tests+    , runtime+    ]  -- | Extract the element prefixed by the given element in the list. prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a]) prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y)  -- | Make the case-by-case unit tests.-makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test-makeCompilerTests packageConf basePath = do-  files <- sortBy (comparing (map toLower)) . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests"-  return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do-    testFile packageConf basePath False file-    testFile packageConf basePath True file+makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> Maybe Int -> Bool -> IO (TestTree,TestTree)+makeCompilerTests packageConf basePath rand isTs = do+  runtimeFiles' <- runtimeTestFiles+  runtimeFiles  <- maybe (return runtimeFiles') (randomize runtimeFiles') rand+  codegenFiles  <- codegenTestFiles+  return+    ( makeTestGroup "Runtime tests"+                    runtimeFiles+                    (\file -> do testFile packageConf basePath False isTs file+                                 testFile packageConf basePath True isTs file)+    , makeTestGroup "Codegen tests"+                    codegenFiles+                    (testCodegen packageConf basePath isTs))+  where+    makeTestGroup title files inner =+      testGroup title $ flip map files $ \file ->+        testCase file $ inner file+    runtimeTestFiles =+      filter (not . nonRuntime) <$> testFiles+    codegenTestFiles =+      filter (isInfixOf "/codegen/") <$> testFiles+    testFiles =+      sortBy (comparing (map toLower)) . filter (isSuffixOf ".hs") <$>+      getRecursiveContents "tests"+    nonRuntime x =+      any (`isInfixOf` x) ["/Compile/","/regressions/","/codegen/"]+    randomize :: [String] -> Int -> IO [String]+    randomize l i = do+      is <- randomizeAux S.empty i (0,length l - 1)+      return . map (l !!) $ S.toList is+    randomizeAux :: Set Int -> Int -> (Int,Int) -> IO (Set Int)+    randomizeAux s count b = do+      i <- randomRIO b+      let s' = S.insert i s+      if S.size s' == count+        then return s'+        else randomizeAux (S.insert i s) count b -testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()-testFile packageConf basePath opt file = do-  let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file-      out = toJsName file-      resf = root <.> "res"+fns :: Bool -> String -> (String, String, FilePath)+fns isTs file =+  ( root+  , if isTs then toTsName file else toJsName file+  , root <.> "res"+  )+  where+    root = reverse . drop 1 . dropWhile (/='.') . reverse $ file++testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> Bool -> String -> IO ()+testFile packageConf basePath opt isTs file = do+  let (root, out, resf) = fns isTs file       config =-        addConfigDirectoryIncludePaths ["tests/"] $-          def { configOptimize = opt-              , configTypecheck = False-              , configPackageConf = packageConf-              , configBasePath = basePath-              }+        addConfigDirectoryIncludePaths ["tests/"]+          defaultConfig+            { configOptimize    = opt+            , configTypecheck   = False+            , configPackageConf = packageConf+            , configBasePath    = basePath+            , configTypeScript  = isTs+            }   resExists <- doesFileExist resf   let partialName = root ++ "_partial.res"   partialExists <- doesFileExist partialName   compileFromTo config file (Just out)-  result <- runJavaScriptFile out+  result <- Compile.runScriptFile isTs out   if resExists      then do output <- readFile resf              assertEqual file output (either show snd result)@@ -79,6 +127,29 @@            Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err          else assertEqual (file ++ ": Expected program to fail") True (either (const True) (const False) result) --- | Run a JS file.-runJavaScriptFile :: String -> IO (Either (String,String) (String,String))-runJavaScriptFile file = readAllFromProcess "node" [file] ""+-- | Test the generated code output for the given file with+-- optimizations turned on. This disables runtime generation and+-- things like that; it's only concerned with the core of the program.+testCodegen :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO ()+testCodegen packageConf basePath isTs file = do+  let (_, out, resf) = fns isTs file+      config =+        addConfigDirectoryIncludePaths ["tests/codegen/"]+          defaultConfig+            { configOptimize      = True+            , configTypecheck     = False+            , configPackageConf   = packageConf+            , configBasePath      = basePath+            , configExportStdlib  = False+            , configPrettyPrint   = True+            , configLibrary       = True+            , configExportRuntime = False+            , configTypeScript    = isTs+            }+  compileFromTo config file (Just out)+  actual <- readStripped out+  expected <- readStripped $ resf ++ (if isTs then "_ts" else "")+  assertEqual file expected actual+  where readStripped =+          fmap (unlines . filter (not . null) . lines) . readFile+
+ tests/AllBaseModules.hs view
@@ -0,0 +1,28 @@+module AllBaseModules where++import Control.Exception ()+import Data.Char ()+import Data.Data ()+import Data.Defined ()+import Data.Either ()+import Data.Function ()+import Data.List ()+import Data.LocalStorage ()+import Data.Maybe ()+import Data.MutMap ()+import Data.MutMap.Internal ()+import Data.Mutex ()+import Data.Nullable ()+import Data.Ord ()+import Data.Ratio ()+import Data.Text ()+import Data.Time ()+import Data.Var ()+import Debug.Trace ()+import FFI+import Fay.Unsafe ()+import Prelude+import Unsafe.Coerce ()++main :: Fay ()+main = putStrLn "ok"
+ tests/AllBaseModules.res view
@@ -0,0 +1,1 @@+ok
tests/AutomaticList.hs view
@@ -1,6 +1,5 @@ module AutomaticList where -import Prelude import FFI  main :: Fay ()
tests/Bool.hs view
@@ -1,4 +1,2 @@-import Prelude- main :: Fay () main = print True
tests/CPP.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-}+ #ifdef FAY import           Prelude #else
tests/Char.hs view
@@ -1,10 +1,38 @@ module Char where -import Prelude import FFI +import Data.Char+ main :: Fay () main = do   print 'a'   putStrLn ('a' : "bc")   print (head "abc")+  print (ord 'a')+  print (chr 97)+  print (chr (ord 'a'))+  print (ord (chr 97))+  print (isAscii 'a')+  print (isAscii (chr 128))+  print (isLatin1 (chr 255))+  print (isLatin1 (chr 256))+  print (toUpper 'a')+  print (toLower 'A')+  print (toLower (toUpper 'a'))+  print (isAsciiLower 'a')+  print (isAsciiLower 'A')+  print (isAsciiUpper 'Z')+  print (isAsciiUpper 'z')+  print (isAsciiUpper (toUpper 'a'))+  print (isAsciiUpper (toLower 'A'))+  print (isAsciiLower (toLower 'Z'))+  print (isAsciiLower (toUpper 'z'))+  print (all isDigit "0123456789")+  print (isDigit 'a')+  print (all isOctDigit "01234567")+  print (any isOctDigit ['8', '9'])+  print (all isHexDigit "0123456789ABCDEFabcdef")+  print (any isHexDigit "ghijklmnopqrstuvwxyzGHIJKLMNOPQRSTUVWXYZ")+  print (all isSpace [' ', '\t', '\n', '\r', '\f', '\v', '\xa0', '\x3000'])+
tests/Char.res view
@@ -1,3 +1,29 @@ a abc a+97+a+a+97+true+false+true+false+A+a+a+true+false+true+false+true+false+true+false+true+false+true+false+true+false+true
tests/Compile/StrictWrapper.hs view
@@ -1,4 +1,8 @@-module StrictWrapper (f,g,h,r,clog) where+module StrictWrapper (+  f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth,+  sumInt, sumIntWrapped, zipWithPlus, zipWithPlusWrapped,+  sumPair, sumPairWrapped, zipPairs, zipPairsWrapped+) where  import           FFI import           Prelude@@ -20,6 +24,45 @@ clog :: a -> Fay () clog = ffi "console.log(%1)" +-- FFI Expressions+logInlineOnly = ffi "console.log(%1)" :: a -> Fay ()++logSeparateOnly :: a -> Fay ()+logSeparateOnly = ffi "console.log(%1)"++logBoth :: a -> Fay ()+logBoth = ffi "console.log(%1)" :: a -> Fay ()++-- lists+sumInt :: [Int] -> Int+sumInt xs = sum xs++zipWithPlus :: [Int] -> [Int] -> [Int]+zipWithPlus xs ys = zipWith (+) xs ys++data IntList = IntList { list :: [Int] }++sumIntWrapped :: IntList -> Int+sumIntWrapped (IntList xs) = sumInt xs++zipWithPlusWrapped :: IntList -> IntList -> IntList+zipWithPlusWrapped (IntList x) (IntList y) = IntList $ zipWithPlus x y++-- tuples+sumPair :: (Int, Int) -> Int+sumPair (x,y) = x + y++zipPairs :: (Int, Int) -> (Int, Int) -> (Int, Int)+zipPairs (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)++data IntPair = IntPair { pair :: (Int, Int) }++sumPairWrapped :: IntPair -> Int+sumPairWrapped (IntPair x) = sumPair x++zipPairsWrapped :: IntPair -> IntPair -> IntPair+zipPairsWrapped (IntPair x) (IntPair y) = IntPair $ zipPairs x y+ -- You should probably not use the strict wrapper from Fay, this is just for the sake of the test. main :: Fay () main = do@@ -28,3 +71,18 @@   ffi "console.log(Strict.StrictWrapper.h({instance:'R',i:1}))" :: Fay ()   ffi "console.log(Strict.StrictWrapper.r)" :: Fay ()   ffi "Strict.StrictWrapper.clog(123)" :: Fay ()+  ffi "Strict.StrictWrapper.logInlineOnly('inlineOnly')" :: Fay ()+  ffi "Strict.StrictWrapper.logSeparateOnly('separateOnly')" :: Fay ()+  ffi "Strict.StrictWrapper.logBoth('both')" :: Fay ()+  +  -- lists+  (ffi "console.log(Strict.StrictWrapper.sumInt(%1))" :: [Int] -> Fay ()) [1, 2, 3]+  (ffi "console.log(Strict.StrictWrapper.sumIntWrapped(%1))" :: IntList -> Fay ()) (IntList [1, 2, 3])+  (ffi "console.log(Strict.StrictWrapper.zipWithPlus(%1, %2))" :: [Int] -> [Int] -> Fay ()) [1, 2, 3] [1, 2, 3]+  (ffi "console.log(Strict.StrictWrapper.zipWithPlusWrapped(%1, %2))" :: IntList -> IntList -> Fay ()) (IntList [1, 2, 3]) (IntList [1, 2, 3])+  +  -- tuples+  (ffi "console.log(Strict.StrictWrapper.sumPair(%1))" :: (Int, Int) -> Fay ()) (1, 3)+  (ffi "console.log(Strict.StrictWrapper.sumPairWrapped(%1))" :: IntPair -> Fay ()) (IntPair (1, 3))+  (ffi "console.log(Strict.StrictWrapper.zipPairs(%1, %2))" :: (Int, Int) -> (Int, Int) -> Fay ()) (1, 3) (1, 3)+  (ffi "console.log(Strict.StrictWrapper.zipPairsWrapped(%1, %2))" :: IntPair -> IntPair -> Fay ()) (IntPair (1, 3)) (IntPair (1, 3))
tests/Compile/StrictWrapper.res view
@@ -3,3 +3,14 @@ { instance: 'R', i: 2 } { instance: 'R', i: 2 } 123+inlineOnly+separateOnly+both+6+6+[ 2, 4, 6 ]+{ instance: 'IntList', list: [ 2, 4, 6 ] }+4+4+[ 2, 6 ]+{ instance: 'IntPair', pair: [ 2, 6 ] }
+ tests/Compile/pretty.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+  let n = 3::Int+  print . length' 0 . takeWhile (<=n) $ [0..]+  putStrLn $  if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+  forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/pretty.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
+ tests/Compile/prettyOperators.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+  let n = 3::Int+  print . length' 0 . takeWhile (<=n) $ [0..]+  putStrLn $  if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+  forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/prettyOperators.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
+ tests/Compile/prettyThunks.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+  let n = 3::Int+  print . length' 0 . takeWhile (<=n) $ [0..]+  putStrLn $  if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+  forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/prettyThunks.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
tests/Defined.hs view
@@ -1,5 +1,4 @@ import           FFI-import           Prelude  data R = R (Defined Double)
+ tests/DesugarFFI.hs view
@@ -0,0 +1,28 @@+module DesugarFFI where++import Prelude+import FFI++-- top-level FFI call with multi type signature+addOne, addTwo :: Int -> Int++addOne = ffi "%1 + 1"+addTwo = ffi "%1 + 2"++-- FFI call in a let binding+addThree :: Int -> Int+addThree x =+  let go :: Int -> Int+      go = ffi "%1 + 3"+  in go x++-- FFI call in a where binding+addFour :: Int -> Int+addFour x = go x+  where+  go :: Int -> Int+  go = ffi "%1 + 4"++main = do+  let result = addOne . addTwo .  addThree . addFour $ 0+  putStrLn $ show result
+ tests/DesugarFFI.res view
@@ -0,0 +1,1 @@+10
tests/DoLet2.hs view
@@ -1,6 +1,5 @@ module DoLet2 where -import Prelude import FFI  main = do
tests/DoLet3.hs view
@@ -1,6 +1,5 @@ module DoLet3 where -import Prelude import FFI  data R = R Int
tests/Double.hs view
@@ -1,3 +1,4 @@-import           Prelude+module Double where +main :: Fay () main = print ((2 * 4 / 2) :: Double)
tests/Double2.hs view
@@ -1,3 +1,4 @@-import           Prelude+module Double2 where +main :: Fay () main = print ((10 + (2 * (4 / 2))) :: Double)
tests/Double3.hs view
@@ -1,3 +1,4 @@-import           Prelude+module Double3 where +main :: Fay () main = print ((5 * 3 / 2) :: Double)
tests/Double4.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Double4 where +main :: Fay () main = print 1-
tests/Either.hs view
@@ -1,4 +1,4 @@-import Prelude+module Either where  raw :: Either Int Int -> Int raw x = case x of Left a -> a + 1
+ tests/EmptyDataDeclArray.hs view
@@ -0,0 +1,20 @@+import FFI++data Array a++empty :: Fay (Array a)+empty = ffi "[]"++push:: a -> Array a -> Fay ()+push = ffi "%2.push(%1)"++len :: Array a -> Fay Int+len = ffi "%1['length']"++main :: Fay ()+main = do+  arr <- empty+  print arr+  push (5::Int) arr+  print =<< len arr+  print arr
+ tests/EmptyDataDeclArray.res view
@@ -0,0 +1,3 @@+[]+1+[ 5 ]
tests/Eq.hs view
@@ -1,4 +1,4 @@-import Prelude+module Eq where  main = do   when (1 == 1) $ putStrLn "Expected =="
tests/ExportEThingAll.hs view
@@ -1,6 +1,5 @@ module ExportEThingAll where -import Prelude import ExportEThingAll_Export  main = print Barbles
tests/ExportList.hs view
@@ -1,6 +1,5 @@-module Main (main) where+module ExportList (main) where -import Prelude import ExportList_A import FFI @@ -15,4 +14,3 @@   print $ b1 b   print c   print d-
tests/ExportList_A.hs view
@@ -1,7 +1,6 @@ module ExportList_A (x, A (..), B (B, b1), module ExportList_B) where  import ExportList_B-import Prelude  x :: Double x = 1
tests/ExportList_B.hs view
@@ -2,7 +2,6 @@  import ExportList_C import ExportList_D-import Prelude  y :: Double y = 2
tests/ExportQualified_Export.hs view
@@ -2,8 +2,7 @@ module ExportQualified_Export (main, X.X) where  import           Prelude--import           "foo" X+import           "base" X  main :: Fay () main = return ()
tests/ExportType.hs view
@@ -8,7 +8,6 @@   ) where  import           FFI-import           Prelude  data X = X
tests/Floating.hs view
@@ -1,4 +1,4 @@-import Prelude+module Floating where  main = do   print $ exp 0
tests/FromString.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings, RebindableSyntax #-} module FromString where -import Prelude import FromString.FayText import FromString.Dep (myString, depTest)+import Prelude  main :: Fay () main = do@@ -12,4 +12,3 @@   putStrLn myString   print myString   depTest-
tests/GADTs_without_records.hs view
@@ -2,14 +2,12 @@  module GADTs_without_records where -import Prelude- data Expr a where   I :: Int -> Expr Int   Plus :: Expr Int -> Expr Int -> Expr Int   B :: Bool -> Expr Bool   IfThenElse :: Expr Bool -> Expr a -> Expr a -> Expr a-  + false :: Expr Bool false = B False @@ -23,7 +21,7 @@ eval (IfThenElse p e1 e2) = case eval p of   True -> eval e1   False -> eval e2-  + n5 = I 5 n2 = I 2
tests/GuardWhere.hs view
@@ -1,4 +1,4 @@-import Prelude+module GuardWhere where  poseL :: Bool -> String poseL y | y == True = "Not OK"
tests/HidePreludeImport_Import.hs view
@@ -1,6 +1,4 @@ module HidePreludeImport_Import where -import           Prelude- last :: Double last = 1
tests/HierarchicalImport.hs view
@@ -1,6 +1,6 @@-import           Prelude+module HierarchicalImport where+ import           Hierarchical.Export  main :: Fay () main = putStrLn exported-
+ tests/ImplicitPrelude.hs view
@@ -0,0 +1,7 @@+module ImplicitPrelude where++result :: Int+result = 3 + 4++main :: Fay ()+main = putStrLn (show result)
+ tests/ImplicitPrelude.res view
@@ -0,0 +1,1 @@+7
tests/ImportHiding.hs view
@@ -1,4 +1,4 @@-import Prelude+module ImportHiding where  import ImportList1.A hiding (y) import ImportList1.B hiding (x)
tests/ImportIThingAll.hs view
@@ -1,4 +1,5 @@-import           Prelude+module ImportIThingAll where+ import           FFI  import           ImportList1.C        (A (..))
tests/ImportList.hs view
@@ -1,6 +1,5 @@ module ImportList where -import           Prelude import           FFI  import           ImportList1.A        (x)
tests/ImportListType.hs view
@@ -1,3 +1,5 @@+module ImportListType where+ import Prelude (Fay, putStrLn)  main :: Fay ()
tests/ImportType.hs view
@@ -1,4 +1,4 @@-import           Prelude+module ImportType where  import           ExportType @@ -14,4 +14,3 @@   print w'   print (V 1 2)   print (v1 (V 1 2))-
tests/ImportType2.hs view
@@ -3,4 +3,5 @@ import ImportType2I.A (foo) import ImportType2I.B (Foo) +main :: Fay () main = foo
tests/ImportType2I/A.hs view
tests/ImportType2I/B.hs view
+ tests/Integer.hs view
@@ -0,0 +1,10 @@+module Integer where++main :: Fay ()+main = do+  -- Integer is Ord, Eq, and Show, but not Num.+  print $ (1::Integer) < 1000+  print $ (1::Integer) > 1000+  print $ (1::Integer) == 1000+  print $ (3::Integer) == 3+  print $ 1024
+ tests/Integer.res view
@@ -0,0 +1,5 @@+true+false+false+true+1024
tests/Integral.hs view
@@ -1,4 +1,4 @@-import Prelude+module Integral where  printPair :: (Int,Int) -> Fay () printPair (x,y) = print x >> print y
tests/Issue215A.hs view
@@ -1,7 +1,5 @@ module Issue215A where -import Prelude import Issue215.B -main = do-        print $ f 2+main = print $ f 2
tests/Js2FayFunc.hs view
@@ -1,6 +1,8 @@+module Js2FayFunc where+ import FFI-import Prelude +main :: Fay () main = do   f <- getF   g <- getG
tests/JsFunctionPassing.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE EmptyDataDecls #-} +module JsFunctionPassing where+ import           FFI-import           Prelude  data Func 
+ tests/LambdaCase.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE LambdaCase #-}+module LambdaCase where++f :: Int -> Bool+f = \case+  2 -> True+  _ -> False++main :: Fay ()+main = do+  print (f 2)
+ tests/LambdaCase.res view
@@ -0,0 +1,1 @@+true
tests/LazyOperators.hs view
@@ -1,7 +1,5 @@ module LazyOperators where -import           Prelude- main :: Fay () main = print testFn 
tests/List.hs view
@@ -1,3 +1,5 @@+module List where+ import           FFI import           Prelude hiding (take) 
tests/List2.hs view
@@ -1,6 +1,9 @@+module List2 where+ import           FFI import           Prelude hiding (take) +main :: Fay () main = putStrLn (showList (take 5 (let ns = 1 : map' (foo 123) ns in ns)))  foo :: Double -> Double -> Double
+ tests/ListEq.hs view
@@ -0,0 +1,7 @@+module ListEq where++main :: Fay ()+main = do+  print $ []      == []+  print $ [1,2,3] == [1,2,3]+  print $ ["a"]   == ["b"]
+ tests/ListEq.res view
@@ -0,0 +1,3 @@+true+true+false
+ tests/MainThunk.hs view
@@ -0,0 +1,10 @@+import FFI++main = do putStrLn "Hey ho!"+          setTimeout 500 doThing+          doThing++doThing = putStrLn "Hello, World!"++setTimeout :: Int -> (Fay ()) -> Fay ()+setTimeout = ffi "(function (f,i) { var id = setTimeout(function () { f(id); }, i); return id; })(%2,%1)"
+ tests/MainThunk.res view
@@ -0,0 +1,3 @@+Hey ho!+Hello, World!+Hello, World!
tests/ModuleReExports.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}  module ModuleReExports where 
tests/ModuleRecordClash.hs view
@@ -1,6 +1,5 @@ module ModuleRecordClash (main) where -import Prelude import ModuleRecordClash.R  data R = R
tests/ModuleRecordClash2.hs view
@@ -1,11 +1,9 @@-module Main where+module ModuleRecordClash2 where  import           FFI import           ModuleRecordClash2_Hello-import           Prelude  alert :: String -> Fay () alert = ffi "console.log(%1)" -main = do-    alert (greeting defaultHello)+main = alert (greeting defaultHello)
tests/ModuleRecordClash2_Hello.hs view
@@ -1,8 +1,6 @@ -- This module needs to be top level to do the intended test. module ModuleRecordClash2_Hello where -import           Prelude- defaultHello :: ModuleRecordClash2_Hello defaultHello = ModuleRecordClash2_Hello { greeting = "Hello, world!" } 
tests/Monad.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE EmptyDataDecls    #-}---- | Monads test.--import           Prelude+{-# LANGUAGE EmptyDataDecls #-}+module Monad where  main :: Fay () main = do@@ -13,4 +10,3 @@   y <- return 101112   print x   print y-
tests/Monad2.hs view
@@ -1,10 +1,7 @@ {-# LANGUAGE EmptyDataDecls #-}- {-# LANGUAGE RankNTypes     #-} --- | Monads test.--import           Prelude+module Monad2 where  main :: Fay () main = do
+ tests/MultiWayIf.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE MultiWayIf #-}+module MultiWayIf where++f :: Int -> Char+f x = if | x == 1    -> 'a'+         | x == 2    -> 'b'+         | otherwise -> 'c'++main :: Fay ()+main = do+  print (f 1)+  print (f 2)+  print (f 3)
+ tests/MultiWayIf.res view
@@ -0,0 +1,3 @@+a+b+c
tests/NestedImporting.hs view
@@ -1,6 +1,4 @@ module NestedImporting where -import Prelude- r :: Double r = 1
tests/NestedImporting2.hs view
@@ -1,6 +1,5 @@ module NestedImporting2 where -import Prelude import NestedImporting2.A  main :: Fay ()
tests/NewtypeImport_Export.hs view
@@ -1,7 +1,6 @@ module NewtypeImport_Export where  import FFI-import Prelude  newtype MyInteger = MyInteger Int 
tests/NewtypeImport_Import.hs view
@@ -1,25 +1,26 @@-import           Prelude+module NewtypeImport_Import where+ import           NewtypeImport_Export  x = case MyInteger undefined of-      MyInteger _ -> 1+  MyInteger _ -> 1  y = case undefined of-      MyInteger _ -> 1+  MyInteger _ -> 1  int :: Int int = undefined  yInt = case int of-         _ -> 1+  _ -> 1  main = do-    print x-    print y-    print yInt-    print (Baz (Bar 1))-    baz <- getBaz-    print baz-    case baz of-      Baz (Bar i) -> print i-    print (bar $ unwrapBaz baz)+  print x+  print y+  print yInt+  print (Baz (Bar 1))+  baz <- getBaz+  print baz+  case baz of+    Baz (Bar i) -> print i+  print (bar $ unwrapBaz baz)
tests/Nullable.hs view
@@ -1,5 +1,6 @@+module Nullable where+ import           FFI-import           Prelude  data R = R (Nullable Double) @@ -39,4 +40,4 @@ r2 = ffi "{ instance : 'R', slot1 : null }"  parseInt :: String -> Nullable Int-parseInt = ffi "(function () { var n = global.parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"+parseInt = ffi "(function () { var n = parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"
tests/Num.hs view
@@ -1,7 +1,6 @@ module Num where -import           Prelude-+main :: Fay () main = do   print (1 + 2::Int)   print (4 - 1::Int)
tests/Ord.hs view
@@ -1,7 +1,6 @@ module Ord where -import           Prelude-+main :: Fay () main = do   when ((1::Int) < 2) $ putStrLn "Expected <"   when ((1::Int) < 1) $ putStrLn "Unexpected < (1)"
+ tests/PrefixOpPat.hs view
@@ -0,0 +1,7 @@+module PrefixOpPat where++f ((:) x y) = x++main :: Fay ()+main = do+  print $ f [1,2]
+ tests/PrefixOpPat.res view
@@ -0,0 +1,1 @@+1
tests/QualifiedImport.hs view
@@ -1,7 +1,6 @@ module QualifiedImport where  import           FFI-import           Prelude  import qualified QualifiedImport.X import qualified QualifiedImport.X as X
tests/Ratio.hs view
@@ -1,6 +1,5 @@ module Ratio where -import Prelude import Data.Ratio  main :: Fay ()
tests/ReExport3.hs view
@@ -1,4 +1,3 @@-import Prelude import ReExport2  main :: Fay ()
tests/ReExportGlobally.hs view
@@ -1,7 +1,6 @@ module ReExportGlobally (main, x) where  import           FFI-import           Prelude  import           ReExportGlobally.A (x) 
tests/ReExportGloballyExplicit.hs view
@@ -1,7 +1,6 @@ module Foo (main, x) where  import           FFI-import           Prelude  import           ReExportGlobally.A (x) 
tests/RealFrac.hs view
@@ -1,5 +1,6 @@-import Prelude+module RealFrac where +main :: Fay () main = do   print $ fst $ properFraction 1.5   print $ snd $ properFraction 1.5
tests/RecCon.hs view
@@ -1,7 +1,8 @@-import           Prelude+module RecCon where  data Bool = True | False +main :: Fay () main = print (head (fix (\xs -> 123 : xs)))  fix f = let x = f x in x
tests/RecDecl.hs view
@@ -1,5 +1,6 @@+module RecDecl where+ import           FFI-import           Prelude  data R = R { i :: Double, c :: Char } data S = S Double Char
tests/RecordImport2_Export1.hs view
@@ -1,5 +1,5 @@ module RecordImport2_Export1 (main) where-import Prelude+ data R = R { wrong :: Double }  main :: Fay ()
tests/RecordImport2_Export2.hs view
@@ -1,3 +1,3 @@ module RecordImport2_Export2 where-import Prelude+ data R = R { correct :: Double }
tests/RecordImport2_Import.hs view
@@ -1,6 +1,5 @@ module RecordExport where -import Prelude import FFI import RecordImport2_Export1 import RecordImport2_Export2
tests/RecordImport_Export.hs view
@@ -2,7 +2,5 @@  module RecordImport_Export where -import           Prelude- data R = R Integer data Fields = Fields { fieldFoo :: Integer, fieldBar :: Integer }
tests/RecordImport_Import.hs view
@@ -1,6 +1,7 @@ {- NOTE: This file is also used in the Compile tests. -} -import           Prelude+module RecordImport_Import where+ import           RecordImport_Export  f :: R -> R
tests/Sink.hs view
@@ -1,12 +1,10 @@ -- https://github.com/faylang/fay/issues/285-module Main where+module Sink where -import Prelude import FFI  run :: Fay ()-run = do-    runSink (Sink putStrLn) "hello"+run = runSink (Sink putStrLn) "hello"  newtype Sink a = Sink { runSink :: a -> Fay () } 
tests/SkipLetTypes.hs view
@@ -1,6 +1,5 @@-import Prelude+module SkipLetType where  main = let t :: Bool            t = True        in print t-
tests/SkipWhereTypes.hs view
@@ -1,7 +1,6 @@-import Prelude+module SkipWhereTypes where  main = print t   where     t :: Bool     t = True-
− tests/String.hs 
@@ -1,4 +0,0 @@-import           Prelude--main = putStrLn "Hello, World!"-
− tests/String.res 
@@ -1,1 +0,0 @@-Hello, World!
tests/StringForcing.hs view
@@ -1,6 +1,5 @@ module StringForcing where -import Prelude import FFI  main = do
+ tests/Strings.hs view
@@ -0,0 +1,3 @@+module Strings where++main = putStrLn "Hello, World!"
+ tests/Strings.res view
@@ -0,0 +1,1 @@+Hello, World!
tests/T190.hs view
@@ -1,7 +1,5 @@ module T190 where -import Prelude- import T190_B import T190_C 
tests/T190_A.hs view
@@ -1,6 +1,4 @@ module T190_A where -import Prelude- foo :: Int -> Fay () foo _ = putStrLn "WRONG!"
tests/T190_B.hs view
@@ -1,6 +1,5 @@ module T190_B where -import           Prelude import           T190_A  main :: Fay ()
tests/T190_C.hs view
@@ -1,6 +1,4 @@ module T190_C where -import Prelude- foo :: String -> Fay () foo x = putStrLn x
+ tests/TextOrd.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports    #-}+{-# LANGUAGE RebindableSyntax #-}+module TextOrd where++import Prelude++import Data.Text++main :: Fay ()+main = do+  print ("abc" < ("c"::Text))+  print ("a" < ("bcd"::Text))+  print ("bcd" > ("a"::Text))+  print ("bcd" < ("a"::Text))
+ tests/TextOrd.res view
@@ -0,0 +1,4 @@+true+true+true+false
+ tests/Trace.hs view
@@ -0,0 +1,11 @@+module Trace where++import FFI+import Debug.Trace++fac :: Int -> Int+fac 0 = trace "fac" (traceShow 0 1)+fac n = trace "fac" (traceShow n (n * fac (n - 1)))++main :: Fay ()+main = print $ fac 5
+ tests/Trace.res view
@@ -0,0 +1,13 @@+fac+5+fac+4+fac+3+fac+2+fac+1+fac+0+120
tests/TupleCalls.hs view
@@ -1,5 +1,6 @@+module TupleCalls where+ import FFI-import Prelude  f :: (Int,Double) -> Double f = ffi "%1[0]+%1[1]"@@ -10,10 +11,10 @@ h :: (String,Int) -> (Int,String) h = ffi "[%1[0]['length'],'#'+%1[1]['toString']()+'#']" +main :: Fay () main = do   print $ f (1,2.3)   print $ fst (g 8.76)   print $ snd (g 8.76)   print $ fst (h ("abc",12))   putStrLn $ snd (h ("abc",12))-
tests/TyVarSerialization.hs view
@@ -1,6 +1,5 @@ module TyVarSerialization where -import Prelude import FFI  main :: Fay ()
+ tests/Var.hs view
@@ -0,0 +1,24 @@+-- | Tests for the var types.++module Var where++import Data.Var++main =+  do v <- newVar (0 :: Int)+     subscribe v+               (\v ->+                  putStrLn ("v changed: " ++ show v))+     set v 4+     modify v (+ 5)+     s <- newSig+     subscribe s+               (\v ->+                  putStrLn ("s signalled: " ++ show v))+     set s (567 :: Int)+     r <- newRef (123 :: Int)+     v <- get r+     putStrLn ("ref: " ++ show v)+     set r (666 :: Int)+     v <- get r+     putStrLn ("ref(2): " ++ show v)
+ tests/Var.res view
@@ -0,0 +1,5 @@+v changed: 4+v changed: 9+s signalled: 567+ref: 123+ref(2): 666
+ tests/VarPtr.hs view
@@ -0,0 +1,11 @@+module VarPtr where++import Data.Var++data Record = Record Int++main = do +  v <- newVar $ Record 5+  subscribeAndRead v $ \y -> case y of+    Record a -> putStrLn . show $ a+  set v $ Record 10
+ tests/VarPtr.res view
@@ -0,0 +1,2 @@+5+10
+ tests/WhenUnlessRecursion.hs view
@@ -0,0 +1,22 @@+module WhenUnlessRecursion where++import FFI++getStackSize :: Fay Int+getStackSize = ffi "(Error[\"stackTraceLimit\"] = Infinity, new Error().stack.split('\\n').length)"++checkGrowth :: Maybe Int -> Int -> Fay ()+checkGrowth Nothing _      = return ()+checkGrowth (Just old) new = if new == old then return () else (error $ "Call stack growth: " ++ show old ++ " to " ++ show new)++main = do+  putStrLn "loopIf"     >> loopIf     Nothing 0+  putStrLn "loopWhen"   >> loopWhen   Nothing 0+  putStrLn "loopUnless" >> loopUnless Nothing 0+  where+    pred = (< 5)+    step = (+ 1)+    action f s n = getStackSize >>= \s' -> checkGrowth s s' >> f (Just s') (step n)+    loopIf     s n = if          (pred n) then (action loopIf     s n) else return ()+    loopWhen   s n = when        (pred n)      (action loopWhen   s n)+    loopUnless s n = unless (not (pred n))     (action loopUnless s n)
+ tests/WhenUnlessRecursion.res view
@@ -0,0 +1,3 @@+loopIf+loopWhen+loopUnless
tests/asPatternMatch.hs view
@@ -1,4 +1,4 @@-import           Prelude+module AsPatternMatch where  matchSame :: [a] -> ([a],[a]) matchSame x@y = (x,y)
tests/automatic.hs view
@@ -1,4 +1,5 @@-import Prelude+module Automatic where+ import FFI  func :: Bool -> Int -> Int -> Int@@ -19,4 +20,3 @@   print' (semiAutomatic func False)   print' (automatic func True)   print' (automatic func False)-
tests/baseFixities.hs view
@@ -1,4 +1,4 @@-import Prelude+module BaseFixities where  fmap :: (a -> b) -> Fay a -> Fay b fmap f m = m >>= (return . f)
tests/basicFunctions.hs view
@@ -1,4 +1,4 @@-import           Prelude+module BasicFunctions where  main = putStrLn (concat' ["Hello, ","World!"]) @@ -9,4 +9,3 @@  append (x:xs) ys = x : append xs ys append []     ys = ys-
tests/case.hs view
@@ -1,6 +1,5 @@-import           Prelude+module Case where  main = putStrLn (case True of                    True -> "Hello!"                    False -> "Ney!")-
tests/case2.hs view
@@ -1,6 +1,5 @@-import           Prelude+module Case2 where  main = putStrLn (case False of                    True -> "Hello!"                    False -> "Ney!")-
+ tests/case3.hs view
@@ -0,0 +1,11 @@+module Case3 where++f x = case () of+  _ | x == 1 -> 1+    | x == 2 -> 2+    | True -> 3++main = do+  print (f 1)+  print (f 2)+  print (f 3)
+ tests/case3.res view
@@ -0,0 +1,3 @@+1+2+3
tests/caseList.hs view
@@ -1,8 +1,7 @@-import           Prelude+module CaseList where  main = putStrLn (case [1,2,3,4,5] of   [1,2,3,4,6] -> "6!"   [1,2,4,2,4] -> "a!"   [1,2,3,4,5] -> "OK."   _           -> "Broken.")-
tests/caseWildcard.hs view
@@ -1,6 +1,5 @@-import           Prelude+module CaseWildcard where  main = putStrLn (case False of                   True -> "Hello!"                   _    -> "Ney!")-
tests/circular.hs view
@@ -1,7 +1,5 @@ module Circular where -import           Prelude- main :: Fay () main = let y = x + 1::Double            x = y + 1
tests/curry.hs view
@@ -1,4 +1,4 @@-import Prelude+module Curry where  f :: Int -> Int -> Int f x y = x + y
tests/cycle.hs view
@@ -1,3 +1,4 @@-import Prelude+module Cycle where +main :: Fay () main = mapM_ putStrLn (take 5 (cycle ["a", "b", "c"]))
tests/do.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Do where +main :: Fay () main = do putStrLn "Hello,"; putStrLn "World!"-
tests/doAssingPatternMatch.hs view
@@ -1,6 +1,6 @@-import           Prelude+module DoAssingPatternMatch where +main :: Fay () main = do   [1,2] <- return [1,2]   putStrLn "OK."-
tests/doBindAssign.hs view
@@ -1,6 +1,6 @@-import           Prelude+module DoBindAssign where +main :: Fay () main = do   x <- return "Hello, World!" >>= return   putStrLn x-
tests/doLet.hs view
@@ -1,4 +1,4 @@-import           Prelude+module DoLet where  main = do   first@@ -7,6 +7,7 @@   fourth   fifth   sixth+  newtyp  first = do   let x = 123@@ -44,3 +45,10 @@   print y   print x +newtype I = I Int+newtyp = do+  putStrLn "newtype"+  I i <- return (I 1)+  print i+  let I j = I 2+  print j
tests/doLet.res view
@@ -11,3 +11,6 @@ 10 777 123+newtype+1+2
tests/emptyMain.hs view
@@ -1,3 +1,4 @@-import           Prelude+module EmptyMain where +main :: Fay () main = return ()
tests/enumFrom.hs view
@@ -1,4 +1,4 @@-import Prelude+module EnumFrom where  main :: Fay () main = do
tests/error.hs view
@@ -1,3 +1,3 @@-import Prelude+module Error where  main = error "This is an error"
tests/ffiExpr.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}-module Main where+module FfiExpr where -import Prelude import FFI  main :: Fay ()
tests/ffimunging.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Maybe where+module FfiMunging where  import           FFI-import           Prelude  data Munge a b = Fudge a b 
tests/fix.hs view
@@ -1,5 +1,6 @@-import           Prelude+module Fix where +main :: Fay () main = print (head (tail (fix (\xs -> 123 : xs))))  fix f = let x = f x in x
tests/fromInteger.hs view
@@ -1,4 +1,4 @@-import           Prelude+module FromInteger where  main :: Fay () main = putStrLn $ show $ fromInteger 5
tests/fromIntegral.hs view
@@ -1,4 +1,7 @@-import           Prelude+module FromIntegral where  main :: Fay ()-main = putStrLn $ show $ fromIntegral 5+main = print $ fromIntegral' 5++fromIntegral' :: Int -> Double+fromIntegral' = fromIntegral
tests/guards.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Guards where  f :: Int -> Int f n | n <=  0 = 0
tests/infixDataConst.hs view
@@ -1,4 +1,4 @@-import           Prelude+module InfixDataConst where  data Ty1 = Integer `InfixConst1` Integer 
tests/ints.hs view
@@ -1,5 +1,5 @@-import           Prelude+module Ints where +main :: Fay () main = do-  print 123-+  print (123 :: Int)
tests/linesAndWords.hs view
@@ -1,7 +1,8 @@-import Prelude+module LinesAndWords where  quote s = "\"" ++ s ++ "\"" +main :: Fay () main = do   mapM_ (putStrLn . quote) $ words "  this  is\ta\n\r\ftest  "   putStrLn $ quote $ unwords ["this", "is", "too"]
tests/listComprehensions.hs view
@@ -1,4 +1,4 @@-import           Prelude+module ListComprehensions where  main :: Fay () main = putStrLn $ show $ sum [ x*x | x <- [1::Int, 2, 3, 4, 5], let y = x + 4, y < 8]
tests/listlen.hs view
@@ -1,7 +1,6 @@ module Listlen (main) where  import FFI-import Prelude  -- Test provided by ticket go :: [Double] -> [Double]
tests/mutableReference.hs view
@@ -1,9 +1,7 @@--- | Mutable references.--{-# LANGUAGE EmptyDataDecls    #-}+{-# LANGUAGE EmptyDataDecls #-}+module MutableReference where  import           FFI-import           Prelude  main :: Fay () main = do
tests/nameGen.hs view
@@ -1,4 +1,4 @@-import           Prelude+module NameGen where  data SomeRec = SomeRec { a :: Integer, b :: Integer } | Y | X @@ -12,4 +12,3 @@     putStrLn $ case t of                     SomeRec _ _ -> "Bad"                     Y -> "OK."-
tests/namedFieldPuns.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-}+module NamedFieldPuns where  import           FFI-import           Prelude -data SomeRec = SomeRec { a :: Integer, b :: Integer } | Y | X+data SomeRec = SomeRec { a :: Int, b :: Int } | Y | X  fun :: SomeRec -> SomeRec fun SomeRec{a} = SomeRec{a=a+1, b=10}
tests/negation.hs view
@@ -1,8 +1,9 @@-import           Prelude+module Negation where  print' :: Double -> Fay () print' = print +main :: Fay () main = do print' $ (-7/2)           print' $ (-7)/2           print' $ -f x/y
tests/newtype.hs view
@@ -1,5 +1,6 @@+module Newtype where+ import FFI-import Prelude  newtype MyInteger = MyInteger Int @@ -21,13 +22,30 @@ getBaz :: Fay Baz getBaz = ffi "{ instance: 'Bar', bar: 1 }" +getBazExpr = ffi "{ instance: 'Bar', bar : 2 }" :: Fay Baz++getBazExpr' = f (Baz (Bar 2)) (ffi "{ instance: 'Bar', bar : 3 }" :: Baz)+f :: Baz -> Baz -> Baz+f (Baz x) (Baz y) = Baz (Bar (bar x + bar y))++ main = do     print x     print y     print yInt     print (Baz (Bar 1))+     baz <- getBaz     print baz-    case baz of-      Baz (Bar i) -> print i+    case baz of Baz (Bar i) -> print i     print (bar $ unwrapBaz baz)++    bazExpr <- getBazExpr+    print bazExpr+    case bazExpr of Baz (Bar i) -> print i+    print (bar $ unwrapBaz bazExpr)++    let bazExpr' = getBazExpr'+    print bazExpr'+    case bazExpr' of Baz (Bar i) -> print i+    print (bar $ unwrapBaz bazExpr')
tests/newtype.res view
@@ -5,3 +5,9 @@ { instance: 'Bar', bar: 1 } 1 1+{ instance: 'Bar', bar: 2 }+2+2+{ instance: 'Bar', bar: 5 }+5+5
tests/newtypeIndirectApp.hs view
@@ -1,6 +1,4 @@-module Main where--import           Prelude+module NewtypeIndirectApp where  newtype Parser a = Parser { runParser :: Char -> Either Char (a, Char) } 
tests/numTheory.hs view
@@ -1,4 +1,4 @@-import Prelude+module NumTheory where  main = do   print $ (subtract 3 5 :: Int)
tests/nums.hs view
@@ -1,5 +1,4 @@-import           Prelude+module Nums where  main :: Fay () main = print (-10 :: Double)-
tests/pats.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Pats where  main :: Fay () main = do
tests/patternGuards.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} --- | As pattern matches+module PatternGuards where  import           FFI-import           Prelude  isPositive :: Double -> Bool isPositive x | x > 0 = True
tests/patternMatchFail.hs view
@@ -1,4 +1,4 @@-import           Prelude+module PatternMatchFail where +main :: Fay () main = putStrLn ((\a 'a' -> "OK.") 0 'b')-
+ tests/patternMatchLet.hs view
@@ -0,0 +1,10 @@+module PatternMatchLet where++first3 :: String -> Fay ()+first3 cs = do+  let (a:b:c:_) = cs+  putStrLn [a, b, c]++main :: Fay ()+main = first3 "abcd"+
+ tests/patternMatchLet.res view
@@ -0,0 +1,1 @@+abc
tests/patternMatchingTuples.hs view
@@ -1,8 +1,4 @@--- compile with fay --html-wrapper--- error thrown as soon as HTML page is loaded:--- Uncaught TypeError: Cannot read property 'car' of null--import Prelude+module PatternMatchingTuples where  main :: Fay () main = putStrLn doTest
tests/recordFunctionPatternMatch.hs view
@@ -1,11 +1,11 @@-import           Prelude+module RecordFunctionPatternMatch where  data Person = Person String String Int +main :: Fay () main = putStrLn (foo (Person "Chris" "Done" 14))  foo (Person "Chris" "Done" 13) = "Foo!" foo (Person "Chris" "Barf" 14) = "Bar!" foo (Person "Chris" "Done" 14) = "Hello!" foo _ = "World!"-
tests/recordPatternMatch.hs view
@@ -1,8 +1,7 @@-import           Prelude+module RecordPatternMatch where  data Person = Person String String Int  main = putStrLn (case Person "Chris" "Done" 14 of                    Person "Chris" "Done" 13 -> "Hello!"                    _ -> "World!")-
tests/recordPatternMatch2.hs view
@@ -1,4 +1,4 @@-import           Prelude+module RecordPatternMatch2 where  data Person = Person String String Int @@ -7,4 +7,3 @@                    Person "Chris" "Barf" 14 -> "Bar!"                    Person "Chris" "Done" 14 -> "Hello!"                    _ -> "World!")-
tests/recordUseBeforeDefine.hs view
@@ -1,4 +1,4 @@-import           Prelude+module RecordUseBeforeDefine where  import           Hierarchical.RecordDefined @@ -10,4 +10,3 @@   print $ g (Callback 1)  data R = R Double-
tests/recordWildCards.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE NamedFieldPuns  #-} {-# LANGUAGE RecordWildCards #-} +module RecordWildCards where+ import           FFI-import           Prelude  data C = C { a :: Int, b :: Int, c :: Int, d :: Int } 
tests/records.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Records where  data Person1 = Person1 String String Int data Person2 = Person2 { fname :: String, sname :: String, age :: Int }@@ -14,4 +14,3 @@   putStrLn (case p2 of Person2 "Chris" "Done" 13 -> "Hello!")   putStrLn (case p2a of Person2 "Chris" "Done" 13 -> "Hello!")   putStrLn (case p3 of Person3 "Chris" "Done" 13 -> "Hello!")-
tests/recursive.hs view
@@ -1,6 +1,4 @@-module Main where--import Prelude+module Recursive where  ones :: [Int] ones = 1 : ones
tests/reservedWords.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE EmptyDataDecls    #-} -import           Prelude+module ReservedWords where  main = do   -- All reserved words@@ -43,4 +43,3 @@   putStrLn ""   -- Stdlib functions that need to be encoded   putStrLn $ const "stdconst" 2-
tests/sections.hs view
@@ -1,7 +1,5 @@ module Sections where -import           Prelude- withTwo :: (Int -> Int) -> Int withTwo f = f 2 
tests/seq-fake.hs view
@@ -1,4 +1,4 @@-import Prelude+module SeqFake where  fakeSeq :: a -> b -> b fakeSeq x y = y
tests/seq.hs view
@@ -1,3 +1,3 @@-import Prelude+module Seq where  main = error "You shall not pass!" `seq` return ()
tests/serialization.hs view
@@ -1,4 +1,5 @@-import Prelude+module Serialization where+ import FFI  data Parametric a = Parametric a@@ -10,8 +11,8 @@   printMaybeConcrete (Just (ConcreteRecord 42))   printMaybeAutomatic (Just (ConcreteRecord 42))   printMaybe (Just (ConcreteRecord 42))-  printUnknown (error "do not want")-  printUnknownField (Just (error "do not want"))+  printUnknown 42+  printUnknownField (Just 42)   printAutomatic (Just (ConcreteRecord 42))  printParametricButConcreteType :: Parametric ConcreteRecord -> Fay ()
tests/serialization.res view
@@ -3,15 +3,14 @@ { instance: 'Parametric',   slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Parametric',-  slot1: { forced: false, value: [Function] } }+  slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just',-  slot1: { forced: false, value: [Function] } }-{ forced: false, value: [Function] }-{ instance: 'Just',-  slot1: { forced: false, value: [Function] } }+  slot1: { instance: 'ConcreteRecord', concreteField: 42 } }+42+{ instance: 'Just', slot1: 42 } { instance: 'Just',   slot1: { instance: 'ConcreteRecord', concreteField: 42 } }
tests/succPred.hs view
@@ -1,4 +1,4 @@-import Prelude+module SuccPred where  main = do   print (succ 1 :: Int)
tests/tailRecursion.hs view
@@ -1,5 +1,5 @@ -- | This is to test tail-recursive calls are iterative.-import           Prelude+module TailRecursion where  main = do   print (sumTo 1000 0 :: Double)
tests/then.hs view
@@ -1,4 +1,3 @@-import           Prelude+module Then where  main = putStrLn "Hello," >> putStrLn "World!"-
tests/tupleCon.hs view
@@ -1,4 +1,4 @@-import Prelude+module TupleCon where  main = do   print $ (,) 1 2
tests/tupleSec.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TupleSections #-}-import Prelude+module TupleSec where  main = do     print $ (,2) 1
tests/unit.hs view
@@ -1,4 +1,5 @@-import Prelude+module Unit where+ main = case (f ()) of   () -> print 123 
tests/utf8.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE EmptyDataDecls    #-} --- | Unicode test.--import           Prelude+module Utf8 where  main :: Fay () main = do@@ -131,4 +129,3 @@   putStrLn "ﹰ ﹱ ﹲ ﹴ ﹶ ﹷ ﹸ ﹹ ﹺ ﹻ ﹼ ﹽ ﹾ ﹿ ﺀ ﺁ ﺂ ﺃ ﺄ ﺅ ﺆ ﺇ ﺈ ﺉ ﺊ ﺋ ﺌ ﺍ ﺎ ﺏ ﺐ ﺑ ﺒ ﺓ ﺔ ﺕ ﺖ ﺗ ﺘ ﺙ ﺚ ﺛ ﺜ ﺝ ﺞ ﺟ ﺠ ﺡ ﺢ ﺣ ﺤ ﺥ ﺦ ﺧ ﺨ ﺩ ﺪ ﺫ ﺬ ﺭ ﺮ ﺯ ﺰ ﺱ ﺲ ﺳ ﺴ ﺵ ﺶ ﺷ ﺸ ﺹ ﺺ ﺻ ﺼ ﺽ ﺾ ﺿ ﻀ ﻁ ﻂ ﻃ ﻄ ﻅ ﻆ ﻇ ﻈ ﻉ ﻊ ﻋ ﻌ ﻍ ﻎ ﻏ ﻐ ﻑ ﻒ ﻓ ﻔ ﻕ ﻖ ﻗ ﻘ ﻙ ﻚ ﻛ ﻜ ﻝ ﻞ ﻟ ﻠ ﻡ ﻢ ﻣ ﻤ ﻥ ﻦ ﻧ ﻨ ﻩ ﻪ ﻫ ﻬ ﻭ ﻮ ﻯ ﻰ ﻱ ..."   -- Halfwidth and Fullwidth Forms   putStrLn "！ ＂ ＃ ＄ ％ ＆ ＇ （ ） ＊ ＋ ， － ． ／ ０ １ ２ ３ ４ ５ ６ ７ ８ ９ ： ； ＜ ＝ ＞ ？ ＠ Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ Ｋ Ｌ Ｍ Ｎ Ｏ Ｐ Ｑ Ｒ Ｓ Ｔ Ｕ Ｖ Ｗ Ｘ Ｙ Ｚ ［ ＼ ］ ＾ ＿ ｀ ａ ｂ ｃ ｄ ｅ ｆ ｇ ｈ ｉ ｊ ｋ ｌ ｍ ｎ ｏ ｐ ｑ ｒ ｓ ｔ ｕ ｖ ｗ ｘ ｙ ｚ ｛ ｜ ｝ ～ ｡ ｢ ｣ ､ ･ ｦ ｧ ｨ ｩ ｪ ｫ ｬ ｭ ｮ ｯ ｰ ｱ ｲ ｳ ｴ ｵ ｶ ｷ ｸ ｹ ｺ ｻ ｼ ｽ ｾ ｿ ﾀ ﾁ ﾂ ..."-
tests/where.hs view
@@ -1,6 +1,5 @@-import           Prelude+module Where where  main = putStrLn $ "Hello " ++ friends ++ family   where friends = "my friends"         family = " and family"-
tests/whereBind.hs view
@@ -1,4 +1,4 @@-import           Prelude+module WhereBind where  main :: Fay () main =
tests/whereBind2.hs view
@@ -1,4 +1,4 @@-import           Prelude+module WhereBind2 where  someFun :: Int -> String someFun x = fun x
tests/whereBind3.hs view
@@ -1,4 +1,4 @@-import           Prelude+module WhereBind3 where  f :: String -> String f x = friends ++ family@@ -6,4 +6,3 @@         family = " and family"  main = putStrLn (f "my friends")-