packages feed

fay 0.14.5.0 → 0.24.2.0

raw patch · 531 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ CHANGELOG.md view
@@ -0,0 +1,495 @@+## Changelog++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)++* 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)++* 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)++* 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'])++### 0.18.1 (2013-11-07)++* Add support for TupleSections++#### 0.18.0.5 (2013-10-28)++Bugfixes:+* Disallow unsupported patterns in where/let declarations instead of `<<loop>>`ing on them++Minor:+* Put upper bounds on all dependencies++#### 0.18.0.4 (2013-10-25)++Bugfixes:+* Allow `//` as an operator name (added flag to `hse-cpp`)+* Don't transcode function values when using an EmptyDataDecl++#### 0.18.0.3 (2013-10-23)++Minor:+* Allow `optparse-applicative == 0.7.*`+* Fix `examples/Cont.hs`++#### 0.18.0.2 (2013-10-16)++Bug fixes:+* Regression: Work around a bug in optparse-applicative 0.6 that prevents `--strict` from being used.++#### 0.18.0.1 (2013-10-16)++* Source maps for top level definitions, use `--sourcemap`++Bug fixes:+* Regression: Equality checks for (G)ADTs (`deriving Eq`)+* Fix `--strict` for top level ADT values (such as `module M where g = R`)+* Regression: Serialization in the presence of compression/renaming+* Pass NoImplicitPrelude (and other enabled extensions) to haskell-names to resolve ambiguities when Prelude isn't imported.++Minor:+* Bump optparse-applicative to 0.6.*+* Bump haskell-names to 0.3.1 to allow compilation with Cabal 1.14+* Ignore more declarations (useful when code sharing with GHC)++## 0.18.0.0 (2013-09-24)++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](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.++Bug fixes:+* Don't crash when trying to get the fayToJsFun of an object without constructor.name+* Fixed bug that accidentally flattened list arguments in `jsToFay`+* Fix construction with RecordWildCards not taking already listed fields into account++Breaking Changes:+* Fay.Compiler.Debug has been removed (for now)+* The interactive compilation mode has been removed (for now)++Internal changes:+* Migrated to haskell-src-ext's annotated AST.+* Name resolution is now done using haskell-names, Fay's name resolution code is now pure and a lot simpler.++## 0.17.0.0 (2013-08-27)++* With the `RebindableSyntax` and `OverloadedStrings` extensions Fay will treat Haskell string literals as JavaScript Strings. Add this in all modules and import Fay.Text (from the `fay-text` package). This is *not* a breaking change, without these extensions in a module `String` will be used, as before. All modules can still interoperate normally even if only some of them use this feature. Note that you may have to define `fromInteger` when using this with Num literals.++* The type signature of `Fay.FFI.ffi` (in fay) and `FFI.ffi` (in fay-base) has been generalized to `IsString s => s -> a` to support `RebindableSyntax`.++* Much faster compile time (of the compiler itself) by having the executables depend on the library.++Bugfixes:+* The empty list and unit is now serialized to `null` when using Automatic (it used to throw an error).++Minor:+* Restrict upper bound on `language-ecmascript` to `< 1.0`++#### 0.16.0.3 (2013-08-23)++* Support for tuple constructors (`(,,) 1,2,3`)++Minor:+* Bump `pretty-show` to `>= 1.6`+* Remove the `-fdevel` flag (when compiling fay itself)++#### 0.16.0.2 (2013-08-21)++Minor:+* Bump `haskell-src-exts` to `>= 1.14`++#### 0.16.0.1 (2013-08-08)++Bugfixes:+ * Allow combining multiline strings with CPP++## 0.16.0.0 (2013-08-05)+ * New module generation, modules generate code separately in the format `My.Module.foo` instead of `My$Module$foo`+ * Transcoding information is also produced separately for each module+ * Removed `--naked`, `--dispatcher`, and `--no-dispatcher`. They are probably not needed anymore+ * Removed `Fay$$fayToJsUserDefined` and `Fay$$jsToFayUserDefined`, instead call `Fay$$fayToJs` and `Fay$$jsToFay` respectively+ * Escape semi reserved words from `Object` when printing (`constructor` -> `$constructor`). This only matters if you call Fay from JS+ * `Automatic` now handles lists and tuples (#251)+ * `Language.Fay.FFI` renamed to `Fay.FFI` (as before, Fay code can import `FFI` from `fay-base`)++Minor:+ * Print location of parse errors+ * Compile with -XNoImplicitPrelude+ * Support for testing nested modules (module A, module A.B)+ * Bump `language-ecmascript to >= 0.15` (new API)+ * Rename/remove some CompileErrors+ * All tests are now included in dist++Bug fixes:+ * Force cars in string serialization (#306)++## 0.15.0.0 (2013-06-08)+ * Expression level FFI calls, `ffi "alert('hello!')" :: Fay ()`+ * Support let pattern matches+ * Smaller output for serialization code+ * --base-path flag to use a custom base (mainly for fay-prim)+ * Allow ExistentialQuantification, FlexibleContexts, FlexibleInstances, KindSignatures+ * Verify that GADTs using non-record syntax works+ * JS->Fay function serialization+ * Serialization support for `()`, tuples and `Char`+ * Add more reserved words for Google Closure++Bugfixes:+ * Fix a bug when an imported module contains types+ * Fix a bug with EModuleContents exports+ * Fix where clause inside pattern guards in function definitions+ * Fix type variables in serialization for multiple constructors+ * Fix EThingAll exports for types with constructors with a different name+ * Don't export types in EThingAll and EThingWith+++### 0.14.5.0 (2013-04-24)+* Support for newtypes (with no runtime cost!)+* --base-path flag to specify custom locations for fay-base+* Fix a bug where imports shadowing local bindings would prevent the local binding from being exported+++### 0.14.4.0 (2013-04-21)+* Fix record updates on IE <= 8+* Import tweaks, will make compilation a lot faster (4x reported) when there are a lot of imports+* Parse hs sources with base fixities
+ README.md view
@@ -0,0 +1,7 @@+# Fay programming language++[![Build Status](https://secure.travis-ci.org/faylang/fay.png?branch=master)](http://travis-ci.org/faylang/fay)++We use the Github wiki for our home page and documentation: https://github.com/faylang/fay/wiki++[Changelog](CHANGELOG.md)
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/CodeWorld.hs view
@@ -0,0 +1,469 @@+{-+    (By Chris Smith)+    Reimplementation of gloss (minus bitmaps) in terms of Fay.  This is a proof+    of concept that Fay is in a state where it can support use cases like+    gloss-web on the client.++    TODO:+    - Fix the problem with unary negation+    - Implement support for events and game mode++    To try it out, skip the boilerplate section at the top; in the final+    implementation, it will eventually be moved to a different module and+    imported.  Change the definition of go to one of drawIt, animateIt, or+    simulateIt to try the various modes.+-}++{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE EmptyDataDecls    #-}++module CodeWorld where++import Prelude+import FFI+++data Element++getElementById :: String -> Fay Element+getElementById = ffi "document['getElementById'](%1)"++focusElement :: Element -> Fay ()+focusElement = ffi "%1.focus()"++data Event++addEventListener :: String -> Bool -> (Event -> Fay Bool) -> Fay ()+addEventListener = ffi "window['addEventListener'](%1,%3,%2)"++--getEventKeyCode :: Event -> Fay String+--getEventKeyCode = ffi "%1['keyCode']"++getEventMouseButton :: Event -> Fay Int+getEventMouseButton = ffi "%1['button']"++data Timer++setInterval :: Double -> Fay () -> Fay Timer+setInterval = ffi "window['setInterval'](%2,%1)"++data Ref a++newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"++currentTimeMillis :: Fay Double+currentTimeMillis = ffi "(Date.now?Date.now():new Date().getTime())"++data Context++getContext :: Element -> String -> Fay Context+getContext = ffi "%1['getContext'](%2)"++clearRect :: Context -> Double -> Double -> Double -> Double -> Fay ()+clearRect = ffi "%1['clearRect'](%2,%3,%4,%5)"++save :: Context -> Fay ()+save = ffi "%1['save']()"++restore :: Context -> Fay ()+restore = ffi "%1['restore']()"++canvasTranslate :: Context -> Double -> Double -> Fay ()+canvasTranslate = ffi "%1['translate'](%2,%3)"++canvasScale :: Context -> Double -> Double -> Fay ()+canvasScale = ffi "%1['scale'](%2,%3)"++transform :: Context+          -> Double -> Double -> Double -> Double -> Double -> Double+          -> Fay ()+transform = ffi "%1['transform'](%2,%3,%4,%5,%6,%7)"++setTextAlign :: Context -> String -> Fay ()+setTextAlign = ffi "%1['textAlign']=%2"++setTextBaseline :: Context -> String -> Fay ()+setTextBaseline = ffi "%1['textBaseline']=%2"++setLineWidth :: Context -> Double -> Fay ()+setLineWidth = ffi "%1['lineWidth']=%2"++setFont :: Context -> String -> Fay ()+setFont = ffi "%1['font']=%2"++setStrokeStyle :: Context -> String -> Fay ()+setStrokeStyle = ffi "%1['strokeStyle']=%2"++setFillStyle :: Context -> String -> Fay ()+setFillStyle = ffi "%1['fillStyle']=%2"++beginPath :: Context -> Fay ()+beginPath = ffi "%1['beginPath']()"++closePath :: Context -> Fay ()+closePath = ffi "%1['closePath']()"++fill :: Context -> Fay ()+fill = ffi "%1['fill']()"++stroke :: Context -> Fay ()+stroke = ffi "%1['stroke']()"++fillText :: Context ->String -> Double -> Double -> Fay ()+fillText = ffi "%1['fillText'](%2,%3,%4)"++moveTo :: Context -> Double -> Double -> Fay ()+moveTo = ffi "%1['moveTo'](%2,%3)"++lineTo :: Context -> Double -> Double -> Fay ()+lineTo = ffi "%1['lineTo'](%2,%3)"++canvasArc :: Context -> Double -> Double -> Double -> Double -> Double -> Bool -> Fay ()+canvasArc = ffi "%1['arc'](%2,%3,%4,%5,%6,%7)"++-- Special functions defined in codeworld.js++getSpecialKey :: Event -> Fay String+getSpecialKey = ffi "window.getSpecialKey(%1)"++getPressedKey :: Event -> Fay String+getPressedKey = ffi "window.getPressedKey(%1)"++getReleasedKey :: Event -> Fay String+getReleasedKey = ffi "window.getReleasedKey(%1)"++stopEvent :: Event -> Fay ()+stopEvent = ffi "window.stopEvent(%1)"++mouseToElementX :: Event -> Fay Double+mouseToElementX = ffi "window.mouseToElementX(%1)"++mouseToElementY :: Event -> Fay Double+mouseToElementY = ffi "window.mouseToElementY(%1)"++type Transform = (Double, Double, Double, Double, Double, Double)++translateTransform :: Double -> Double -> Transform -> Transform+translateTransform x y (a,b,c,d,e,f) =+    (a, b, c, d, a * x + c * y + e, b * x + d * y + f)++scaleTransform :: Double -> Double -> Transform -> Transform+scaleTransform x y (a,b,c,d,e,f) =+    (x*a, x*b, y*c, y*d, e, f)++rotateTransform :: Double -> Transform -> Transform+rotateTransform r (a,b,c,d,e,f) = let th = r * pi / 180 in+    (a * cos th + c * sin th,+     b * cos th + d * sin th,+     c * cos th - a * sin th,+     d * cos th - b * sin th,+     e, f)++withTransform :: Context -> Transform -> Fay () -> Fay ()+withTransform ctx (a,b,c,d,e,f) action = do+    save ctx+    transform ctx a b c d e f+    beginPath ctx+    action+    restore ctx++data Color = RGBA Double Double Double Double++white, black :: Color+white = RGBA 1 1 1 1+black = RGBA 0 0 0 1++red, green, blue, cyan, magenta, yellow :: Color+red        = RGBA 1 0 0 1+green      = RGBA 0 1 0 1+blue       = RGBA 0 0 1 1+yellow     = RGBA 1 1 0 1+cyan       = RGBA 0 1 1 1+magenta    = RGBA 1 0 1 1++orange, rose, chartreuse, aquamarine, violet, azure :: Color+orange     = RGBA 1.0 0.5 0.0 1+rose       = RGBA 1.0 0.0 0.5 1+chartreuse = RGBA 0.5 1.0 0.0 1+aquamarine = RGBA 0.0 1.0 0.5 1+violet     = RGBA 0.5 0.0 1.0 1+azure      = RGBA 0.0 0.5 1.0 1++light :: Color -> Color+light (RGBA r g b a) = RGBA+    (min 1 (r + 0.2))+    (min 1 (g + 0.2))+    (min 1 (b + 0.2))+    a++dark :: Color -> Color+dark (RGBA r g b a) = RGBA+    (max 0 (r - 0.2))+    (max 0 (g - 0.2))+    (max 0 (b - 0.2))+    a++gray, grey :: Double -> Color+gray = grey+grey k = RGBA k k k 1++type Point = (Double, Double)+type Vector = Point++data Picture = Polygon [Point]+             | Line [Point]+             | ThickArc Double Double Double Double+             | Text String+             | Color Color Picture+             | Translate Double Double Picture+             | Scale Double Double Picture+             | Rotate Double Picture+             | Pictures [Picture]++blank :: Picture+blank = Pictures []++polygon :: [Point] -> Picture+polygon = Polygon++line :: [Point] -> Picture+line = Line++thickArc :: Double -> Double -> Double -> Double -> Picture+thickArc = ThickArc++arc :: Double -> Double -> Double -> Picture+arc b e r = thickArc b e r 0++circle :: Double -> Picture+circle = arc 0 360++circleSolid :: Double -> Picture+circleSolid r = thickCircle (r/2) r++thickCircle :: Double -> Double -> Picture+thickCircle = thickArc 0 360++text :: String -> Picture+text = Text++color :: Color -> Picture -> Picture+color = Color++translate :: Double -> Double -> Picture -> Picture+translate = Translate++scale :: Double -> Double -> Picture -> Picture+scale = Scale++rotate :: Double -> Picture -> Picture+rotate = Rotate++pictures :: [Picture] -> Picture+pictures = Pictures++rectangleSolid :: Double -> Double -> Picture+rectangleSolid w h = polygon [+    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2)+    ]++rectangleWire :: Double -> Double -> Picture+rectangleWire w h = line [+    (0-w/2, 0-h/2), (w/2, 0-h/2), (w/2, h/2), (0-w/2, h/2), (0-w/2, 0-h/2)+    ]++pathFromPoints :: Context -> [Point] -> Fay ()+pathFromPoints _   [] = return ()+pathFromPoints ctx ((sx,sy):ps) = do+    moveTo ctx sx sy+    forM_ ps $ \(x,y) -> lineTo ctx x y++drawPicture :: Context -> Transform -> Picture -> Fay ()+drawPicture ctx t (Polygon ps) = do+    withTransform ctx t $ pathFromPoints ctx ps+    fill ctx++drawPicture ctx t (Line ps) = do+    withTransform ctx t $ pathFromPoints ctx ps+    stroke ctx++drawPicture ctx t (ThickArc b e r w) = do+    save ctx+    withTransform ctx t $ do+        when (r > 0) $ canvasArc ctx 0 0 r (b*pi/180) (e*pi/180) False+        closePath ctx+    when (w > 0) $ setLineWidth ctx w+    stroke ctx+    restore ctx++drawPicture ctx t (Text txt) =+    withTransform ctx t $ do+        canvasScale ctx 1 (0-1)+        fillText ctx txt 0 0++drawPicture ctx t (Color (RGBA r g b a) p) = do+    let str = "rgba(" ++ show (r * 100) ++ "%,"+                      ++ show (g * 100) ++ "%,"+                      ++ show (b * 100) ++ "%,"+                      ++ show a ++ ")"+    save ctx+    setStrokeStyle ctx str+    setFillStyle ctx str+    drawPicture ctx t p+    restore ctx++drawPicture ctx t (Translate x y p) = drawPicture ctx (translateTransform x y t) p+drawPicture ctx t (Scale x y p)     = drawPicture ctx (scaleTransform x y t) p+drawPicture ctx t (Rotate r p)      = drawPicture ctx (rotateTransform r t) p+drawPicture ctx t (Pictures ps)     = mapM_ (drawPicture ctx t) ps++withCanvas :: (Element -> Context -> Fay ()) -> Fay ()+withCanvas go = addEventListener "load" False $ const $ do+    canvas <- getElementById "canvas"+    ctx    <- getContext canvas "2d"+    go canvas ctx+    return False++drawOn :: Context -> Picture -> Fay ()+drawOn ctx pic = do+    clearRect ctx 0 0 500 500+    save ctx+    canvasTranslate ctx 250 250+    canvasScale ctx 1 (0-1)+    setTextAlign ctx "left"+    setTextBaseline ctx "alphabetic"+    setLineWidth ctx 0+    setFont ctx "100px Times Roman"+    drawPicture ctx (1,0,0,1,0,0) pic+    restore ctx++displayInCanvas :: Picture -> Fay ()+displayInCanvas pic = withCanvas $ \ canvas ctx -> drawOn ctx pic++animateInCanvas :: (Double -> Picture) -> Fay ()+animateInCanvas anim = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    setInterval 30 $ do+        currentTime <- currentTimeMillis+        let t = (currentTime - startTime) / 1000+        drawOn ctx (anim t)+    return ()++data SimState a = SimState a++withSimState :: (a -> a) -> Ref (SimState a) -> Fay a+withSimState f ref = do+    SimState val <- readRef ref+    let newVal = f val+    writeRef ref (SimState newVal)+    return newVal++-- XXX: This is a hack to pretend to have a decent purely functional+-- random number generator.  It should be replaced by a correct+-- implementation as soon as possible.++unsafeRand :: Double -> Double -> Double+unsafeRand = ffi "Math.random()*%2+%1"++data StdGen = StdGen++newStdGen :: Fay StdGen+newStdGen = return StdGen++splitR :: StdGen -> (StdGen, StdGen)+splitR g = (g, g)++randomR :: (Double, Double) -> StdGen -> (Double, StdGen)+randomR (lo, hi) g = (unsafeRand lo (hi - lo), g)++simulateInCanvas :: (StdGen -> a)+                 -> (Double -> a -> a)+                 -> (a -> Picture)+                 -> Fay ()+simulateInCanvas i s d = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    g <- newStdGen+    valueRef <- newRef (SimState (i g))+    timeRef <- newRef startTime+    setInterval 30 $ do+        lastTime     <- readRef timeRef+        currentTime  <- currentTimeMillis+        let dt     = (currentTime - lastTime) / 1000+        val <- withSimState (s dt) valueRef+        writeRef timeRef currentTime+        drawOn ctx (d val)+    return ()++data GameEvent = KeyPressEvent String+               | KeyReleaseEvent String+               | MousePressEvent Int Point+               | MouseReleaseEvent Int Point+               | MouseMoveEvent Point+  deriving Show+playInCanvas :: (StdGen -> a)+             -> (Double -> a -> a)+             -> (GameEvent -> a -> a)+             -> (a -> Picture)+             -> Fay ()+playInCanvas i s e d = withCanvas $ \ canvas ctx -> do+    startTime <- currentTimeMillis+    g <- newStdGen+    valueRef <- newRef (SimState (i g))+    timeRef <- newRef startTime+    addEventListener "keydown" False $ \ev -> do+        k <- getSpecialKey ev+        if k == "None" then return True else do+            withSimState (e (KeyPressEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "keypress" False $ \ev -> do+        k <- getPressedKey ev+        if k == "None" then return True else do+            withSimState (e (KeyPressEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "keyup" False $ \ev -> do+        k <- getReleasedKey ev+        if k == "None" then return True else do+            withSimState (e (KeyReleaseEvent k)) valueRef+            stopEvent ev+            return False+    addEventListener "mousedown" False $ \ev -> do+        focusElement canvas+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            b <- getEventMouseButton ev+            withSimState (e (MousePressEvent b (x,y))) valueRef+            stopEvent ev+            return False+    addEventListener "mouseup" False $ \ev -> do+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            b <- getEventMouseButton ev+            withSimState (e (MouseReleaseEvent b (x,y))) valueRef+            stopEvent ev+            return False+    addEventListener "mousemove" False $ \ev -> do+        x <- mouseToElementX ev+        y <- mouseToElementY ev+        if abs x > 250 || abs y > 250 then return True else do+            withSimState (e (MouseMoveEvent (x,y))) valueRef+            stopEvent ev+            return False+    setInterval 30 $ do+        lastTime     <- readRef timeRef+        currentTime  <- currentTimeMillis+        let dt     = (currentTime - lastTime) / 1000+        val <- withSimState (s dt) valueRef+        writeRef timeRef currentTime+        drawOn ctx (d val)+    return ()
+ examples/CodeWorldMain.hs view
@@ -0,0 +1,134 @@+-- By Chris Smith++{-# LANGUAGE NoImplicitPrelude #-}++module MyDrawing where++import Prelude+import FFI+import CodeWorld++main = playInCanvas initial step event draw++data World = World {+    stars     :: [(Double, Double, Double)],+    asts      :: [(Point, Vector)],+    ship      :: (Point, Vector),+    direction :: Double,+    left      :: Double,+    right     :: Double,+    thrust    :: Double,+    energy    :: Double,+    score     :: Double,+    lastScore :: Double,+    maxScore  :: Double,+    savedGen  :: StdGen+    }++initial g = initialWith 0 0 g++initialWith m l g0 =+  case splitR g0 of+    (genStars, g1) -> case splitR g1 of+      (genAsts,  g2) ->+        World {+            stars     = take 40 (makeStars genStars),+            asts      = take 20 (makeAsts  genAsts),+            ship      = ((0,0), (0,0)),+            direction = 0,+            left      = 0,+            right     = 0,+            thrust    = 0,+            energy    = 1,+            score     = 0,+            maxScore  = m,+            lastScore = l,+            savedGen  = g2+            }++makeStars g0 = case randomR (-250, 250) g0 of+  (x, g1) -> case randomR (-250, 250) g1 of+    (y, g2) -> case randomR (   1,   3) g2 of+      (r, g3) -> (x,y,r) : makeStars g3++makeAsts  g0 = case randomR (-250, 250) g0 of+  (x,  g1) -> case randomR (-250, 250) g1 of+    (y,  g2) -> case randomR ( -30,  30) g2 of+      (vx, g3) -> case randomR ( -30,  30) g3 of+        (vy, g4) -> ((x,y), (vx, vy)) : makeAsts g4++effective w x | energy w > 0 = x w+              | otherwise    = 0++lost w = any (collision (ship w)) (asts w)+    where collision ((x1,y1),_) ((x2,y2),_) = (((x2-x1)^2::Double) + ((y2-y1)^2::Double)) < 1764++step dt w = if lost w+    then initialWith (maxScore w) (if score w < 1 then lastScore w else score w) (savedGen w)+    else w {+        asts      = map (stepBody dt) (asts w),+        ship      = stepThrust dt (stepBody dt (ship w)) (effective w thrust) (direction w),+        direction = stepDir    dt (direction w) (left w) (right w),+        energy    = fence 0 1 (energy w + dt * (0.5 * (1 - thrust w) - 1.0 * thrust w)),+        score     = score w + dt,+        maxScore  = max (maxScore w) (score w)+        }++fence lo hi v = max 0 (min hi v)++stepThrust dt ((x,y), (sx,sy)) th dir = ((x,y), (sx', sy'))+    where sx' = sx + th * (-30) * sin (dir * pi / 180) * dt+          sy' = sy + th *   30  * cos (dir * pi / 180) * dt++stepDir dt dir l r = dir + l * 90 * dt - r * 90 * dt++stepBody dt ((x,y),(sx,sy)) = ((wrap (x + sx * dt), wrap (y + sy * dt)), (sx, sy))+  where wrap k | k <= (-300) = k + 600+               | k >=   300  = k - 600+               | otherwise   = k++draw w = pictures [+    rectangleSolid 500 500,+    drawStars (stars w),+    drawAsts (asts w),+    drawShip (ship w) (direction w) (effective w thrust),+    drawEnergyBar (energy w),+    drawScoreBar (score w) (lastScore w) (maxScore w)+    ]++drawStars ss = pictures [+    color (gray 0.5) (translate x y (circleSolid r ))+        | (x,y,r)   <- ss+    ]++drawAsts  as = pictures [+    color (light red) (translate x y (circleSolid 30))+        | ((x,y),_) <- as+    ]++drawShip ((x,y),_) dir th = translate x y (rotate dir (pictures [+    color (gray 0.2) (circle 12),+    color cyan   (polygon [(-9, -8), (9, -8), ( 0, 12) ]),+    if th > 0 then color orange (polygon [( -8, -8), (-10, -11), (10, -11), (8, -8)])+              else blank+    ]))++drawEnergyBar e = color yellow $ translate 0 (-230) $ rectangleSolid (400 * e) 15++drawScoreBar s l m = pictures [+  color blue $ translate 0 230 $ rectangleSolid 500 15,+  color white $ translate (-200) 225 $ scale 0.2 0.15 $ text $ "Score: " ++ fmtScore s,+  color white $ translate ( -25) 225 $ scale 0.2 0.15 $ text $ "Last: " ++ fmtScore l,+  color white $ translate ( 150) 225 $ scale 0.2 0.15 $ text $ "Max: " ++ fmtScore m+  ]++fmtScore :: Double -> String+fmtScore s = show (floor (10 * s))++event (KeyPressEvent   "Up")    w = w { thrust = 1 }+event (KeyReleaseEvent "Up")    w = w { thrust = 0 }+event (KeyPressEvent   "Left")  w = w { left   = 1 }+event (KeyReleaseEvent "Left")  w = w { left   = 0 }+event (KeyPressEvent   "Right") w = w { right  = 1 }+event (KeyReleaseEvent "Right") w = w { right  = 0 }+event _                         w = w
+ examples/Cont.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NoImplicitPrelude #-}++-- | An example implementation of the lovely continuation monad.++module Cont where++import FFI+import Prelude++--------------------------------------------------------------------------------+-- Entry point.++-- | Main entry point.+main :: Fay ()+main = runContT demo (const (return ()))++demo :: Deferred ()+demo = case contT of+  CC return (>>=) (>>) callCC lift -> do+    lift (putStrLn "Hello!")+    sync setTimeout 500+    contents <- sync readFile "README.md"+    lift (putStrLn ("File contents is: " ++ take 10 contents ++ "..."))++--------------------------------------------------------------------------------+-- Deferred library.++-- | An example deferred monad.+type Deferred a = ContT () Fay a++-- | Set an asynchronous timeout.+setTimeout :: Int -> (() -> Fay ()) -> Fay ()+setTimeout = ffi "global.setTimeout(%2,%1)"++readFile :: String -> (String -> Fay b) -> Fay b+readFile = ffi "require('fs').readFile(%1,'utf-8',function(_,s){ %2(s); })"++sync :: (t -> (a -> Fay r) -> Fay r) -> t -> ContT r Fay a+sync m a = ContT $ \c -> m a c++--------------------------------------------------------------------------------+-- Continuation library.++-- | The continuation monad.+data ContT r m a = ContT { runContT :: (a -> m r) -> m r }+class Monad (m :: * -> *)+instance (Monad m) => Monad (ContT r m)++data CC = CC+  { cc_return :: forall a r. a -> ContT r Fay a+  , cc_bind :: forall a b r. ContT r Fay a -> (a -> ContT r Fay b) -> ContT r Fay b+  , cc_then :: forall a b r. ContT r Fay a -> ContT r Fay b -> ContT r Fay b+  , cc_callCC :: forall a b r. ((a -> ContT r Fay b) -> ContT r Fay a) -> ContT r Fay a+  , cc_lift :: forall a r. Fay a -> ContT r Fay a+  }++-- | The continuation monad module.+contT =+  let return a = ContT (\f -> f a)+      m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)+      m >> n = m >>= \_ -> n+      callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c+      lift m = ContT (\x -> m >>=* x)+  in CC return (>>=) (>>) callCC lift where (>>=*) = (>>=)
+ 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/FayFromJs.hs view
@@ -0,0 +1,16 @@+-- | Compile with `fay examples/FayFromJs.hs --strict FayFromJs`++module FayFromJs where++import           Prelude++data Vector = Vector { x :: Double , y :: Double }++aVector :: Vector+aVector = Vector 1 2++len :: Vector -> Double+len (Vector a b) = sqrt (a^^2 + b^^2)++add :: Vector -> Vector -> Vector+add (Vector a b) (Vector c d) = Vector (a+c) (b+d)
+ examples/FayFromJs.html view
@@ -0,0 +1,36 @@+<!doctype html>+<html>+  <head>+    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>++    <script type="text/javascript" src="FayFromJs.js"></script>+    </script>+    <script>+      function print(label, v)+      {+        var div = document.createElement("div");+        div.innerHTML = label + JSON.stringify(v);+        document.body.appendChild(div);+      }++      window.onload = function () {+        var V = Strict.FayFromJs;+        // Constant+        print("aVector = ", V.aVector);+        // Simple function calls+        print("|aVector| = ", V.len(V.aVector));+        // Arguments are deserialized from JSON using Automatic.+        print("|[10, 20]| = ", V.len({ instance : "Vector", x : 10, y : 20 }));+        // Call with uncurried arguments+        // Return values are serialized to the JSON format using Automatic.+        print( "aVector + [10, 20] = "+             , V.add(V.aVector, { instance : "Vector", x : 10, y : 20 }));+        // Curried call is also fine+        print( "aVector + [10, 20] = "+             , V.add(V.aVector)({ instance : "Vector", x : 10, y : 20 }));+      };+    </script>+  </head>+  <body>+  </body>+</html>
+ examples/Separated.hs view
@@ -0,0 +1,18 @@+-- $ fay --print-runtime > examples/separated-rts.js+-- $ fay --include examples --stdlib --no-dispatcher --naked --no-ghc --no-rts --pretty examples/Separated.hs -o examples/separated-stdlib.js+-- $ fay --include examples --no-stdlib --dispatcher --naked --no-ghc --no-rts --pretty examples/Separated.hs -o examples/separated-dispatcher.js+-- $ fay --include examples --no-stdlib --no-dispatcher --no-ghc --no-rts --naked --pretty examples/Y.hs -o examples/separated-y.js+-- $ fay --include examples --no-stdlib --no-dispatcher --no-ghc --no-rts --naked --pretty examples/X.hs -o examples/separated-x.js+-- $ (cat examples/separated-rts.js; cat examples/separated-stdlib.js; cat examples/separated-dispatcher.js; cat examples/separated-y.js; echo 'Fay$$_(Y$main)') | node+-- { instance: 'Bar', slot1: [ 1, 2, 3 ], slot2: 'Hello, Bar!' }+-- $ (cat examples/separated-rts.js; cat examples/separated-stdlib.js; cat examples/separated-dispatcher.js; cat examples/separated-x.js; echo 'Fay$$_(X$main)') | node+-- { instance: 'Foo', slot1: [ 1, 2, 3 ], slot2: 'Hello, Foo!' }+-- $++module Separated where++import FFI+import Prelude++import X+import Y
+ examples/X.hs view
@@ -0,0 +1,13 @@+module X where++import FFI+import Prelude++data Foo = Foo [Int] String++printFoo :: Foo -> Fay ()+printFoo = ffi "console.log(%1)"++fooGo = printFoo (Foo [1,2,3] "Hello, Foo!")++main = fooGo
+ examples/Y.hs view
@@ -0,0 +1,13 @@+module Y where++import FFI+import Prelude++data Bar = Bar [Int] String++printBar :: Bar -> Fay ()+printBar = ffi "console.log(%1)"++barGo = printBar (Bar [1,2,3] "Hello, Bar!")++main = barGo
+ examples/alert.html view
@@ -0,0 +1,8 @@+<html>+  <head>+    <title></title>+    <script src="alert.js"></script>+  </head>+  <body>+  </body>+</html>
+ examples/calc.hs view
@@ -0,0 +1,124 @@+-- | Calculator based on http://trelford.com/PitCalculatorApp.htm+--+-- Compile with+-- $ fay -p --html-wrapper --html-js-lib jquery.min.js examples/calc.hs+-- You also need to download jquery.min.js.+--++{-# OPTIONS -fno-warn-orphans -fno-warn-type-defaults -fno-warn-unused-do-bind #-}+{-# LANGUAGE EmptyDataDecls #-}++module Calc (main) where++import           FFI+import           Prelude++main :: Fay ()+main = do+  display <- select "<input type='text' value='' style='text-align:right'>"+  operation <- newRef Nothing :: Fay (Ref (Maybe (Double -> Double)))+  appendMore <- newRef False++  let buttons =+        [[enter 7, enter 8, enter 9, ("/",operator (/))]+        ,[enter 4, enter 5, enter 6, ("*",operator (*))]+        ,[enter 1, enter 2, enter 3, ("-",operator (-))]+        ,[("C",clear), enter 0, ("=",calculate), ("+",operator (+))]]+      enter :: Double -> (String,Fay ())+      enter n = (show n,do current <- getVal display+                           addit <- readRef appendMore+                           if addit+                              then do setVal (current ++ show n) display+                                      return ()+                              else do setVal (show n) display+                                      writeRef appendMore True)+      getInput = getVal display >>= (return . parseDouble)+      operator op = do+        calculate+        num <- getInput+        writeRef operation (Just (op num))+      clear = do+        setVal "0" display+        writeRef operation Nothing+        calculate+      calculate = do+        op <- readRef operation+        case op of+          Nothing -> return ()+          Just maths -> do+            num <- getInput+            setVal (show (maths num)) display+            return ()+        writeRef operation Nothing+        writeRef appendMore False++  ready $ do+    body <- select "body"+    table <- select "<table></table>" & appendTo body+    dtr <- select "<tr></tr>" & appendTo table+    select "<td colspan='4'></td>" & appendTo dtr & append display+    forM_ buttons $ \row -> do+      tr <- select "<tr></tr>" & appendTo table+      forM_ row $ \(text,action) -> do+        td <- select "<td></td>" & appendTo tr+        select "<input type='button' value='' style='width:32px'>"+              & setVal text+              & appendTo td+              & onClick (do action; return False)++--------------------------------------------------------------------------------+-- JQuery bindings+-- These are provided in the fay-jquery package.++data JQuery+instance Show JQuery++data Element++-- | Nicer/easier binding for >>=.+(&) :: Fay a -> (a -> Fay b) -> Fay b+x & y = x >>= y+infixl 1 &++getVal :: JQuery -> Fay String+getVal = ffi "%1['val']()"++setVal :: String -> JQuery -> Fay JQuery+setVal = ffi "%2['val'](%1)"++select :: String -> Fay JQuery+select = ffi "window['jQuery'](%1)"++ready :: Fay () -> Fay ()+ready = ffi "window['jQuery'](%1)"++append :: JQuery -> JQuery -> Fay JQuery+append = ffi "%2['append'](%1)"++appendTo :: JQuery -> JQuery -> Fay JQuery+appendTo = ffi "%2['appendTo'](%1)"++onClick :: Fay Bool -> JQuery -> Fay JQuery+onClick = ffi "%2['click'](%1)"++--------------------------------------------------------------------------------+-- Utilities++parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1) || 0"++--------------------------------------------------------------------------------+-- Refs+-- This will be provided in the fay package by default.++data Ref a+instance Show (Ref a)++newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"
+ examples/calc.html view
@@ -0,0 +1,16 @@+<!doctype html>+<html>+  <head>+    <title>Calc</title>+    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+    <script type="text/javascript" src="jquery.min.js"></script>+    <script type="text/javascript" src="calc.js"></script>+    </script>+  </head>+  <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="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/codeworld.html view
@@ -0,0 +1,9 @@+<html>+<head>+  <script type="text/javascript" src="codeworld.js"></script>+  <script type="text/javascript" src="CodeWorldMain.js"></script>+</head>+<body>+<canvas id="canvas" style="border: solid black 1px" width="500" height="500"></canvas>+</body>+</html>
+ examples/dom.html view
@@ -0,0 +1,8 @@+<html>+  <head>+    <title></title>+    <script src="dom.js"></script>+  </head>+  <body>+  </body>+</html>
+ examples/jquery.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE EmptyDataDecls    #-}+++module JQuery where++import           FFI+import           Prelude++main :: Fay ()+main = do+  ready $ do+    putStrLn (showDouble 123)+    body <- select "body"+    printArg body+    addClassWith (\i s -> do putStrLn ("i… " ++ showDouble i)+                             putStrLn ("s… " ++ showString s)+                             return "abc")+                 body+    addClassWith (\i s -> do putStrLn ("i… " ++ showDouble i)+                             putStrLn ("s… " ++ showString s)+                             putStrLn (showString ("def: " ++ s))+                             return "foo")+                 body+    printArg body+    return ()++data JQuery+instance Show JQuery++data Element++printArg :: a -> Fay ()+printArg = ffi "console.log(\"%%o\",%1)"++showDouble :: Double -> String+showDouble = ffi "(%1).toString()"++showString :: String -> String+showString = ffi "JSON.stringify(%1)"++select :: String -> Fay JQuery+select = ffi "jQuery(%1)"++addClassWith :: (Double -> String -> Fay String) -> JQuery -> Fay JQuery+addClassWith = ffi "%2.addClass(%1)"++ready :: Fay () -> Fay ()+ready = ffi "jQuery(%1)"
+ examples/jquery.html view
@@ -0,0 +1,10 @@+<html>+  <head>+    <title>jQuery demo</title>+    <meta http-equiv="Content-Type" content="charset=utf-8">+    <script src="jquery.min.js"></script>+    <script src="jquery.js"></script>+  </head>+  <body>+  </body>+</html>
+ examples/json.hs view
@@ -0,0 +1,35 @@+module Console where++import           FFI+import           Prelude+import           Fay.Text++data MyData = MyData  { xVar :: Text, yVar :: Int }++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++-- | Print using console.log.+print' :: String -> Fay ()+print' = ffi "console.log(%1)"++printBool :: Bool -> Fay ()+printBool = ffi "console.log(%1)"++printInt :: Int -> Fay ()+printInt = ffi "console.log(%1)"++toMyData :: String -> Fay MyData+toMyData = ffi "JSON.parse(%1)"++toJSON :: MyData -> Fay String+toJSON = ffi "JSON.stringify(%1)"
+ examples/node.hs view
@@ -0,0 +1,26 @@+-- | Simple example interfacing with node.++{-# LANGUAGE EmptyDataDecls    #-}+++module Test where++import           FFI+import           Prelude++data Sys++data Details+instance Show Details++main = do+  sys <- require' "sys"+  npm <- require' "npm"+  details <- inspect sys npm+  print $ details++require' :: String -> Fay Sys+require' = ffi "require(%1)"++inspect :: Sys -> Automatic a -> Fay Details+inspect = ffi "%1.inspect(%2)"
+ examples/nqueens.hs view
@@ -0,0 +1,44 @@+++-- !!! count the number of solutions to the "n queens" problem.++module NQueens where++import Prelude+import FFI++main :: Fay ()+main = benchmark $ print (nsoln 11)++listLength :: [a] -> Int -> Int+listLength [] acc = acc+listLength (_:l) acc = listLength l (1 + acc)++listFilter :: (a -> Bool) -> [a] -> [a]+listFilter f [] = []+listFilter f  (a : l)+    | f a       = a : (listFilter f l)+    | otherwise = listFilter f l++nsoln :: Int -> Int+nsoln nq = listLength (gen nq) 0+ where+    safe :: Int -> Int -> [Int] -> Bool+    safe x d []        = True+    safe x d ( q : l) = (x /= q) && (x /= (q+d)) && (x /= (q-d)) && safe x (d+1) l++    gen :: Int -> [[Int]]+    gen 0 =  [] : []+    gen n = concat $ map (\bs -> map (\q ->  q : bs) $ listFilter (\q -> safe q 1 bs) ([1..nq])) (gen (n-1))++benchmark m = do+  start <- getSeconds+  m+  end <- getSeconds+  printS (show (end-start) ++ "ms")++printS :: String -> Fay ()+printS = ffi "console.log(%1)"++getSeconds :: Fay Double+getSeconds = ffi "new Date()"
+ examples/obj.hs view
@@ -0,0 +1,23 @@+++module Print where++import FFI+import Prelude++data Foo = Foo { foo :: Double, bar :: String }++main :: Fay ()+main = do+  callback (Foo 123 "abc")+           (\(Foo n s) -> do printDouble n+                             printString s)++callback :: Foo -> (Foo -> Fay ()) -> Fay ()+callback = ffi "global.callback(%1,%2)"++printDouble :: Double -> Fay ()+printDouble = ffi "console.log(%1)"++printString :: String -> Fay ()+printString = ffi "console.log(%1)"
+ examples/oscillator.hs view
@@ -0,0 +1,610 @@+{-# LANGUAGE EmptyDataDecls    #-}++module RingOscillator (main) where++import FFI++-- System parameters.+--+data Params = Params { alpha :: Double+                     , omega :: Double+                     , deven :: Double+                     , dodd :: Double+                     , beta :: Double+                     , sigma :: Double+                     , nosc :: Int } deriving Show++-- Update functions for system parameters used in the event handlers+-- for the parameter select lists.  Not pretty, but there's not really+-- a nicer way to do it.+--+alphaUpd, omegaUpd :: Params -> Double -> Params+devenUpd, doddUpd :: Params -> Double -> Params+betaUpd, sigmaUpd :: Params -> Double -> Params+noscUpd :: Params -> Int -> Params+alphaUpd p val = p { alpha = val }+omegaUpd p val = p { omega = val }+devenUpd p val = p { deven = val }+doddUpd p val = p { dodd = val }+betaUpd p val = p { beta = val }+sigmaUpd p val = p { sigma = val }+noscUpd p val = p { nosc = val }++-- Need this to be able to make a 'Ref Params'.+--++-- Default values for the system parameters (taken from Bridges &+-- Reich 2001).+--+defaultParams = Params { alpha = 1, omega = 1.8, deven = 0.0075, dodd = 0.0125,+                         beta = 1, sigma = 4, nosc = 5 }+++-- The system state is represented as: [y, x1, ..., xN, y', x1', ..., xN']+-- where y is the position of the external forcing oscillator, x1..xN+-- are the positions of the oscillators in the ring, and y' and+-- x1'..xN' are the time derivatives.  The initial state has some+-- non-zero displacements to get us going and zero velocities.+--+initialState :: Params -> [Double]+initialState p = replicate (nosc p + 1) 1 ++ replicate (nosc p + 1) 0++-- Default initial state.+--+ic = centre defaultParams (initialState defaultParams)++-- Make data storage for scrolling graph view.+--+makeGraphData :: Int -> Int -> Fay (Double,[Buffer])+makeGraphData no size = do+  bufs <- replicateM no (newBuf size)+  return (0,bufs)+++-- Calculate system right hand side, i.e. the equations that determine+-- the time derivative of the system state.+--+rhs :: Params -> [Double] -> [Double]+rhs p state = [dy] ++ dxs ++ [dy'] ++ dxs'+  where n = nosc p++        -- Split system state: Fay doesn't yet allow us to to+        -- something like ((y:xs),(y':xs')) = splitAt (n+1) state, so+        -- we just decompose things manually.+        ss = splitAt (n + 1) state+        sss = fst ss ; sss' = snd ss+        y = head sss ; xs = tail sss+        y' = head sss' ; xs' = tail sss'++        -- Time derivatives of y and the xs are immediately+        -- accessible.+        dy = y' ; dxs = xs'++        -- Forcing system right hand side.+        dy' = 0 - alpha p * (y^2 - 1) * y' - ((omega p)^2::Double) * y++        -- Right hand side for ring oscillators:++        -- Displacement differences.+        xdiffs = (head xs - (xs !! (n - 1))) : zipWith (-) (tail xs) xs++        -- Nonlinear inter-oscillator potential calculation:+        -- V(x) = 1/2 x^2 + 1/4 x^4  =>  V'(x) = x + x^3+        vprime x = x + x^3+        vp = map vprime xdiffs++        -- Differences between adjacent potential values.+        vfacs = zipWith (-) vp (tail vp) ++ [vp !! (n - 1) - head vp]++        -- Damping factors alternate between even and odd numbered+        -- oscillators.+        ds = cycle [dodd p, deven p]++        -- Calculate basic time derivative for each oscillator.+        dxstmp = zipWith3 (\d x' vf -> 0 - d * x' - beta p * vf) ds xs' vfacs++        -- Add forcing term for first oscillator in ring.+        dxs' = (head dxstmp + sigma p * y) : tail dxstmp+++-- Take a single fourth order Runge-Kutta step for an autonomous+-- system.  The arguments are the right hand side function, a system+-- state and a time step.+--+rk4 :: ([Double] -> [Double]) -> [Double] -> Double -> [Double]+rk4 f yn h = zipWith5 (\y a b c d -> y+(a+2*b+2*c+d)/6) yn k1 k2 k3 k4+  where k1 = map mh $ f yn+        k2 = map mh $ f (zipWith (+) yn (map half k1))+        k3 = map mh $ f (zipWith (+) yn (map half k2))+        k4 = map mh $ f (zipWith (+) yn k3)+        mh x = h * x+        half x = 0.5 * x+++-- Because the *velocities* are damped in our model, but not the+-- displacements, there tends to be a more or less linear drift in the+-- average position of the oscillators over time.  This isn't a+-- problem for displaying the positions on the ring, but it's+-- inconvenient for displaying time traces of the positions as a+-- graph.  To make this a bit easier, we centre the oscillator values+-- for graph display by subtracting the mean displacement for the ring+-- oscillators for each ring oscillator.  The forcing displacement and+-- the time derivative values are not affected by this centring, and+-- in fact none of the time derivative calculations for the system are+-- affected either, since they all depend exclusively on *differences*+-- between displacements, not the absolute values of the+-- displacements.+--+centre :: Params -> [Double] -> [Double]+centre p s = [y] ++ xsc ++ [y'] ++ xs'+  where ss = splitAt (nosc p + 1) s+        sss = fst ss ; sss' = snd ss+        y = head sss ; xs = tail sss+        y' = head sss' ; xs' = tail sss'+        m = (sum xs) / fromIntegral (length xs)+        xsc = map (\x->x-m) xs+++-- Display dimensions.+--+ww, wh :: Double                -- Ring canvas dimensions.+ww = 400 ; wh = 400++gww, gwh :: Double              -- Graph canvas dimensions.+gww = 640 ; gwh = 200++-- Other display parameters.+--+dt = 0.025                      -- Integration time step.+framems = 30                    -- Milliseconds between frames.+renderrng = 6.0                 -- Nominal range for graph and ring displays.++-- Sizing for ring view elements.+--+rdotfac, rinner, rdot, fyoff :: Double+rdotfac = 0.0375+rinner = wh / (2 + 7 * rdotfac)+rdot = rdotfac * rinner+fyoff = rinner + 3 * rdot+ctr :: Point+ctr = (0.5 * ww, 5 * rdot + rinner) -- Centre point of ring display.++-- Sizing for graph view elements.+--+gwbuf, ticklen, gwwtime :: Double+gwbuf = 20                      -- Buffer at right end of graph.+ticklen = 10                    -- Graph time tick size.+gwwtime = 10                    -- Time range displayed in graph.+pxpert, pxpersamp :: Double+pxpert = gww / gwwtime          -- Pixels per time unit.+pxpersamp = dt * pxpert         -- Pixels per sample.+nsamp :: Int+nsamp = floor ((gww - gwbuf) / pxpersamp) -- Samples in graph.+++-- Main entry point.  Just register an "onload" handler.+--+main :: Fay ()+main = addWindowEventListener "load" run++-- Main function: runs at load time.+--+run :: Event -> Fay Bool+run _ = do+  -- Get DOM elements and canvas contexts.+  [can,graph] <- mapM getElementById ["canvas","graph"]+  [go,stop,reset] <- mapM getElementById ["go","stop","reset"]+  sels <- mapM getElementById ["alpha","omega","deven","dodd","beta","sigma"]+  noscSel <- getElementById "nosc"+  [c,cg] <- mapM (\c -> getContext c "2d") [can,graph]++  -- Set up references to parameter values, current state, a timer+  -- identifier and the data required for rendering the graph view.+  pref <- newRef defaultParams+  xref <- newRef ic+  timerref <- newRef (Nothing :: Maybe Int)+  gd <- makeGraphData (nosc defaultParams) nsamp+  gdataref <- newRef gd++  -- Render initial ring and graph views.+  render c defaultParams ic renderrng+  renderGraph cg pref gdataref (centre defaultParams ic) renderrng++  -- Event listeners for buttons and parameter value selection.+  addEventListener go "click" $+    doGo timerref (animate c cg pref xref gdataref renderrng) framems+  addEventListener stop "click" $ doStop timerref+  addEventListener reset "click" $ doReset c cg timerref pref xref gdataref sels+  forM_ (zip sels [alphaUpd,omegaUpd,devenUpd,doddUpd,betaUpd,sigmaUpd]) $ \(s, pfn) -> do+    addEventListener s "change" $ doParamChange pref pfn+  addEventListener noscSel "change" $+    doNoscChange c cg timerref pref xref gdataref+  return False+++-- If the simulation isn't currently running (marked by the timer+-- reference being Nothing), start it by causing the animation+-- function to be called at the appropriate interval.+--+doGo :: Ref (Maybe Int) -> Fay () -> Double -> Event -> Fay Bool+doGo tref anim interval _ = do+  oldtimer <- readRef tref+  case oldtimer of+    Nothing -> do+      timer <- setInterval anim interval+      writeRef tref (Just timer)+    Just _ -> return ()+  return False++-- If the simulation is running (marked by the timer reference having+-- a Just value), stop it.+--+doStop :: Ref (Maybe Int) -> Event -> Fay Bool+doStop tref _ = do+  oldtimer <- readRef tref+  case oldtimer of+    Nothing -> return ()+    Just timer -> do+      clearInterval timer+      writeRef tref Nothing+  return False++-- Stop the simulation and set everything back to the state it was at+-- the beginning, including all parameter values (the default values+-- are the middle ones out of five possibilities).+--+doReset :: Context -> Context -> Ref (Maybe Int) -> Ref Params ->+           Ref [Double] -> Ref (Double,[Buffer]) -> [Element] ->+           Event -> Fay Bool+doReset c cg tref pref xref gdataref sels e = do+  doStop tref e+  writeRef pref defaultParams+  writeRef xref ic+  gd <- makeGraphData (nosc defaultParams) nsamp+  writeRef gdataref gd+  render c defaultParams ic renderrng+  renderGraph cg pref gdataref (centre defaultParams ic) renderrng+  forM_ sels $ \s -> setSelectIndex s 2+  return False++-- Simple parameter change: just get the selected value and update the+-- parameter reference.+--+doParamChange :: Ref Params -> (Params -> Double -> Params) -> Event -> Fay Bool+doParamChange pref updfn e = do+  target <- eventTarget e+  sval <- selectValue target+  p <- readRef pref+  writeRef pref (updfn p (parseDouble sval))+  return False++-- A change in number of oscillators is a bit more complicated.  We+-- stop the simulation and reset everything to start over -- there's+-- no obvious way to derive a state with a different number of+-- oscillators from the current state.+--+doNoscChange :: Context -> Context ->+                Ref (Maybe Int) -> Ref Params ->+                Ref [Double] -> Ref (Double,[Buffer]) -> Event -> Fay Bool+doNoscChange c cg timerref pref xref gdataref e = do+  doStop timerref e+  target <- eventTarget e+  sval <- selectValue target+  let newNosc = parseInt sval+  p <- readRef pref+  let pnew = p { nosc = newNosc }+  let xnew = centre pnew (initialState pnew)+  writeRef pref pnew+  writeRef xref xnew+  gd <- makeGraphData newNosc nsamp+  writeRef gdataref gd+  render c pnew xnew renderrng+  renderGraph cg pref gdataref xnew renderrng+  return False+++-- Animation function.  Take a single step of the ODE system and+-- re-render the ring and the graph views.+--+animate :: Context -> Context -> Ref Params -> Ref [Double] ->+           Ref (Double,[Buffer]) -> Double -> Fay ()+animate c cg pref xref gdataref rng = do+  p <- readRef pref+  x <- readRef xref+  let newx = rk4 (rhs p) x dt+  writeRef xref newx+  render c p newx rng+  renderGraph cg pref gdataref (centre p newx) rng+++-- Render the ring view.+--+render :: Context -> Params -> [Double] -> Double -> Fay ()+render c p s rng = do+  -- Extract the forcing and the ring oscillator displacements.+  let f = head s+  let xs = take (nosc p) $ tail s++  -- Draw "furniture": ring and baseline for forcing oscillator.+  clearRect c (0,0) (ww, wh)+  beginPath c+  arc c ctr rinner 0 (2*pi)+  let fscale = rinner * 2 * pi / 5+  moveTo c $ offset ctr (-0.5*fscale,-fyoff)+  lineTo c $ offset ctr (0.5*fscale,-fyoff)+  moveTo c $ offset ctr (0, -dtickin)+  lineTo c $ offset ctr (0, -dtickout)+  setLineWidth c 2+  setStrokeStyle c "grey"+  stroke c++  -- Blobs for ring oscillators: first, forced oscillator is picked+  -- out in blue.+  forM_ [0..(nosc p)-1] (\i -> do+    let th0 = fromIntegral i * 2 * pi / fromIntegral (nosc p)+    let th = th0 + (xs !! i) / rng * 2 * pi / fromIntegral (nosc p)+    let dctr = offset ctr (rinner * sin th, -rinner * cos th)+    beginPath c+    arc c dctr rdot 0 (2*pi)+    setFillStyle c (if i == 0 then "blue" else "red")+    fill c)++  -- Blob for forcing oscillator.+  let dctr = offset ctr (f / rng * fscale, -fyoff)+  beginPath c+  arc c dctr rdot 0 (2*pi)+  setFillStyle c "grey"+  fill c+  where dtickin = fyoff - 0.5 * ticklen+        dtickout = fyoff + 0.5 * ticklen+++-- Render the graph view.+--+renderGraph :: Context -> Ref Params -> Ref (Double,[Buffer]) ->+               [Double] -> Double -> Fay ()+renderGraph cg pref gdataref x rng = do+  -- Get values for parameters and time and state list.+  p <- readRef pref+  (ts,bufs) <- readRef gdataref++  -- Graph "furniture": axes and time ticks.+  setFont cg "10pt sans-serif"+  setStrokeStyle cg "grey"+  setFillStyle cg "grey"+  setLineWidth cg 2+  clearRect cg (0,0) (gww,gwh)+  beginPath cg+  moveTo cg (0,gwh/2)+  lineTo cg (gww,gwh/2)+  moveTo cg (1,0)+  lineTo cg (1,gwh)+  let ticks = takeWhile (\t -> t <= floor (ts + gwwtime)) [floor ts + 1..]+  let tickxs = map (\t -> (fromIntegral t - ts) * pxpert) ticks+  forM_ (zip ticks tickxs) $ \(t,x) -> do+    moveTo cg (x,gwh/2-ticklen/2)+    lineTo cg (x,gwh/2+ticklen/2)+    let txt = show t+    txtw <- measureText cg txt+    fillText cg txt (x-txtw/2,gwh/2+2*ticklen) Nothing+  stroke cg++  -- Add new samples to circular buffers and draw traces: grey for+  -- forcing, blue for forced ring oscillator, red for the other ring+  -- oscillators.+  setLineWidth cg 1+  newbufs <- forM (zip3 x bufs ("grey":"blue":repeat "red")) $ \(newx,buf,col) -> do+    newbuf <- bufAdd buf newx+    beginPath cg+    setStrokeStyle cg col+    y0 <- bufVal newbuf 0+    moveTo cg (0, gwh/2*(1-y0/renderrng))+    when (bufCurSize buf > 1) $ forM_ [1..bufCurSize buf-1] $ \i -> do+      y <- bufVal newbuf i+      lineTo cg (fromIntegral i * pxpersamp, gwh/2*(1-y/renderrng))+    stroke cg+    return newbuf++  -- Update the graph data reference.+  writeRef gdataref (ts+if bufCurSize (head newbufs) < nsamp then 0 else dt,newbufs)+++--------------------------------------------------------------------------------+-- Utilities++zipWith5 :: (a->b->c->d->e->f) -> [a]->[b]->[c]->[d]->[e]->[f]+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 _ _ _ _ _ _ = []++replicateM :: Int -> Fay a -> Fay [a]+replicateM n x = sequence (replicate n x)++parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1)"++parseInt :: String -> Int+parseInt = ffi "parseInt(%1)"++--------------------------------------------------------------------------------+-- DOM++data Element+instance Show Element++type Size = (Int,Int)++getElementById :: String -> Fay Element+getElementById = ffi "document['getElementById'](%1)"++data Event++addWindowEventListener :: String -> (Event -> Fay Bool) -> Fay ()+addWindowEventListener = ffi "window['addEventListener'](%1,%2,false)"++addEventListener :: Element -> String -> (Event -> Fay Bool) -> Fay ()+addEventListener = ffi "%1['addEventListener'](%2,%3,false)"++setInterval :: Fay () -> Double -> Fay Int+setInterval = ffi "window['setInterval'](%1,%2)"++clearInterval :: Int -> Fay ()+clearInterval = ffi "window['clearInterval'](%1)"++print :: a -> Fay ()+print = ffi "console.log(%1)"++eventTarget :: Event -> Fay Element+eventTarget = ffi "%1['target']"++selectValue :: Element -> Fay String+selectValue = ffi "%1[%1['selectedIndex']]['value']"++setSelectIndex :: Element -> Int -> Fay ()+setSelectIndex = ffi "%1['selectedIndex']=%2"++--------------------------------------------------------------------------------+-- Ref++-- | A mutable reference like IORef.+data Ref a++-- | Make a new mutable reference.+newRef :: a -> Fay (Ref a)+newRef = ffi "new Fay$$Ref(%1)"++-- | Replace the value in the mutable reference.+writeRef :: Ref a -> a -> Fay ()+writeRef = ffi "Fay$$writeRef(%1,%2)"++-- | Get the referred value from the mutable value.+readRef :: Ref a -> Fay a+readRef = ffi "Fay$$readRef(%1)"++--------------------------------------------------------------------------------+-- Canvas API++data Context+instance Show Context++type Point = (Double,Double)+type Dim = (Double,Double)++getContext :: Element -> String -> Fay Context+getContext = ffi "%1.getContext(%2)"++offset :: Point -> Dim -> Point+offset (x,y) (dx,dy) = (x+dx,y+dy)++-- Basic attributes++setFillStyle :: Context -> String -> Fay ()+setFillStyle = ffi "%1['fillStyle']=%2"++setFont :: Context -> String -> Fay ()+setFont = ffi "%1['font']=%2"++setLineWidth :: Context -> Double -> Fay ()+setLineWidth = ffi "%1['lineWidth']=%2"++setStrokeStyle :: Context -> String -> Fay ()+setStrokeStyle = ffi "%1['strokeStyle']=%2"++-- Path methods++arc :: Context -> Point -> Double -> Double -> Double -> Fay ()+arc c (x,y) r beg end = arc' c x y r beg end True++arcC :: Context -> Point -> Double -> Double -> Double -> Fay ()+arcC c (x,y) r beg end = arc' c x y r beg end False++arc' :: Context -> Double -> Double -> Double -> Double -> Double ->+        Bool -> Fay ()+arc' = ffi "%1['arc'](%2,%3,%4,%5,%6,%7)"++beginPath :: Context -> Fay ()+beginPath = ffi "%1['beginPath']()"++clip :: Context -> Fay ()+clip = ffi "%1['clip']()"++closePath :: Context -> Fay ()+closePath = ffi "%1['closePath']()"++fill :: Context -> Fay ()+fill = ffi "%1['fill']()"++lineTo :: Context -> Point -> Fay ()+lineTo c (x,y) = lineTo' c x y++lineTo' :: Context -> Double -> Double -> Fay ()+lineTo' = ffi "%1['lineTo'](%2,%3)"++moveTo :: Context -> Point -> Fay ()+moveTo c (x,y) = moveTo' c x y++moveTo' :: Context -> Double -> Double -> Fay ()+moveTo' = ffi "%1['moveTo'](%2,%3)"++stroke :: Context -> Fay ()+stroke = ffi "%1['stroke']()"++-- Rectangles++clearRect :: Context -> Point -> Dim -> Fay ()+clearRect c (x,y) (w,h) = clearRect' c x y w h++clearRect' :: Context -> Double -> Double -> Double -> Double -> Fay ()+clearRect' = ffi "%1['clearRect'](%2,%3,%4,%5)"++-- Text++fillText :: Context -> String -> Point -> Maybe Double -> Fay ()+fillText c s (x,y) Nothing = fillText1 c s x y+fillText c s (x,y) (Just mw) = fillText2 c s x y mw++fillText1 :: Context -> String -> Double -> Double -> Fay ()+fillText1 = ffi "%1['fillText'](%2,%3,%4)"++fillText2 :: Context -> String -> Double -> Double -> Double -> Fay ()+fillText2 = ffi "%1['fillText'](%2,%3,%4,%5)"++measureText :: Context -> String -> Fay Double+measureText = ffi "%1['measureText'](%2)['width']"+++--------------------------------------------------------------------------------+-- Circular buffers++data Array++data Buffer = Buffer { bufSize :: Int+                     , bufCurSize :: Int+                     , bufNext :: Int+                     , bufArr :: Array }++newBuf :: Int -> Fay Buffer+newBuf size = do+  arr <- newArray size+  return $ Buffer size 0 0 arr++bufAdd :: Buffer -> Double -> Fay Buffer+bufAdd (Buffer sz cursz nxt arr) x = do+  let cursz' = if cursz < sz then cursz + 1 else sz+  setArrayVal arr nxt x+  let nxt' = (nxt + 1) `rem` sz+  return $ Buffer sz cursz' nxt' arr++bufVal :: Buffer -> Int -> Fay Double+bufVal (Buffer sz cursz nxt arr) i = do+  let idx = (if cursz < sz then i else nxt + i) `rem` sz+  arrayVal arr idx >>= return++newArray :: Int -> Fay Array+newArray = ffi "new Array(%1)"++setArrayVal :: Array -> Int -> Double -> Fay ()+setArrayVal = ffi "%1[%2]=%3"++arrayVal :: Array -> Int -> Fay Double+arrayVal = ffi "%1[%2]"
+ examples/oscillator.html view
@@ -0,0 +1,92 @@+<!doctype html>+<html>+<head>+  <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+  <script type="text/javascript" src="oscillator.js"></script>+  <style>+    .container { width: 100%; margin-left: 0; margin-right: 0; }+    .animation { display: block; float: left; margin-left: 0; margin-right: 0; }+    .controls { display: block; float: left; margin-left: 10px; margin-right: 0; }+    .graph { display: block; float: left; margin-left: 10px; margin-right: 0; }+    .clear { clear: both; }+    .container .animation { width: 400px; }+    .container .controls { width: 200px; }+    .container .graph { width: 640px; }+  </style>+</head>+<body>+  <h1>Ring oscillator demo</h1>++  <div class="container">+    <div class="animation">+      <canvas id="canvas" width=400 height=400></canvas>+    </div>+    <div class="controls">+      <input id="go" type="button" style="background-image: url(play-icon.png); width: 20px;" value="">+      <input id="stop" type="button" style="background-image: url(stop-icon.png); width: 20px;" value="">+      <input id="reset" type="button" value="Reset">++      <p>N = <select id="nosc">+          <option value="3">3</option>+          <option value="4">4</option>+          <option selected value="5">5</option>+          <option value="6">6</option>+          <option value="10">10</option>+        </select>+      <br>+      &alpha; = <select id="alpha">+          <option value="0.6">0.6</option>+          <option value="0.8">0.8</option>+          <option selected value="1">1</option>+          <option value="1.2">1.2</option>+          <option value="1.4">1.4</option>+        </select>+      <br>+      &omega; = <select id="omega">+          <option value="1.0">1</option>+          <option value="1.4">1.4</option>+          <option selected value="1.8">1.8</option>+          <option value="2.2">2.2</option>+          <option value="2.6">2.6</option>+        </select>+      <br>+      d<sub>even</sub> = <select id="deven">+          <option value="0.0025">0.0025</option>+          <option value="0.005">0.005</option>+          <option selected value="0.0075">0.0075</option>+          <option value="0.01">0.01</option>+          <option value="0.0125">0.0125</option>+        </select>+      <br>+      d<sub>odd</sub> = <select id="dodd">+          <option value="0.0075">0.0075</option>+          <option value="0.01">0.01</option>+          <option selected value="0.0125">0.0125</option>+          <option value="0.015">0.015</option>+          <option value="0.0175">0.0175</option>+        </select>+      <br>+      &beta; = <select id="beta">+          <option value="0.6">0.6</option>+          <option value="0.8">0.8</option>+          <option selected value="1">1</option>+          <option value="1.2">1.2</option>+          <option value="1.4">1.4</option>+        </select>+      <br>+      &sigma; = <select id="sigma">+          <option value="2">2</option>+          <option value="3">3</option>+          <option selected value="4">4</option>+          <option value="5">5</option>+          <option value="6">6</option>+        </select>+      </p>+    </div>+    <div class="clear"></div>+    <div class="graph">+      <canvas id="graph" width=640 height=200></canvas>+    </div>+  </div>+</body>+</html>
+ examples/pat.hs view
@@ -0,0 +1,13 @@+import Prelude++import FFI++main :: Fay ()+main =+      case [1,2] of+        []    -> alert "got []"+        [a]   -> alert "got one value."+        [a,b] -> alert "got two values."++alert :: String -> Fay ()+alert = ffi "console.log(%1)"
+ examples/properties.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE EmptyDataDecls    #-}+++module Dom where++import           FFI+import           Prelude++main :: Fay ()+main = addEventListener "load" updateBody False++updateBody :: Fay ()+updateBody = do+  printList [[1,2,3],[4,5,6]]+  print thebody+  print thewindow+  setInnerHtml thebody "Hai!"+  inner <- getInnerHtml thebody+  print' ("'" ++ inner ++ "'")++printList :: [[Double]] -> Fay ()+printList = ffi "console.log(%1)"++-- | Print using window.print.+print' :: String -> Fay ()+print' = ffi "console['log'](%1)"++addEventListener :: String -> Fay () -> Bool -> Fay ()+addEventListener = ffi "window['addEventListener'](%1,%2,%3)"++setInnerHtml :: Element -> String -> Fay ()+setInnerHtml = ffi "%1['innerHTML']=%2"++getInnerHtml :: Element -> Fay String+getInnerHtml = ffi "%1['innerHTML']"++thebody :: Element+thebody = ffi "document.body"++thewindow :: Element+thewindow = ffi "window"++data Element
+ examples/properties.html view
@@ -0,0 +1,7 @@+<html>+  <head>+    <title></title>+    <script src="properties.js"></script>+  </head>+  <body>Hello!</body>+</html>
+ examples/showExamples.hs view
@@ -0,0 +1,48 @@+import           FFI+import           Prelude++main = do+  let a1 = ("string",1) :: (String,Int)+  putStrLn $ showPair a1+  putStrLn $ showList [1..3]+  putStrLn $ showString "Just a plain string"+  l1 <- readList "[4,5,6]"+  putStrLn . showList . map (1+) $ l1+  (s,i) <- readPair "[\"first\",2]"+  putStrLn $ s ++ " was first and " ++ showInt i ++ " was second"++showInt :: Int -> String+showInt = ffi "JSON.stringify(%1)"++showString :: String -> String+showString = ffi "JSON.stringify(%1)"++showPair :: (String,Int) -> String+showPair = ffi "JSON.stringify(%1)"++showList :: [Int] -> String+showList = ffi "JSON.stringify(%1)"++readList :: String -> Fay [Int]+readList = ffi "JSON.parse(%1)"++readPair :: String -> Fay (String,Int)+readPair = ffi "JSON.parse(%1)"++{-++compile with:+ fay showExamples.hs+run with: (on Debian)+ nodejs showExamples.hs++Produces:++["string",1]+[1,2,3]+"Just a plain string"+[5,6,7]+first was first and 2 was second+++-}
fay.cabal view
@@ -1,5 +1,6 @@+cabal-version:       2.0 name:                fay-version:             0.14.5.0+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,190 +8,217 @@                      .                      /Documentation/                      .-                     See documentation at <http://fay-lang.org/> or build your own documentation with:-                     .-                     > $ cabal unpack fay-                     > $ cd fay-*-                     > $ cabal install-                     > $ cabal install fay-base-                     .+                     See <https://github.com/faylang/fay/wiki>                      .                      /Examples/                      .-                     See <http://fay-lang.org/#examples>.-                     .-                     /Release Notes/-                     * Support for newtypes (with no runtime cost!)-                     .-                     * --base-path flag to specify custom location for fay-base-                     .-                     * Fix a bug where imports shadowing local bindings would prevent the local binding from being exported+                     See the examples directory and <https://github.com/faylang/fay/wiki#fay-in-the-wild>                      .-                     See full history at: <https://github.com/faylang/fay/wiki/Changelog>-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 author:              Chris Done, Adam Bergmark-maintainer:          adam@edea.se+maintainer:          adam@bergmark.nl copyright:           2012 Chris Done, Adam Bergmark-category:            Development+category:            Development, Web, Fay build-type:          Custom-cabal-version:       >=1.8-data-files:          js/runtime.js-                     hs/stdlib.hs-                     src/Language/Fay/FFI.hs-extra-source-files:  examples/ref.hs examples/alert.hs examples/console.hs examples/dom.hs-                     examples/tailrecursive.hs examples/data.hs examples/canvaswater.hs-                     examples/canvaswater.html examples/haskell.png-                     -- Test cases-                     tests/ints.hs tests/ints tests/asPatternMatch-                     tests/caseList.hs tests/Double2.hs-                     tests/fromInteger tests/List.hs tests/RecCon-                     tests/recordPatternMatch tests/String.hs-                     tests/asPatternMatch.hs tests/fromInteger.hs-                     tests/RecCon.hs tests/recordPatternMatch2-                     tests/caseWildcard tests/Double3 tests/Monad-                     tests/recordPatternMatch2.hs tests/tailRecursion-                     tests/basicFunctions tests/caseWildcard.hs-                     tests/Double3.hs tests/Monad2 tests/RecDecl-                     tests/tailRecursion.hs tests/basicFunctions.hs-                     tests/HierarchicalImport tests/Monad2.hs-                     tests/RecDecl.hs tests/recordPatternMatch.hs-                     tests/do tests/Double4 tests/then tests/Bool-                     tests/doAssingPatternMatch tests/Double4.hs-                     tests/HierarchicalImport.hs tests/Monad.hs-                     tests/records tests/then.hs tests/Bool.hs-                     tests/doAssingPatternMatch.hs-                     tests/recordFunctionPatternMatch tests/records.hs-                     tests/Double.hs tests/mutableReference-                     tests/recordFunctionPatternMatch.hs tests/utf8-                     tests/case tests/doBindAssign-                     tests/infixDataConst tests/mutableReference.hs-                     tests/recordUseBeforeDefine tests/utf8.hs-                     tests/case2 tests/doBindAssign.hs tests/emptyMain-                     tests/infixDataConst.hs tests/RecordImport_Export-                     tests/recordUseBeforeDefine.hs tests/case2.hs-                     tests/emptyMain.hs tests/patternGuards-                     tests/RecordImport_Export.hs tests/where-                     tests/do.hs tests/List tests/patternGuards.hs-                     tests/reservedWords tests/where.hs tests/case.hs-                     tests/fix tests/List2 tests/RecordImport_Import-                     tests/reservedWords.hs tests/Double tests/fix.hs-                     tests/List2.hs tests/patternMatchFail.hs-                     tests/RecordImport_Import.hs tests/caseList-                     tests/Double2 tests/String-                     tests/Hierarchical/Export.hs-                     tests/Hierarchical/RecordDefined.hs-                     tests/Api/Records.hs tests/Api/ImportRecords.hs-                     tests/Api/CPPTypecheck.hs-                     tests/serialization.hs tests/serialization+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+  src/haskell-names/LICENSE+  -- Examples+  examples/*.hs+  examples/*.html+  examples/*.png+  -- Test cases+  tests/*.hs+  tests/*.res+  tests/Compile/*.hs+  tests/Compile/*.res+  tests/FromString/*.hs+  tests/FromString/*.res+  tests/Hierarchical/*.hs+  tests/Hierarchical/*.res+  tests/ImportList1/*.hs+  tests/ImportList1/*.res+  tests/ImportType2I/*.hs+  tests/ImportType2I/*.res+  tests/Issue215/*.hs+  tests/Issue215/*.res+  tests/ModuleReExport/*.hs+  tests/ModuleReExport/*.res+  tests/ModuleRecordClash/*.hs+  tests/ModuleRecordClash/*.res+  tests/NestedImporting/*.hs+  tests/NestedImporting/*.res+  tests/NestedImporting2/*.hs+  tests/NestedImporting2/*.res+  tests/QualifiedImport/*.hs+  tests/QualifiedImport/*.res+  tests/ReExportGlobally/*.hs+  tests/ReExportGlobally/*.res  source-repository head   type: git   location: https://github.com/faylang/fay.git -Flag devel-  Description:       Don't build fay-tests if this flag is supplied-  Default:           False+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.Types, Language.Fay.FFI, Fay.Convert, Fay.Compiler, Fay.Compiler.Debug, Fay.Compiler.Config-  other-modules:     Fay.Compiler.Print, Control.Monad.IO, System.Process.Extra, Data.List.Extra, Paths_fay, Fay.Compiler.Misc, Fay.Compiler.FFI, Fay.Compiler.Optimizer, Fay.Compiler.Packages, Fay.Compiler.ModuleScope, Control.Monad.Extra, Fay.Compiler.InitialPass, Fay.Compiler.Decl, Fay.Compiler.Defaults, Fay.Compiler.Exp, Fay.Compiler.Pattern, Fay.Compiler.Typecheck-  ghc-options:       -O2 -Wall -fno-warn-name-shadowing-  build-depends:     base >= 4 && < 5,-                     aeson,-                     attoparsec,-                     containers,-                     data-default,-                     directory,-                     filepath,-                     ghc-paths,-                     Cabal,-                     haskell-src-exts,-                     language-ecmascript >= 0.10,-                     mtl,-                     pretty-show,-                     process,-                     safe,-                     syb,-                     text,-                     unordered-containers,-                     utf8-string,-                     vector+  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 !flag(devel)-    build-depends:-                     -- Requirements for the executables which-                     -- `cabal-dev ghci' needs.-                     HUnit,-                     blaze-html >= 0.5,-                     blaze-markup,-                     bytestring,-                     time,-                     optparse-applicative >= 0.5,-                     split,-                     test-framework,-                     test-framework-hunit,-                     test-framework-th+  if impl(ghc < 7.8)+    build-depends: tagged  executable fay-  hs-source-dirs:    src+  default-language:  Haskell2010                           +  hs-source-dirs:    src/main   ghc-options:       -O2 -Wall-  ghc-prof-options:  -fprof-auto   main-is:           Main.hs-  build-depends:     base >= 4 && < 5,-                     aeson,-                     containers,-                     data-default,-                     directory,-                     filepath,-                     ghc-paths,-                     Cabal,-                     haskell-src-exts,-                     language-ecmascript >= 0.10,-                     mtl,-                     process,-                     safe,-                     syb,-                     utf8-string,--                     haskeline,-                     optparse-applicative >= 0.5,-                     split+  build-depends:+      base+    , fay+    , mtl+    , optparse-applicative >= 0.11 && < 0.16+    , split+  other-modules:+    Paths_fay  executable fay-tests-  if flag(devel)-    buildable:       False-  hs-source-dirs:    src+  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:     Fay.Compiler Test.Convert Test.Api Test.CommandLine Test.Util-  build-depends:     base >= 4 && < 5,-                     aeson,-                     attoparsec,-                     bytestring,-                     containers,-                     data-default,-                     directory,-                     filepath,-                     ghc-paths,-                     Cabal,-                     haskell-src-exts,-                     language-ecmascript >= 0.10,-                     mtl,-                     pretty-show,-                     process,-                     safe,-                     syb,-                     text,-                     unordered-containers,-                     utf8-string,-                     vector,--                     HUnit,-                     test-framework,-                     test-framework-hunit,-                     test-framework-th+  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
− hs/stdlib.hs 
@@ -1,3 +0,0 @@-data Maybe a-  = Just a-  | Nothing
− js/runtime.js 
@@ -1,672 +0,0 @@-// 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();-	};-}--/*******************************************************************************- * 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 ... }-    jsObj = function(){-      return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);-    };--  }-  else if(base == "function") {-    // A proper function.-    jsObj = 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.-        for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {-          // Unserialize the JS values to Fay for the Fay callback.-          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") {-    jsObj = 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);-    }-    jsObj = 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);-    }-    jsObj = arr;--  }-  else if(base == "defined") {-    fayObj = Fay$$_(fayObj);-    if (fayObj instanceof $_Language$Fay$FFI$Undefined) {-      jsObj = undefined;-    } else {-      jsObj = Fay$$fayToJs(args[0],fayObj.slot1);-    }--  }-  else if(base == "nullable") {-    fayObj = Fay$$_(fayObj);-    if (fayObj instanceof $_Language$Fay$FFI$Null) {-      jsObj = null;-    } else {-      jsObj = Fay$$fayToJs(args[0],fayObj.slot1);-    }--  }-  else if(base == "double" || base == "int" || base == "bool") {-    // Bools are unboxed.-    jsObj = Fay$$_(fayObj);--  }-  else if(base == "ptr" || base == "unknown")-    return fayObj;-  else if(base == "automatic" || base == "user") {-    if(fayObj instanceof Fay$$$)-      fayObj = Fay$$_(fayObj);-    jsObj = Fay$$fayToJsUserDefined(type,fayObj);--  }-  else-    throw new Error("Unhandled Fay->JS translation type: " + base);-  return jsObj;-}--// 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 += 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.-    fayObj = new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));--  }-  else if(base == "string") {-    // Unserialize a JS string into Fay list (String).-    fayObj = 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.-    fayObj = 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.-    fayObj = Fay$$list(serializedTuple);--  }-  else if(base == "defined") {-    if (jsObj === undefined) {-      fayObj = new $_Language$Fay$FFI$Undefined();-    } else {-      fayObj = new $_Language$Fay$FFI$Defined(Fay$$jsToFay(args[0],jsObj));-    }--  }-  else if(base == "nullable") {-    if (jsObj === null) {-      fayObj = new $_Language$Fay$FFI$Null();-    } else {-      fayObj = new $_Language$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!";--  }-  else if (base == "double" ||-           base == "bool" ||-           base ==  "ptr" ||-           base ==  "unknown") {-    return jsObj;-  }-  else if(base == "automatic" || base == "user") {-    if (jsObj && jsObj['instance']) {-      fayObj = Fay$$jsToFayUserDefined(type,jsObj);-    }-    else-      fayObj = jsObj;--  }-  else { throw new Error("Unhandled JS->Fay translation type: " + base); }-  return fayObj;-}--/*******************************************************************************- * 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.constructor === lit2.constructor) {-    for(var x in lit1) {-      if(!(lit1.hasOwnProperty(x) && lit2.hasOwnProperty(x) &&-           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/Control/Monad/Extra.hs 
@@ -1,31 +0,0 @@--- | Extra monadic functions.--module 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/Control/Monad/IO.hs 
@@ -1,9 +0,0 @@--- | Alias of MonadIO.--module 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/Data/List/Extra.hs 
@@ -1,14 +0,0 @@--- | Extra list functions.--module 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.hs view
@@ -1,142 +1,157 @@ {-# 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-  ,getRuntime)-   where+  ,readConfigRuntime+  ) where +import           Fay.Compiler.Prelude+ import           Fay.Compiler-import           Fay.Compiler.Misc   (printSrcLoc)+import           Fay.Compiler.Misc                      (ioWarn, printSrcSpanInfo) import           Fay.Compiler.Packages-import           Fay.Compiler.Print+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.List-import qualified Data.Set                     as S+import           Data.Aeson                             (encode)+import qualified Data.ByteString.Lazy                   as L import           Language.Haskell.Exts        (prettyPrint) import           Language.Haskell.Exts.Syntax-import           Paths_fay+import           Language.Haskell.Exts.SrcLoc+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 filein fileout = do-  result <- maybe (compileFile config filein)-                  (compileFromToAndGenerateHtml config filein)-                  fileout-  case result of-    Right out -> maybe (putStrLn out) (flip writeFile out) fileout-    Left err -> error $ showCompileError $ err+compileFromTo :: Config -> FilePath -> Maybe FilePath -> IO ()+compileFromTo cfg filein fileout =+  if configTypecheckOnly cfg+  then do+    cfg' <- resolvePackages cfg+    res <- typecheck cfg' filein+    either (error . showCompileError) (ioWarn cfg') res+  else do+    result <- maybe (compileFile cfg filein)+                      (compileFromToAndGenerateHtml cfg filein)+                      fileout+    case result of+      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)+-- | 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 -> do+  mres <- compileFileWithResult config { configFilePath = Just filein } filein+  case mres of+    Right res -> do       when (configHtmlWrapper config) $         writeFile (replaceExtension fileout "html") $ unlines [             "<!doctype html>"           , "<html>"           , "  <head>"           ,"    <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>"-          , unlines . map ("    "++) . map makeScriptTagSrc $ configHtmlJSLibs config+          , unlines . map (("    "++) . makeScriptTagSrc) $ configHtmlJSLibs config           , "    " ++ makeScriptTagSrc relativeJsPath-          , "    </script>"           , "  </head>"           , "  <body>"           , "  </body>"           , "</html>"]-      return (Right out)++      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 ++ resOutput res else resOutput res)             where relativeJsPath = makeRelative (dropFileName fileout) fileout                   makeScriptTagSrc :: FilePath -> String-                  makeScriptTagSrc = \s ->-                    "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"+                  makeScriptTagSrc s = "<script type=\"text/javascript\" src=\"" ++ s ++ "\"></script>"+                  sourceMapHeader = "//@ sourceMappingURL=" ++ replaceExtension fileout "map" ++ "\n"     Left err -> return (Left err)  -- | Compile the given file.-compileFile :: CompileConfig -> FilePath -> IO (Either CompileError String)-compileFile config filein = do-  either Left (Right . fst) <$> 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,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 <- getRuntime+  raw <- readConfigRuntime config   hscode <- readFile filein-  raw <- readFile runtime   config' <- resolvePackages config-  compileToModule filein config' raw compileToplevelModule hscode+  compileToModule filein config' raw (compileToplevelModule filein) hscode  -- | Compile the given module to a runnable module.-compileToModule :: (Show from,Show to,CompilesTo from to)-                => FilePath-                -> CompileConfig -> String -> (from -> Compile to) -> String-                -> IO (Either CompileError (String,CompileState))+compileToModule :: FilePath+                -> 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 with hscode-  case result of-    Left err -> return (Left err)-    Right (PrintState{..},state,_) ->-      return $ Right $ (generate (concat (reverse psOutput))-                                        (S.toList $ getCurrentExports state)-                                        (stateModuleName state), state)--  where generate | configNaked config = generateNaked-                 | otherwise          = generateWrapped-        generateNaked jscode _exports _module = unlines $-          [if configExportRuntime config then raw else ""-          ,jscode]-        generateWrapped jscode exports (ModuleName (clean -> modulename)) = unlines $ filter (not . null) $-          ["/** @constructor"-          ,"*/"-          ,"var " ++ modulename ++ " = function(){"-          ,if configExportRuntime config then raw else ""-          ,jscode-          ,"// Exports"-          ,unlines (map printExport exports)-          ,"// Built-ins"-          ,"this._ = Fay$$_;"-          ,if configExportBuiltins config-              then unlines ["this.$           = Fay$$$;"-                           ,"this.$fayToJs    = Fay$$fayToJs;"-                           ,"this.$jsToFay    = Fay$$jsToFay;"-                           ]-              else ""-          ,"};"-          ,if not (configLibrary config)-              then unlines [";"-                           ,"var main = new " ++ modulename ++ "();"-                           ,"main._(main." ++ modulename ++ "$main);"-                           ]-              else ""-          ]-        clean ('.':cs) = '$' : clean cs-        clean (c:cs)   = c : clean cs-        clean [] = []---- | Print an this.x = x; export out.-printExport :: QName -> String-printExport name =-  printJSString (JsSetProp JsThis-                           (JsNameVar name)-                           (JsName (JsNameVar name)))+  return $ case result of+    Left err -> Left err+    Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) ->+      Right ( pwOutputString pw+            , if null (pwMappings pw) then Nothing else Just (pwMappings pw)+            , state+            )+      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@@ -144,44 +159,56 @@   ('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-  ParseError _ err -> err-  UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d-  UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es-  UnsupportedMatchSyntax m -> "unsupported match/binding syntax: " ++ prettyPrint m-  UnsupportedWhereInMatch m -> "unsupported `where' syntax: " ++ prettyPrint m-  UnsupportedWhereInAlt alt -> "`where' not supported here: " ++ prettyPrint alt-  UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr-  UnsupportedQualStmt stmt -> "unsupported list qualifier: " ++ prettyPrint stmt-  UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit-  UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d-  UnsupportedOperator qop -> "unsupported operator syntax: " ++ prettyPrint qop-  UnsupportedPattern pat -> "unsupported pattern syntax: " ++ prettyPrint pat-  UnsupportedRhs rhs -> "unsupported right-hand side syntax: " ++ prettyPrint rhs-  UnsupportedGuardedAlts ga -> "unsupported guarded alts: " ++ prettyPrint ga-  EmptyDoBlock -> "empty `do' block"-  UnsupportedModuleSyntax{} -> "unsupported module syntax (may be supported later)"-  LetUnsupported -> "let not supported here"-  InvalidDoBlock -> "invalid `do' block"-  RecursiveDoUnsupported -> "recursive `do' isn't supported"-  FfiNeedsTypeSig d -> "your FFI declaration needs a type signature: " ++ prettyPrint d-  FfiFormatBadChars      srcloc cs -> printSrcLoc srcloc ++ ": invalid characters for FFI format string: " ++ show cs-  FfiFormatNoSuchArg     srcloc i  -> printSrcLoc srcloc ++ ": no such argument in FFI format string: " ++ show i-  FfiFormatIncompleteArg srcloc    -> printSrcLoc srcloc ++ ": incomplete `%' syntax in FFI format string"-  FfiFormatInvalidJavaScript srcloc code err ->-    printSrcLoc srcloc ++ ":" ++-    "\ninvalid JavaScript code in FFI format string:\n"-                                         ++ err ++ "\nin " ++ code-  UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p-  UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i-  Couldn'tFindImport i places ->+  Couldn'tFindImport i places      ->     "could not find an import in the path: " ++ prettyPrint i ++ ", \n" ++     "searched in these places: " ++ intercalate ", " places-  UnableResolveUnqualified name -> "unable to resolve unqualified name " ++ prettyPrint name-  UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname+  EmptyDoBlock -> "empty `do' block"+  FfiFormatBadChars srcloc cs      -> printSrcSpanInfo srcloc ++ ": invalid characters for FFI format string: " ++ show cs+  FfiFormatIncompleteArg srcloc    -> printSrcSpanInfo srcloc ++ ": incomplete `%' syntax in FFI format string"+  FfiFormatInvalidJavaScript l c m ->+    printSrcSpanInfo l ++ ":" +++    "\ninvalid JavaScript code in FFI format string:\n" ++ m ++ "\nin " ++ c+  FfiFormatNoSuchArg srcloc i      ->+    printSrcSpanInfo srcloc ++ ":" +++    "\nno such argument in FFI format string: " ++ show i+  FfiNeedsTypeSig d                -> "your FFI declaration needs a type signature: " ++ prettyPrint d+  GHCError s                       -> "ghc: " ++ s+  InvalidDoBlock                   -> "invalid `do' block"+  ParseError pos err               ->+    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 (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: " ++ prettyPrint i+  UnsupportedLet                   -> "let not supported here"+  UnsupportedLetBinding d          -> "unsupported let binding: " ++ prettyPrint d+  UnsupportedLiteral lit           -> "unsupported literal syntax: " ++ prettyPrint lit+  UnsupportedModuleSyntax s m      -> "unsupported module syntax in " ++ s ++ ": " ++ prettyPrint m+  UnsupportedPattern pat           -> "unsupported pattern syntax: " ++ prettyPrint pat+  UnsupportedQualStmt stmt         -> "unsupported list qualifier: " ++ prettyPrint stmt+  UnsupportedRecursiveDo           -> "recursive `do' isn't supported"+  UnsupportedRhs rhs               -> "unsupported right-hand side syntax: " ++ prettyPrint rhs+  UnsupportedWhereInAlt alt        -> "`where' not supported here: " ++ prettyPrint alt+  UnsupportedWhereInMatch m        -> "unsupported `where' syntax: " ++ prettyPrint m  -- | Get the JS runtime source.-getRuntime :: IO String-getRuntime = getDataFileName "js/runtime.js"+-- This will return the user supplied runtime if it exists.+readConfigRuntime :: Config -> IO String+readConfigRuntime cfg =+  case configRuntimePath cfg of+    Just path -> readFile path+    Nothing -> return $ getRuntimeSource cfg
src/Fay/Compiler.hs view
@@ -1,226 +1,217 @@+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ViewPatterns          #-}  -- | The Haskell→Javascript compiler.  module Fay.Compiler-  (runCompile+  (runCompileModule   ,compileViaStr-  ,compileForDocs-  ,compileToAst-  ,compileModule+  ,compileWith   ,compileExp   ,compileDecl   ,compileToplevelModule+  ,compileModuleFromContents+  ,compileModuleFromAST   ,parseFay)   where -import           Fay.Compiler.InitialPass (initialPass)-import           Fay.Compiler.Config+import           Fay.Compiler.Prelude++import           Fay.Compiler.Decl import           Fay.Compiler.Defaults+import           Fay.Compiler.Desugar import           Fay.Compiler.Exp-import           Fay.Compiler.Decl import           Fay.Compiler.FFI+import           Fay.Compiler.Import+import           Fay.Compiler.InitialPass        (initialPass) import           Fay.Compiler.Misc-import           Fay.Compiler.ModuleScope (bindAsLocals, findTopLevelNames, moduleLocals) 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.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.IO-import           Control.Monad.Extra-import           Control.Monad.State-import           Control.Monad.RWS-import           Data.Default                    (def)+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (gets, modify)+ import qualified Data.Set                        as S-import           Data.Maybe-import           Language.Haskell.Exts+import           Language.Haskell.Exts hiding (name)+import           Language.Haskell.Names          (annotateModule)  -------------------------------------------------------------------------------- -- Top level entry points  -- | Compile a Haskell source string to a JavaScript source string.-compileViaStr :: (Show from,Show to,CompilesTo from to)-              => FilePath-              -> CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (PrintState,CompileState,CompileWriter))-compileViaStr filepath config with from = do-  cs <- defaultCompileState-  rs <- defaultCompileReader config-  runCompile rs-             cs-             (parseResult (throwError . uncurry ParseError)-                          (fmap (\x -> execState (runPrinter (printJS x)) printConfig) . with)-                          (parseFay filepath from))--  where printConfig = def { psPretty = configPrettyPrint config }+compileViaStr --- | Compile a Haskell source string to a JavaScript source string.-compileToAst :: (Show from,Show to,CompilesTo from to)-              => FilePath-              -> CompileReader-              -> CompileState-              -> (from -> Compile to)-              -> String-              -> IO (Either CompileError (to,CompileState,CompileWriter))-compileToAst filepath reader state with from =-  runCompile reader-             state+  :: FilePath+  -> Config+  -> (F.Module -> Compile [JsStmt])+  -> String+  -> IO (Either CompileError (Printer,CompileState,CompileWriter))+compileViaStr filepath cfg with from = do+  rs <- defaultCompileReader cfg+  runTopCompile rs+             defaultCompileState              (parseResult (throwError . uncurry ParseError)-                          with+                          (fmap (mconcat . map printJS) . with)                           (parseFay filepath from)) --- | Compile the given Fay code for the documentation. This is--- specialised because the documentation isn't really “real”--- compilation.-compileForDocs :: Module -> Compile [JsStmt]-compileForDocs mod = do-  initialPass mod-  -- collectRecords mod-  compileModule False mod- -- | Compile the top-level Fay module.-compileToplevelModule :: Module -> Compile [JsStmt]-compileToplevelModule mod@(Module _ (ModuleName modulename) _ _ _ _ _)  = do+compileToplevelModule :: FilePath -> F.Module -> Compile [JsStmt]+compileToplevelModule filein mod@Module{}  = do   cfg <- config id--  when (configTypecheck cfg) $-    typecheck (configPackageConf cfg) (configWall cfg) $-      fromMaybe modulename $ configFilePath cfg-  initialPass mod-  -- collectRecords mod-  cs <- io defaultCompileState-  modify $ \s -> s { stateImported = stateImported cs }-  (stmts,CompileWriter{..}) <- listen $ compileModule True mod-  let fay2js = if null writerFayToJs then [] else [fayToJsDispatcher writerFayToJs]-      js2fay = if null writerJsToFay then [] else [jsToFayDispatcher writerJsToFay]-      maybeOptimize = if configOptimize cfg then runOptimizer optimizeToplevel else id-  if configDispatcherOnly cfg-     then return (maybeOptimize (writerCons ++ fay2js ++ js2fay))-     else return (maybeOptimize (stmts ++-                    if configDispatchers cfg then writerCons ++ fay2js ++ js2fay else []))+  when (configTypecheck cfg) $ do+    res <- io $ typecheck cfg $+             fromMaybe (F.moduleNameString (F.moduleName mod)) $+               configFilePath cfg+    either throwError warn res+  initialPass filein+  -- Reset imports after initialPass so the modules can be imported during code generation.+  (hstmts, fstmts) <- startCompile compileFileWithSource filein+  return (hstmts++fstmts)+compileToplevelModule _ m = throwError $ UnsupportedModuleSyntax "compileToplevelModule" m  -------------------------------------------------------------------------------- -- Compilers --- | Compile Haskell module.-compileModule :: Bool -> Module -> Compile [JsStmt]-compileModule toplevel (Module _ modulename _pragmas Nothing exports imports decls) =-  withModuleScope $ do-    modify $ \s -> s { stateModuleName = modulename-                     , stateModuleScope = findTopLevelNames modulename decls-                     }-    imported <- fmap concat (mapM compileImport imports)-    current <- compileDecls True decls+-- | Compile a source string.+compileModuleFromContents :: String -> Compile ([JsStmt], [JsStmt])+compileModuleFromContents = compileFileWithSource "<interactive>" -    case exports of-      Just exps -> mapM_ emitExport exps-      Nothing -> do-        exps <- moduleLocals modulename <$> gets stateModuleScope-        modify $ flip (foldr addCurrentExport) exps+-- | Compile given the location and source string.+compileFileWithSource :: FilePath -> String -> Compile ([JsStmt], [JsStmt])+compileFileWithSource filepath contents = do+  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 exportStdlib (stateModuleName st) wr+  fstmts' <- maybeOptimize fstmts+  return (hstmts', fstmts')+  where+    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+      cfg <- config id+      return $ if configOptimize cfg+        then runOptimizer optimizeToplevel stmts+        else stmts -    exportStdlib     <- config configExportStdlib-    exportStdlibOnly <- config configExportStdlibOnly-    if exportStdlibOnly-       then if anStdlibModule modulename || toplevel-               then if toplevel-                       then return imported-                       else return (current ++ imported)-               else return []-       else if not exportStdlib && anStdlibModule modulename-               then return []-               else return (imported ++ current)-compileModule _ mod = throwError (UnsupportedModuleSyntax mod)+-- | Compile a parse HSE module.+compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt])+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 -instance CompilesTo Module [JsStmt] where compileTo = compileModule False+  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 --- | 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 -> Bool-anStdlibModule (ModuleName name) = elem name ["Prelude","FFI","Language.Fay.FFI","Data.Data"] --- | Compile the given import.-compileImport :: ImportDecl -> Compile [JsStmt]-compileImport (ImportDecl _ _ _ _ Just{} _ _) = do---  warn $ "import with package syntax ignored: " ++ prettyPrint i-  return []-compileImport (ImportDecl _ name False _ Nothing Nothing Nothing) =-  compileImportWithFilter name (const $ return True)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (True, specs))) =-  compileImportWithFilter name (fmap not . imported specs)-compileImport (ImportDecl _ name False _ Nothing Nothing (Just (False, specs))) =-  compileImportWithFilter name (imported specs)-compileImport i =-  throwError $ UnsupportedImport i+--------------------------------------------------------------------------------+-- Misc compilation -imported :: [ImportSpec] -> QName -> Compile Bool-imported is qn = anyM (matching qn) is+-- | For a module A.B, generate+-- | var A = {};+-- | A.B = {};+createModulePath :: ModuleName a -> Compile [JsStmt]+createModulePath (unAnn -> m) = do+  cfg <- config id+  let isTs = configTypeScript cfg+  reg <- fmap concat . mapM (modPath isTs) . mkModulePaths $ m+  strict <-+    if shouldExportStrictWrapper m cfg+      then fmap concat . mapM (modPath isTs) . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m+       else return []+  return $ reg ++ strict   where-    matching :: QName -> ImportSpec -> Compile Bool-    matching (Qual _ _) (IAbs _) = return True -- Types are always OK-    matching (Qual _ name) (IVar var) = return $ name == var-    matching (Qual _ name) (IThingAll typ) = do-      recs <- typeToRecs $ UnQual typ-      if UnQual name `elem` recs-        then return True+    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]+    whenImportNotGenerated mp makePath = do+      added <- gets $ addedModulePath mp+      if added+        then return []         else do-          fields <- typeToFields $ UnQual typ-          return $ UnQual name `elem` fields-    matching (Qual _ name) (IThingWith typ cns) =-      flip anyM cns $ \cn -> case cn of-        ConName _ -> do-          recs <- typeToRecs $ UnQual typ-          return $ UnQual name `elem` recs-        VarName _ -> do-          fields <- typeToFields $ UnQual typ-          return $ UnQual name `elem` fields-    matching q is = error $ "compileImport: Unsupported QName ImportSpec combination " ++ show (q, is) ++ ", this is a bug!"+          modify $ addModulePath mp+          return $ makePath mp +-- | Generate exports for non local names, local exports have already been added to the module.+generateExports :: Compile [JsStmt]+generateExports = do+  modName <- gets stateModuleName+  maybe [] (map (exportExp modName) . S.toList) <$> gets (getNonLocalExportsWithoutNewtypes modName)+  where+    exportExp :: N.ModuleName -> N.QName -> JsStmt+    exportExp m v = JsSetQName Nothing (changeModule m v) $ case findPrimOp v of+      Just p  -> JsName $ JsNameVar p -- TODO add test case for this case, is it needed at all?+      Nothing -> JsName $ JsNameVar v -compileImportWithFilter :: ModuleName -> (QName -> Compile Bool) -> Compile [JsStmt]-compileImportWithFilter name importFilter =-  unlessImported name importFilter $ \filepath contents -> do-    state <- get-    reader <- ask-    result <- liftIO $ compileToAst filepath reader state (compileModule False) contents-    case result of-      Right (stmts,state,writer) -> do-        imports <- filterM importFilter $ S.toList $ getCurrentExports state-        tell writer-        modify $ \s -> s { stateImported    = stateImported state-                         , stateLocalScope  = S.empty-                         , stateModuleScope = bindAsLocals imports (stateModuleScope s)-                         , _stateExports    = _stateExports state-                         }-        return stmts-      Left err -> throwError err+-- | Generate strict wrappers for the exports of the module.+generateStrictExports :: Compile [JsStmt]+generateStrictExports = do+  cfg <- config id+  modName <- gets stateModuleName+  if shouldExportStrictWrapper modName cfg+    then do+      locals <- gets (getLocalExportsWithoutNewtypes modName)+      nonLocals <- gets (getNonLocalExportsWithoutNewtypes modName)+      let int = maybe [] (map exportExp' . S.toList) locals+      let ext = maybe [] (map (exportExp modName)  . S.toList) nonLocals+      return $ int ++ ext+    else return []+  where+    exportExp :: N.ModuleName -> N.QName -> JsStmt+    exportExp m v = JsSetQName Nothing (changeModule' ("Strict." ++) $ changeModule m v) $ JsName $ JsNameVar $ changeModule' ("Strict." ++) v -unlessImported :: ModuleName-               -> (QName -> Compile Bool)-               -> (FilePath -> String -> Compile [JsStmt])-               -> Compile [JsStmt]-unlessImported "Fay.Types" _ _ = return []-unlessImported name importFilter importIt = do-  imported <- gets stateImported-  case lookup name imported of-    Just _ -> do-      exports <- gets $ getExportsFor name-      imports <- filterM importFilter $ S.toList exports-      modify $ \s -> s { stateModuleScope = bindAsLocals imports (stateModuleScope s) }-      return []-    Nothing -> do-      dirs <- configDirectoryIncludePaths <$> config id-      (filepath,contents) <- findImport dirs name-                         -- TODO stateImported is already added in initialPass so it is not needed here-                         -- but one Api test fails if it's removed.-      modify $ \s -> s { stateImported     = (name,filepath) : imported-                       }-      res <- importIt filepath contents-      return res+    exportExp' :: N.QName -> JsStmt+    exportExp' name = JsSetQName Nothing (changeModule' ("Strict." ++) name) $ serialize (JsName (JsNameVar name))++    serialize :: JsExp -> JsExp+    serialize n = JsApp (JsRawExp "Fay$$fayToJs") [JsRawExp "['automatic']", n]++-- | 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","Data.Ratio","Debug.Trace","Data.Char"]
− src/Fay/Compiler/Config.hs 
@@ -1,66 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}---- | Configuration functions.--module Fay.Compiler.Config where--import Data.Default-import Data.Maybe-import Fay.Types---- | 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---- | Default configuration.-instance Default CompileConfig where-  def =-    addConfigPackage "fay-base" $-      CompileConfig-      { configOptimize           = False-      , configFlattenApps        = False-      , configExportBuiltins     = True-      , configExportRuntime      = True-      , configExportStdlib       = True-      , configExportStdlibOnly   = False-      , configDispatchers        = True-      , configDispatcherOnly     = False-      , configNaked              = False-      , configDirectoryIncludes  = []-      , configPrettyPrint        = False-      , configHtmlWrapper        = False-      , configHtmlJSLibs         = []-      , configLibrary            = False-      , configWarn               = True-      , configFilePath           = Nothing-      , configTypecheck          = True-      , configWall               = False-      , configGClosure           = False-      , configPackageConf        = Nothing-      , configPackages           = []-      , configBasePath           = Nothing-      }
− src/Fay/Compiler/Debug.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Some useful debug functions.--module Fay.Compiler.Debug where--import Fay.Compiler.Defaults-import Fay.Compiler-import Fay.Compiler.Misc (parseResult)-import Fay.Types--import Control.Monad.Error-import Data.Default---- | Compile a String of Fay and print it as beautified JavaScript.-printTestCompile :: String -> IO ()-printTestCompile = printCompile def { configWarn = False } (compileModule False)---- | Compile a Haskell source string to a JavaScript source string.-compileTestAst :: (Show from,Show to,CompilesTo from to)-             => CompileConfig-             -> (from -> Compile to)-             -> String-             -> IO ()-compileTestAst cfg with from = do-  state <- defaultCompileState-  reader <- defaultCompileReader cfg-  out <- runCompile reader-             state-             (parseResult (throwError . uncurry ParseError)-                          with-                          (parseFay "<interactive>" from))-  case out of-    Left err -> error $ show err-    Right (ok,_,_) -> print ok---- | Print a useful debug output of a compilation.-debug :: (Show from,Show to,CompilesTo from to) => (from -> Compile to) -> String -> IO ()-debug compile string = do-  putStrLn "AST:\n"-  compileTestAst c compile string-  putStrLn ""-  putStrLn "JS (unoptimized):\n"-  printCompile def { configTypecheck = False } compile string-  putStrLn "JS (optimized):\n"-  printCompile c compile string--  where c = def { configOptimize = True, configTypecheck = False }---- | Compile the given input and print the output out prettily.-printCompile :: (Show from,Show to,CompilesTo from to)-              => CompileConfig-              -> (from -> Compile to)-              -> String-              -> IO ()-printCompile config with from = do-  result <- compileViaStr "<interactive>" config { configPrettyPrint = True } with from-  case result of-    Left err -> print err-    Right (PrintState{..},_,_) -> do-      putStrLn (concat (reverse (psOutput)))
src/Fay/Compiler/Decl.hs view
@@ -1,229 +1,262 @@-{-# OPTIONS -fno-warn-orphans -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns          #-}  -- | Compile declarations.  module Fay.Compiler.Decl where -import Fay.Compiler.Exp-import Fay.Compiler.FFI-import Fay.Compiler.Misc-import Fay.Compiler.Pattern-import Fay.Types+import           Fay.Compiler.Prelude -import Control.Applicative-import Control.Monad.Error-import Data.List.Extra-import Control.Monad.RWS-import Language.Haskell.Exts+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.Exts                        (convertFieldDecl, fieldDeclNames)+import           Fay.Exts.NoAnnotation           (unAnn)+import qualified Fay.Exts.Scoped                 as S+import           Fay.Types --- | Compile Haskell declaration.-compileDecls :: Bool -> [Decl] -> Compile [JsStmt]-compileDecls toplevel decls =-  case decls of-    [] -> return []-    (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (scoped (compilePatBind toplevel (Just sig) bind))-                                                      (compileDecls toplevel decls)-    (decl:decls) -> appendM (scoped (compileDecl toplevel decl))-                            (compileDecls toplevel decls)+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (gets, modify)+import           Language.Haskell.Exts hiding (binds, loc, name) -  where appendM m n = do x <- m-                         xs <- n-                         return (x ++ xs)-        scoped = if toplevel then withScope else id+{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} +-- | Compile Haskell declaration.+compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]+compileDecls toplevel = fmap concat . mapM (compileDecl toplevel)+ -- | Compile a declaration.-compileDecl :: Bool -> Decl -> Compile [JsStmt]-compileDecl toplevel decl =-  case decl of-    pat@PatBind{} -> compilePatBind toplevel Nothing pat-    FunBind matches -> compileFunCase toplevel matches-    DataDecl _ DataType _ _ _ constructors _ -> compileDataDecl toplevel decl constructors-    GDataDecl _ DataType _l _i _v _n decls _ -> compileDataDecl toplevel decl (map convertGADT decls)-    DataDecl _ NewType  _ _ _ constructors _ -> compileNewtypeDecl constructors-    -- Just ignore type aliases and signatures.-    TypeDecl{} -> return []-    TypeSig{} -> return []-    InfixDecl{} -> return []-    ClassDecl{} -> return []-    InstDecl{} -> return [] -- FIXME: Ignore.-    DerivDecl{} -> return []-    _ -> throwError (UnsupportedDeclaration decl)+compileDecl :: Bool -> S.Decl -> Compile [JsStmt]+compileDecl toplevel decl = case decl of+  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 _) _  head' constructors _ ->+    ifOptimizeNewtypes (return [])+                       (compileDataDecl toplevel (mkTyVars head') constructors)+  -- Just ignore type aliases and signatures.+  TypeDecl {} -> return []+  TypeSig  {} -> return []+  InfixDecl{} -> return []+  ClassDecl{} -> return []+  InstDecl {} -> return [] -- FIXME: Ignore.+  DerivDecl{} -> return []+  DefaultDecl{} -> return []+  RulePragmaDecl{} -> return []+  DeprPragmaDecl{} -> return []+  WarnPragmaDecl{} -> return []+  InlineSig{} -> return []+  InlineConlikeSig{} -> return []+  SpecSig{} -> return []+  SpecInlineSig{} -> return []+  InstSig{} -> return []+  AnnPragma{} -> return []+  _ -> throwError (UnsupportedDeclaration decl) --- | Convenient instance.-instance CompilesTo Decl [JsStmt] where compileTo = compileDecl True +mkTyVars :: S.DeclHead -> [S.TyVarBind]+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 Type -> Decl -> Compile [JsStmt]-compilePatBind toplevel sig pat =-  case pat of-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) (BDecls []) ->-      case ffiExp rhs of-        Just formatstr -> case sig of-          Just sig -> compileFFI srcloc ident formatstr sig-          Nothing  -> throwError (FfiNeedsTypeSig pat)-        _ -> compileUnguardedRhs srcloc toplevel ident rhs-    PatBind srcloc (PVar ident) Nothing (UnGuardedRhs rhs) bdecls -> do-      compileUnguardedRhs srcloc toplevel ident (Let bdecls rhs)-    _ -> throwError (UnsupportedDeclaration pat)+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) (UnGuardedRhs _ rhs) (Just bdecls) ->+    compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs)+  PatBind _ pat (UnGuardedRhs _ rhs) _bdecls -> case pat of+    PList {} -> compilePatBind' pat rhs+    PTuple{} -> compilePatBind' pat rhs+    PApp  {} -> compilePatBind' pat rhs+    _        -> throwError $ UnsupportedDeclaration patDecl+  _ -> throwError $ UnsupportedDeclaration patDecl+  where+    compilePatBind' :: S.Pat -> S.Exp -> Compile [JsStmt]+    compilePatBind' pat rhs = do+      exp <- compileExp rhs+      name <- withScopedTmpJsName return+      m <- compilePat (JsName name) pat []+      m2 <- interleavePatternMatchFailures m pat m+      return (JsVar name exp : m2) -  where ffiExp (App (Var (UnQual (Ident "ffi"))) (Lit (String formatstr))) = Just formatstr-        ffiExp _ = Nothing+    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 :: SrcLoc -> Bool -> Name -> Exp -> Compile [JsStmt]-compileUnguardedRhs srcloc toplevel ident rhs = do-  unless toplevel $ bindVar ident-  withScope $ do-    body <- compileExp rhs-    bind <- bindToplevel srcloc toplevel ident (thunk body)-    return [bind]+compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt]+compileUnguardedRhs toplevel srcloc ident rhs = do+  body <- compileExp rhs+  bind <- bindToplevel toplevel (Just (srcInfoSpan (S.srcSpanInfo srcloc))) ident (thunk body)+  return [bind] --- | Compile a data declaration.-compileDataDecl :: Bool -> Decl -> [QualConDecl] -> Compile [JsStmt]-compileDataDecl toplevel _decl constructors =+-- | Compile a data declaration (or a GADT, latter is converted to former).+compileDataDecl :: Bool -> [S.TyVarBind] -> [S.QualConDecl] -> Compile [JsStmt]+compileDataDecl toplevel tyvars constructors =   fmap concat $-    forM constructors $ \(QualConDecl srcloc _ _ condecl) ->+    forM constructors $ \(QualConDecl _ _ _ condecl) ->       case condecl of-        ConDecl name types  -> do-          let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types-              fields' = (zip (map return fields) types)-          cons <- makeConstructor name fields-          func <- makeFunc name fields-          emitFayToJs name fields'-          emitJsToFay name fields'-          emitCons cons-          return [func]-        InfixConDecl t1 name t2 -> do-          let slots = ["slot1","slot2"]+        ConDecl _ name types -> do+          let slots =  map (Ident () . ("slot"++) . show . fst) $ zip [1 :: Int ..] types+              fields = zip (map return slots) types+          cons <- makeConstructor name slots+          func <- makeFunc name slots+          emitFayToJs name tyvars fields+          emitJsToFay name tyvars fields+          return [cons, func]+        InfixConDecl _ t1 name t2 -> do+          let slots = [Ident () "slot1",Ident () "slot2"]               fields = zip (map return slots) [t1, t2]           cons <- makeConstructor name slots           func <- makeFunc name slots-          emitFayToJs name fields-          emitJsToFay name fields-          emitCons cons-          return [func]-        RecDecl name fields' -> do-          let fields = concatMap fst fields'+          emitFayToJs name tyvars fields+          emitJsToFay name tyvars fields+          return [cons, func]+        RecDecl _ name fields' -> do+          let fields = concatMap fieldDeclNames fields'           cons <- makeConstructor name fields           func <- makeFunc name fields-          funs <- makeAccessors srcloc fields-          emitFayToJs name fields'-          emitJsToFay name fields'-          emitCons cons-          return (func : funs)+          funs <- makeAccessors fields+          emitFayToJs name tyvars (map convertFieldDecl fields')+          emitJsToFay name tyvars (map convertFieldDecl fields')+          return (cons : func : funs)    where-    emitCons cons = tell (mempty { writerCons = [cons] })--    -- Creates a constructor R_RecConstr for a Record-    makeConstructor :: Name -> [Name] -> Compile JsStmt-    makeConstructor name (map (JsNameVar . UnQual) -> fields) = do+    -- Creates a constructor _RecConstr for a Record+    makeConstructor :: Name a -> [Name b] -> Compile JsStmt+    makeConstructor (unAnn -> name) (map (JsNameVar . UnQual () . unAnn) -> fields) = do       qname <- qualify name-      emitExport (EVar qname)       return $-        JsVar (JsConstructor qname) $-          JsFun fields (for fields $ \field -> JsSetProp JsThis field (JsName field))-            Nothing+        JsSetConstructor qname $+          JsFun (Just $ JsConstructor qname)+                fields+                (flip fmap fields $ \field -> JsSetProp JsThis field (JsName field))+                Nothing      -- Creates a function to initialize the record by regular application-    makeFunc :: Name -> [Name] -> Compile JsStmt-    makeFunc name (map (JsNameVar . UnQual) -> fields) = do+    makeFunc :: Name a -> [Name b] -> Compile JsStmt+    makeFunc (unAnn -> name) (map (JsNameVar . UnQual () . unAnn) -> fields) = do       let fieldExps = map JsName fields       qname <- qualify name-      return $ JsVar (JsNameVar qname) $-        foldr (\slot inner -> JsFun [slot] [] (Just inner))-          (thunk $ JsNew (JsConstructor qname) fieldExps)-          fields+      let mp = mkModulePathFromQName qname+      let func = foldr (\slot inner -> JsFun Nothing [slot] [] (Just inner))+                       (thunk $ JsNew (JsConstructor qname) fieldExps)+                       fields+      added <- gets (addedModulePath mp)+      if added+        then return . JsSetQName Nothing qname $ JsApp (JsName $ JsBuiltIn "objConcat")+                                                       [func, JsName $ JsNameVar qname]+        else do+          modify $ addModulePath mp+          return $ JsSetQName Nothing qname func      -- Creates getters for a RecDecl's values-    makeAccessors :: SrcLoc -> [Name] -> Compile [JsStmt]-    makeAccessors srcloc fields =-      forM fields $ \name ->-           bindToplevel srcloc-                        toplevel+    makeAccessors :: [S.Name] -> Compile [JsStmt]+    makeAccessors fields =+      forM fields $ \(unAnn -> name) ->+           bindToplevel toplevel+                        Nothing                         name-                        (JsFun [JsNameVar "x"]+                        (JsFun Nothing+                               [JsNameVar "x"]                                []                                (Just (thunk (JsGetProp (force (JsName (JsNameVar "x")))-                                                       (JsNameVar (UnQual name))))))+                                                       (JsNameVar (UnQual () name)))))) --- | Compile a newtype declaration.-compileNewtypeDecl :: [QualConDecl] -> Compile [JsStmt]-compileNewtypeDecl [QualConDecl _ _ _ condecl] = do-  case condecl of-      -- newtype declaration without destructor-    ConDecl name  [ty]            -> addNewtype name Nothing ty-    RecDecl cname [([dname], ty)] -> addNewtype cname (Just dname) ty-    x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x-  return []-  where-    getBangTy :: BangType -> Type-    getBangTy (BangedTy t)   = t-    getBangTy (UnBangedTy t) = t-    getBangTy (UnpackedTy t) = t -    addNewtype cname dname ty = do-      qcname <- qualify cname-      qdname <- case dname of-                  Nothing -> return Nothing-                  Just n  -> qualify n >>= return . Just-      modify (\cs@CompileState{stateNewtypes=nts} ->-               cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts})-compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q- -- | Compile a function which pattern matches (causing a case analysis).-compileFunCase :: Bool -> [Match] -> Compile [JsStmt]+compileFunCase :: Bool -> [S.Match] -> Compile [JsStmt] compileFunCase _toplevel [] = return []-compileFunCase toplevel matches@(Match srcloc name argslen _ _ _:_) = do+compileFunCase toplevel (InfixMatch l pat name pats rhs binds : rest) =+  compileFunCase toplevel (Match l name (pat:pats) rhs binds : rest)+compileFunCase toplevel matches@(Match srcloc name argslen _ _:_) = do   pats <- fmap optimizePatConditions (mapM compileCase matches)-  bindVar name-  bind <- bindToplevel srcloc-                       toplevel+  bind <- bindToplevel toplevel+                       (Just (srcInfoSpan (S.srcSpanInfo srcloc)))                        name-                       (foldr (\arg inner -> JsFun [arg] [] (Just inner))-                              (stmtsThunk (concat pats ++ basecase))+                       (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner))+                              (stmtsThunk $ deleteAfterReturn (concat pats ++ basecase))                               args)   return [bind]-  where args = zipWith const uniqueNames argslen+  where+    deleteAfterReturn :: [JsStmt] -> [JsStmt]+    deleteAfterReturn [] = []+    deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+    deleteAfterReturn (x:xs) = x:deleteAfterReturn xs -        isWildCardMatch (Match _ _ pats _ _ _) = all isWildCardPat pats+    args = zipWith const uniqueNames argslen -        compileCase :: Match -> Compile [JsStmt]-        compileCase match@(Match _ _ pats _ rhs _) = do-          withScope $ do-            whereDecls' <- whereDecls match-            generateScope $ zipWithM (\arg pat -> compilePat (JsName arg) pat []) args pats-            generateScope $ mapM compileLetDecl whereDecls'-            rhsform <- compileRhs rhs-            body <- if null whereDecls'-                      then return $ either id JsEarlyReturn rhsform-                      else do-                          binds <- mapM compileLetDecl whereDecls'-                          return $ case rhsform of-                            Right exp ->-                              (JsEarlyReturn (JsApp (JsFun [] (concat binds) (Just exp)) []))-                            Left stmt ->-                              (JsEarlyReturn (JsApp (JsFun [] (concat binds ++ [stmt]) Nothing) []))-            foldM (\inner (arg,pat) ->-                    compilePat (JsName arg) pat inner)-                  [body]-                  (zip args pats)+    isWildCardMatch (Match _ _ pats          _ _) = all isWildCardPat pats+    isWildCardMatch (InfixMatch _ pat _ pats _ _) = all isWildCardPat (pat:pats) -        whereDecls :: Match -> Compile [Decl]-        whereDecls (Match _ _ _ _ _ (BDecls decls)) = return decls-        whereDecls match = throwError (UnsupportedWhereInMatch match)+    compileCase :: S.Match -> Compile [JsStmt]+    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+      body <- if null whereDecls'+                then return [either id JsEarlyReturn rhsform]+                else do+                    binds <- mapM compileLetDecl whereDecls'+                    case rhsform of+                      Right exp ->+                        return [JsEarlyReturn $ JsApp (JsFun Nothing [] (concat binds) (Just exp)) []]+                      Left stmt ->+                        withScopedTmpJsName $ \n -> return+                          [ JsVar n (JsApp (JsFun Nothing [] (concat binds ++ [stmt]) Nothing) [])+                          , JsIf (JsNeq JsUndefined (JsName n)) [JsEarlyReturn (JsName n)] []+                          ]+      foldM (\inner (arg,pat) ->+              compilePat (JsName arg) pat inner)+            body+            (zip args pats) -        basecase :: [JsStmt]-        basecase = if any isWildCardMatch matches-                      then []-                      else [throw ("unhandled case in " ++ prettyPrint name)-                                  (JsList (map JsName args))]+    whereDecls :: S.Match -> Compile [S.Decl]+    whereDecls (Match _ _ _ _ (Just (BDecls _ decls))) = return decls+    whereDecls (Match _ _ _ _ Nothing) = return []+    whereDecls match = throwError (UnsupportedWhereInMatch match) +    basecase :: [JsStmt]+    basecase = if any isWildCardMatch matches+                  then []+                  else [throw ("unhandled case in " ++ prettyPrint name)+                              (JsList (map JsName args))]+ -- | Compile a right-hand-side expression.-compileRhs :: Rhs -> Compile (Either JsStmt JsExp)-compileRhs (UnGuardedRhs exp) = Right <$> compileExp exp-compileRhs (GuardedRhss rhss) = Left <$> compileGuards rhss+compileRhs :: S.Rhs -> Compile (Either JsStmt JsExp)+compileRhs (UnGuardedRhs _ exp) = Right <$> compileExp exp+compileRhs (GuardedRhss _ rhss) = Left <$> compileGuards rhss
src/Fay/Compiler/Defaults.hs view
@@ -4,19 +4,21 @@  module Fay.Compiler.Defaults where -import Fay.Compiler.Config-import Fay.Compiler.Decl (compileDecls)-import Fay.Compiler.Exp (compileLit)-import Fay.Types+import           Fay.Compiler.Decl (compileDecls)+import           Fay.Compiler.Exp  (compileLit)+import           Fay.Config+import           Fay.Types+import           Paths_fay -import Data.Default-import Data.Map as M-import Data.Set as S-import Language.Haskell.Exts.Syntax-import Paths_fay+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@@ -26,17 +28,16 @@     }  -- | The default compiler state.-defaultCompileState :: IO CompileState-defaultCompileState = do-  types <- getDataFileName "src/Language/Fay/Types.hs"-  return $ CompileState {-    _stateExports = M.empty-  , stateModuleName = ModuleName "Main"-  , stateRecordTypes = []-  , stateRecords = []-  , stateNewtypes = []-  , stateImported = [("Fay.Types",types)]-  , stateNameDepth = 1-  , stateLocalScope = S.empty-  , stateModuleScope = def+defaultCompileState :: CompileState+defaultCompileState = CompileState+  { stateInterfaces    = M.empty+  , stateModuleName    = "Main"+  , stateRecordTypes   = []+  , stateRecords       = []+  , stateNewtypes      = []+  , stateImported      = []+  , stateNameDepth     = 1+  , stateJsModulePaths = S.empty+  , stateUseFromString = False+  , stateTypeSigs      = M.empty   }
+ src/Fay/Compiler/Desugar.hs view
@@ -0,0 +1,360 @@+-- | 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'+  , 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.Monad.Except            (throwError)+import           Control.Monad.Reader            (asks)+import qualified Data.Generics.Uniplate.Data     as U+import           Language.Haskell.Exts hiding (binds, loc, name)++-- | Top level, desugar a whole module possibly returning errors+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+  >>= desugarTupleCon+  >>= return . desugarPatParen+  >>= return . desugarFieldPun+  >>= return . desugarPatFieldPun+  >>= desugarDo+  >>= desugarTupleSection+  >>= desugarImplicitPrelude+  >>= desugarFFITypeSigs+  >>= desugarLCase+  >>= return . desugarMultiIf+  >>= return . desugarInfixOp+  >>= return . desugarInfixPat+  >>= return . desugarExpParen+{-# ANN desugar' "HLint: ignore Use <$>" #-}++-- | (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)))+  RightSection l q e -> withScopedTmpName l $ \tmp ->+      return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e)+  _ -> return ex++-- | 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++desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l)+desugarStmt' inner stmt =+  maybe initStmt subsequentStmt inner+  where+    initStmt = case stmt of+      Qualifier _ exp -> Just exp+      LetStmt{}     -> error "UnsupportedLet"+      _             -> error "InvalidDoBlock"++    subsequentStmt inner' = case stmt of+      Generator loc pat exp -> desugarGenerator loc pat inner' exp+      Qualifier s exp -> Just $ InfixApp s exp+                                         (QVarOp s $ UnQual s $ Symbol s ">>")+                                         inner'+      LetStmt _ (BDecls s binds) -> Just $ Let s (BDecls s binds) inner'+      LetStmt _ _ -> error "UnsupportedLet"+      RecStmt{} -> error "UnsupportedRecursiveDo"++    desugarGenerator :: l -> Pat l -> Exp l -> Exp l -> Maybe (Exp l)+    desugarGenerator s pat inner' exp =+      Just $ InfixApp s+                      exp+                      (QVarOp s $ UnQual s $ Symbol s ">>=")+                      (Lambda s [pat] inner')++-- | (,)  => \x y   -> (x,y)+--   (,,) => \x y z -> (x,y,z)+-- etc+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 :: 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 $ unscopedTmpNames l prefix+          params = PVar l <$> names+          body   = Tuple l b (Var l . UnQual l <$> names)+      _ -> Nothing++-- | \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++    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+      (rn, re) <- genSlotNames l rest (tail ns)+      return (head ns : rn, Var l (UnQual l (head ns)) : re)+    genSlotNames l (Just e : rest) ns = do+      (rn, re) <- genSlotNames l rest ns+      return (rn, e : re)++-- (p) => p for patterns+desugarPatParen :: (Data l, Typeable l) => Module l -> Module l+desugarPatParen = transformBi $ \pt -> case pt of+  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 -> 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+  PFieldPun l n -> PFieldPat l n (PVar l (unQual n))+  _             -> pf++-- | Desugar list comprehensions.+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+  where+    desugarListComp' l e [] = return (List l [ e ])+    desugarListComp' l e (QualStmt _ (Generator _ p e2) : stmts) = do+      nested <- desugarListComp' l e stmts+      withScopedTmpName l $ \f ->+        return (Let l (BDecls l [ FunBind l [+            Match l f [ p           ] (UnGuardedRhs l nested) Nothing+          , Match l f [ PWildCard l ] (UnGuardedRhs l (List l [])) Nothing+          ]]) (App l (App l (Var l (Qual l (ModuleName l "$Prelude") (Ident l "concatMap"))) (Var l (UnQual l f))) e2))+    desugarListComp' l e (QualStmt _ (Qualifier _ e2) : stmts) = do+      nested <- desugarListComp' l e stmts+      return (If l e2 nested (List l []))+    desugarListComp' l e (QualStmt _ (LetStmt _ bs) : stmts) = do+      nested <- desugarListComp' l e stmts+      return (Let l bs nested)+    desugarListComp' _ _ (_ : _) =+      error "UnsupportedListComprehension"++-- | We only have Enum instance for Int, but GHC hard codes [x..y]+-- 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 l ()+checkEnum = mapM_ f . universeBi+  where+    f ex = case ex of+      e@(EnumFrom       _ e1)       -> checkIntOrUnknown e [e1]+      e@(EnumFromTo     _ e1 e2)    -> checkIntOrUnknown e [e1,e2]+      e@(EnumFromThen   _ e1 e2)    -> checkIntOrUnknown e [e1,e2]+      e@(EnumFromThenTo _ e1 e2 e3) -> checkIntOrUnknown e [e1,e2,e3]+      _ -> return ()++    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+      Lit _ Int{}       -> True+      Lit            {} -> False+      Tuple          {} -> False+      List           {} -> False+      EnumFrom       {} -> False+      EnumFromTo     {} -> False+      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++universeBi :: U.Biplate (from a) (to a) => from a -> [to a]+universeBi = U.universeBi++transformBiM :: (Monad m, U.Biplate (from a) (to a)) => (to a -> m (to a)) -> from a -> m (from a)+transformBiM = U.transformBiM
+ 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,379 +1,343 @@-{-# OPTIONS -fno-warn-name-shadowing -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}---- | Compile expressions+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-}+{-# LANGUAGE ViewPatterns          #-} -module Fay.Compiler.Exp where+-- | Compile expressions. -import Fay.Compiler.Misc-import Fay.Compiler.Pattern-import Fay.Compiler.Print-import Fay.Types+module Fay.Compiler.Exp+  (compileExp+  ,compileGuards+  ,compileLetDecl+  ,compileLit+  ) where -import Control.Applicative-import Control.Monad.Error-import Control.Monad.RWS-import Data.Maybe-import Language.Haskell.Exts+import           Fay.Compiler.Prelude --- | Compile Haskell expression.-compileExp :: Exp -> Compile JsExp-compileExp exp =-  case exp of-    Paren exp                     -> compileExp exp-    Var qname                     -> compileVar qname-    Lit lit                       -> compileLit lit-    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 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 qname                     -> compileVar qname-    Do stmts                      -> compileDoBlock stmts-    Lambda _ pats exp             -> compileLambda pats exp-    LeftSection e o               -> compileExp =<< desugarLeftSection e o-    RightSection o e              -> compileExp =<< desugarRightSection o e-    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   -> updateRec rec fieldUpdates-    ListComp exp stmts            -> compileExp =<< desugarListComp exp stmts-    ExpTypeSig _ e _ -> compileExp e+import           Fay.Compiler.FFI                (compileFFIExp)+import           Fay.Compiler.Misc+import           Fay.Compiler.Pattern+import           Fay.Compiler.Print+import           Fay.Compiler.QName+import           Fay.Config+import           Fay.Exts.NoAnnotation           (unAnn)+import           Fay.Exts.Scoped                 (noI)+import qualified Fay.Exts.Scoped                 as S+import           Fay.Types -    exp -> throwError (UnsupportedExpression exp)+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (asks, gets)+import qualified Data.Char                       as Char+import           Language.Haskell.Exts hiding (alt, binds, name, op)+import           Language.Haskell.Names          (NameInfo (RecExpWildcard), Scoped (Scoped)) --- | Compiling instance.-instance CompilesTo Exp JsExp where compileTo = compileExp+-- | Compile Haskell expression.+compileExp :: S.Exp -> Compile JsExp+compileExp e = case e of+  Var _ qname                        -> compileVar qname+  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+  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 _ 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 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 :: QName -> Compile JsExp+compileVar :: S.QName -> Compile JsExp+compileVar (Special _ t@TupleCon{}) = shouldBeDesugared t compileVar qname = do-  qname <- resolveName qname-  return (JsName (JsNameVar qname))+    nc <- lookupNewtypeConst qname+    nd <- lookupNewtypeDest qname+    if isJust nc || isJust nd+      then -- variable is either a newtype constructor or newtype destructor,+           -- replace it with identity function+           return idFun+      else JsName . JsNameVar <$> unsafeResolveName qname+  where+    idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1))  -- | Compile Haskell literal.-compileLit :: 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)))-    -- TODO: Use real JS strings instead of array, probably it will-    -- lead to the same result.-    String string -> return (JsApp (JsName (JsBuiltIn "list"))-                                   [JsLit (JsStr string)])-    lit           -> throwError (UnsupportedLiteral lit)+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+    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 :: Exp -> Exp -> Compile JsExp-compileApp exp1 exp2 = do-   flattenApps <- config configFlattenApps-   jsexp1 <- compileExp exp1-   case jsexp1 of-     JsName (JsNameVar qname) -> do-       ntc <- lookupNewtypeConst qname-       ntd <- lookupNewtypeDest  qname-       if isJust ntc || isJust ntd-         then compileExp exp2-         else (if flattenApps then method2 else method1) jsexp1-     _ -> (if flattenApps then method2 else method1) jsexp1-   where-  -- Method 1:-  -- In this approach code ends up looking like this:-  -- 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 exp1 =-    JsApp <$> (forceFlatName <$> return exp1)-          <*> fmap return (compileExp exp2)-  forceFlatName name = JsApp (JsName JsForce) [name]+compileApp :: S.Exp -> S.Exp -> Compile JsExp+compileApp exp1@(Con _ q) exp2 =+  ifOptimizeNewtypes+    (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q)+    (compileApp' exp1 exp2)+compileApp exp1@(Var _ q) exp2 =+  ifOptimizeNewtypes+    (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q)+    (compileApp' exp1 exp2)+compileApp exp1 exp2 =+  compileApp' exp1 exp2 -  -- Method 2:-  -- In this approach code ends up looking like this:-  -- 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 exp1 = fmap flatten $-    JsApp <$> return exp1-          <*> fmap return (compileExp exp2)-  flatten (JsApp op args) =-   case op of-     JsApp l r -> JsApp l (r ++ args)-     _        -> JsApp (JsName JsApply) (op : args)-  flatten x = x+-- | Helper for compileApp.+compileApp' :: S.Exp -> S.Exp -> Compile JsExp+compileApp' exp1 exp2 = do+  flattenApps <- config configFlattenApps+  jsexp1 <- compileExp exp1+  (if flattenApps then method2 else method1) jsexp1 exp2+    where+    -- Method 1:+    -- In this approach code ends up looking like this:+    -- 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 e1 e2 =+      JsApp <$> (forceFlatName <$> return e1)+            <*> fmap return (compileExp e2)+      where+        forceFlatName name = JsApp (JsName JsForce) [name] +    -- Method 2:+    -- In this approach code ends up looking like this:+    -- 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 e1 e2 = fmap flatten $+      JsApp <$> return e1+            <*> fmap return (compileExp e2)+      where+        flatten (JsApp op args) =+         case op of+           JsApp l r -> JsApp l (r ++ args)+           _        -> JsApp (JsName JsApply) (op : args)+        flatten x = x+ -- | Compile a negate application-compileNegApp :: Exp -> Compile JsExp+compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e --- | Compile an infix application, optimizing the JS cases.-compileInfixApp :: Exp -> QOp -> Exp -> Compile JsExp-compileInfixApp exp1 ap exp2 = compileExp (App (App (Var op) exp1) exp2)--  where op = getOp ap-        getOp (QVarOp op) = op-        getOp (QConOp op) = op- -- | Compile a let expression.-compileLet :: [Decl] -> Exp -> Compile JsExp+compileLet :: [S.Decl] -> S.Exp -> Compile JsExp compileLet decls exp = do-  withScope $ do-    generateScope $ mapM compileLetDecl decls-    binds <- mapM compileLetDecl decls-    body <- compileExp exp-    return (JsApp (JsFun [] (concat binds) (Just body)) [])+  binds <- mapM compileLetDecl decls+  body <- compileExp exp+  return (JsApp (JsFun Nothing [] [] (Just $ stmtsThunk $ concat binds ++ [JsEarlyReturn body])) [])  -- | Compile let declaration.-compileLetDecl :: Decl -> Compile [JsStmt]+compileLetDecl :: S.Decl -> Compile [JsStmt] compileLetDecl decl = do   compileDecls <- asks readerCompileDecls-  v <- case decl of-    decl@PatBind{} -> compileDecls False [decl]-    decl@FunBind{} -> compileDecls False [decl]-    TypeSig{}      -> return []-    _              -> throwError (UnsupportedLetBinding decl)-  return v+  case decl of+    PatBind{} -> compileDecls False [decl]+    FunBind{} -> compileDecls False [decl]+    TypeSig{} -> return []+    _         -> throwError $ UnsupportedLetBinding decl  -- | Compile a list expression.-compileList :: [Exp] -> Compile JsExp+compileList :: [S.Exp] -> Compile JsExp compileList xs = do   exps <- mapM compileExp xs   return (makeList exps)  -- | Compile an if.-compileIf :: Exp -> Exp -> Exp -> Compile JsExp+compileIf :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp compileIf cond conseq alt =   JsTernaryIf <$> fmap force (compileExp cond)               <*> compileExp conseq               <*> compileExp alt  -- | Compile case expressions.-compileCase :: Exp -> [Alt] -> Compile JsExp-compileCase exp alts = do-  exp <- compileExp exp+compileCase :: S.Exp -> [S.Alt] -> Compile JsExp+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 [tmpName]-                   (concat pats)-                   (if any isWildCardAlt alts+      JsApp (JsFun Nothing+                   [tmpName]+                   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 -> Alt -> Compile [JsStmt]-compilePatAlt exp alt@(Alt _ pat rhs wheres) = case wheres of-  BDecls (_ : _) -> throwError (UnsupportedWhereInAlt alt)-  IPBinds (_ : _) -> throwError (UnsupportedWhereInAlt alt)-  _ -> withScope $ do-    generateScope $ compilePat exp pat []+compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt]+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 :: 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 :: [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) =+compileGuards :: [S.GuardedRhs] -> Compile JsStmt+compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) =   makeIf <$> fmap force (compileExp guard)          <*> compileExp exp-         <*> if null rest then (return []) else do+         <*> if null rest then return [] else do            gs' <- compileGuards rest            return [gs']-    where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss--compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss $ rhss+    where makeIf gs e = JsIf gs [JsEarlyReturn e] --- | Compile a do block.-compileDoBlock :: [Stmt] -> Compile JsExp-compileDoBlock stmts = do-  doblock <- foldM compileStmt Nothing (reverse stmts)-  maybe (throwError EmptyDoBlock) compileExp doblock+compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss noI $ rhss  -- | Compile a lambda.-compileLambda :: [Pat] -> Exp -> Compile JsExp-compileLambda pats exp = do-  withScope $ do-    generateScope $ generateStatements JsNull-    exp <- compileExp exp-    stmts <- generateStatements exp-    case stmts of-      [JsEarlyReturn fun@JsFun{}] -> return fun-      _ -> error "Unexpected statements in compileLambda"+compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp+compileLambda pats = compileExp >=> \exp -> do+  stmts <- generateStatements exp+  case stmts of+    [JsEarlyReturn fun@JsFun{}] -> return fun+    _ -> error "Unexpected statements in compileLambda"    where unhandledcase = throw "unhandled case" . JsName         allfree = all isWildCardPat pats         generateStatements exp =           foldM (\inner (param,pat) -> do                   stmts <- compilePat (JsName param) pat inner-                  return [JsEarlyReturn (JsFun [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))---- | Desugar left sections to lambdas.-desugarLeftSection :: Exp -> QOp -> Compile Exp-desugarLeftSection e o = withScopedTmpName $ \tmp ->-    return (Lambda undefined [PVar tmp] (InfixApp e o (Var (UnQual tmp))))---- | Desugar left sections to lambdas.-desugarRightSection :: QOp -> Exp -> Compile Exp-desugarRightSection o e = withScopedTmpName $ \tmp ->-    return (Lambda undefined [PVar tmp] (InfixApp (Var (UnQual tmp)) o e))+        deleteAfterReturn :: [JsStmt] -> [JsStmt]+        deleteAfterReturn [] = []+        deleteAfterReturn (x@(JsEarlyReturn _):_) = [x]+        deleteAfterReturn (x:xs) = x:deleteAfterReturn xs  -- | Compile [e1..] arithmetic sequences.-compileEnumFrom :: Exp -> Compile JsExp+compileEnumFrom :: S.Exp -> Compile JsExp compileEnumFrom i = do   e <- compileExp i-  name <- resolveName "enumFrom"-  return (JsApp (JsName (JsNameVar name)) [e])+  return (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFrom"))) [e])  -- | Compile [e1..e3] arithmetic sequences.-compileEnumFromTo :: Exp -> Exp -> Compile JsExp+compileEnumFromTo :: S.Exp -> S.Exp -> Compile JsExp compileEnumFromTo i i' = do   f <- compileExp i   t <- compileExp i'-  name <- resolveName "enumFromTo"   cfg <- config id   return $ case optEnumFromTo cfg f t of     Just s -> s-    _ -> JsApp (JsApp (JsName (JsNameVar name)) [f]) [t]+    _ -> JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromTo"))) [f]) [t]  -- | Compile [e1,e2..] arithmetic sequences.-compileEnumFromThen :: Exp -> Exp -> Compile JsExp+compileEnumFromThen :: S.Exp -> S.Exp -> Compile JsExp compileEnumFromThen a b = do   fr <- compileExp a   th <- compileExp b-  name <- resolveName "enumFromThen"-  return (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th])+  return (JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromThen"))) [fr]) [th])  -- | Compile [e1,e2..e3] arithmetic sequences.-compileEnumFromThenTo :: Exp -> Exp -> Exp -> Compile JsExp+compileEnumFromThenTo :: S.Exp -> S.Exp -> S.Exp -> Compile JsExp compileEnumFromThenTo a b z = do   fr <- compileExp a   th <- compileExp b   to <- compileExp z-  name <- resolveName "enumFromThenTo"   cfg <- config id   return $ case optEnumFromThenTo cfg fr th to of     Just s -> s-    _ -> JsApp (JsApp (JsApp (JsName (JsNameVar name)) [fr]) [th]) [to]+    _ -> JsApp (JsApp (JsApp (JsName (JsNameVar (Qual () "Prelude" "enumFromThenTo"))) [fr]) [th]) [to]  -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS.-compileRecConstr :: QName -> [FieldUpdate] -> Compile JsExp-compileRecConstr name fieldUpdates = do-    -- var obj = new $_Type()-    qname <- resolveName name-    let record = JsVar (JsNameVar name) (JsNew (JsConstructor qname) [])-    setFields <- liftM concat (forM fieldUpdates (updateStmt name))-    return $ JsApp (JsFun [] (record:setFields) (Just (JsName (JsNameVar name)))) []-  where updateStmt :: QName -> FieldUpdate -> Compile [JsStmt]-        updateStmt o (FieldUpdate field value) = do-          exp <- compileExp value-          return [JsSetProp (JsNameVar o) (JsNameVar field) exp]-        updateStmt name FieldWildcard = do-          records <- liftM stateRecords get-          let fields = fromJust (lookup name records)-          return (map (\fieldName -> JsSetProp (JsNameVar name)-                                               (JsNameVar fieldName)-                                               (JsName (JsNameVar fieldName)))-                      fields)-        -- TODO: FieldPun-        -- I couldn't find a code that generates (FieldUpdate (FieldPun ..))-        updateStmt _ u = error ("updateStmt: " ++ show u)+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 <- 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)) =+      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 _ _ = throwError $ UnsupportedExpression origExp -updateRec :: Exp -> [FieldUpdate] -> Compile JsExp-updateRec rec fieldUpdates = do-    record <- force <$> compileExp rec-    let copyName = UnQual (Ident "$_record_to_update")-        copy = JsVar (JsNameVar copyName)-                     (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))-    setFields <- forM fieldUpdates (updateExp copyName)-    return $ JsApp (JsFun [] (copy:setFields) (Just (JsName (JsNameVar copyName)))) []-  where updateExp :: QName -> FieldUpdate -> Compile JsStmt-        updateExp copyName (FieldUpdate field value) =-          JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value-        updateExp copyName (FieldPun name) =-          -- let a = 1 in C {a}-          return $ JsSetProp (JsNameVar copyName)-                             (JsNameVar (UnQual name))-                             (JsName (JsNameVar (UnQual name)))-        -- TODO: FieldWildcard-        -- I also couldn't find a code that generates (FieldUpdate FieldWildCard)-        updateExp _ FieldWildcard = error "unsupported update: FieldWildcard"+    wildcardFields l = case l of+      Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName . fst) es+      _ -> []+    lowerFirst :: String -> String+    lowerFirst "" = ""+    lowerFirst (x:xs) = '_' : Char.toLower x : xs --- | Desugar list comprehensions.-desugarListComp :: Exp -> [QualStmt] -> Compile Exp-desugarListComp e [] =-    return (List [ e ])-desugarListComp e (QualStmt (Generator loc p e2) : stmts) = do-    nested <- desugarListComp e stmts-    withScopedTmpName $ \f ->-      return (Let (BDecls [ FunBind [-          Match loc f [ p         ] Nothing (UnGuardedRhs nested)    (BDecls []),-          Match loc f [ PWildCard ] Nothing (UnGuardedRhs (List [])) (BDecls [])-          ]]) (App (App (Var (UnQual (Ident "concatMap"))) (Var (UnQual f))) e2))-desugarListComp e (QualStmt (Qualifier e2)       : stmts) = do-    nested <- desugarListComp e stmts-    return (If e2 nested (List []))-desugarListComp e (QualStmt (LetStmt bs)         : stmts) = do-    nested <- desugarListComp e stmts-    return (Let bs nested)-desugarListComp _ (s                             : _    ) =-    throwError (UnsupportedQualStmt s)+-- | Compile a record update.+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)+                   (JsRawExp ("Object.create(" ++ printJSString record ++ ")"))+  setFields <- forM fieldUpdates (updateExp copyName)+  return $ JsApp (JsFun Nothing [] (copy:setFields) (Just $ JsName $ JsNameVar copyName)) []+  where+    updateExp :: QName a -> S.FieldUpdate -> Compile JsStmt+    updateExp (unAnn -> copyName) (FieldUpdate _ (unQualify . unAnn -> field) value) =+      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{} = throwError $ UnsupportedExpression origExp  -- | Make a Fay list. makeList :: [JsExp] -> JsExp-makeList exps = (JsApp (JsName (JsBuiltIn "list")) [JsList exps])---- | Compile a statement of a do block.-compileStmt :: Maybe Exp -> Stmt -> Compile (Maybe Exp)-compileStmt inner stmt =-  case inner of-    Nothing -> initStmt-    Just inner -> subsequentStmt inner--  where initStmt =-          case stmt of-            Qualifier exp -> return (Just exp)-            LetStmt{}     -> throwError LetUnsupported-            _             -> throwError InvalidDoBlock--        subsequentStmt inner =-          case stmt of-            Generator loc pat exp -> compileGenerator loc pat inner exp-            Qualifier exp -> return (Just (InfixApp exp-                                                    (QVarOp (UnQual (Symbol ">>")))-                                                    inner))-            LetStmt (BDecls binds) -> return (Just (Let (BDecls binds) inner))-            LetStmt _ -> throwError LetUnsupported-            RecStmt{} -> throwError RecursiveDoUnsupported--        compileGenerator srcloc pat inner exp = do-          let body = Lambda srcloc [pat] inner-          return (Just (InfixApp exp-                                 (QVarOp (UnQual (Symbol ">>=")))-                                 body))+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@@ -382,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@@ -398,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,78 +1,81 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-} {-# LANGUAGE TupleSections     #-} {-# LANGUAGE ViewPatterns      #-}-{-# OPTIONS -Wall #-} --- | Compiling the FFI support.+-- | Compile FFI definitions.  module Fay.Compiler.FFI   (emitFayToJs   ,emitJsToFay-  ,compileFFI-  ,jsToFayDispatcher-  ,fayToJsDispatcher)-  where+  ,compileFFIExp+  ,jsToFayHash+  ,fayToJsHash+  ,typeArity+  ) where -import Fay.Compiler.Misc-import Fay.Compiler.Print           (printJSString)-import Fay.Types+import           Fay.Compiler.Prelude -import Control.Monad.Error-import Control.Monad.Writer-import Control.Applicative ((<$>), (<*>))-import Data.Char-import Data.Generics.Schemes-import Data.List-import Data.Maybe-import Data.String-import Language.ECMAScript3.Parser  as JS-import Language.ECMAScript3.Syntax-import Language.Haskell.Exts        (prettyPrint)-import Language.Haskell.Exts.Syntax-import Prelude                      hiding (exp)-import Safe+import           Fay.Compiler.Misc+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.Types --- | Compile an FFI call.-compileFFI :: SrcLoc -- ^ Location of the original FFI decl.-           -> Name  -- ^ Name of the to-be binding.-           -> String -- ^ The format string.-           -> Type   -- ^ Type signature.-           -> Compile [JsStmt]-compileFFI srcloc name formatstr sig =+import           Control.Monad.Except         (throwError)+import           Control.Monad.Writer         (tell)+import           Data.Generics.Schemes+import           Language.ECMAScript3.Parser  as JS+import           Language.ECMAScript3.Syntax+import           Language.Haskell.Exts        (SrcSpanInfo, prettyPrint)+import           Language.Haskell.Exts.Syntax++-- | 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' srcloc name formatstr =<< rmNewtys sig--  where rmNewtys :: Type -> Compile Type-        rmNewtys (TyForall b c t) = TyForall b 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 t-        rmNewtys (TyCon qname)    = do-          newty <- lookupNewtypeConst =<< qualifyQName qname-          return $ case newty of-                     Nothing     -> TyCon qname-                     Just (_,ty) -> ty-        rmNewtys (TyParen t)      = TyParen <$> rmNewtys t-        rmNewtys (TyInfix t1 q t2)= flip TyInfix q <$> rmNewtys t1 <*> rmNewtys t2-        rmNewtys (TyKind t k)     = flip TyKind k <$> rmNewtys t--compileFFI' :: SrcLoc -> Name -> String -> Type -> Compile [JsStmt]-compileFFI' srcloc name formatstr sig = do-  inner <- formatFFI srcloc formatstr (zip params funcFundamentalTypes)-  case JS.parse JS.parseExpression (prettyPrint name) (printJSString (wrapReturn inner)) of-    Left err -> throwError (FfiFormatInvalidJavaScript srcloc inner (show err))-    Right exp  -> do-      config' <- config id-      when (configGClosure config') $ warnDotUses srcloc inner exp-      fmap return (bindToplevel srcloc True name (body inner))+  compileFFI' . unAnn =<< rmNewtys sig'+  where+    rmNewtys :: S.Type -> Compile N.Type+    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 [pname] [] (Just inner)+    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;@@ -83,73 +86,73 @@         returnType = last funcFundamentalTypes  -- | Warn about uses of naked x.y which will not play nicely with Google Closure.-warnDotUses :: SrcLoc -> String -> ParsedExpression -> Compile ()-warnDotUses srcloc string expr =+warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile ()+warnDotUses srcSpanInfo string expr =   when anyrefs $-    warn $ printSrcLoc srcloc ++ ":\nDot ref syntax used in FFI JS code: " ++ string+    warn $ printSrcSpanInfo srcSpanInfo ++ ":\nDot ref syntax used in FFI JS code: " ++ string -  where anyrefs = not (null (listify dotref expr)) ||+  where+    anyrefs = not (null (listify dotref expr)) ||                   not (null (listify ldot expr)) -        dotref :: ParsedExpression -> Bool-        dotref x = case x of-          DotRef _ (VarRef _ (Id _ name)) _-             | elem name globalNames -> False-          DotRef{}                   -> True-          _                          -> False+    dotref :: Expression SourcePos -> Bool+    dotref x = case x of+      DotRef _ (VarRef _ (Id _ name)) _+         | name `elem` globalNames -> False+      DotRef{}                     -> True+      _                            -> False -        ldot :: LValue SourcePos -> Bool-        ldot x =-          case x of-            LDot _ (VarRef _ (Id _ name)) _-             | elem name globalNames -> False-            LDot{}                   -> True-            _                        -> False+    ldot :: LValue SourcePos -> Bool+    ldot x =+      case x of+        LDot _ (VarRef _ (Id _ name)) _+         | name `elem` globalNames -> False+        LDot{}                     -> True+        _                          -> False -        globalNames = ["Math","console","JSON"]+    globalNames = ["Math","console","JSON"]  -- | Make a Fay→JS encoder.-emitFayToJs :: Name -> [([Name],BangType)] -> Compile ()-emitFayToJs name (explodeFields -> fieldTypes) = do+emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile ()+emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do   qname <- qualify name-  tell (mempty { writerFayToJs = [translator qname] })+  let ctrName = printJSString $ unQual qname+  tell $ mempty { writerFayToJs = [(ctrName, translator)] }    where-    translator qname =-      JsIf (JsInstanceOf (JsName transcodingObjForced) (JsConstructor qname))-           (obj : fieldStmts (zip [0..] fieldTypes) ++ [ret])-           []+    translator =+      JsFun Nothing+            [JsNameVar "type", argTypes, transcodingObjForced]+            (obj : fieldStmts (map (getIndex name tyvars) fieldTypes))+            (Just $ JsName obj_)      obj :: JsStmt     obj = JsVar obj_ $-      JsObj [("instance",JsLit (JsStr (printJSString name)))]+      JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))] -    fieldStmts :: [(Int,(Name,BangType))] -> [JsStmt]+    fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt]     fieldStmts [] = []     fieldStmts ((i,fieldType):fts) =-      (JsVar obj_v field) :-        (JsIf (JsNeq JsUndefined (JsName obj_v))+      JsVar obj_v field :+        JsIf (JsNeq JsUndefined (JsName obj_v))           [JsSetPropExtern obj_ decl (JsName obj_v)]-          []) :+          [] :         fieldStmts fts       where-        obj_v = JsNameVar (UnQual (Ident $ "obj_" ++ d))-        decl = JsNameVar (UnQual (Ident d))+        obj_v = JsNameVar $ UnQual () (Ident () $ "obj_" ++ d)+        decl = JsNameVar $ UnQual () (Ident () d)         (d, field) = declField i fieldType -    obj_ = JsNameVar (UnQual (Ident "obj_"))--    ret :: JsStmt-    ret = JsEarlyReturn (JsName obj_)+    obj_ = JsNameVar "obj_"      -- Declare/encode Fay→JS field-    declField :: Int -> (Name,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))))+                          (JsNameVar (UnQual () fname))))  -- | A name used for transcoding. transcodingObj :: JsName@@ -160,54 +163,46 @@ transcodingObjForced = JsNameVar "_obj"  -- | Get arg types of a function type.-functionTypeArgs :: Type -> [FundamentalType]-functionTypeArgs t =-  case t of-    TyForall _ _ i -> functionTypeArgs i-    TyFun a b      -> argType a : functionTypeArgs b-    TyParen st     -> functionTypeArgs st-    r              -> [argType r]+functionTypeArgs :: N.Type -> [FundamentalType]+functionTypeArgs t = case t of+  TyForall _ _ _ i -> functionTypeArgs i+  TyFun _ a b      -> argType a : functionTypeArgs b+  TyParen _ st     -> functionTypeArgs st+  r                -> [argType r]  -- | Convert a Haskell type to an internal FFI representation.-argType :: Type -> FundamentalType+argType :: N.Type -> FundamentalType argType t = case t of-  TyCon "String"              -> StringType-  TyCon "Double"              -> DoubleType-  TyCon "Int"                 -> IntType-  TyCon "Bool"                -> BoolType-  TyApp (TyCon "Ptr") _       -> PtrType-  TyApp (TyCon "Automatic") _ -> Automatic-  TyApp (TyCon "Defined") a   -> Defined (argType a)-  TyApp (TyCon "Nullable") a  -> Nullable (argType a)-  TyApp (TyCon "Fay") a       -> JsType (argType a)-  TyFun x xs                  -> FunctionType (argType x : functionTypeArgs xs)-  TyList x                    -> ListType (argType x)-  TyTuple _ xs                -> TupleType (map argType xs)-  TyParen st                  -> argType st-  TyApp op arg                -> userDefined (reverse (arg : expandApp op))+  TyCon _ (UnQual _ (Ident _ "String"))                -> StringType+  TyCon _ (UnQual _ (Ident _ "Double"))                -> DoubleType+  TyCon _ (UnQual _ (Ident _ "Int"))                   -> IntType+  TyCon _ (UnQual _ (Ident _ "Bool"))                  -> BoolType+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Ptr"))) _       -> PtrType+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Automatic"))) _ -> Automatic+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Defined"))) a   -> Defined (argType a)+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Nullable"))) a  -> Nullable (argType a)+  TyApp _ (TyCon _ (UnQual _ (Ident _ "Fay"))) a       -> JsType (argType a)+  TyFun _ x xs                  -> FunctionType (argType x : functionTypeArgs xs)+  TyList _ x                    -> ListType (argType x)+  TyTuple _ _ xs                -> TupleType (map argType xs)+  TyParen _ st                  -> argType st+  TyApp _ op arg                -> userDefined (reverse (arg : expandApp op))   _                     ->     -- No semantic point to this, merely to avoid GHC's broken     -- warning.     case t of-      TyCon (UnQual user)   -> UserDefined user []+      TyCon _ (UnQual _ user)   -> UserDefined user []       _ -> UnknownType --- | Extract the type.-bangType :: BangType -> Type-bangType typ = case typ of-  BangedTy ty   -> ty-  UnBangedTy ty -> ty-  UnpackedTy ty -> ty- -- | Expand a type application.-expandApp :: Type -> [Type]-expandApp (TyParen t) = expandApp t-expandApp (TyApp op arg) = arg : expandApp op+expandApp :: N.Type -> [N.Type]+expandApp (TyParen _ t) = expandApp t+expandApp (TyApp _ op arg) = arg : expandApp op expandApp x = [x]  -- | Generate a user-defined type.-userDefined :: [Type] -> FundamentalType-userDefined (TyCon (UnQual name):typs) = UserDefined name (map argType typs)+userDefined :: [N.Type] -> FundamentalType+userDefined (TyCon _ (UnQual _ name):typs) = UserDefined name (map argType typs) userDefined _ = UnknownType  -- | Translate: JS → Fay.@@ -233,10 +228,10 @@   _ -> recursive    where flat specialize =-          JsApp (JsName (JsBuiltIn (fromString (method ++ "_" ++ specialize))))+          JsApp (JsName (JsBuiltIn (Ident () (method ++ "_" ++ specialize))))                 [exp]         recursive =-          JsApp (JsName (JsBuiltIn (fromString method)))+          JsApp (JsName (JsBuiltIn (Ident () method)))                 [typeRep context typ                 ,exp]         js ty' =@@ -283,19 +278,19 @@                                         (ret "unknown"))  -- | Get the arity of a type.-typeArity :: Type -> Int+typeArity :: Type a -> Int typeArity t = case t of-  TyForall _ _ i -> typeArity i-  TyFun _ b      -> 1 + typeArity b-  TyParen st     -> typeArity st+  TyForall _ _ _ i -> typeArity i+  TyFun _ _ b      -> 1 + typeArity b+  TyParen _ st     -> typeArity st   _              -> 0 --- | Format the FFI format string with the given arguments.-formatFFI :: SrcLoc                     -- ^ Location of the original FFI decl.+-- | Format the FFI  format string with the given arguments.+formatFFI :: SrcSpanInfo                -- ^ Source Location.           -> String                     -- ^ The format string.           -> [(JsName,FundamentalType)] -- ^ Arguments.           -> Compile String             -- ^ The JS code.-formatFFI srcloc formatstr args = go formatstr where+formatFFI loc formatstr args = go formatstr where   go ('%':'*':xs) = do     these <- mapM inject (zipWith const [1..] args)     rest <- go xs@@ -303,10 +298,10 @@   go ('%':'%':xs) = do     rest <- go xs     return ('%' : rest)-  go ['%'] = throwError (FfiFormatIncompleteArg srcloc)+  go ['%'] = throwError (FfiFormatIncompleteArg loc)   go ('%':(span isDigit -> (op,xs))) =     case readMay op of-     Nothing -> throwError (FfiFormatBadChars srcloc op)+     Nothing -> throwError (FfiFormatBadChars loc op)      Just n -> do        this <- inject n        rest <- go xs@@ -317,65 +312,57 @@    inject n =     case listToMaybe (drop (n-1) args) of-      Nothing -> throwError (FfiFormatNoSuchArg srcloc n)-      Just (arg,typ) -> do+      Nothing -> throwError (FfiFormatNoSuchArg loc n)+      Just (arg,typ) ->         return (printJSString (fayToJs SerializeAnywhere typ (JsName arg)))  -- | Generate n name-typ pairs from the given list. explodeFields :: [([a], t)] -> [(a, t)] explodeFields = concatMap $ \(names,typ) -> map (,typ) names --- | The dispatcher for Fay->JS conversion.-fayToJsDispatcher :: [JsStmt] -> JsStmt-fayToJsDispatcher cases =-  JsVar (JsBuiltIn "fayToJsUserDefined")-        (JsFun [JsNameVar "type",transcodingObj]-               (decl ++ cases ++ [baseCase])-               Nothing)--  where decl = [JsVar transcodingObjForced-                      (force (JsName transcodingObj))-               ,JsVar argTypes-                      (JsLookup (JsName JsParametrizedType)-                                (JsLit (JsInt 2)))]-        baseCase =-          JsEarlyReturn (JsName transcodingObj)---- | The dispatcher for JS->Fay conversion.-jsToFayDispatcher :: [JsStmt] -> JsStmt-jsToFayDispatcher cases =-  JsVar (JsBuiltIn "jsToFayUserDefined")-        (JsFun [JsNameVar "type",transcodingObj]-               (decl ++ cases ++ [baseCase])-               Nothing)+-- | Generate Fay→JS encoding.+fayToJsHash :: [(String, JsExp)] -> [JsStmt]+fayToJsHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "fayToJsHash", JsObj cases]] -  where baseCase =-          JsEarlyReturn (JsName transcodingObj)-        decl = [JsVar argTypes-                      (JsLookup (JsName JsParametrizedType)-                                (JsLit (JsInt 2)))]+-- | Generate JS→Fay decoding.+jsToFayHash :: [(String, JsExp)] -> [JsStmt]+jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]]  -- | Make a JS→Fay decoder.-emitJsToFay ::  Name -> [([Name], BangType)] -> Compile ()-emitJsToFay name (explodeFields -> fieldTypes) = do+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 = [translator qname] })+  tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] })    where     translator qname =-      JsIf (JsEq (JsGetPropExtern (JsName transcodingObj) "instance")-                 (JsLit (JsStr (printJSString name))))-           [JsEarlyReturn (JsNew (JsConstructor qname)-                                 (zipWith decodeField fieldTypes [0..]))]-           []+      JsFun Nothing [JsNameVar "type", argTypes, transcodingObj] []+            (Just $ JsNew (JsConstructor qname)+                          (map (decodeField . getIndex name tyvars) fieldTypes))     -- Decode JS→Fay field-    decodeField :: (Name,BangType) -> Int -> JsExp-    decodeField (fname,typ) i =+    decodeField :: (Int,(N.Name,N.Type)) -> JsExp+    decodeField (i,(fname,typ)) =       jsToFay (SerializeUserArg i)-              (argType (bangType typ))+              (argType typ)               (JsGetPropExtern (JsName transcodingObj)                                (prettyPrint fname))  -- | The argument types used in serialization of parametrized user-defined types. argTypes :: JsName argTypes = JsNameVar "argTypes"++-- | Get the index of a name from the set of type variables bindings.+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 ty of+    TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of+      Nothing -> error $ "unknown type variable " ++ prettyPrint tyname +++                         " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," +++                         " vars were: " ++ unwords (map prettyPrint tyvars) ++ ", rest: " ++ show tyvars+      Just i -> (i,(sname,ty))+    _ -> (0,(sname,ty))++-- | Extract the name from a possibly-kinded tyvar.+tyvar :: N.TyVarBind -> N.Name+tyvar (UnkindedVar _ v) = v+tyvar (KindedVar _ v _) = v
+ src/Fay/Compiler/GADT.hs view
@@ -0,0 +1,21 @@+-- | Convert GADTs into normal data types.++module Fay.Compiler.GADT+  (convertGADT+  ) where++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 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+    convertFunc :: Type a -> [Type a]+    convertFunc (TyCon _ _) = []+    convertFunc (TyFun _ x xs) = x : convertFunc xs+    convertFunc (TyParen _ x) = convertFunc x+    convertFunc _ = []
+ src/Fay/Compiler/Import.hs view
@@ -0,0 +1,123 @@+{-# 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+  ) where++import           Fay.Compiler.Prelude++import           Fay.Compiler.Misc+import           Fay.Compiler.Parse+import           Fay.Config+import qualified Fay.Exts                        as F+import           Fay.Exts.NoAnnotation           (unAnn)+import           Fay.Types++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++-- | Start the compilation process using `compileModule` to compile a file.+startCompile :: (FilePath -> String -> Compile a) -> FilePath -> Compile a+startCompile compileModule filein = do+  modify $ \s -> s { stateImported = [] }+  fmap fst . listen $ compileModuleFromFile compileModule filein++-- | Compile a module+compileWith+  :: (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 before from = do+  rd <- ask+  st <- get+  res <- Compile . lift . lift $+    runCompileModule+      rd+      st+      (parseResult (throwError . uncurry ParseError)+                   (\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+                   )+                   (parseFay filepath from))+  either throwError return res++-- | Compile a module given its file path+compileModuleFromFile+  :: (FilePath -> String -> Compile a)+  -> FilePath+  -> Compile a+compileModuleFromFile compileModule fp = io (readFile fp) >>= compileModule fp++-- | Lookup a module from include directories and compile.+compileModuleFromName+  :: Monoid a+  => (FilePath -> String -> Compile a)+  -> F.ModuleName+  -> Compile a+compileModuleFromName compileModule nm =+  unlessImported nm compileModule+    where+      unlessImported+        :: Monoid a+        => ModuleName l+        -> (FilePath -> String -> Compile a)+        -> Compile a+      unlessImported (ModuleName _ "Fay.Types") _ = return mempty+      unlessImported (unAnn -> name) importIt = do+        imported <- gets stateImported+        case lookup name imported of+          Just _  -> return mempty+          Nothing -> do+            dirs <- configDirectoryIncludePaths <$> config id+            (filepath,contents) <- findImport dirs name+            modify $ \s -> s { stateImported = (name,filepath) : imported }+            importIt filepath contents++-- | Compile an import.+compileImport+  :: Monoid a+  => (FilePath -> String -> Compile a)+  -> F.ImportDecl+  -> Compile a+compileImport compileModule i = case i of+  -- 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)+findImport alldirs (unAnn -> mname) = go alldirs mname where+  go :: [FilePath] -> ModuleName a -> Compile (FilePath,String)+  go _ (ModuleName _ "Fay.Types") = return ("Fay/Types.hs", "newtype Fay a = Fay (Identity a)\n\nnewtype Identity a = Identity a")+  go (dir:dirs) name = do+    exists <- io (doesFileExist path)+    if exists+      then (path,) . stdlibHack <$> io (readFile path)+      else go dirs name+    where+      path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"+      replace c r = map (\x -> if x == c then r else x)+  go [] name =+    throwError $ Couldn'tFindImport (unAnn name) alldirs++  stdlibHack = case mname of+    ModuleName _ "Fay.FFI" -> const "module Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"+    _ -> id
src/Fay/Compiler/InitialPass.hs view
@@ -1,117 +1,158 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-} -module Fay.Compiler.InitialPass where+-- | Preprocessing collecting names, data types, newtypes, imports, and exports+-- for all modules recursively.+module Fay.Compiler.InitialPass+  (initialPass+  ) where -import Fay.Compiler.Misc-import Fay.Types-import Fay.Compiler.Config-import Fay.Compiler.Decl (compileNewtypeDecl)+import           Fay.Compiler.Prelude -import Control.Applicative-import Control.Monad.Error-import Control.Monad.RWS-import Language.Haskell.Exts.Syntax-import Language.Haskell.Exts.Parser+import           Fay.Compiler.Desugar+import           Fay.Compiler.GADT+import           Fay.Compiler.Import+import           Fay.Compiler.Misc+import           Fay.Compiler.Parse+import qualified Fay.Exts                        as F+import           Fay.Exts.NoAnnotation           (unAnn)+import           Fay.Types -initialPass :: Module -> Compile ()-initialPass (Module _ _ _ Nothing _ imports decls) = do-  forM_ imports $ \imp ->-    case imp of-      ImportDecl _ _ _ _ Just{} _ _ -> return ()+import           Control.Monad.Except            (throwError)+import           Control.Monad.RWS               (modify)+import qualified Data.Map                        as M+import           Language.Haskell.Exts hiding (name)+import qualified Language.Haskell.Names          as HN (getInterfaces) -      ImportDecl _ name False _ Nothing Nothing _ ->-        void $ unlessImported name $ \filepath contents -> do-          result <- compileWith filepath initialPass contents-          case result of-            Right ((),st,_) ->-              -- Merges the state gotten from passing through an imported-              -- module with the current state. We can assume no duplicate-              -- records exist since GHC would pick that up.-              modify $ \s -> s { stateRecords = stateRecords st-                               , stateRecordTypes = stateRecordTypes st-                               , stateImported = stateImported st-                               , stateNewtypes = stateNewtypes st-                               }-            Left err -> throwError err+-- | Preprocess and collect all information needed during code generation.+initialPass :: FilePath -> Compile ()+initialPass = startCompile preprocessFileWithSource -      i -> throwError $ UnsupportedImport i+-- | Preprocess a module given its filepath and content.+preprocessFileWithSource :: FilePath -> String -> Compile ()+preprocessFileWithSource filepath contents = do+  (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource desugar contents+  -- This is the state we want to keep+  modify $ \s -> s { stateRecords     = stateRecords     st+                   , stateRecordTypes = stateRecordTypes st+                   , stateImported    = stateImported    st+                   , stateNewtypes    = stateNewtypes    st+                   , stateInterfaces  = stateInterfaces  st+                   , stateTypeSigs    = stateTypeSigs    st+                     -- TODO This needs to be added otherwise the+                     -- "executable" generation in Fay.hs gets the+                     -- wrong name. Not sure why it works to do it+                     -- here!+                   , stateModuleName  = stateModuleName  st+                   } +-- | Preprocess from an AST+preprocessAST :: () -> F.Module -> Compile ()+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-  forM_ decls scanNewtypeDecls--initialPass m = throwError (UnsupportedModuleSyntax m)--compileWith :: (Show from,Parseable from)-            => FilePath-            -> (from -> Compile ())-            -> String-            -> Compile (Either CompileError ((),CompileState,CompileWriter))-compileWith filepath with from = do-  compileReader <- ask-  compileState  <- get-  liftIO $ runCompile compileReader-                      compileState-                      (parseResult (throwError . uncurry ParseError)-                                   with-                                   (parseFay filepath from))+  ifOptimizeNewtypes+    (forM_ decls scanNewtypeDecls)+    (return ())+preprocessAST () mod = throwError $ UnsupportedModuleSyntax "preprocessAST" mod --- | Don't re-import the same modules.-unlessImported :: ModuleName-                           -> (FilePath -> String -> Compile ())-                           -> Compile ()-unlessImported name importIt = do-  imported <- gets stateImported-  case lookup name imported of-    Just _ -> return ()-    Nothing -> do-      dirs <- configDirectoryIncludePaths <$> config id-      (filepath,contents) <- findImport dirs name-      modify $ \s -> s { stateImported = (name,filepath) : imported }-      importIt filepath contents+--------------------------------------------------------------------------------+-- | Preprocessing -scanNewtypeDecls :: Decl -> Compile ()-scanNewtypeDecls (DataDecl _ NewType _ _ _ constructors _) =-  void $ compileNewtypeDecl constructors+-- | Find newtype declarations+scanNewtypeDecls :: F.Decl -> Compile ()+scanNewtypeDecls (DataDecl _ NewType{} _ _ constructors _) = compileNewtypeDecl constructors scanNewtypeDecls _ = return () -scanRecordDecls :: Decl -> Compile ()+-- | Add new types to the state+compileNewtypeDecl :: [F.QualConDecl] -> Compile ()+compileNewtypeDecl [QualConDecl _ _ _ condecl] = case condecl of+    -- newtype declaration without destructor+  ConDecl _ name  [ty]            -> addNewtype name Nothing ty+  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+    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,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 name _tyvarb qualcondecls _deriv -> do-      let ns = flip map 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 _l _i _v _n 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-    addRecordTypeState name cons = modify $ \s -> s-      { stateRecordTypes = (UnQual name, map UnQual cons) : stateRecordTypes s }+    addRecordTypeState (unAnn -> name') (map unAnn -> cons') = do+      name <- qualify name'+      cons <- mapM qualify cons'+      modify $ \s -> s { stateRecordTypes = (name, cons) : stateRecordTypes s } -    conDeclName (ConDecl n _) = n-    conDeclName (InfixConDecl _ n _) = n-    conDeclName (RecDecl n _) = n+    conDeclName (ConDecl _ n _) = n+    conDeclName (InfixConDecl _ _ n _) = n+    conDeclName (RecDecl _ n _) = n      -- | Collect record definitions and store record name and field names.     -- A ConDecl will have fields named slot1..slotN-    dataDecl :: [QualConDecl] -> Compile ()-    dataDecl constructors = do+    dataDecl :: [F.QualConDecl] -> Compile ()+    dataDecl constructors =       forM_ constructors $ \(QualConDecl _ _ _ condecl) ->         case condecl of-          ConDecl name types -> do-            let fields =  map (Ident . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types+          ConDecl _ name types -> do+            let fields =  map (Ident () . ("slot"++) . show . fst) . zip [1 :: Integer ..] $ types             addRecordState name fields-          InfixConDecl _t1 name _t2 ->-            addRecordState name ["slot1", "slot2"]-          RecDecl name fields' -> do-            let fields = concatMap fst fields'+          InfixConDecl _ _t1 name _t2 ->+            addRecordState name [F.mkIdent "slot1", F.mkIdent "slot2"]+          RecDecl _ name fields' -> do+            let fields = concatMap F.fieldDeclNames fields'             addRecordState name fields        where-        addRecordState :: Name -> [Name] -> Compile ()-        addRecordState name fields = modify $ \s -> s-          { stateRecords = (UnQual name,map UnQual fields) : stateRecords s }+        addRecordState :: Name a -> [Name b] -> Compile ()+        addRecordState name' fields = do+          name <- qualify name'+          modify $ \s -> s+            { stateRecords = (name,map unAnn fields) : stateRecords s }++scanTypeSigs :: F.Decl -> Compile ()+scanTypeSigs decl = case decl of+  TypeSig _ names typ -> mapM_ (`addTypeSig` typ) names+  _ -> return ()+  where+    addTypeSig :: F.Name -> F.Type -> Compile ()+    addTypeSig (unAnn -> n') (unAnn -> t) = do+      n <- qualify n'+      modify $ \s -> s { stateTypeSigs = M.insert n t (stateTypeSigs s) }
src/Fay/Compiler/Misc.hs view
@@ -1,45 +1,35 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS -Wall -fno-warn-orphans  #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Miscellaneous functions used throughout the compiler.  module Fay.Compiler.Misc where -import qualified Fay.Compiler.ModuleScope        as ModuleScope+import           Fay.Compiler.Prelude++import           Fay.Compiler.ModuleT            (runModuleT)+import           Fay.Compiler.PrimOp+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.IO-import           Control.Monad.RWS-import           Data.List-import           Data.Maybe-import qualified Data.Set                        as S-import           Data.String+import           Control.Monad.Except            (runExceptT, throwError)+import           Control.Monad.RWS               (asks, gets, modify, runRWST) import           Data.Version                    (parseVersion)-import           Language.Haskell.Exts.Extension-import           Language.Haskell.Exts.Fixity-import           Language.Haskell.Exts.Parser-import           Language.Haskell.Exts.Pretty-import           Language.Haskell.Exts.Syntax-import           Prelude                         hiding (exp, mod)-import           System.Directory-import           System.FilePath+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) --- | Extra the string from an ident.-unname :: Name -> String-unname (Ident str) = str-unname _ = error "Expected ident from uname." -- FIXME:---- | Make an identifier from the built-in HJ module.-fayBuiltin :: String -> QName-fayBuiltin = Qual (ModuleName "Fay$") . Ident- -- | Wrap an expression in a thunk. thunk :: JsExp -> JsExp -- thunk exp = JsNew (fayBuiltin "Thunk") [JsFun [] [] (Just exp)]@@ -52,118 +42,96 @@     -- optimization.     JsApp fun@JsFun{} [] -> JsNew JsThunk [fun]     -- Otherwise make a regular thunk.-    _ -> JsNew JsThunk [JsFun [] [] (Just expr)]+    _ -> JsNew JsThunk [JsFun Nothing [] [] (Just expr)]  -- | Wrap an expression in a thunk. stmtsThunk :: [JsStmt] -> JsExp-stmtsThunk stmts = JsNew JsThunk [JsFun [] stmts Nothing]+stmtsThunk stmts = JsNew JsThunk [JsFun Nothing [] stmts Nothing]  -- | Generate unique names. uniqueNames :: [JsName] uniqueNames = map JsParam [1::Integer ..]  -- | Resolve a given maybe-qualified name to a fully qualifed name.-resolveName :: QName -> Compile QName-resolveName special@Special{} = return special-resolveName q@Qual{} = do-  env <- gets stateModuleScope-  maybe (throwError $ UnableResolveQualified q) return (ModuleScope.resolveName q env)-resolveName u@(UnQual name) = do-  names <- gets stateLocalScope-  env <- gets stateModuleScope-  if S.member name names-    then return (UnQual name)-    else maybe (qualify name) return (ModuleScope.resolveName u env)+tryResolveName :: Show l => QName (Scoped l) -> Maybe N.QName+tryResolveName s@Special{}                                      = Just $ unAnn s+tryResolveName s@(UnQual _ (Ident _ n)) | "$gen" `isPrefixOf` n = Just $ unAnn s+tryResolveName (unAnn -> Qual () (ModuleName () "$Prelude") n)  = Just $ Qual () (ModuleName () "Prelude") n+tryResolveName q@(Qual _ (ModuleName _ "Fay$") _)               = Just $ unAnn q+tryResolveName (Qual (Scoped ni _) _ _)                         = case ni of+    GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n+    _             -> Nothing+    -- TODO should LocalValue just return the name for qualified imports?+tryResolveName q@(UnQual (Scoped ni _) (unAnn -> name))         = case ni of+    GlobalValue n -> replaceWithBuiltIns . origName2QName $ origName n+    LocalValue _  -> Just $ UnQual () name+    ScopeError _  -> resolvePrimOp q+    _             -> Nothing -lookupNewtypeConst :: QName -> Compile (Maybe (Maybe QName,Type))-lookupNewtypeConst name = do-  newtypes <- gets stateNewtypes-  case find (\(cname,_,_) -> cname == name) newtypes of+origName2QName :: OrigName -> N.QName+origName2QName = gname2Qname . origGName+  where+    gname2Qname :: GName -> N.QName+    gname2Qname g = case g of+      GName "" s -> UnQual () $ mkName s+      GName m  s -> Qual () (ModuleName () m) $ mkName s+      where+        mkName s@(x:_)+          | isAlpha x || x == '_' = Ident () s+          | otherwise = Symbol () s+        mkName "" = error "mkName \"\""++replaceWithBuiltIns :: N.QName -> Maybe N.QName+replaceWithBuiltIns n = findPrimOp n <|> return n++-- | Resolve a given maybe-qualified name to a fully qualifed name.+-- Use this when a resolution failure is a bug.+unsafeResolveName :: S.QName -> Compile N.QName+unsafeResolveName q = maybe (throwError $ UnableResolveQualified (unAnn q)) return $ tryResolveName q++-- | Resolve a newtype constructor.+lookupNewtypeConst :: S.QName -> Compile (Maybe (Maybe N.QName,N.Type))+lookupNewtypeConst n = do+  let mName = tryResolveName n+  case mName of     Nothing -> return Nothing-    Just (_,dname,ty) -> return $ Just (dname,ty)+    Just name -> do+      newtypes <- gets stateNewtypes+      case find (\(cname,_,_) -> cname == name) newtypes of+        Nothing -> return Nothing+        Just (_,dname,ty) -> return $ Just (dname,ty) -lookupNewtypeDest :: QName -> Compile (Maybe (QName,Type))-lookupNewtypeDest name = do+-- | Resolve a newtype destructor.+lookupNewtypeDest :: S.QName -> Compile (Maybe (N.QName,N.Type))+lookupNewtypeDest n = do+  let mName = tryResolveName n   newtypes <- gets stateNewtypes-  case find (\(_,dname,_) -> dname == Just name) newtypes of+  case find (\(_,dname,_) -> dname == mName) newtypes of     Nothing -> return Nothing     Just (cname,_,ty) -> return $ Just (cname,ty)  -- | Qualify a name for the current module.-qualify :: Name -> Compile QName-qualify name = do+qualify :: Name a -> Compile N.QName+qualify (Ident _ name) = do   modulename <- gets stateModuleName-  return (Qual modulename name)+  return (Qual () modulename (Ident () name))+qualify (Symbol _ name) = do+  modulename <- gets stateModuleName+  return (Qual () modulename (Symbol () name))  -- | Qualify a QName for the current module if unqualified.-qualifyQName :: QName -> Compile QName-qualifyQName (UnQual name) = qualify name-qualifyQName n             = return n+qualifyQName :: QName a -> Compile N.QName+qualifyQName (UnQual _ name) = qualify name+qualifyQName (unAnn -> n)    = return n  -- | Make a top-level binding.-bindToplevel :: SrcLoc -> Bool -> Name -> JsExp -> Compile JsStmt-bindToplevel srcloc toplevel name expr = do-  qname <- (if toplevel then qualify else return . UnQual) name-  return (JsMappedVar srcloc (JsNameVar qname) expr)---- | Create a temporary environment and discard it after the given computation.-withModuleScope :: Compile a -> Compile a-withModuleScope m = do-  scope <- gets stateModuleScope-  value <- m-  modify $ \s -> s { stateModuleScope = scope }-  return value---- | Create a temporary scope and discard it after the given computation.-withScope :: Compile a -> Compile a-withScope m = do-  scope <- gets stateLocalScope-  value <- m-  modify $ \s -> s { stateLocalScope = scope }-  return value---- | Run a compiler and just get the scope information.-generateScope :: Compile a -> Compile ()-generateScope m = do-  st <- get-  _ <- m-  scope <- gets stateLocalScope-  put st { stateLocalScope = scope }---- | Bind a variable in the current scope.-bindVar :: Name -> Compile ()-bindVar name = do-  modify $ \s -> s { stateLocalScope = S.insert name (stateLocalScope s) }---- | Emit exported names.-emitExport :: ExportSpec -> Compile ()-emitExport spec = case spec of-  EVar (UnQual n) -> emitVar n-  EVar q@Qual{} -> modify $ addCurrentExport q-  EThingAll (UnQual name) -> do-    emitVar name-    r <- lookup (UnQual name) <$> gets stateRecords-    maybe (return ()) (mapM_ (emitVar . unQName)) r-  EThingWith (UnQual name) ns -> do-    emitVar name-    mapM_ emitCName ns-  EAbs _ -> return () -- Type only, skip-  EModuleContents mod ->-    mapM_ (emitExport . EVar) =<< ModuleScope.moduleLocals mod <$> gets stateModuleScope--  -- Skip qualified exports for type exports in fay-base since-  -- qualified imports are not supported yet an error will be thrown-  -- on the import so hopefully this won't be confusing.-  EThingAll (Qual _ _) -> return ()-  e -> do-    liftIO (print e)-    throwError $ UnsupportedExportSpec e- where-   emitVar = return . UnQual >=> resolveName >=> emitExport . EVar-   emitCName (VarName n) = emitVar n-   emitCName (ConName n) = emitVar n-   unQName (UnQual u) = u-   unQName _ = error "unQName Qual or Special -- should never happen"+bindToplevel :: Bool -> Maybe SrcSpan -> Name a -> JsExp -> Compile JsStmt+bindToplevel toplevel msrcloc (unAnn -> name) expr =+  if toplevel+    then do+      mod <- gets stateModuleName+      return $ JsSetQName msrcloc (Qual () mod name) expr+    else return $ JsVar (JsNameVar $ UnQual () name) expr  -- | Force an expression in a thunk. force :: JsExp -> JsExp@@ -177,25 +145,27 @@ isConstant _       = False  -- | Deconstruct a parse result (a la maybe, foldr, either).-parseResult :: ((SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b+parseResult :: ((F.SrcLoc,String) -> b) -> (a -> b) -> ParseResult a -> b parseResult die ok result = case result of   ParseOk a -> ok a   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@@ -206,15 +176,20 @@ throwExp msg expr = JsThrowExp (JsList [JsLit (JsStr msg),expr])  -- | Is an alt a wildcard?-isWildCardAlt :: Alt -> Bool+isWildCardAlt :: S.Alt -> Bool isWildCardAlt (Alt _ pat _ _) = isWildCardPat pat  -- | Is a pattern a wildcard?-isWildCardPat :: Pat -> Bool+isWildCardPat :: S.Pat -> Bool isWildCardPat PWildCard{} = True isWildCardPat PVar{}      = True isWildCardPat _           = False +-- | Return formatter string if expression is a FFI call.+ffiExp :: Exp a -> Maybe String+ffiExp (App _ (Var _ (UnQual _ (Ident _ "ffi"))) (Lit _ (String _ formatstr _))) = Just formatstr+ffiExp _ = Nothing+ -- | Generate a temporary, SCOPED name for testing conditions and -- such. withScopedTmpJsName :: (JsName -> Compile a) -> Compile a@@ -227,32 +202,49 @@  -- | Generate a temporary, SCOPED name for testing conditions and -- such. We don't have name tracking yet, so instead we use this.-withScopedTmpName :: (Name -> Compile a) -> Compile a+withScopedTmpName :: (S.Name -> Compile a) -> Compile a withScopedTmpName withName = do   depth <- gets stateNameDepth   modify $ \s -> s { stateNameDepth = depth + 1 }-  ret <- withName $ Ident $ "$gen" ++ show depth+  ret <- withName $ Ident S.noI $ "$gen" ++ show depth   modify $ \s -> s { stateNameDepth = depth }   return ret  -- | Print out a compiler warning. warn :: String -> Compile () warn "" = return ()-warn w = do-  shouldWarn <- config configWarn-  when shouldWarn . liftIO . hPutStrLn stderr $ "Warning: " ++ w+warn w = config id >>= io . (`ioWarn` w) +ioWarn :: Config -> String -> IO ()+ioWarn _ "" = return ()+ioWarn cfg w =+  when (configWall cfg) $+    hPutStrLn stderr $ "Warning: " ++ w+ -- | Pretty print a source location.-printSrcLoc :: SrcLoc -> String+printSrcLoc :: S.SrcLoc -> String printSrcLoc SrcLoc{..} = srcFilename ++ ":" ++ show srcLine ++ ":" ++ show srcColumn +printSrcSpanInfo :: SrcSpanInfo -> String+printSrcSpanInfo (SrcSpanInfo a b) = concat $ printSrcSpan a : map printSrcSpan b++printSrcSpan :: SrcSpan -> String+printSrcSpan SrcSpan{..} = srcSpanFilename ++ ": (" ++ show srcSpanStartLine ++ "," ++ show srcSpanStartColumn ++ ")-(" ++ show srcSpanEndLine ++ "," ++ show srcSpanEndColumn ++ ")"++ -- | Lookup the record for a given type name.-typeToRecs :: QName -> Compile [QName]-typeToRecs typ = fromMaybe [] . lookup typ <$> gets stateRecordTypes+typeToRecs :: QName a -> Compile [N.QName]+typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes +recToFields :: S.QName -> Compile [N.Name]+recToFields con =+  case tryResolveName con of+    Nothing -> return []+    Just c -> fromMaybe [] . lookup c <$> gets stateRecords+ -- | Get the fields for a given type.-typeToFields :: QName -> Compile [QName]-typeToFields typ = do+typeToFields :: QName a -> Compile [N.Name]+typeToFields (unAnn -> typ) = do   allrecs <- gets stateRecords   typerecs <- typeToRecs typ   return . concatMap snd . filter ((`elem` typerecs) . fst) $ allrecs@@ -270,89 +262,37 @@   where     readVersion = listToMaybe . filter (null . snd) . readP_to_S parseVersion --- | Find an import's filepath and contents from its module name.-findImport :: [FilePath] -> ModuleName -> Compile (FilePath,String)-findImport alldirs mname = go alldirs mname where-  go (dir:dirs) name = do-    exists <- io (doesFileExist path)-    if exists-      then fmap (path,) (fmap stdlibHack (io (readFile path)))-      else go dirs name-    where-      path = dir </> replace '.' '/' (prettyPrint name) ++ ".hs"-      replace c r = map (\x -> if x == c then r else x)-  go [] name =-    throwError $ Couldn'tFindImport name alldirs--  stdlibHack-    | mname == ModuleName "Language.Fay.Stdlib" = \s -> s ++ "\n\ndata Maybe a = Just a | Nothing"-    | mname == ModuleName "Language.Fay.FFI"    = const "module Language.Fay.FFI where\n\ndata Nullable a = Nullable a | Null\n\ndata Defined a = Defined a | Undefined"-    | otherwise = id---- | Convert a GADT to a normal data type.-convertGADT :: GadtDecl -> QualConDecl-convertGADT d =-  case d of-    GadtDecl srcloc name typ -> QualConDecl srcloc tyvars context-                                            (ConDecl name (convertFunc typ))-  where tyvars = []-        context = []-        convertFunc (TyCon _) = []-        convertFunc (TyFun x xs) = UnBangedTy x : convertFunc xs-        convertFunc (TyParen x) = convertFunc x-        convertFunc _ = []+-- | Run the top level compilation for all modules.+runTopCompile+  :: CompileReader+  -> CompileState+  -> Compile a+  -> IO (Either CompileError (a,CompileState,CompileWriter))+runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state')) --- | Run the compiler.-runCompile :: CompileReader -> CompileState-           -> Compile a-           -> IO (Either CompileError (a,CompileState,CompileWriter))-runCompile reader' state' m = runErrorT (runRWST (unCompile m) reader' state')+-- | Runs compilation for a single module.+runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a+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'+    flattenPragmas :: [ModulePragma l] -> [String]+    flattenPragmas = concatMap pragmaName+    pragmaName (LanguagePragma _ q) = map unname q+    pragmaName _ = [] --- | The CPP's parsing state.-data CPPState = NoCPP-              | CPPIf Bool CPPState-              | CPPElse Bool CPPState+hasLanguagePragma :: String -> [ModulePragma l] -> Bool+hasLanguagePragma pr = hasLanguagePragmas [pr] --- | The parse mode for Fay.-parseMode :: ParseMode-parseMode = defaultParseMode-  { extensions = [GADTs-                 ,StandaloneDeriving-                 ,PackageImports-                 ,EmptyDataDecls-                 ,TypeOperators-                 ,RecordWildCards-                 ,NamedFieldPuns]-  , fixities = Just (preludeFixities ++ baseFixities)-  }+-- | 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/ModuleScope.hs 
@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Handles variable bindings on the module level and also keeps track of--- primitive operations that we want to treat specially.--module Fay.Compiler.ModuleScope-  (ModuleScope-  ,bindAsLocals-  ,findTopLevelNames-  ,resolveName-  ,moduleLocals)-  where--import           Control.Arrow-import           Control.Monad.Reader-import           Control.Monad.Writer-import           Data.Default-import           Data.Map (Map)-import qualified Data.Map as M-import           Language.Haskell.Exts hiding (name, binds)-import           Prelude hiding (mod)---- | Maps names bound in the module to their real names--- The keys are unqualified for locals and imports,--- the values are always fully qualified--- Example contents:---   [ (UnQUal     "main"      , Qual "Main"     "main")---   , (UnQual     "take"      , Qual "Prelude"  "take")---   , (  Qual "M" "insertWith", Qual "Data.Map" "insertWith") ]-newtype ModuleScope = ModuleScope (Map QName QName)-  deriving Show--instance Monoid ModuleScope where-  mempty                                  = ModuleScope M.empty-  mappend (ModuleScope a) (ModuleScope b) = ModuleScope $ a `M.union` b--instance Default ModuleScope where-  def = mempty---- | Find the path of a locally bound name--- Returns special values in the "Fay$" module for primOps-resolveName :: QName -> ModuleScope -> Maybe QName-resolveName q (ModuleScope binds) = case M.lookup q binds of -- lookup in the module environment.--  -- something pointing to prelude, is it a primop?-  Just q'@(Qual (ModuleName "Prelude") n) -> case M.lookup n envPrimOpsMap of-    Just x  -> Just x  -- A primop which looks like it's imported from prelude.-    Nothing -> Just q' -- Regular prelude import, leave it as is.--  -- No matches in the current environment, so it may be a primop if it's unqualified.-  -- If Nothing is returned from either of the branches it means that there is-  -- no primop and nothing in env scope so GHC would have given an error.-  Nothing -> case q of-    UnQual n -> M.lookup n envPrimOpsMap-    _        -> Nothing-  j -> j -- Non-prelude import that was found in the env---- | Bind a list of names into the local scope--- Right now all bindings are made unqualified-bindAsLocals :: [QName] -> ModuleScope -> ModuleScope-bindAsLocals qs (ModuleScope binds) =-  -- This needs to be changed to not use unqual to support qualified imports.-  ModuleScope $ binds `M.union` M.fromList (map (unqual &&& id) qs)-    where unqual (Qual _ n) = (UnQual n)-          unqual u@UnQual{} = u-          unqual Special{}  = error "fay: ModuleScope.bindAsLocals: Special"---- | Find all names that are bound locally in this module, which excludes imports.-moduleLocals :: ModuleName -> ModuleScope -> [QName]-moduleLocals mod (ModuleScope binds) = filter isLocal . M.elems $ binds-  where-    isLocal (Qual m _) = mod == m-    isLocal _ = False------------------------------------------------------------------------------------- Primitive Operations---- | The built-in operations that aren't actually compiled from--- anywhere, they come from runtime.js.------ They're in the names list so that they can be overriden by the user--- in e.g. let a * b = a - b in 1 * 2.------ So we resolve them to Fay$, i.e. the prefix used for the runtime--- support. $ is not allowed in Haskell module names, so there will be--- no conflicts if a user decicdes to use a module named Fay.------ So e.g. will compile to (*) Fay$$mult, which is in runtime.js.-envPrimOpsMap :: Map Name QName-envPrimOpsMap = M.fromList-  [ (Symbol ">>",    (Qual (ModuleName "Fay$") (Ident "then")))-  , (Symbol ">>=",   (Qual (ModuleName "Fay$") (Ident "bind")))-  , (Ident "return", (Qual (ModuleName "Fay$") (Ident "return")))-  , (Ident "force",  (Qual (ModuleName "Fay$") (Ident "force")))-  , (Ident "seq",    (Qual (ModuleName "Fay$") (Ident "seq")))-  , (Symbol "*",     (Qual (ModuleName "Fay$") (Ident "mult")))-  , (Symbol "+",     (Qual (ModuleName "Fay$") (Ident "add")))-  , (Symbol "-",     (Qual (ModuleName "Fay$") (Ident "sub")))-  , (Symbol "/",     (Qual (ModuleName "Fay$") (Ident "divi")))-  , (Symbol "==",    (Qual (ModuleName "Fay$") (Ident "eq")))-  , (Symbol "/=",    (Qual (ModuleName "Fay$") (Ident "neq")))-  , (Symbol ">",     (Qual (ModuleName "Fay$") (Ident "gt")))-  , (Symbol "<",     (Qual (ModuleName "Fay$") (Ident "lt")))-  , (Symbol ">=",    (Qual (ModuleName "Fay$") (Ident "gte")))-  , (Symbol "<=",    (Qual (ModuleName "Fay$") (Ident "lte")))-  , (Symbol "&&",    (Qual (ModuleName "Fay$") (Ident "and")))-  , (Symbol "||",    (Qual (ModuleName "Fay$") (Ident "or")))-  ]------------------------------------------------------------------------------------- AST--type ModuleScopeSt = ReaderT ModuleName (Writer ModuleScope) ()---- | Get module level names from a haskell module AST.-findTopLevelNames :: ModuleName -> [Decl] -> ModuleScope-findTopLevelNames mod decls = snd . runWriter $ runReaderT (mapM_ d_decl decls) mod--bindName :: Name -> ModuleScopeSt-bindName k = ask >>= \mod -> tell (ModuleScope $ M.singleton (UnQual k) (Qual mod k))--d_decl :: Decl -> ModuleScopeSt-d_decl d = case d of-  DataDecl _ _ _ _ _ dd _         -> mapM_ d_qualCon dd-  PatBind _ (PVar n) _ _ _        -> bindName n-  FunBind (Match _ n _ _ _ _ : _) -> bindName n-  ClassDecl _ _ _ _ _ cds         -> mapM_ d_classDecl cds-  TypeSig _ ns _                  -> mapM_ bindName ns-  _                               -> return ()--d_classDecl :: ClassDecl -> ModuleScopeSt-d_classDecl cd = case cd of-  ClsDecl d -> d_decl d-  _         -> return ()--d_qualCon :: QualConDecl -> ModuleScopeSt-d_qualCon (QualConDecl _ _ _ cd) = case cd of-  ConDecl n _        -> bindName n-  InfixConDecl _ n _ -> bindName n-  RecDecl n ns       -> bindName n >> mapM_ bindName (concatMap fst ns)
+ 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,31 +1,28 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards     #-}+{-# LANGUAGE TupleSections     #-}  -- | Optimizing the outputted JavaScript(-ish) AST.  module Fay.Compiler.Optimizer where -import Fay.Compiler.Misc+import           Fay.Compiler.Prelude -import Control.Applicative-import Control.Arrow (first)-import Control.Monad.Error-import Control.Monad.Writer-import Control.Monad.State-import Data.List-import Data.Maybe-import Fay.Types-import Language.Haskell.Exts (QName(..),ModuleName(..),Name(..))+import           Fay.Compiler.Misc+import           Fay.Types -import Prelude hiding (exp)+import           Control.Monad.State             (State, modify, runState)+import           Control.Monad.Writer            (runWriter, tell)+import qualified Fay.Exts.NoAnnotation           as N+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 -- abstraction. So \x y z -> if x then (\a -> a) else (\a -> a) has an -- arity of 3, not 4.-type FuncArity = (QName,Int)+type FuncArity = (N.QName,Int)  -- | Optimize monad. type Optimize = State OptState@@ -33,62 +30,60 @@ -- | State. data OptState = OptState   { optStmts   :: [JsStmt]-  , optUncurry :: [QName]+  , optUncurry :: [N.QName]   }  -- | Run an optimizer, which may output additional statements. runOptimizer :: ([JsStmt] -> Optimize [JsStmt]) -> [JsStmt] -> [JsStmt] runOptimizer optimizer stmts =   let (newstmts,OptState _ uncurried) = flip runState st $ optimizer stmts-  in (newstmts ++ (tco (catMaybes (map (uncurryBinding newstmts) (nub uncurried)))))+  in newstmts ++ (tco . mapMaybe (uncurryBinding newstmts) $ nub uncurried)   where st = OptState stmts []  -- | Inline x >> y to x;y in the JS output. inlineMonad :: [JsStmt] -> [JsStmt] inlineMonad = map go where-  go stmt =-    case stmt of-      JsVar name exp          -> JsVar name (inline exp)-      JsMappedVar a name exp  -> JsMappedVar a name (inline exp)-      JsIf exp stmts stmts'   -> JsIf (inline exp) (map go stmts) (map go stmts')-      JsEarlyReturn exp       -> JsEarlyReturn (inline exp)-      JsThrow exp             -> JsThrow (inline exp)-      JsWhile exp stmts       -> JsWhile (inline exp) (map go stmts)-      JsUpdate name exp       -> JsUpdate name (inline exp)-      JsSetProp a b exp       -> JsSetProp a b (inline exp)-      JsSetPropExtern a b exp -> JsSetPropExtern a b (inline exp)-      JsContinue              -> JsContinue-      JsBlock stmts           -> JsBlock (map go stmts)-      JsExpStmt exp           -> JsExpStmt (inline exp)+  go stmt = case stmt of+    JsVar name exp          -> JsVar name (inline exp)+    JsIf exp stmts stmts'   -> JsIf (inline exp) (map go stmts) (map go stmts')+    JsEarlyReturn exp       -> JsEarlyReturn (inline exp)+    JsThrow exp             -> JsThrow (inline exp)+    JsWhile exp stmts       -> JsWhile (inline exp) (map go stmts)+    JsUpdate name exp       -> JsUpdate name (inline exp)+    JsSetProp a b exp       -> JsSetProp a b (inline exp)+    JsSetQName s a exp      -> JsSetQName s a (inline exp)+    JsSetModule a exp       -> JsSetModule a (inline exp)+    JsSetConstructor a exp  -> JsSetConstructor a (inline exp)+    JsSetPropExtern a b exp -> JsSetPropExtern a b (inline exp)+    JsContinue              -> JsContinue+    JsBlock stmts           -> JsBlock (map go stmts)+    JsExpStmt exp           -> JsExpStmt (inline exp) -  inline expr =-    case expr of-      -- Optimizations-      JsApp op args -> case flatten expr of-        Nothing -> JsApp (inline op) (map inline args)-        Just x  -> x+  inline expr = case expr of+    -- Optimizations+    JsApp op args -> fromMaybe (JsApp (inline op) $ map inline args) (flatten expr) -      -- Plumbing-      JsFun names stmts mexp           -> JsFun names (map go stmts) (fmap inline mexp)+    -- Plumbing+    JsFun nm names stmts mexp        -> JsFun nm names (map go stmts) (fmap inline mexp) -      JsNegApp exp                     -> JsNegApp (inline exp)-      JsTernaryIf exp1 exp2 exp3       -> JsTernaryIf (inline exp1) (inline exp2) (inline exp3)-      JsParen exp                      -> JsParen (inline exp)-      JsGetProp exp name               -> JsGetProp (inline exp) name-      JsLookup exp exp2                -> JsLookup (inline exp) (inline exp2)-      JsUpdateProp exp name exp2       -> JsUpdateProp (inline exp) name (inline exp2)-      JsGetPropExtern exp string       -> JsGetPropExtern (inline exp) string-      JsUpdatePropExtern exp name exp2 -> JsUpdatePropExtern (inline exp) name (inline exp2)-      JsList exps                      -> JsList (map inline exps)-      JsNew name exps                  -> JsNew name (map inline exps)-      JsThrowExp exp                   -> JsThrowExp (inline exp)-      JsInstanceOf exp name            -> JsInstanceOf (inline exp) name-      JsIndex i exp                    -> JsIndex i (inline exp)-      JsEq exp exp2                    -> JsEq (inline exp) (inline exp2)-      JsNeq exp exp2                   -> JsNeq (inline exp) (inline exp2)-      JsInfix string exp exp2          -> JsInfix string (inline exp) (inline exp2)-      JsObj keyvals                    -> JsObj keyvals-      rest                             -> rest+    JsNegApp exp                     -> JsNegApp (inline exp)+    JsTernaryIf exp1 exp2 exp3       -> JsTernaryIf (inline exp1) (inline exp2) (inline exp3)+    JsParen exp                      -> JsParen (inline exp)+    JsGetProp exp name               -> JsGetProp (inline exp) name+    JsLookup exp exp2                -> JsLookup (inline exp) (inline exp2)+    JsUpdateProp exp name exp2       -> JsUpdateProp (inline exp) name (inline exp2)+    JsGetPropExtern exp string       -> JsGetPropExtern (inline exp) string+    JsUpdatePropExtern exp name exp2 -> JsUpdatePropExtern (inline exp) name (inline exp2)+    JsList exps                      -> JsList (map inline exps)+    JsNew name exps                  -> JsNew name (map inline exps)+    JsThrowExp exp                   -> JsThrowExp (inline exp)+    JsInstanceOf exp name            -> JsInstanceOf (inline exp) name+    JsIndex i exp                    -> JsIndex i (inline exp)+    JsEq exp exp2                    -> JsEq (inline exp) (inline exp2)+    JsNeq exp exp2                   -> JsNeq (inline exp) (inline exp2)+    JsInfix string exp exp2          -> JsInfix string (inline exp) (inline exp2)+    JsObj keyvals                    -> JsObj keyvals+    rest                             -> rest  -- | Flatten a a>>(b>>c) to [a,b,c]. flatten :: JsExp -> Maybe JsExp@@ -99,18 +94,19 @@  -- | Try to collect nested a>>(b>>c). collect :: JsExp -> Maybe [JsExp]-collect exp =-  case exp of-    JsApp op args | isThen op -> do-      case args of-        [rest,x] -> do xs <- collect rest-                       return (x : xs)-        [x]  -> return [x]-        _ -> Nothing-    _ -> return [exp]+collect exp = case exp of+  JsApp op args | isThen op ->+    case args of+      [rest,x] -> (x :) <$> collect rest+      [x]  -> return [x]+      _ -> Nothing+  _ -> return [exp] -  where isThen = (== JsName (JsNameVar (Qual (ModuleName "Fay$") (Ident "then$uncurried"))))+  where+    isThen (JsName (JsNameVar (Qual _ (ModuleName _ m) (Ident _ n)))) = m == "Fay$" && n == "then$uncurried"+    isThen _ = False + -- | Perform any top-level cross-module optimizations and GO DEEP to -- optimize further. optimizeToplevel :: [JsStmt] -> Optimize [JsStmt]@@ -120,16 +116,16 @@ tco :: [JsStmt] -> [JsStmt] tco = map inStmt where   inStmt stmt = case stmt of-    JsMappedVar srcloc name exp -> JsMappedVar srcloc name (inject name exp)     JsVar name exp -> JsVar name (inject name exp)+    JsSetQName l name exp -> JsSetQName l name (inject (JsNameVar name) exp)     e -> e   inject name exp = case exp of-    JsFun params [] (Just (JsNew JsThunk [JsFun [] stmts ret])) ->-      JsFun params+    JsFun nm params [] (Just (JsNew JsThunk [JsFun _ [] stmts ret])) ->+      JsFun nm params             []             (Just               (JsNew JsThunk-                     [JsFun []+                     [JsFun Nothing []                             (optimize params name (stmts ++ [ JsEarlyReturn e | Just e <- [ret] ]))                             Nothing]))     _ -> exp@@ -163,14 +159,14 @@   stripFuncForces arities exp = case exp of     JsApp (JsName JsForce) [JsName (JsNameVar f)]       | Just _ <- lookup f arities -> return (JsName (JsNameVar f))-    JsFun ps stmts body            -> do substmts <- mapM stripInStmt stmts+    JsFun nm ps stmts body         -> do substmts <- mapM stripInStmt stmts                                          sbody <- maybe (return Nothing) (fmap Just . go) body-                                         return (JsFun ps substmts sbody)+                                         return (JsFun nm ps substmts sbody)     JsApp a b                      -> do       result <- walkAndStripForces arities exp       case result of-        Just strippedExp             -> go strippedExp-        Nothing                      -> JsApp <$> go a <*> mapM go b+        Just strippedExp           -> go strippedExp+        Nothing                    -> JsApp <$> go a <*> mapM go b     JsNegApp e                     -> JsNegApp <$> go e     JsTernaryIf a b c              -> JsTernaryIf <$> go a <*> go b <*> go c     JsParen e                      -> JsParen <$> go e@@ -190,12 +186,14 @@ walkAndStripForces :: [FuncArity] -> JsExp -> Optimize (Maybe JsExp) walkAndStripForces arities = go True [] where   go frst args app = case app of-    JsApp (JsName JsForce) [e] -> if frst-                                     then do result <- go False args e-                                             case result of-                                               Nothing -> return Nothing-                                               Just ex -> return (Just (JsApp (JsName JsForce) [ex]))-                                     else go False args e+    JsApp (JsName JsForce) [e] ->+      if frst+        then do+          result <- go False args e+          case result of+            Nothing -> return Nothing+            Just ex -> return (Just (JsApp (JsName JsForce) [ex]))+        else go False args e     JsApp op [arg] -> go False (arg:args) op     JsName (JsNameVar f)       | Just arity <- lookup f arities, length args == arity -> do@@ -211,11 +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-    JsMappedVar srcloc name exp -> JsMappedVar srcloc name <$> transform exp     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,46 +222,45 @@  -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity]-collectFuncs = (++ prim) . concat . map collectFunc where-  collectFunc (JsMappedVar _ name exp) = collectFunc (JsVar name exp)-  collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)]+collectFuncs = (++ prim) . concatMap collectFunc where+  collectFunc (JsSetQName _ name exp) | arity > 0 = [(name,arity)]     where arity = expArity exp   collectFunc _ = []-  prim = map (first (Qual (ModuleName "Fay$"))) (unary ++ binary)-  unary = map (,1) [Ident "return"]-  binary = map ((,2) . Ident)+  prim = map (first (Qual () (ModuleName () "Fay$"))) (unary ++ binary)+  unary = map (,1) [Ident () "return"]+  binary = map ((,2) . Ident ())                ["then","bind","mult","mult","add","sub","div"                ,"eq","neq","gt","lt","gte","lte","and","or"]  -- | Get the arity of an expression. expArity :: JsExp -> Int-expArity (JsFun _ _ mexp) = 1 + maybe 0 expArity mexp+expArity (JsFun _ _ _ mexp) = 1 + maybe 0 expArity mexp expArity _ = 0  -- | Change foo(x)(y) to foo$uncurried(x,y).-uncurryBinding :: [JsStmt] -> QName -> Maybe JsStmt+uncurryBinding :: [JsStmt] -> N.QName -> Maybe JsStmt uncurryBinding stmts qname = listToMaybe (mapMaybe funBinding stmts)   where     funBinding stmt = case stmt of-      JsMappedVar srcloc (JsNameVar name) body-        | name == qname -> JsMappedVar srcloc (JsNameVar (renameUncurried name)) <$> uncurryIt body       JsVar (JsNameVar name) body         | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body+      JsSetQName l name body+        | name == qname -> JsSetQName l (renameUncurried name) <$> uncurryIt body       _ -> Nothing      uncurryIt = Just . go [] where       go args exp = case exp of-        JsFun [arg] [] (Just body) -> go (arg : args) body-        inner -> JsFun (reverse args) [] (Just inner)+        JsFun _ [arg] [] (Just body) -> go (arg : args) body+        inner -> JsFun Nothing (reverse args) [] (Just inner)  -- | Rename an uncurried copy of a curried function.-renameUncurried :: QName -> QName+renameUncurried :: N.QName -> N.QName renameUncurried q = case q of-  Qual m n -> Qual m (renameUnQual n)-  UnQual n -> UnQual (renameUnQual n)+  Qual _ m n -> Qual () m (renameUnQual n)+  UnQual _ n -> UnQual () (renameUnQual n)   s -> s   where     renameUnQual n = case n of-      Ident nom -> Ident (nom ++ postfix)-      Symbol nom -> Symbol (nom ++ postfix)+      Ident _ nom -> Ident () (nom ++ postfix)+      Symbol _ nom -> Symbol () (nom ++ postfix)     postfix = "$uncurried"
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.Types-import Fay.Compiler.Config+import           Fay.Compiler.Prelude -import Control.Applicative-import Control.Monad-import Control.Monad.Extra-import Data.Maybe-import Data.List-import Data.Version-import GHC.Paths-import Paths_fay-import System.Directory-import System.FilePath-import System.Process.Extra+import           Fay.Config+import           Paths_fay +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 = do+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@@ -38,11 +33,14 @@                     else fmap ($ nameVer) getShareGen       let includes = [shareDir,shareDir </> "src"]       exists <- mapM doesSourceDirExist includes-      if any id exists+      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,13 +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 -> 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 = concat [["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,172 +1,164 @@-{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Compile pattern matches.  module Fay.Compiler.Pattern where -import Fay.Compiler.Misc-import Fay.Types+import           Fay.Compiler.Prelude -import Control.Monad.Error-import Control.Monad.State-import Control.Monad.Reader-import Data.List-import Data.Maybe-import Language.Haskell.Exts+import           Fay.Compiler.Misc+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.Types +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 -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePat exp pat body =-  case pat of-    PVar name       -> compilePVar name exp body-    PApp cons pats  -> do-      qcons <- qualifyQName cons-      newty <- lookupNewtypeConst qcons-      case newty of-        Nothing -> compilePApp cons pats exp body-        Just _  -> compileNewtypePat pats exp body-    PLit literal    -> compilePLit exp literal body-    PParen pat      -> compilePat exp pat body-    PWildCard       -> return body-    pat@PInfixApp{} -> compileInfixPat exp pat body-    PList pats      -> compilePList pats body exp-    PTuple pats     -> compilePList pats body exp-    PAsPat name pat -> compilePAsPat exp name pat body-    PRec name pats  -> compilePatFields exp name pats body-    pat             -> throwError (UnsupportedPattern pat)+compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt]+compilePat exp pat body = case pat of+  PVar _ name       -> compilePVar name exp body+  PApp _ cons pats  -> do+    newty <- lookupNewtypeConst cons+    case newty of+      Nothing -> compilePApp pat cons pats exp body+      Just _  -> compileNewtypePat pats exp body+  PLit _ sign lit   -> compilePLit exp sign lit body+  PWildCard _       -> return body+  PList _ pats      -> compilePList pats body exp+  PTuple _ _bx pats -> compilePList pats body exp+  PAsPat _ name pt  -> compilePAsPat exp name pt body+  PRec _ name pats  -> compilePatFields exp name pats body+  PParen{}          -> shouldBeDesugared pat+  PInfixApp{}       -> shouldBeDesugared pat+  _                 -> throwError (UnsupportedPattern pat)  -- | Compile a pattern variable e.g. x.-compilePVar :: Name -> JsExp -> [JsStmt] -> Compile [JsStmt]-compilePVar name exp body = do-  bindVar name-  return $ JsVar (JsNameVar (UnQual name)) exp : body+compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt]+compilePVar (unAnn -> name) exp body =+  return $ JsVar (JsNameVar (UnQual () name)) exp : body  -- | Compile a record field pattern.-compilePatFields :: JsExp -> QName -> [PatField] -> [JsStmt] -> Compile [JsStmt]+compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do-    c <- liftM (++ body) (compilePats' [] pats)-    qname <- resolveName name-    return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]-  where -- compilePats' collects field names that had already been matched so that-        -- wildcard generates code for the rest of the fields.-        compilePats' :: [QName] -> [PatField] -> Compile [JsStmt]-        compilePats' names (PFieldPun name:xs) =-          compilePats' names (PFieldPat (UnQual name) (PVar name):xs)--        compilePats' names (PFieldPat fieldname (PVar varName):xs) = do-          r <- compilePats' (fieldname : names) xs-          bindVar varName-          return $ JsVar (JsNameVar (UnQual varName))-                         (JsGetProp (force exp) (JsNameVar fieldname))-                   : r -- TODO: think about this force call+  c <- (++ body) <$> compilePats' [] pats+  qname <- unsafeResolveName name+  return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []]+  where+    -- compilePats' collects field names that had already been matched so that+      -- wildcard generates code for the rest of the fields.+      compilePats' :: [S.QName] -> [S.PatField] -> Compile [JsStmt]+      compilePats' _ (p@PFieldPun{}:_) = shouldBeDesugared p+      compilePats' names (PFieldPat _ fieldname (PVar _ (unAnn -> varName)):xs) = do+        r <- compilePats' (fieldname : names) xs+        return $ JsVar (JsNameVar (UnQual () varName))+                       (JsGetProp (force exp) (JsNameVar (unQualify $ unAnn fieldname)))+                 : r -- TODO: think about this force call -        compilePats' names (PFieldWildcard:xs) = do-          records <- liftM stateRecords get-          let fields = fromJust (lookup name records)-              fields' = fields \\ names-          f <- mapM (\fieldName -> do bindVar (unQual fieldName)-                                      return (JsVar (JsNameVar fieldName)-                                             (JsGetProp (force exp) (JsNameVar fieldName))))-                   fields'-          r <- compilePats' names xs-          return $ f ++ r+      compilePats' names (PFieldWildcard (wildcardFields -> fields):xs) = do+        f <- forM fields $ \fieldName ->+          return $ JsVar (JsNameVar fieldName)+                         (JsGetProp (force exp) (JsNameVar fieldName))+        r <- compilePats' names xs+        return $ f ++ r -        compilePats' _ [] = return []+      compilePats' _ [] = return [] -        compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat)+      compilePats' _ (pat:_) = throwError (UnsupportedFieldPattern pat) -        unQual (Qual _ n) = n-        unQual (UnQual n) = n-        unQual Special{} = error "Trying to unqualify a Special..."+      wildcardFields :: S.X -> [N.QName]+      wildcardFields l = case l of+        Scoped (RecPatWildcard es) _ -> map (unQualify . origName2QName) es+        _ -> []  -- | Compile a literal value from a pattern match.-compilePLit :: JsExp -> 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                []] -  where -- Equality test for two expressions, with some optimizations.-        equalExps :: JsExp -> JsExp -> JsExp-        equalExps a b-          | isConstant a && isConstant b = JsEq a b-          | isConstant a = JsEq a (force b)-          | isConstant b = JsEq (force a) b-          | otherwise =-             JsApp (JsName (JsBuiltIn "equal")) [a,b]+  where+    -- Equality test for two expressions, with some optimizations.+    equalExps :: JsExp -> JsExp -> JsExp+    equalExps a b+      | isConstant a && isConstant b = JsEq a b+      | isConstant a = JsEq a (force b)+      | isConstant b = JsEq (force a) b+      | otherwise =+         JsApp (JsName (JsBuiltIn "equal")) [a,b]  -- | Compile as binding in pattern match-compilePAsPat :: JsExp -> Name -> Pat -> [JsStmt] -> Compile [JsStmt]-compilePAsPat exp name pat body = do-  bindVar name-  x <- compilePat exp pat body-  return ([JsVar (JsNameVar (UnQual name)) exp] ++ x)+compilePAsPat :: JsExp -> S.Name -> S.Pat -> [JsStmt] -> Compile [JsStmt]+compilePAsPat exp (unAnn -> name) pat body = do+  p <- compilePat exp pat body+  return $ JsVar (JsNameVar $ UnQual () name) exp : p -compileNewtypePat :: [Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt]+-- | Compile a pattern match on a newtype.+compileNewtypePat :: [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] compileNewtypePat [pat] exp body = compilePat exp pat body compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps  -- | Compile a pattern application.-compilePApp :: QName -> [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)-    UnQual "True"   -> boolIf True-    UnQual "False"  -> boolIf False+    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:-    _ -> do-      rf <- fmap (lookup cons) (gets stateRecords)-      let recordFields =-            fromMaybe-              (error $ "Constructor '" ++ prettyPrint cons ++-                       "' was not found in stateRecords, did you try running this through GHC first?")-              rf-      substmts <- foldM (\body (field,pat) ->-                             compilePat (JsGetProp forcedExp (JsNameVar field)) pat body)-                  body-                  (reverse (zip recordFields pats))-      qcons <- resolveName cons-      return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)-                   substmts-                   []]+    n -> do+      let n' = tryResolveName n+      case n' of+        Nothing -> error $ "Constructor '" ++ prettyPrint n ++ "' could not be resolved"+        Just _ -> do+          recordFields <- map (UnQual ()) <$> recToFields n+          substmts <- foldM (\bd (field,pat) ->+                                 compilePat (JsGetProp forcedExp (JsNameVar field)) pat bd)+                      body+                      (reverse (zip recordFields pats))+          qcons <- unsafeResolveName cons+          return [JsIf (forcedExp `JsInstanceOf` JsConstructor qcons)+                       substmts+                       []]  -- | Compile a pattern list.-compilePList :: [Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt]+compilePList :: [S.Pat] -> [JsStmt] -> JsExp -> Compile [JsStmt] compilePList [] body exp =   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 -> Pat -> [JsStmt] -> Compile [JsStmt]-compileInfixPat exp pat@(PInfixApp left (Special cons) right) body =-  case cons of-    Cons -> do-      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
@@ -0,0 +1,71 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}++--------------------------------------------------------------------------------+-- | Primitive Operations+-- Built-in operations that aren't actually compiled from+-- anywhere, they come from runtime.js.+--+-- They're in the names list so that they can be overriden by the user+-- in e.g. let a * b = a - b in 1 * 2.+--+-- So we resolve them to Fay$, i.e. the prefix used for the runtime+-- support. $ is not allowed in Haskell module names, so there will be+-- no conflicts if a user decicdes to use a module named Fay.+--+-- So e.g. will compile to (*) Fay$$mult, which is in runtime.js.++module Fay.Compiler.PrimOp+  ( fayBuiltin+  , findPrimOp+  , 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++-- | Make an identifier from the built-in HJ module.+fayBuiltin :: a -> String -> QName a+fayBuiltin a = Qual a (ModuleName a "Fay$") . Ident a++-- | Mapping from unqualified names to qualified primitive names.+primOpsMap :: Map N.Name N.QName+primOpsMap = M.fromList+  [ (Symbol () ">>",     fayBuiltin () "then")+  , (Symbol () ">>=",    fayBuiltin () "bind")+  , (Ident  () "return", fayBuiltin () "return")+  , (Ident  () "force",  fayBuiltin () "force")+  , (Ident  () "seq",    fayBuiltin () "seq")+  , (Symbol ()  "*",     fayBuiltin () "mult")+  , (Symbol ()  "+",     fayBuiltin () "add")+  , (Symbol ()  "-",     fayBuiltin () "sub")+  , (Symbol ()  "/",     fayBuiltin () "divi")+  , (Symbol ()  "==",    fayBuiltin () "eq")+  , (Symbol ()  "/=",    fayBuiltin () "neq")+  , (Symbol ()  ">",     fayBuiltin () "gt")+  , (Symbol ()  "<",     fayBuiltin () "lt")+  , (Symbol ()  ">=",    fayBuiltin () "gte")+  , (Symbol ()  "<=",    fayBuiltin () "lte")+  , (Symbol ()  "&&",    fayBuiltin () "and")+  , (Symbol ()  "||",    fayBuiltin () "or")+  ]++-- | Lookup a primop that was resolved to a Prelude definition.+findPrimOp :: N.QName -> Maybe N.QName+findPrimOp (Qual _ (ModuleName _ "Prelude") s) = M.lookup s primOpsMap+findPrimOp _ = Nothing++-- | If this is resolved to a Prelude identifier or if it's unqualified,+-- check if it's a primop+resolvePrimOp :: QName a -> Maybe N.QName+resolvePrimOp (unAnn -> q) = case q of+  (Qual _ (ModuleName _ "Prelude") _) -> findPrimOp q+  (UnQual _ n) -> findPrimOp $ Qual () (ModuleName () "Prelude") n+  _ -> Nothing
src/Fay/Compiler/Print.hs view
@@ -1,293 +1,284 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# OPTIONS -fno-warn-unused-do-bind #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE RecordWildCards      #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | 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           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.Syntax-import           Prelude                      hiding (exp)+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 QName where+instance Printable (QName l) where   printJS qname =     case qname of-      Qual moduleName name -> moduleName +> "$" +> name-      UnQual name -> printJS name-      Special con -> printJS con+      Qual _ (ModuleName _ "Fay$") name -> "Fay$$" <> printJS name+      Qual _ moduleName name -> printJS moduleName <> printProp name+      UnQual _ name -> printJS name+      Special _ con -> printJS con --- | Print module name.-instance Printable ModuleName where-  printJS (ModuleName "Fay$") =-    write "Fay$"-  printJS (ModuleName moduleName) = write $ go moduleName+-- | 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 -    where go ('.':xs) = '$' : go xs+-- | Print module name.+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 SpecialCon where+instance Printable (SpecialCon l) where   printJS specialCon =-    printJS $ (Qual (ModuleName "Fay$") . Ident) $+    printJS $ fayBuiltin () $       case specialCon of-        UnitCon -> "unit"-        Cons    -> "cons"-        _       -> error $ "Special constructor not supported: " ++ show specialCon+        UnitCon _ -> "unit"+        Cons    _ -> "cons"+        _         -> error $ "Special constructor not supported: " +++                   show (void specialCon) --- | Print (and properly encode) a name.-instance Printable Name where-  printJS name = write $-    case name of-      Ident ident -> encodeName ident-      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 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 <> " = " <> printJS expr <> ";" <> newline <>+    -- The unqualifiedness here is bad.+    printCons name <> ".prototype.instance = \"" <> printConsUnQual name <> "\";" <> newline+  printJS (JsSetModule mp expr) =+    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-  printJS (JsMappedVar _ name expr) =-    "var " +> name +> " = " +> expr +> ";" +> newline+    "while (" <> printJS cond <> ") {" <> newline <>+    indented (printStmts stmts) <>+    "}" <> newline+  printJS JsContinue = "continue;" <> newline +-- | Print a module path.+instance Printable ModulePath where+  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 (JsFun params stmts ret) =-    "function("-    +> (intercalateM "," (map printJS params))-    +> "){" +> newline-    +> indented (stmts +>+    "{" <> 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 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 (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+ident n = case n of+  JsConstructor (Qual _ _ s) -> JsNameVar $ UnQual () s+  a                          -> a+ -- | Print one of the kinds of names. instance Printable JsName where   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)-      JsConstructor qname -> "$_" +> printJS qname-      JsBuiltIn qname     -> "Fay$$" +> printJS qname-      JsParametrizedType  -> write "type"+      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  -> "type"+      JsModuleName (ModuleName _ m) -> write m --- | Just write out strings.-instance Printable String where-  printJS = write+-- | Print a constructor name given a QName.+printCons :: QName l -> Printer+printCons (UnQual _ n) = printConsName n+printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n+printCons Special {} = error "qname2String Special" --- | A printer is a printable.-instance Printable (Printer ()) where-  printJS = id+-- | Print an unqualified name.+printConsUnQual :: QName l -> Printer+printConsUnQual (UnQual _ x) = printJS x+printConsUnQual (Qual _ _ n) = printJS n+printConsUnQual Special {} = error "printConsUnqual Special" +-- | Print a constructor name given a Name. Helper for printCons.+printConsName :: Name l -> Printer+printConsName = ("_" <>) . printJS+ -------------------------------------------------------------------------------- -- Name encoding  -- | Words reserved in haskell as well are not needed here: -- case, class, do, else, if, import, in, let reservedWords :: [String]-reservedWords = [-  "break", "catch", "const", "continue", "debugger", "delete", "enum", "export",-  "extends", "finally", "for", "function", "global", "implements", "instanceof",-  "interface", "new", "null", "package", "private", "protected", "public", "return",-  "static", "super", "switch", "this", "throw", "try", "typeof", "undefined",-  "var", "void", "while", "window", "with", "yield","true","false"]+reservedWords =+  ["abstract","boolean","break","byte","case","catch","char","class"+  ,"comment","const","continue","debugger","default","delete","do","double"+  ,"else","enum","export","extends","false","final","finally","float"+  ,"for","function","global","goto","if","implements","import","in"+  ,"instanceOf","instanceof","int","interface","label","long","native"+  ,"new","null","package","private","protected","public","return","short"+  ,"static","super","switch","synchronized","this","throw","throws"+  ,"transient","true","try","typeof","undefined","var","void","while"+  ,"window","with","yield"]+  -- These are not reserved, but they exist on thunks (inherited from Object) meaning they shouldn't be overridden.+  -- 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 :: [Char] -> [Char]-normalizeName name =-  concatMap encodeChar name-+normalizeName :: String -> String+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)---- | 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
@@ -0,0 +1,47 @@+-- | Extras for haskell-src-exts names.++module Fay.Compiler.QName where++import           Language.Haskell.Exts++-- | Extract the module name from a qualified name.+qModName :: QName a -> Maybe (ModuleName a)+qModName (Qual _ m _) = Just m+qModName _          = Nothing++-- | Extract the name from a QName.+unQual :: QName a -> Name a+unQual (Qual _ _ n) = n+unQual (UnQual _ n) = n+unQual Special{} = error "unQual Special{}"++unQualify :: QName a -> QName a+unQualify (Qual a _ n) = UnQual a n+unQualify u@UnQual{} = u+unQualify Special{}  = error "unQualify: Special{}"++-- | Change or add the ModuleName of a QName.+changeModule :: ModuleName a -> QName a -> QName a+changeModule m (Qual a _ n) = Qual a m n+changeModule m (UnQual a n) = Qual a m n+changeModule _ Special{}  = error "changeModule Special{}"++changeModule' :: (String -> String) -> QName a -> QName a+changeModule' f (Qual l (ModuleName ml mn) n) = Qual l (ModuleName ml $ f mn) n+changeModule' _ x = x++withIdent :: (String -> String) -> QName a -> QName a+withIdent f q = case q of+  Qual l m n -> Qual l m $ withIdent' f n+  UnQual l n -> UnQual l $ withIdent' f n+  Special{} -> q+  where+    withIdent' :: (String -> String) -> Name a -> Name a+    withIdent' f' n' = case n' of+      Symbol{} -> n'+      Ident l s -> Ident l (f' s)++-- | Extract the string from a Name.+unname :: Name a -> String+unname (Ident _ s) = s+unname (Symbol _ s) = s
+ src/Fay/Compiler/State.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NamedFieldPuns #-}++-- | Pure functions for working with CompileState++module Fay.Compiler.State where++import           Fay.Compiler.Misc+import           Fay.Compiler.QName+import qualified Fay.Exts.NoAnnotation  as N+import           Fay.Types++import qualified Data.Map               as M+import           Data.Set               (Set)+import qualified Data.Set               as S+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)+getNonLocalExportsWithoutNewtypes modName cs =+  fmap ( S.filter (not . isLocal)+       . S.map (origName2QName . sv_origName)+       . S.filter (not . (`isNewtype` cs))+       . (\(Symbols exports _) -> exports)+       )+       . M.lookup modName . stateInterfaces $ cs+  where+   isLocal = (Just modName ==) . qModName++getLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)+getLocalExportsWithoutNewtypes modName cs =+  fmap ( S.filter isLocal+       . S.map (origName2QName . sv_origName)+       . S.filter (not . (`isNewtype` cs))+       . (\(Symbols exports _) -> exports)+       )+       . M.lookup modName . stateInterfaces $ cs+  where+   isLocal = (Just modName ==) . qModName++-- | 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 = 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+isNewtypeDest o = any (\(_,mdest,_) -> mdest == Just o) . stateNewtypes++-- | Is this *resolved* name a new type constructor?+isNewtypeCons :: N.QName -> CompileState -> Bool+isNewtypeCons o = any (\(cons,_,_) -> cons  == o) . stateNewtypes++-- | Add a ModulePath to CompileState, meaning it has been printed.+addModulePath :: ModulePath -> CompileState -> CompileState+addModulePath mp cs = cs { stateJsModulePaths = mp `S.insert` stateJsModulePaths cs }++-- | Has this ModulePath been added/printed?+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,19 +2,22 @@  module Fay.Compiler.Typecheck where -import           Control.Monad.IO-import           Data.List-import           Data.Maybe+import           Fay.Compiler.Prelude++import           Fay.Compiler.Defaults import           Fay.Compiler.Misc+import           Fay.Config import           Fay.Types-import qualified GHC.Paths                       as GHCPaths-import           System.Process.Extra +import qualified GHC.Paths             as GHCPaths++import           System.Directory+import           System.Environment+ -- | Call out to GHC to type-check the file.-typecheck :: Maybe FilePath -> Bool -> String -> Compile ()-typecheck packageConf wall fp = do-  cfg <- config id-  faydir <- io faySourceDir+typecheck :: Config -> FilePath -> IO (Either CompileError String)+typecheck cfg fp = do+  faydir <- faySourceDir   let includes = configDirectoryIncludes cfg    -- Remove the fay source dir from includeDirs to prevent errors on FFI instance declarations.@@ -22,21 +25,37 @@   let packages = nub . map (fromJust . fst) . filter (isJust . fst) $ includes    ghcPackageDbArgs <--    case packageConf of+    case configPackageConf cfg of       Nothing -> return []       Just pk -> do-        flag <- io getGhcPackageDbFlag+        flag <- getGhcPackageDbFlag         return [flag ++ '=' : pk]   let flags =           [ "-fno-code"-          , "-hide-package base"-          , "-cpp", "-DFAY=1"+          , "-hide-all-packages"+          , "-cpp", "-pgmPcpphs", "-optP--cpp"+          , "-optP-C" -- Don't let hse-cpp remove //-style comments.+          , "-DFAY=1"           , "-main-is"           , "Language.Fay.DummyMain"-          , "-i" ++ concat (intersperse ":" includeDirs)+          , "-i" ++ intercalate ":" includeDirs           , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages-  res <- io $ readAllFromProcess GHCPaths.ghc flags ""-  either error (warn . fst) res+  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 | wall = ["-Wall"]+    wallF | configWall cfg = ["-Wall"]           | otherwise = []
+ 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/Convert.hs view
@@ -1,198 +1,252 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# 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 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)--    -- 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)--    -- 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.  'encodeFay' can be used to+--   resolve this issue.+showToFay :: Data a => a -> Maybe Value+showToFay = spoon . encodeFay id -  -- Number converters-  convertDouble = fmap (Number . D) . pDouble-  convertInt = fmap (Number . I) . pInt+-- | 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 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+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 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.+readFromFay :: Data a => Value -> Maybe a+readFromFay = either (const Nothing) Just . 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.  This is like readFromFay,+--   except it yields helpful error messages on failure.+readFromFay' :: Data a => Value -> Either String a+readFromFay' = decodeFay (const id) --- | Convert a value representing a Fay value to a Haskell value.+-- | 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 -readFromFay :: Data a => Value -> Maybe a-readFromFay value = do-  parseData value-  `ext1R` parseArray value-  `extR` parseDouble value-  `extR` parseInt value-  `extR` parseBool value-  `extR` parseString value-  `extR` parseText value+type GenericParser = forall a. Data a => Value -> Either String a --- | Parse a data type or record.-parseData :: Data a => Value -> Maybe a-parseData value = result where-  result = getObject value >>= parseObject typ-  typ = dataTypeOf (fromJust result)-  getObject x =+-- | Parse a data type or record or tuple.+parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a+parseDataOrTuple rec value = result where+  result = getAndParse value+  typ = dataTypeOf (undefined :: a)+  getAndParse x =     case x of-      Object obj -> return obj-      _ -> mzero+      Object obj -> parseObject rec typ obj+      Array tuple -> parseTuple rec typ tuple+      _ -> badData value --- | 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+-- | Parse a tuple.+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+                                          put next+                                          value <- lift (Vector.indexM arr i)+                                          lift (rec value))+                                      cons)+                         [0..]+    _ -> badData (Array arr) -      where fields = constrFields cons+-- | Parse a data constructor from an object.+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 +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 a float.+parseFloat :: Value -> Either String Float+parseFloat = parseEither parseJSON+ -- | 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+parseDouble :: Value -> Either String Double+parseDouble = parseEither parseJSON  -- | Parse an int.-parseInt :: Value -> Maybe Int-parseInt value = do-  number <- parseNumber value-  case number of-    I n -> return (fromIntegral n)-    _ -> mzero---- | Parse a number.-parseNumber :: Value -> Maybe Number-parseNumber value =-  case value of-    Number n -> return n-    _ -> mzero+parseInt :: Value -> Either String Int+parseInt = parseEither parseJSON  -- | Parse a bool.-parseBool :: Value -> Maybe Bool-parseBool value =-  case value of-    Bool n -> return n-    _ -> mzero+parseBool :: Value -> Either String Bool+parseBool value = case value of+  Bool n -> return n+  _ -> badData value  -- | Parse a string.-parseString :: Value -> Maybe String-parseString value =-  case value of-    String s -> return (Text.unpack s)-    _ -> mzero+parseString :: Value -> Either String String+parseString value = case value of+  String s -> return (Text.unpack s)+  _ -> 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 -> Either String Char+parseChar value = case value of+  String s | Just (c,_) <- Text.uncons s -> return c+  _ -> badData value+ -- | Parse a Text.-parseText :: Value -> Maybe Text-parseText value =-  case value of-    String s -> return s-    _ -> mzero+parseText :: Value -> Either String Text+parseText value = case value of+  String s -> return s+  _ -> 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 -> Either String ()+parseUnit value = case value of+  Null -> return ()+  _ -> 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/Exts.hs view
@@ -0,0 +1,70 @@+module Fay.Exts where++import qualified Language.Haskell.Exts as A++type X = A.SrcSpanInfo++type Alt = A.Alt X+type BangType = A.BangType X+type ClassDecl = A.ClassDecl X+type Decl = A.Decl X+type DeclHead = A.DeclHead X+type Ex = A.Exp X+type Exp = A.Exp X+type ExportSpec = A.ExportSpec X+type FieldDecl = A.FieldDecl X+type FieldUpdate = A.FieldUpdate X+type GadtDecl = A.GadtDecl X+type GuardedRhs = A.GuardedRhs X+type ImportDecl = A.ImportDecl X+type ImportSpec = A.ImportSpec X+type Literal = A.Literal X+type Match = A.Match X+type Module = A.Module X+type ModuleName = A.ModuleName X+type ModulePragma = A.ModulePragma X+type Name = A.Name X+type Pat = A.Pat X+type PatField = A.PatField X+type QName = A.QName X+type QOp = A.QOp X+type QualConDecl = A.QualConDecl X+type QualStmt = A.QualStmt X+type Rhs = A.Rhs X+type SpecialCon = A.SpecialCon X+type SrcLoc = A.SrcLoc+type Stmt = A.Stmt X+type TyVarBind = A.TyVarBind X+type Type = A.Type X++moduleName :: A.SrcInfo a => A.Module a -> A.ModuleName a+moduleName (A.Module _ (Just (A.ModuleHead _ n _ _)) _ _ _) = n+moduleName (A.Module a Nothing                     _ _ _) = A.ModuleName a "Main"+moduleName m = error $ "moduleName: " ++ A.prettyPrint m++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++moduleNameString :: A.ModuleName t -> String+moduleNameString (A.ModuleName _ n) = n++mkIdent :: String -> A.Name A.SrcSpanInfo+mkIdent = A.Ident noI++noI :: A.SrcSpanInfo+noI = A.noInfoSpan (A.mkSrcSpan A.noLoc A.noLoc)++convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.Type a)+convertFieldDecl (A.FieldDecl _ ns b) = (ns, b)++fieldDeclNames :: A.FieldDecl a -> [A.Name a]+fieldDeclNames (A.FieldDecl _ ns _) = ns++declHeadName :: A.DeclHead a -> A.Name a+declHeadName d = case d of+  A.DHead _ n -> n+  A.DHInfix _ _ n -> n+  A.DHParen _ h -> declHeadName h+  A.DHApp _ h _ -> declHeadName h
+ src/Fay/Exts/NoAnnotation.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS -fno-warn-orphans  #-}+{-# LANGUAGE FlexibleInstances #-}+module Fay.Exts.NoAnnotation where++import           Fay.Compiler.Prelude++import           Data.List.Split                 (splitOn)+import           Data.String+import qualified Language.Haskell.Exts as A++type Alt = A.Alt ()+type BangType = A.BangType ()+type ClassDecl = A.ClassDecl ()+type Decl = A.Decl ()+type DeclHead = A.DeclHead ()+type Ex = A.Exp ()+type Exp = A.Exp ()+type ExportSpec = A.ExportSpec ()+type FieldDecl = A.FieldDecl ()+type FieldUpdate = A.FieldUpdate ()+type GadtDecl = A.GadtDecl ()+type GuardedRhs = A.GuardedRhs ()+type ImportDecl = A.ImportDecl ()+type ImportSpec = A.ImportSpec ()+type Literal = A.Literal ()+type Match = A.Match ()+type Module = A.Module ()+type ModuleName = A.ModuleName ()+type ModulePragma = A.ModulePragma ()+type Name = A.Name ()+type Pat = A.Pat ()+type PatField = A.PatField ()+type QName = A.QName ()+type QOp = A.QOp ()+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+type SrcSpanInfo = A.SrcSpanInfo+type Stmt = A.Stmt ()+type TyVarBind = A.TyVarBind ()+type Type = A.Type ()++unAnn :: Functor f => f a -> f ()+unAnn = void++-- | Helpful for some things.+instance IsString (A.Name ()) where+  fromString n@(c:_)+    | isAlpha c || c == '_' = A.Ident () n+    | otherwise             = A.Symbol () n+  fromString [] = error "Name fromString: empty string"++-- | Helpful for some things.+instance IsString (A.QName ()) where+  fromString s = case splitOn "." s of+    []  -> error "QName fromString: empty string"+    [x] -> A.UnQual () $ fromString x+    xs  -> A.Qual () (fromString $ intercalate "." $ init xs) $ fromString (last xs)++-- | Helpful for writing qualified symbols (Fay.*).+instance IsString (A.ModuleName ()) where+   fromString = A.ModuleName ()
+ src/Fay/Exts/Scoped.hs view
@@ -0,0 +1,49 @@+module Fay.Exts.Scoped where++import qualified Fay.Exts                        as F++import qualified Language.Haskell.Exts as A+import qualified Language.Haskell.Names          as HN (Scoped (Scoped), NameInfo (None))+++type X = HN.Scoped A.SrcSpanInfo++type Alt = A.Alt X+type BangType = A.BangType X+type ClassDecl = A.ClassDecl X+type Decl = A.Decl X+type DeclHead = A.DeclHead X+type Ex = A.Exp X+type Exp = A.Exp X+type ExportSpec = A.ExportSpec X+type FieldDecl = A.FieldDecl X+type FieldUpdate = A.FieldUpdate X+type GadtDecl = A.GadtDecl X+type GuardedRhs = A.GuardedRhs X+type ImportDecl = A.ImportDecl X+type ImportSpec = A.ImportSpec X+type Literal = A.Literal X+type Match = A.Match X+type Module = A.Module X+type ModuleName = A.ModuleName X+type ModulePragma = A.ModulePragma X+type Name = A.Name X+type Pat = A.Pat X+type PatField = A.PatField X+type QName = A.QName X+type QOp = A.QOp X+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+type TyVarBind = A.TyVarBind X+type Type = A.Type X++noI :: HN.Scoped A.SrcSpanInfo+noI = HN.Scoped HN.None F.noI++srcSpanInfo :: HN.Scoped A.SrcSpanInfo -> A.SrcSpanInfo+srcSpanInfo (HN.Scoped _ l) = l
+ src/Fay/FFI.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE NoImplicitPrelude    #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | The internal FFI module.++module Fay.FFI+  (Fay+  ,Nullable (..)+  ,Defined (..)+  ,Ptr+  ,Automatic+  ,ffi)+  where++import           Data.String (IsString)+import           Fay.Types+import           Prelude     (error)++-- | Values that may be null+--  Nullable x decodes to x, Null decodes to null.+data Nullable a = Nullable a | Null++-- | Values that may be undefined+-- Defined x encodes to x, Undefined decodes to undefined.+-- An undefined property in a record will be removed when encoding.+data Defined a = Defined a | Undefined++-- | Do not serialize the specified type. This is useful for, e.g.+--+-- > foo :: String -> String+-- > foo = ffi "%1"+--+-- This would normally serialize and unserialize the string, for no+-- reason, in this case. Instead:+--+-- > foo :: Ptr String -> Ptr String+--+-- Will just give an identity function.+type Ptr a = a++-- | The opposite of "Ptr". Serialize the specified polymorphic type.+--+-- > foo :: Automatic a -> String+--+type Automatic a = a++-- | Declare a foreign action.+ffi :: IsString s+    => s             -- ^ The foreign value.+    -> a             -- ^ Bottom.+ffi = error "Fay.FFI.ffi: Used foreign function outside a JS engine context."
+ 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/Types.hs view
@@ -1,348 +1,143 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE DeriveDataTypeable         #-}-{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE TypeFamilies               #-}  -- | All Fay types and instances.  module Fay.Types-  (JsStmt(..)-  ,JsExp(..)-  ,JsLit(..)-  ,JsName(..)-  ,CompileError(..)-  ,Compile(..)-  ,CompilesTo(..)-  ,Printable(..)-  ,Fay-  ,CompileReader(..)-  ,CompileWriter(..)-  ,CompileConfig(..)-  ,CompileState(..)-  ,addCurrentExport-  ,getCurrentExports-  ,getExportsFor-  ,faySourceDir-  ,FundamentalType(..)-  ,PrintState(..)-  ,Printer(..)-  ,Mapping(..)-  ,SerializeContext(..))-  where+  ( 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           Control.Applicative-import           Control.Monad.Error    (Error, ErrorT, MonadError)-import           Control.Monad.Identity (Identity)-import           Control.Monad.State-import           Control.Monad.RWS-import           Data.Default-import           Data.Maybe-import           Data.Map              (Map)-import qualified Data.Map              as M-import           Data.Set              (Set)-import qualified Data.Set              as S-import           Data.String-import           Language.Haskell.Exts-import           System.FilePath+import           Fay.Compiler.Prelude -import           Fay.Compiler.ModuleScope (ModuleScope)-import           Paths_fay+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+#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?-  , configExportBuiltins     :: Bool                       -- ^ Export built-in functions?-  , configExportRuntime      :: Bool                       -- ^ Export the runtime?-  , configExportStdlib       :: Bool                       -- ^ Export the stdlib?-  , configExportStdlibOnly   :: Bool                       -- ^ Export /only/ the stdlib?-  , configDispatchers        :: Bool                       -- ^ Export dispatchers?-  , configDispatcherOnly     :: Bool                       -- ^ Export /only/ the dispatcher?-  , configNaked              :: Bool                       -- ^ Export without a module wrapper?-  , 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.-  , 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.-                                                           --   TODO: This flag is not used thoroughly, decide if it's needed.-  , 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-  } deriving (Show)- -- | State of the compiler. data CompileState = CompileState-  { _stateExports     :: Map ModuleName (Set QName) -- ^ Collects exports from modules-  , stateRecordTypes  :: [(QName,[QName])]          -- ^ Map types to constructors-  , stateRecords      :: [(QName,[QName])]          -- ^ Map constructors to fields-  , stateNewtypes     :: [(QName, Maybe QName, Type)] -- ^ Newtype constructor, destructor, wrapped type tuple-  , stateImported     :: [(ModuleName,FilePath)]    -- ^ Map of all imported modules and their source locations.-  , stateNameDepth    :: Integer                    -- ^ Depth of the current lexical scope.-  , stateLocalScope   :: Set Name                   -- ^ Names in the current lexical scope.-  , stateModuleScope  :: ModuleScope                -- ^ Names in the module scope.-  , stateModuleName   :: ModuleName                 -- ^ Name of the module currently being compiled.+  -- TODO Change N.QName to GName? They can never be special so it would simplify.+  { stateInterfaces    :: Map N.ModuleName Symbols           -- ^ Exported identifiers for all modules+  , stateRecordTypes   :: [(N.QName,[N.QName])]              -- ^ Map types to constructors+  , stateRecords       :: [(N.QName,[N.Name])]               -- ^ Map constructors to fields+  , stateNewtypes      :: [(N.QName, Maybe N.QName, N.Type)] -- ^ Newtype constructor, destructor, wrapped type tuple+  , stateImported      :: [(N.ModuleName,FilePath)]          -- ^ Map of all imported modules and their source locations.+  , stateNameDepth     :: Integer                            -- ^ Depth of the current lexical scope, used for creating unshadowing variables.+  , stateModuleName    :: N.ModuleName                       -- ^ Name of the module currently being compiled.+  , stateJsModulePaths :: Set ModulePath                     -- ^ Module paths that have code generated for them.+  , stateUseFromString :: Bool                               -- ^ Use JS Strings instead of [Char] for string literals?+  , stateTypeSigs      :: Map N.QName N.Type                 -- ^ Module level declarations having explicit type signatures   } deriving (Show)  -- | Things written out by the compiler. data CompileWriter = CompileWriter-  { writerCons     :: [JsStmt] -- ^ Constructors.-  , writerFayToJs  :: [JsStmt] -- ^ Fay to JS dispatchers.-  , writerJsToFay  :: [JsStmt] -- ^ JS to Fay dispatchers.-  }-  deriving (Show)+  { writerCons    :: [JsStmt]         -- ^ Constructors.+  , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers.+  , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers.+  } 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   :: Literal -> Compile JsExp-  , readerCompileDecls :: Bool -> [Decl] -> Compile [JsStmt]+  { readerConfig       :: Config -- ^ The compilation configuration.+  , readerCompileLit   :: S.Sign -> S.Literal -> Compile JsExp+  , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt]   } --- | The data-files source directory.-faySourceDir :: IO FilePath-faySourceDir = fmap (takeDirectory . takeDirectory . takeDirectory) (getDataFileName "src/Language/Fay/Stdlib.hs")---- | Adds a new export to '_stateExports' for the module specified by--- 'stateModuleName'.-addCurrentExport :: QName -> CompileState -> CompileState-addCurrentExport q cs =-    cs { _stateExports = M.insert (stateModuleName cs) qnames $ _stateExports cs}-  where-    qnames = maybe (S.singleton q) (S.insert q)-           $ M.lookup (stateModuleName cs) (_stateExports cs)---- | Get all of the exported identifiers for the current module.-getCurrentExports :: CompileState -> Set QName-getCurrentExports cs = getExportsFor (stateModuleName cs) cs---- | Get all of the exported identifiers for the given module.-getExportsFor :: ModuleName -> CompileState -> Set QName-getExportsFor mn cs = excludeNewtypes cs $ fromMaybe S.empty $ M.lookup mn (_stateExports cs)-  where-    excludeNewtypes :: CompileState -> Set QName -> Set QName-    excludeNewtypes cs' names =-      let newtypes = stateNewtypes cs'-          constrs = map (\(c, _, _) -> c) newtypes-          destrs  = map (\(_, d, _) -> fromJust d) . filter (\(_, d, _) -> isJust d) $ newtypes-       in names `S.difference` (S.fromList constrs `S.union` S.fromList destrs)- -- | Compile monad. newtype Compile a = Compile-  { unCompile :: RWST CompileReader CompileWriter CompileState (ErrorT CompileError IO) a -- ^ Run the compiler.-  }-  deriving (MonadState CompileState-           ,MonadError CompileError-           ,MonadReader CompileReader-           ,MonadWriter CompileWriter-           ,MonadIO-           ,Monad-           ,Functor-           ,Applicative)---- | Just a convenience class to generalize the parsing/printing of--- various types of syntax.-class (Parseable from,Printable to) => CompilesTo from to | from -> to where-  compileTo :: from -> Compile to---- | A source mapping.-data Mapping = Mapping-  { mappingName :: String -- ^ The name of the mapping.-  , mappingFrom :: SrcLoc -- ^ The original source location.-  , mappingTo   :: SrcLoc -- ^ The new source location.-  } deriving (Show)---- | The state of the pretty printer.-data PrintState = PrintState-  { psPretty       :: Bool      -- ^ Are we to pretty print?-  , psLine         :: Int       -- ^ The current line.-  , psColumn       :: Int       -- ^ Current column.-  , psMapping      :: [Mapping] -- ^ Source mappings.-  , 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+  { 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+    ) --- | The printer monad.-newtype Printer a = Printer { runPrinter :: State PrintState a }-  deriving (Monad,Functor,MonadState PrintState)+type CompileModule a = ModuleT Symbols IO (Either CompileError (a, CompileState, CompileWriter)) --- | Print some value.-class Printable a where-  printJS :: a -> Printer ()+instance MonadModule Compile where+  type ModuleInfo Compile = Symbols+  lookupInCache        = liftModuleT . lookupInCache+  insertInCache n m    = liftModuleT $ insertInCache n m+  readModuleInfo fps n = liftModuleT $ readModuleInfo fps n --- | Error type.-data CompileError-  = ParseError SrcLoc String-  | UnsupportedDeclaration Decl-  | UnsupportedExportSpec ExportSpec-  | UnsupportedMatchSyntax Match-  | UnsupportedWhereInMatch Match-  | UnsupportedExpression Exp-  | UnsupportedLiteral Literal-  | UnsupportedLetBinding Decl-  | UnsupportedOperator QOp-  | UnsupportedPattern Pat-  | UnsupportedFieldPattern PatField-  | UnsupportedRhs Rhs-  | UnsupportedGuardedAlts GuardedAlts-  | UnsupportedWhereInAlt Alt-  | UnsupportedImport ImportDecl-  | UnsupportedQualStmt QualStmt-  | EmptyDoBlock-  | UnsupportedModuleSyntax Module-  | LetUnsupported-  | InvalidDoBlock-  | RecursiveDoUnsupported-  | Couldn'tFindImport ModuleName [FilePath]-  | FfiNeedsTypeSig Decl-  | FfiFormatBadChars SrcLoc String-  | FfiFormatNoSuchArg SrcLoc Int-  | FfiFormatIncompleteArg SrcLoc-  | FfiFormatInvalidJavaScript SrcLoc String String-  | UnableResolveUnqualified Name-  | UnableResolveQualified QName-  deriving (Show)-instance Error CompileError+liftModuleT :: ModuleT Symbols IO a -> Compile a+liftModuleT = Compile . lift . lift  -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a)-  deriving Monad------------------------------------------------------------------------------------- JS AST types---- | Statement type.-data JsStmt-  = JsVar JsName JsExp-  | JsMappedVar SrcLoc JsName JsExp-  | JsIf JsExp [JsStmt] [JsStmt]-  | JsEarlyReturn JsExp-  | JsThrow JsExp-  | JsWhile JsExp [JsStmt]-  | JsUpdate JsName JsExp-  | JsSetProp JsName JsName JsExp-  | JsSetPropExtern JsName JsName JsExp-  | JsContinue-  | JsBlock [JsStmt]-  | JsExpStmt JsExp-  deriving (Show,Eq)---- | Expression type.-data JsExp-  = JsName JsName-  | JsRawExp String-  | JsSeq [JsExp]-  | JsFun [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)]-  | JsUndefined-  deriving (Show,Eq)---- | A name of some kind.-data JsName-  = JsNameVar QName-  | JsThis-  | JsParametrizedType-  | JsThunk-  | JsForce-  | JsApply-  | JsParam Integer-  | JsTmp Integer-  | JsConstructor QName-  | JsBuiltIn Name-  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 Name [FundamentalType]- | Defined FundamentalType- | Nullable FundamentalType- -- Simple types.- | DateType- | StringType- | DoubleType- | IntType- | BoolType- | PtrType- --  Automatically serialize this type.- | Automatic- -- Unknown.- | UnknownType-   deriving (Show)---- | Helpful for some things.-instance IsString Name where-  fromString = Ident---- | Helpful for some things.-instance IsString QName where-  fromString = UnQual . Ident---- | Helpful for writing qualified symbols (Fay.*).-instance IsString ModuleName where-  fromString = ModuleName---- | 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/Language/Fay/FFI.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE EmptyDataDecls       #-}-{-# LANGUAGE NoImplicitPrelude    #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | The internal FFI module. Needs to be renamed to Fay.FFI at some point.--module Language.Fay.FFI-  (Fay-  ,Nullable (..)-  ,Defined (..)-  ,Ptr-  ,Automatic-  ,ffi)-  where--import           Fay.Types-import           Prelude            (Bool, Char, Double, Int, Maybe, String,-                                     error)---- | Values that may be null---  Nullable x decodes to x, Null decodes to null.-data Nullable a = Nullable a | Null---- | Values that may be undefined--- Defined x encodes to x, Undefined decodes to undefined.--- An undefined property in a record will be removed when encoding.-data Defined a = Defined a | Undefined---- | Do not serialize the specified type. This is useful for, e.g.------ > foo :: String -> String--- > foo = ffi "%1"------ This would normally serialize and unserialize the string, for no--- reason, in this case. Instead:------ > foo :: Ptr String -> Ptr String------ Will just give an identity function.-type Ptr a = a---- | The opposite of "Ptr". Serialize the specified polymorphic type.------ > foo :: Automatic a -> String----type Automatic a = a---- | Declare a foreign action.-ffi :: String        -- ^ The foreign value.-    -> a             -- ^ Bottom.-ffi = error "Language.Fay.FFI.foreignFay: Used foreign function not in a JS engine context."
− src/Main.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-}-{-# OPTIONS -fno-warn-orphans #-}--- | Main compiler executable.--module Main where--import           Fay-import           Fay.Compiler-import           Fay.Compiler.Config-import           Fay.Compiler.Debug--import qualified Control.Exception        as E-import           Control.Monad-import           Control.Monad.Error-import           Data.Default-import           Data.List.Split          (wordsBy)-import           Data.Maybe-import           Data.Version             (showVersion)-import           Options.Applicative-import           Paths_fay                (version)-import           System.Console.Haskeline-import           System.Environment-import           System.IO---- | 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-  , optFiles        :: [String]-  , optOptimize     :: Bool-  , optGClosure     :: Bool-  , optPackageConf  :: Maybe String-  , optNoRTS        :: Bool-  , optNoStdlib     :: Bool-  , optPrintRuntime :: Bool-  , optNaked        :: Bool-  , optNoDispatcher :: Bool-  , optDispatcher   :: Bool-  , optStdlibOnly   :: Bool-  , optNoBuiltins   :: Bool-  , optBasePath     :: Maybe FilePath-  }---- | Main entry point.-main :: IO ()-main = do-  packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  opts <- execParser parser-  if optVersion opts-    then runCommandVersion-    else do-      if optPrintRuntime opts-         then getRuntime >>= readFile >>= putStr-         else do-           let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $-                 addConfigPackages (optPackages opts) $ def-                   { configOptimize         = optOptimize opts-                   , configFlattenApps      = optFlattenApps opts-                   , configExportBuiltins   = not (optNoBuiltins opts)-                   , configPrettyPrint      = optPretty opts-                   , configLibrary          = optLibrary opts-                   , configHtmlWrapper      = optHTMLWrapper opts-                   , configHtmlJSLibs       = optHTMLJSLibs opts-                   , configTypecheck        = not $ optNoGHC opts-                   , configWall             = optWall opts-                   , configGClosure         = optGClosure opts-                   , configPackageConf      = optPackageConf opts <|> packageConf-                   , configExportRuntime    = not (optNoRTS opts)-                   , configNaked            = optNaked opts-                   , configExportStdlib     = not (optNoStdlib opts)-                   , configDispatchers      = not (optNoDispatcher opts)-                   , configDispatcherOnly   = optDispatcher opts-                   , configExportStdlibOnly = optStdlibOnly opts-                   , configBasePath         = optBasePath opts-                   }-           void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"-           case optFiles opts of-                ["-"] -> hGetContents stdin >>= printCompile config (compileModule True)-                []    -> runInteractive-                files -> forM_ files $ \file -> do-                  if optStdout opts-                    then compileFromTo config file Nothing-                    else compileFromTo config file (Just (outPutFile opts file))--  where-    parser = info (helper <*> options) (fullDesc <> header helpTxt)--    outPutFile :: FayCompilerOptions -> String -> FilePath-    outPutFile opts file = fromMaybe (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")-  <*> 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")-  <*> 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 "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")-  <*> arguments Just (metavar "- | <hs-file>...")-  <*> 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-rts" <> short 'r' <> help "Don't export the RTS")-  <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")-  <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout")-  <*> switch (long "naked" <> help "Print all declarations naked at the top-level (unwrapped)")-  <*> switch (long "no-dispatcher" <> help "Don't output a type serialization dispatcher")-  <*> switch (long "dispatcher" <> help "Only output the type serialization dispatchers")-  <*> switch (long "stdlib" <> help "Only output the stdlib")-  <*> switch (long "no-builtins" <> help "Don't export no-builtins")-  <*> 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"))--  where strsOption m =-          nullOption (m <> reader (Right . wordsBy (== ',')) <> value [])----- | Make incompatible options.-incompatible :: Monad m-  => (FayCompilerOptions -> Bool)-  -> FayCompilerOptions -> String -> m Bool-incompatible test opts message = case test opts of-  True -> E.throw $ userError message-  False -> return True---- | The basic help text.-helpTxt :: String-helpTxt = concat-  ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"-  ,"SYNOPSIS\n"-  ,"  fay [OPTIONS] [- | <hs-file>...]\n"-  ,"  fay - takes input on stdin and prints to stdout. Pretty prints\n"-  ,"  fay <hs-file>... processes each .hs file"-  ]---- | Print the command version.-runCommandVersion :: IO ()-runCommandVersion = putStrLn $ "fay " ++ showVersion version---- | Incompatible options.-htmlAndStdout :: FayCompilerOptions -> Bool-htmlAndStdout opts = optHTMLWrapper opts && optStdout opts---- | Run interactively.-runInteractive :: IO ()-runInteractive = runInputT defaultSettings loop where-  loop = do-    minput <- getInputLine "> "-    case minput of-      Nothing -> return ()-      Just "" -> loop-      Just input -> do-        result <- liftIO $ compileViaStr "<interactive>" config compileExp input-        case result of-          Left err -> do-            -- an error occured, maybe input was not an expression,-            -- but a declaration, try compiling the input as a declaration-            outputStrLn ("can't parse input as expression: " ++ show err)-            result' <- liftIO $ compileViaStr "<interactive>" config (compileDecl True) input-            case result' of-              Right (PrintState{..},_,_) -> outputStr (concat (reverse psOutput))-              Left err' ->-                outputStrLn ("can't parse input as declaration: " ++ show err')-          Right (PrintState{..},_,_) -> outputStr (concat (reverse psOutput))-        loop-  config = def { configPrettyPrint = True }
− src/System/Process/Extra.hs 
@@ -1,15 +0,0 @@--- | Extra process functions.--module System.Process.Extra where--import System.Exit-import System.Process---- | Read everything from a process, either failure or both stderr and stdout.-readAllFromProcess :: FilePath -> [String] -> String -> IO (Either 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-    ExitSuccess     -> Right (err, out)
− src/Test/Api.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}--module Test.Api (tests) where--import Fay-import Fay.Compiler.Config--import Data.Default-import Data.Maybe-import Language.Haskell.Exts.Syntax-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--tests :: Test-tests = $testGroupGenerator--case_imports :: Assertion-case_imports = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework } 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-  case res of-    Left err -> error (show err)-    Right (_,r) -> assertBool "RecordImport_Export was not added to stateImported" .-                     isJust . lookup (ModuleName "RecordImport_Export") $ stateImported r--case_stateRecordTypes :: Assertion-case_stateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Api/Records.hs"-  case res of-    Left err -> error (show err)-    Right (_,r) -> do-      -- TODO order should not matter-      assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])-        ]-        (stateRecordTypes r)--case_importStateRecordTypes :: Assertion-case_importStateRecordTypes = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Api/ImportRecords.hs"-  case res of-    Left err -> error (show err)-    Right (_,r) -> do-      -- TODO order should not matter-      assertEqual "stateRecordTypes mismatch"-        [ (UnQual (Ident "T"),[UnQual (Symbol ":+")])-        , (UnQual (Ident "R"),[UnQual (Ident "R"), UnQual (Ident "S")])-        ]-        (stateRecordTypes r)--case_typecheckCPP :: Assertion-case_typecheckCPP = do-  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Api/CPPTypecheck.hs" } "tests/Api/CPPTypecheck.hs"-  either (assertFailure . show) (const $ return ()) res--fp :: FilePath-fp = "tests/RecordImport_Import.hs"--defConf :: CompileConfig-defConf = addConfigDirectoryIncludePaths ["tests/"]-        $ def { configTypecheck = False }
− src/Test/CommandLine.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Test.CommandLine (tests) where--import Control.Applicative-import Data.Maybe-import System.Directory-import System.Environment-import System.FilePath-import System.Process.Extra-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.TH-import Test.HUnit                     (Assertion, assertBool)-import Test.Util--tests :: Test-tests = $testGroupGenerator--compileFile :: [String] -> IO (Either String String)-compileFile flags = do-  whatAGreatFramework <- fmap (fmap (\x -> x</>"bin"</>"fay") . (lookup "HASKELL_SANDBOX"))-                              getEnvironment-  fay <- fayPath-  let path = fromMaybe "couldn't find fay" (whatAGreatFramework <|> fay)-  exists <- doesFileExist path-  if exists-     then do r <- readAllFromProcess path flags ""-             return $ case r of-               Left l -> Left ("Reason: " ++ l)-               Right t -> Right $ snd t-     else error $ "fay path not are existing: " ++ path--case_executable :: Assertion-case_executable = do-  fay <- fayPath-  assertBool "Could not find fay executable" (isJust fay)--case_compile :: Assertion-case_compile = do-  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)
− src/Test/Convert.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE DeriveDataTypeable        #-}-{-# LANGUAGE ExistentialQuantification #-}--module Test.Convert (tests) where--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)--tests :: Test-tests = testGroup "Test.Convert" [reading, showing]-  where reading = testGroup "reading" $-          flip map readTests $ \(ReadTest value) ->-            let label = show value-            in testCase label $-                 assertEqual label (Just value) (showToFay value >>= readFromFay)-        showing = testGroup "showing" $-          flip map showTests $ \(Testcase value output) ->-            let label = show value-            in testCase label $-                 assertEqual label-                   (either error Just $ parseOnly Aeson.value output)-                   (showToFay value)-------------------------------------------------------------------------------------- Test cases---- | A test.-data Testcase = forall x. Show x => Testcase x Bytes.ByteString---- | A read test.-data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x----- | Tests---- | Read tests.-readTests :: [ReadTest]-readTests =-  [ReadTest $ NullaryConstructor-  ,ReadTest $ NAryConstructor 123 66.6-  ,ReadTest $ LabelledRecord { barInt = 123, barDouble = 66.6 }-  ,ReadTest $ LabelledRecord2 { bar = 123, bob = 66.6 }-  ,ReadTest $ FooBar "Tinkie Winkie" "Humanzee" Zot-  ,ReadTest $ Bar $ Foo "one" "two"-  ,ReadTest $ StepcutFoo 123-  ,ReadTest $ StepcutBar (StepcutFoo 456)-  ,ReadTest $ StepcutFoo' 789-  ,ReadTest $ Baz (StepcutFoo' 10112)-  ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\""-  ]---- | Test cases.-showTests :: [Testcase]-showTests =-   -- Fundamental data types-  [(1 :: Int) → "1"-  ,(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\""-  ,'a' → "\"a\""-  -- Data records-  ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}"-  ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"-  ,LabelledRecord { barInt = 123, barDouble = 4.5 }-     → "{\"barDouble\":4.5,\"barInt\":123,\"instance\":\"LabelledRecord\"}"-  ,Bar (Foo "one" "two") → "{\"slot1\":{\"slot1\":\"one\",\"slot2\":\"two\",\"instance\":\"Foo\"},\"instance\":\"Bar\"}"-  ,TextConstructor (pack "foo bar baz") → "{\"slot1\":\"foo bar baz\",\"instance\":\"TextConstructor\"}"-  -- Unicode-  ,"¡ ¢ £ ¤ ¥ " → "\"¡ ¢ £ ¤ ¥ \""-  ,"Ā ā Ă ă Ą " → "\"Ā ā Ă ă Ą \""-  ,"ƀ Ɓ Ƃ ƃ Ƅ " → "\"ƀ Ɓ Ƃ ƃ Ƅ \""-  ,"ɐ ɑ ɒ ɓ ɔ " → "\"ɐ ɑ ɒ ɓ ɔ \""-  ,"Ё Ђ Ѓ Є Ѕ " → "\"Ё Ђ Ѓ Є Ѕ \""-  ,"Ա Բ Գ Դ Ե " → "\"Ա Բ Գ Դ Ե \""-  ,"، ؛ ؟ ء آ " → "\"، ؛ ؟ ء آ \""-  ,"ँ ं ः अ आ " → "\"ँ ं ः अ आ \""-  ,"ఁ ం ః అ ఆ " → "\"ఁ ం ః అ ఆ \""-  ,"ก ข ฃ ค ฅ " → "\"ก ข ฃ ค ฅ \""-  ,"ກ ຂ ຄ ງ ຈ " → "\"ກ ຂ ຄ ງ ຈ \""-  ,"ༀ ༁ ༂ ༃ ༄ " → "\"ༀ ༁ ༂ ༃ ༄ \""-  ,"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ " → "\"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ \""-  ,"Ḁ ḁ Ḃ ḃ Ḅ " → "\"Ḁ ḁ Ḃ ḃ Ḅ \""-  ,"ぁ あ ぃ い ぅ " → "\"ぁ あ ぃ い ぅ \""-  ,"ァ ア ィ イ ゥ " → "\"ァ ア ィ イ ゥ \""-  ,"ㄅ ㄆ ㄇ ㄈ ㄉ " → "\"ㄅ ㄆ ㄇ ㄈ ㄉ \""-  ,"ㄱ ㄲ ㄳ ㄴ ㄵ " → "\"ㄱ ㄲ ㄳ ㄴ ㄵ \""-  ]--  where x → y = Testcase x (UTF8.fromString y)--data Foo = Foo String String-  deriving (Show,Data,Typeable,Read,Eq)-data Bar = Bar Foo-  deriving (Show,Data,Typeable,Read,Eq)---- | Nullary constructor.-data NullaryConstructor = NullaryConstructor-  deriving (Show,Data,Typeable,Read,Eq)---- | n-ary labelless constructor.-data NAryConstructor = NAryConstructor Int Double-  deriving (Show,Data,Typeable,Read,Eq)---- | Labelled record.-data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }-                    | LabelledRecord2 { bar :: Int, bob :: Double }-  deriving (Show,Data,Typeable,Read,Eq)---- | Order matters in unlabelled constructors.-data SomeThing =-  FooBar String String Zot-  deriving (Read,Data,Typeable,Show,Eq)---- | This triggers order difference. Go figure.-data Zot = Zot-  deriving (Read,Data,Typeable,Show,Eq)--data StepcutFoo = StepcutFoo { _unStepcutFoo :: Int }-    deriving (Eq, Show, Read, Typeable, Data)--data StepcutBar = StepcutBar StepcutFoo-    deriving (Eq, Show, Read, Typeable, Data)--data StepcutFoo' = StepcutFoo' Int-    deriving (Eq, Show, Read, Typeable, Data)--data Baz = Baz StepcutFoo'-    deriving (Eq, Show, Read, Typeable, Data)--data TextConstructor = TextConstructor Text-    deriving (Eq, Show, Read, Typeable, Data)
− src/Test/Util.hs 
@@ -1,38 +0,0 @@-module Test.Util-  ( fayPath-  , isRight-  , fromLeft-  ) where--import           Control.Applicative-import           System.Directory-import           System.Process.Extra        (readAllFromProcess)-import           Prelude              hiding (pred)---- Path to the fay executable, looks in cabal-dev, dist, PATH in that order.-fayPath :: IO (Maybe FilePath)-fayPath =-  (<|>) <$> firstWhereM doesFileExist [cabalDevPath, distPath] <*> usingWhich-  where-    cabalDevPath = "./cabal-dev/bin/fay"-    distPath = "./dist/build/fay/fay"-    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-  [] -> return Nothing-  a:as -> pred a >>= \b ->-          if b then return (Just a)-               else firstWhereM pred 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"
− src/Tests.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE ViewPatterns #-}---- | Generate the web site/documentation for the Fay project.------ This depends on the Fay compiler to generate examples and the--- javascript of the page is also built with Fay.--module Main where--import           Fay-import           Fay.Compiler.Config--import           Control.Applicative-import           Data.Default-import           Data.List-import           Data.Maybe-import           System.Directory-import           System.Environment-import           System.FilePath-import           System.Process.Extra-import qualified Test.Api                       as Api-import qualified Test.CommandLine               as Cmd-import qualified Test.Convert                   as C-import           Test.Framework-import           Test.Framework.Providers.HUnit-import           Test.HUnit                     (assertEqual)---- | Main test runner.-main :: IO ()-main = do-  sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment-  (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs-  compiler <- makeCompilerTests (packageConf <|> sandbox)-  defaultMainWithArgs [Api.tests, Cmd.tests, compiler, C.tests]-                      args---- | 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 -> IO Test-makeCompilerTests packageConf = do-  files <- fmap (map ("tests" </>) . sort . filter (isSuffixOf ".hs")) $ getDirectoryContents "tests"-  return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do-    testFile packageConf False file-    testFile packageConf True file--testFile :: Maybe FilePath -> Bool -> String -> IO ()-testFile packageConf opt file = do-  let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file-      out = toJsName file-      config =-        addConfigDirectoryIncludePaths ["tests/"] $-          def { configOptimize = opt-              , configTypecheck = False-              , configPackageConf = packageConf-              }-  outExists <- doesFileExist root-  compileFromTo config file (Just out)-  result <- runJavaScriptFile out-  if outExists-     then do output <- readFile root-             assertEqual file output (either show id result)-     else assertEqual file True (either (const True) (const False) result)---- | Run a JS file.-runJavaScriptFile :: String -> IO (Either String String)-runJavaScriptFile file = fmap (fmap snd) (readAllFromProcess "node" [file] "")
+ 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
@@ -0,0 +1,166 @@+-- | Main compiler executable.++module Main where++import           Fay+import           Paths_fay                 (version)++import           Control.Applicative       ((<|>), (<$>), (<*>))+import qualified Control.Exception         as E+import           Control.Monad+import           Control.Monad.Reader+import           Data.List.Split           (wordsBy)+import           Data.Maybe+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+  { 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+  config' <- defaultConfigWithSandbox+  opts    <- execParser parser+  let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $+        addConfigPackages (optPackages opts) $ config'+          { configOptimize         = optOptimize opts+          , configFlattenApps      = optFlattenApps 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 <|> configPackageConf config'+          , configExportRuntime    = not (optNoRTS opts)+          , configExportStdlib     = not (optNoStdlib opts)+          , configExportStdlibOnly = optStdlibOnly opts+          , configBasePath         = optBasePath opts+          , configStrict           = optStrict opts+          , 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 readConfigRuntime config >>= putStr+      else do+        void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible"+        case optFiles opts of+          []    -> putStrLn $ helpTxt ++ "\n  More information: fay --help"+          files -> forM_ files $ \file ->+            compileFromTo config file (if optStdout opts then Nothing else Just (outPutFile opts file))++  where+    parser = info (helper <*> options) (fullDesc <> header helpTxt)++    outPutFile :: FayCompilerOptions -> String -> FilePath+    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+  <$> 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")+  <*> 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")+  <*> 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 "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")+  <*> 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")+  <*> 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+  => (FayCompilerOptions -> Bool)+  -> FayCompilerOptions -> String -> m Bool+incompatible test opts message = if test opts+  then E.throw $ userError message+  else return True++-- | The basic help text.+helpTxt :: String+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 ()+runCommandVersion = putStrLn $ "fay " ++ showVersion version++-- | Incompatible options.+htmlAndStdout :: FayCompilerOptions -> Bool+htmlAndStdout opts = optHTMLWrapper opts && optStdout opts
+ src/tests/Test/CommandLine.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE TemplateHaskell #-}++module Test.CommandLine (tests) where++import           Fay.Compiler.Prelude+import           Test.Util++import           System.Directory+import           System.Environment+import           System.FilePath+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH++tests :: TestTree+tests = $testGroupGenerator++compileFile :: [String] -> IO (Either String String)+compileFile flags = do+  whatAGreatFramework <- fmap (fmap (\x -> x</>"bin"</>"fay") . lookup "HASKELL_SANDBOX")+                              getEnvironment+  fay <- fayPath+  let path = fromMaybe "couldn't find fay" (whatAGreatFramework <|> fay)+  exists <- doesFileExist path+  if exists+     then do r <- readAllFromProcess path flags ""+             return $ case r of+               Left  (l,_) -> Left ("Reason: " ++ l)+               Right (_,t) -> Right t+     else error $ "fay path not are existing: " ++ path++case_executable :: Assertion+case_executable = do+  fay <- fayPath+  assertBool "Could not find fay executable" (isJust fay)++case_compile :: Assertion+case_compile = do+  whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment+  res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] +++                      ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ])+  case res of+    Left  e -> assertFailure $ "Compilation failed: " ++ e+    Right _ -> assertBool "impossible" True
+ src/tests/Test/Compile.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}++module Test.Compile (tests,runScriptFile) where++import           Fay+import           Fay.Compiler.Prelude++import           Language.Haskell.Exts+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.TH++tests :: TestTree+tests = $testGroupGenerator++case_imports :: Assertion+case_imports = do+  cfg <- defConf+  res <- compileFile cfg fp+  assertBool "Could not compile file with imports" (isRight res)++case_importedList :: Assertion+case_importedList = do+  cfg <- defConf+  res <- compileFileWithState cfg fp+  case res of+    Left err -> error (show err)+    Right (_,_,r) -> assertBool "RecordImport_Export was not added to stateImported" .+                       isJust . lookup (ModuleName () "RecordImport_Export") $ stateImported r++fp :: FilePath+fp = "tests/RecordImport_Import.hs"++case_stateRecordTypes :: Assertion+case_stateRecordTypes = do+  cfg <- defConf+  res <- compileFileWithState cfg "tests/Compile/Records.hs"+  case res of+    Left err -> error (show err)+    Right (_,_,r) ->+      -- TODO order should not matter+      assertEqual "stateRecordTypes mismatch"+        [ ("Compile.Records.T", ["Compile.Records.:+"])+        , ("Compile.Records.R", ["Compile.Records.R","Compile.Records.S"])+        ]+        (filter (isFromMod "Compile.Records") $ stateRecordTypes r)++case_importStateRecordTypes :: Assertion+case_importStateRecordTypes = do+  cfg <- defConf+  res <- compileFileWithState cfg "tests/Compile/ImportRecords.hs"+  case res of+    Left err -> error (show err)+    Right (_,_,r) ->+      -- TODO order should not matter+      assertEqual "stateRecordTypes mismatch"+        [ ("Compile.Records.T",["Compile.Records.:+"])+        , ("Compile.Records.R",["Compile.Records.R", "Compile.Records.S"])+        ]+        (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+  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+  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+  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++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+  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"++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
@@ -0,0 +1,156 @@+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}++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.Text                      (Text, pack)+import           Test.Tasty+import           Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "Test.Convert" [reading, showing]+  where reading = testGroup "reading" $+          flip map readTests $ \(ReadTest value) ->+            let label = show value+            in testCase label $+                 assertEqual label (Just value) (showToFay value >>= readFromFay)+        showing = testGroup "showing" $+          flip map showTests $ \(Testcase value output) ->+            let label = show value+            in testCase label $+                 assertEqual label+                   (either error Just $ parseOnly Aeson.value output)+                   (showToFay value)+++--------------------------------------------------------------------------------+-- Test cases++-- | A test.+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+++-- | Tests++-- | Read tests.+readTests :: [ReadTest]+readTests =+  [ReadTest $ NullaryConstructor+  ,ReadTest $ NAryConstructor 123 66.6+  ,ReadTest $ LabelledRecord { barInt = 123, barDouble = 66.6 }+  ,ReadTest $ LabelledRecord2 { bar = 123, bob = 66.6 }+  ,ReadTest $ FooBar "Tinkie Winkie" "Humanzee" Zot+  ,ReadTest $ Bar $ Foo "one" "two"+  ,ReadTest $ StepcutFoo 123+  ,ReadTest $ StepcutBar (StepcutFoo 456)+  ,ReadTest $ StepcutFoo' 789+  ,ReadTest $ Baz (StepcutFoo' 10112)+  ,ReadTest $ TextConstructor $ pack "This is \"some text\n\n\""+  ,ReadTest $ (("foo",'a') :: (String,Char))+  ,ReadTest $ ((pack "foo",'a',23) :: (Text,Char,Int))+  ,ReadTest $ TupleList [(pack "foo",pack "bar")]+  ,ReadTest $ TupleList' [((pack "foo",23) :: (Text,Int))]+  ,ReadTest $ ()+  ]++-- | Test cases.+showTests :: [Testcase]+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] :: [Int]) → "[1,2]"+  ,((1,2) :: (Int,Int)) → "[1,2]"+  ,"abc" → "\"abc\""+  ,'a' → "\"a\""+  , () → "null"+  -- Data records+  ,NullaryConstructor → "{\"instance\":\"NullaryConstructor\"}"+  ,NAryConstructor 123 4.5 → "{\"slot1\":123,\"slot2\":4.5,\"instance\":\"NAryConstructor\"}"+  ,LabelledRecord { barInt = 123, barDouble = 4.5 }+     → "{\"barDouble\":4.5,\"barInt\":123,\"instance\":\"LabelledRecord\"}"+  ,Bar (Foo "one" "two") → "{\"slot1\":{\"slot1\":\"one\",\"slot2\":\"two\",\"instance\":\"Foo\"},\"instance\":\"Bar\"}"+  ,TextConstructor (pack "foo bar baz") → "{\"slot1\":\"foo bar baz\",\"instance\":\"TextConstructor\"}"+  -- Unicode+  ,"¡ ¢ £ ¤ ¥ " → "\"¡ ¢ £ ¤ ¥ \""+  ,"Ā ā Ă ă Ą " → "\"Ā ā Ă ă Ą \""+  ,"ƀ Ɓ Ƃ ƃ Ƅ " → "\"ƀ Ɓ Ƃ ƃ Ƅ \""+  ,"ɐ ɑ ɒ ɓ ɔ " → "\"ɐ ɑ ɒ ɓ ɔ \""+  ,"Ё Ђ Ѓ Є Ѕ " → "\"Ё Ђ Ѓ Є Ѕ \""+  ,"Ա Բ Գ Դ Ե " → "\"Ա Բ Գ Դ Ե \""+  ,"، ؛ ؟ ء آ " → "\"، ؛ ؟ ء آ \""+  ,"ँ ं ः अ आ " → "\"ँ ं ः अ आ \""+  ,"ఁ ం ః అ ఆ " → "\"ఁ ం ః అ ఆ \""+  ,"ก ข ฃ ค ฅ " → "\"ก ข ฃ ค ฅ \""+  ,"ກ ຂ ຄ ງ ຈ " → "\"ກ ຂ ຄ ງ ຈ \""+  ,"ༀ ༁ ༂ ༃ ༄ " → "\"ༀ ༁ ༂ ༃ ༄ \""+  ,"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ " → "\"Ⴀ Ⴁ Ⴂ Ⴃ Ⴄ \""+  ,"Ḁ ḁ Ḃ ḃ Ḅ " → "\"Ḁ ḁ Ḃ ḃ Ḅ \""+  ,"ぁ あ ぃ い ぅ " → "\"ぁ あ ぃ い ぅ \""+  ,"ァ ア ィ イ ゥ " → "\"ァ ア ィ イ ゥ \""+  ,"ㄅ ㄆ ㄇ ㄈ ㄉ " → "\"ㄅ ㄆ ㄇ ㄈ ㄉ \""+  ,"ㄱ ㄲ ㄳ ㄴ ㄵ " → "\"ㄱ ㄲ ㄳ ㄴ ㄵ \""+  ]++  where x → y = Testcase x (UTF8.fromString y)++data Foo = Foo String String+  deriving (Show,Data,Typeable,Read,Eq)+data Bar = Bar Foo+  deriving (Show,Data,Typeable,Read,Eq)++-- | Nullary constructor.+data NullaryConstructor = NullaryConstructor+  deriving (Show,Data,Typeable,Read,Eq)++-- | n-ary labelless constructor.+data NAryConstructor = NAryConstructor Int Double+  deriving (Show,Data,Typeable,Read,Eq)++-- | Labelled record.+data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double }+                    | LabelledRecord2 { bar :: Int, bob :: Float }+  deriving (Show,Data,Typeable,Read,Eq)++-- | Order matters in unlabelled constructors.+data SomeThing =+  FooBar String String Zot+  deriving (Read,Data,Typeable,Show,Eq)++-- | This triggers order difference. Go figure.+data Zot = Zot+  deriving (Read,Data,Typeable,Show,Eq)++data StepcutFoo = StepcutFoo { _unStepcutFoo :: Int }+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutBar = StepcutBar StepcutFoo+    deriving (Eq, Show, Read, Typeable, Data)++data StepcutFoo' = StepcutFoo' Int+    deriving (Eq, Show, Read, Typeable, Data)++data Baz = Baz StepcutFoo'+    deriving (Eq, Show, Read, Typeable, Data)++data TextConstructor = TextConstructor Text+    deriving (Eq, Show, Read, Typeable, Data)++data TupleList = TupleList [(Text,Text)]+  deriving (Read, Typeable, Data, Show, Eq)++data TupleList' a = TupleList' [(Text,a)]+  deriving (Read, Typeable, Data, Show, Eq)
+ 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
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Test.Util+  ( fayPath+  , getRecursiveContents+  ) where++import           Fay.Compiler.Prelude++import           System.Directory+import           System.FilePath++-- Path to the fay executable, looks in cabal-dev, dist, PATH in that order.+fayPath :: IO (Maybe FilePath)+fayPath =+  (<|>) <$> firstWhereM doesFileExist [cabalDevPath, distPath] <*> usingWhich+  where+    cabalDevPath = "./cabal-dev/bin/fay"+    distPath = "./dist/build/fay/fay"+    usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] ""++firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)+firstWhereM p ins = case ins of+  [] -> return Nothing+  a:as -> p a >>= \b ->+          if b then return (Just a)+               else firstWhereM p as++-- from the package `errors`+hush :: Either a b -> Maybe b+hush = either (const Nothing) Just++-- | 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
@@ -0,0 +1,155 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ViewPatterns      #-}++-- | Generate the web site/documentation for the Fay project.+--+-- This depends on the Fay compiler to generate examples and the+-- javascript of the page is also built with Fay.++module Main where++import           Fay.Compiler.Prelude++import           Fay+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           Data.Set             (Set)+import qualified Data.Set             as S+import           System.Directory+import           System.Environment+import           System.FilePath+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)     <- 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 -> 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++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/"]+          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 <- Compile.runScriptFile isTs out+  if resExists+     then do output <- readFile resf+             assertEqual file output (either show snd result)+     else+       if partialExists+         then case result of+           Left (_,res) -> do+             output <- readFile partialName+             assertEqual file output res+           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)++-- | 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/Api/CPPTypecheck.hs 
@@ -1,13 +0,0 @@-{-# LANGUAGE CPP #-}--module CPPTypecheck where--#ifdef FAY-import           FFI-import           Prelude-#endif--data R = R { time :: String }--main :: Fay ()-main = print $ R "x"
− tests/Api/ImportRecords.hs 
@@ -1,3 +0,0 @@-module Api.ImportRecords where--import Api.Records
− tests/Api/Records.hs 
@@ -1,4 +0,0 @@-module Api.Records where--data R = R Int Int | S { x :: Int, y :: Int }-data T = Int :+ Int
+ tests/AutomaticList.hs view
@@ -0,0 +1,38 @@+module AutomaticList where++import FFI++main :: Fay ()+main = do+  printA ()+  printA ([] :: [Int])+  printA [1,2,3]+  printA [[1],[2],[3]]+  printA (1,2)+  printA ([1],[2])+  printArr [1,2,3]+  printArr [[1],[2],[3]]+  printT (1,2)+  printT ([1],[2])+  printA $ readA "[]"+  printA . tail $ readA "[1,2,3]"+  printA . tail $ readArr "[1,2,3]"+  printA . snd $ readT "[1,2]"++printA :: Automatic a -> Fay ()+printA = ffi "console.log(%1)"++printArr :: Automatic [a] -> Fay ()+printArr = ffi "console.log(%1)"++printT :: (Automatic a, Automatic b) -> Fay ()+printT = ffi "console.log(%1)"++readA :: String -> Automatic a+readA = ffi "JSON.parse(%1)"++readArr :: String -> Automatic [a]+readArr = ffi "JSON.parse(%1)"++readT :: String -> Automatic (a,b)+readT = ffi "JSON.parse(%1)"
+ tests/AutomaticList.res view
@@ -0,0 +1,14 @@+[]+[]+[ 1, 2, 3 ]+[ [ 1 ], [ 2 ], [ 3 ] ]+[ 1, 2 ]+[ [ 1 ], [ 2 ] ]+[ 1, 2, 3 ]+[ [ 1 ], [ 2 ], [ 3 ] ]+[ 1, 2 ]+[ [ 1 ], [ 2 ] ]+[]+[ 2, 3 ]+[ 2, 3 ]+2
− tests/Bool 
@@ -1,1 +0,0 @@-true
tests/Bool.hs view
@@ -1,4 +1,2 @@-import Prelude- main :: Fay () main = print True
+ tests/Bool.res view
@@ -0,0 +1,1 @@+true
+ tests/CPP.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE NoImplicitPrelude #-}++#ifdef FAY+import           Prelude+#else+this is invalid code+#endif++#ifdef FAY+main :: Fay ()+#endif++#ifndef FAY+more invalid code+#if FAY+this should not be used+#endif+#else+#if FAY+main = print True+#else+invalid and nested+#endif+#endif
+ tests/CPP.res view
@@ -0,0 +1,1 @@+true
+ tests/Char.hs view
@@ -0,0 +1,38 @@+module Char where++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
@@ -0,0 +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/CPPMultiLineStrings.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NoImplicitPrelude #-}+module CPPMultiLineStrings where++import Prelude+import FFI++printAll :: [String] -> Fay ()+printAll = ffi "\+  \(function(xs) {\+  \  var prn = function(x) {\+  \    console.log(x);\+  \  };\+  \  for(var i=0; i<xs.length; i++) {\+  \    prn(xs[i]);\+  \  }\+  \})(%1)"++main :: Fay ()+main = printAll ["a", "b", "c"]
+ tests/Compile/CPPTypecheck.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE CPP #-}++module CPPTypecheck where++#ifdef FAY+import           FFI+import           Prelude+#endif++data R = R { time :: String }++main :: Fay ()+main = print $ R "x"
+ tests/Compile/EnumChar.hs view
@@ -0,0 +1,9 @@+module EnumChar where++import           Prelude++f :: [Char]+f = ['a'..'z']++main :: Fay ()+main = print f
+ tests/Compile/ImportRecords.hs view
@@ -0,0 +1,3 @@+module Compile.ImportRecords where++import Compile.Records
+ tests/Compile/Records.hs view
@@ -0,0 +1,4 @@+module Compile.Records where++data R = R Int Int | S { x :: Int, y :: Int }+data T = Int :+ Int
+ tests/Compile/StrictWrapper.hs view
@@ -0,0 +1,88 @@+module StrictWrapper (+  f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth,+  sumInt, sumIntWrapped, zipWithPlus, zipWithPlusWrapped,+  sumPair, sumPairWrapped, zipPairs, zipPairsWrapped+) where++import           FFI+import           Prelude++f :: Int -> Int -> Int+f x y = x + y++data R = R { i :: Int }++g :: R -> Int+g R{i=i} = i++h :: R -> R+h (R i) = R (i + 1)++r :: R+r = R 2++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+  ffi "console.log(Strict.StrictWrapper.f(1,2))" :: Fay ()+  ffi "console.log(Strict.StrictWrapper.g({instance:'R',i:1}))" :: Fay ()+  ffi "console.log(Strict.StrictWrapper.h({instance:'R',i:1}))" :: Fay ()+  ffi "console.log(Strict.StrictWrapper.r)" :: Fay ()+  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
@@ -0,0 +1,16 @@+3+1+{ 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
@@ -0,0 +1,30 @@+import           FFI++data R = R (Defined Double)++main :: Fay ()+main = do+  printD $ Defined (1 :: Double)+  printS $ Defined "Hello, World!"+  printSS $ Defined ["Hello,","World!"]+  printD $ (Undefined :: Defined Double)+  print $ R (Defined 1)+  print $ R Undefined+  print $ r1+  print $ r2+  return ()++printD :: Defined Double -> Fay ()+printD = ffi "console.log(%1)"++printS :: Defined String -> Fay ()+printS = ffi "console.log(%1)"++printSS :: Defined [String] -> Fay ()+printSS = ffi "console.log(%1)"++r1 :: R+r1 = ffi "{ instance: 'R', slot1 : 1 }"++r2 :: R+r2 = ffi "{ instance : 'R' }"
+ tests/Defined.res view
@@ -0,0 +1,8 @@+1+Hello, World!+[ 'Hello,', 'World!' ]+undefined+{ instance: 'R', slot1: 1 }+{ instance: 'R' }+{ instance: 'R', slot1: 1 }+{ instance: 'R' }
+ 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
@@ -0,0 +1,8 @@+module DoLet2 where++import FFI++main = do+  print 1+  let [a,b] = [3]+  print a
+ tests/DoLet2_partial.res view
@@ -0,0 +1,1 @@+1
+ tests/DoLet3.hs view
@@ -0,0 +1,17 @@+module DoLet3 where++import FFI++data R = R Int++main = do+  print 1+  let [a] = [2]+  print a+  let (b,c) = (3,4)+  print b+  print c+  let R d = R 5+  print d+  let [e] = []+  print e
+ tests/DoLet3_partial.res view
@@ -0,0 +1,5 @@+1+2+3+4+5
− tests/Double 
@@ -1,1 +0,0 @@-4
tests/Double.hs view
@@ -1,4 +1,4 @@-import           Prelude--main = print (2 * 4 / 2)+module Double where +main :: Fay ()+main = print ((2 * 4 / 2) :: Double)
+ tests/Double.res view
@@ -0,0 +1,1 @@+4
− tests/Double2 
@@ -1,1 +0,0 @@-14
tests/Double2.hs view
@@ -1,4 +1,4 @@-import           Prelude--main = print (10 + (2 * (4 / 2)))+module Double2 where +main :: Fay ()+main = print ((10 + (2 * (4 / 2))) :: Double)
+ tests/Double2.res view
@@ -0,0 +1,1 @@+14
− tests/Double3 
@@ -1,1 +0,0 @@-7.5
tests/Double3.hs view
@@ -1,4 +1,4 @@-import           Prelude--main = print (5 * 3 / 2)+module Double3 where +main :: Fay ()+main = print ((5 * 3 / 2) :: Double)
+ tests/Double3.res view
@@ -0,0 +1,1 @@+7.5
− tests/Double4 
@@ -1,1 +0,0 @@-1
tests/Double4.hs view
@@ -1,4 +1,4 @@-import           Prelude+module Double4 where +main :: Fay () main = print 1-
+ tests/Double4.res view
@@ -0,0 +1,1 @@+1
+ tests/Either.hs view
@@ -0,0 +1,14 @@+module Either where++raw :: Either Int Int -> Int+raw x = case x of Left a -> a + 1+                  Right b -> b + 2++func :: Either Int Int -> Int+func x = either (\x -> x + 1) (\x -> x + 2) x++main = do+  print $ raw $ Left 5+  print $ raw $ Right 5+  print $ func $ Left 5+  print $ func $ Right 5
+ tests/Either.res view
@@ -0,0 +1,4 @@+6+7+6+7
+ 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
@@ -0,0 +1,7 @@+module Eq where++main = do+  when (1 == 1) $ putStrLn "Expected =="+  when (1 == 2) $ putStrLn "Unexpected =="+  when (1 /= 1) $ putStrLn "Unexpected /="+  when (1 /= 2) $ putStrLn "Expected /="
+ tests/Eq.res view
@@ -0,0 +1,2 @@+Expected ==+Expected /=
+ tests/ExportEThingAll.hs view
@@ -0,0 +1,5 @@+module ExportEThingAll where++import ExportEThingAll_Export++main = print Barbles
+ tests/ExportEThingAll.res view
@@ -0,0 +1,1 @@+{ instance: 'Barbles' }
+ tests/ExportEThingAll_Export.hs view
@@ -0,0 +1,3 @@+module ExportEThingAll_Export (Bar(..)) where++data Bar = Barbles
+ tests/ExportEThingAll_Export.res view
+ tests/ExportEThingWith.hs view
@@ -0,0 +1,3 @@+module ExportEThingWith (Bar(Barbles)) where++data Bar = Barbles
+ tests/ExportEThingWith.res view
+ tests/ExportList.hs view
@@ -0,0 +1,16 @@+module ExportList (main) where++import ExportList_A+import FFI++a = A { a1 = 3 }+b = B { b1 = 4 }++main :: Fay ()+main = do+  print x+  print y+  print $ a1 a+  print $ b1 b+  print c+  print d
+ tests/ExportList.res view
@@ -0,0 +1,6 @@+1+2+3+4+42+64
+ tests/ExportList_A.hs view
@@ -0,0 +1,10 @@+module ExportList_A (x, A (..), B (B, b1), module ExportList_B) where++import ExportList_B++x :: Double+x = 1++data A = A { a1 :: Double }++data B = B { b1 :: Double }
+ tests/ExportList_A.res view
+ tests/ExportList_B.hs view
@@ -0,0 +1,7 @@+module ExportList_B (y, module ExportList_C, module ExportList_D) where++import ExportList_C+import ExportList_D++y :: Double+y = 2
+ tests/ExportList_B.res view
+ tests/ExportList_C.hs view
@@ -0,0 +1,3 @@+module ExportList_C where++c = 42
+ tests/ExportList_C.res view
+ tests/ExportList_D.hs view
@@ -0,0 +1,3 @@+module ExportList_D(module ExportList_D) where++d = 64
+ tests/ExportList_D.res view
+ tests/ExportQualified_Export.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE PackageImports #-}+module ExportQualified_Export (main, X.X) where++import           Prelude+import           "base" X++main :: Fay ()+main = return ()
+ tests/ExportQualified_Export.res view
+ tests/ExportQualified_Import.hs view
@@ -0,0 +1,3 @@+module ExportQualified_Import where++import ExportQualified_Export
+ tests/ExportQualified_Import.res view
+ tests/ExportType.hs view
@@ -0,0 +1,23 @@+module ExportType (+    X (..) -- Export constructor implicitly (EThingAll)+  , Y (Y)  -- Export constructor explicitly (EThingWith)+  , Z (..) -- Export fields implicitly (EThingAll)+  , W      -- Export only type (EAbs)+  , w      -- Export fields separately (EVar)+  , V (V, v1) -- Export fields partially (EThingWith)+  ) where++import           FFI++data X = X++data Y = Y++data Z = Z { z :: Double }++data W = W++w :: W+w = W++data V = V { v1 :: Double, v2 :: Double }
+ tests/ExportType.res view
+ tests/Floating.hs view
@@ -0,0 +1,10 @@+module Floating where++main = do+  print $ exp 0+  print $ sqrt 4+  print $ log (exp 3)+  print $ 2 ** 2+  print $ logBase 10 100+  print $ sin (pi/2)+  print $ cos pi
+ tests/Floating.res view
@@ -0,0 +1,7 @@+1+2+3+4+2+1+-1
+ tests/FromString.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+module FromString where++import FromString.FayText+import FromString.Dep (myString, depTest)+import Prelude++main :: Fay ()+main = do+  print ("This is not a String" :: Text)+  print "This is not a String"+  putStrLn myString+  print myString+  depTest
+ tests/FromString.res view
@@ -0,0 +1,5 @@+This is not a String+This is not a String+test+[ 't', 'e', 's', 't' ]+This is also not a String
+ tests/FromString/Dep.hs view
@@ -0,0 +1,11 @@+module FromString.Dep where++import Prelude+import FromString.DepDep (myText)++myString :: String+myString = "test"++depTest :: Fay ()+depTest = print myText+
+ tests/FromString/Dep.res view
+ tests/FromString/DepDep.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings, RebindableSyntax #-}+module FromString.DepDep where++import Prelude+import FromString.FayText++myText :: Text+myText = "This is also not a String"+
+ tests/FromString/DepDep.res view
+ tests/FromString/FayText.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP                #-}+-- | Module to be shared between server and client.+--+-- This module must be valid for both GHC and Fay.+module FromString.FayText where++import           Prelude+#ifdef FAY+import           FFI+#else+import           Fay.FFI+#endif+import           Data.Data++#ifdef FAY++data Text = Text+    deriving (Show, Read, Eq, Typeable, Data)++pack :: String -> Text+pack = ffi "%1"++unpack :: Text -> String+unpack = ffi "%1"++#else++import qualified Data.Text as T++type Text = T.Text++pack :: String -> Text+pack = T.pack++unpack :: Text -> String+unpack = T.unpack++#endif++fromString :: String -> Text+fromString = pack
+ tests/FromString/FayText.res view
+ tests/GADTs_without_records.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE GADTs #-}++module GADTs_without_records where++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++true :: Expr Bool+true = B True++eval :: Expr a -> a+eval (I x) = x+eval (Plus a1 a2) = eval a1 + eval a2+eval (B x) = x+eval (IfThenElse p e1 e2) = case eval p of+  True -> eval e1+  False -> eval e2++n5 = I 5+n2 = I 2++expr1 = Plus n5 n2++expr2 = IfThenElse true expr1 n5+expr3 = IfThenElse false expr1 n5++main = do+  when (eval n5 == 5) $ putStrLn "Expected 5: Ok"+  when (eval n2 == 2) $ putStrLn "Expected 2: Ok"+  when (eval expr1 == 7) $ putStrLn "Expected 7: Ok"+  when (eval expr2 == 7) $ putStrLn "Expected 7: Ok"+  when (eval expr3 == 5) $ putStrLn "Expected 5: Ok"
+ tests/GADTs_without_records.res view
@@ -0,0 +1,5 @@+Expected 5: Ok+Expected 2: Ok+Expected 7: Ok+Expected 7: Ok+Expected 5: Ok
+ tests/GuardWhere.hs view
@@ -0,0 +1,9 @@+module GuardWhere where++poseL :: Bool -> String+poseL y | y == True = "Not OK"+  where x = 5+poseL _ = "OK"++main :: Fay ()+main = putStrLn $ poseL False
+ tests/GuardWhere.res view
@@ -0,0 +1,1 @@+OK
+ tests/HidePreludeImport.hs view
@@ -0,0 +1,7 @@+module HidePreludeImport where++import HidePreludeImport_Import+import Prelude hiding (last)++main :: Fay ()+main = print last
+ tests/HidePreludeImport.res view
@@ -0,0 +1,1 @@+1
+ tests/HidePreludeImport_Import.hs view
@@ -0,0 +1,4 @@+module HidePreludeImport_Import where++last :: Double+last = 1
+ tests/HidePreludeImport_Import.res view
tests/Hierarchical/Export.hs view
@@ -1,8 +1,6 @@-- module Hierarchical.Export where -import           Language.Fay.FFI+import           FFI import           Prelude  exported :: String
+ tests/Hierarchical/Export.res view
tests/Hierarchical/RecordDefined.hs view
@@ -1,8 +1,6 @@-- module Hierarchical.RecordDefined where -import           Language.Fay.FFI+import           FFI import           Prelude  data Callback a = Callback Double
+ tests/Hierarchical/RecordDefined.res view
− tests/HierarchicalImport 
@@ -1,1 +0,0 @@-exported
tests/HierarchicalImport.hs view
@@ -1,6 +1,6 @@-import           Prelude+module HierarchicalImport where+ import           Hierarchical.Export  main :: Fay () main = putStrLn exported-
+ tests/HierarchicalImport.res view
@@ -0,0 +1,1 @@+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
@@ -0,0 +1,9 @@+module ImportHiding where++import ImportList1.A hiding (y)+import ImportList1.B hiding (x)++main :: Fay ()+main = do+  print x+  print y
+ tests/ImportHiding.res view
@@ -0,0 +1,2 @@+1+2
+ tests/ImportIThingAll.hs view
@@ -0,0 +1,11 @@+module ImportIThingAll where++import           FFI++import           ImportList1.C        (A (..))++main :: Fay ()+main = do+  print $ B1 1+  print $ b1 (B1 1)+  print $ B2 2
+ tests/ImportIThingAll.res view
@@ -0,0 +1,3 @@+{ instance: 'B1', b1: 1 }+1+{ instance: 'B2', slot1: 2 }
+ tests/ImportList.hs view
@@ -0,0 +1,15 @@+module ImportList where++import           FFI++import           ImportList1.A        (x)+import           ImportList1.B        (y, R (s1), r, s2, X (Y), (<<>>))++main :: Fay ()+main = do+  print x+  print y+  print $ s1 r+  print $ s2 r+  print $ Y 1+  print $ 2 <<>> 3
+ tests/ImportList.res view
@@ -0,0 +1,6 @@+1+2+3+4+{ instance: 'Y', slot1: 1 }+5
+ tests/ImportList1/A.hs view
@@ -0,0 +1,12 @@+module ImportList1.A where++import           Prelude+import           FFI++x :: Double+x = 1++y :: Double+y = 1++data R = S
+ tests/ImportList1/A.res view
+ tests/ImportList1/B.hs view
@@ -0,0 +1,20 @@+module ImportList1.B where++import           Prelude+import           FFI++x :: Double+x = 2++y :: Double+y = 2++data R = S { s1 :: Double, s2 :: Double }++r :: R+r = S 3 4++data X = Y Int++(<<>>) :: Double -> Double -> Double+(<<>>) = (+)
+ tests/ImportList1/B.res view
+ tests/ImportList1/C.hs view
@@ -0,0 +1,10 @@+module ImportList1.C where++import           Prelude++data A = B1 { b1 :: Double } | B2 Double++data UnimportedX = UnimportedY++unimportedF :: Double+unimportedF = 1
+ tests/ImportList1/C.res view
+ tests/ImportListType.hs view
@@ -0,0 +1,6 @@+module ImportListType where++import Prelude (Fay, putStrLn)++main :: Fay ()+main = putStrLn "ok"
+ tests/ImportListType.res view
@@ -0,0 +1,1 @@+ok
+ tests/ImportType.hs view
@@ -0,0 +1,16 @@+module ImportType where++import           ExportType++w' :: W+w' = w++main :: Fay ()+main = do+  print X+  print Y+  print (Z 1)+  print (z (Z 1))+  print w'+  print (V 1 2)+  print (v1 (V 1 2))
+ tests/ImportType.res view
@@ -0,0 +1,7 @@+{ instance: 'X' }+{ instance: 'Y' }+{ instance: 'Z', z: 1 }+1+{ instance: 'W' }+{ instance: 'V', v1: 1, v2: 2 }+1
+ tests/ImportType2.hs view
@@ -0,0 +1,7 @@+module ImportType2 where++import ImportType2I.A (foo)+import ImportType2I.B (Foo)++main :: Fay ()+main = foo
+ tests/ImportType2.res view
@@ -0,0 +1,1 @@+A
+ tests/ImportType2I/A.hs view
@@ -0,0 +1,5 @@+module ImportType2I.A where++import Prelude++foo = putStrLn "A"
+ tests/ImportType2I/A.res view
+ tests/ImportType2I/B.hs view
@@ -0,0 +1,7 @@+module ImportType2I.B where++import Prelude++data Foo++foo = putStrLn "B!"
+ tests/ImportType2I/B.res 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
@@ -0,0 +1,30 @@+module Integral where++printPair :: (Int,Int) -> Fay ()+printPair (x,y) = print x >> print y++main = do+  print (( 3) `quot` ( 2))+  print (( 3) `quot` (-2))+  print ((-3) `quot` ( 2))+  print ((-3) `quot` (-2))+  print (( 3) `rem` ( 2))+  print (( 3) `rem` (-2))+  print ((-3) `rem` ( 2))+  print ((-3) `rem` (-2))+  print (( 3) `div` ( 2))+  print (( 3) `div` (-2))+  print ((-3) `div` ( 2))+  print ((-3) `div` (-2))+  print (( 3) `mod` ( 2))+  print (( 3) `mod` (-2))+  print ((-3) `mod` ( 2))+  print ((-3) `mod` (-2))+  printPair (( 3) `divMod` ( 2))+  printPair (( 3) `divMod` (-2))+  printPair ((-3) `divMod` ( 2))+  printPair ((-3) `divMod` (-2))+  printPair (( 3) `quotRem` ( 2))+  printPair (( 3) `quotRem` (-2))+  printPair ((-3) `quotRem` ( 2))+  printPair ((-3) `quotRem` (-2))
+ tests/Integral.res view
@@ -0,0 +1,32 @@+1+-1+-1+1+1+1+-1+-1+1+-2+-2+1+1+-1+1+-1+1+1+-2+-1+-2+1+1+-1+1+1+-1+1+-1+-1+1+-1
+ tests/Issue215/B.hs view
@@ -0,0 +1,6 @@+module Issue215.B where++import Prelude++f :: Int -> Maybe Int+f x = Just x
+ tests/Issue215/B.res view
+ tests/Issue215A.hs view
@@ -0,0 +1,5 @@+module Issue215A where++import Issue215.B++main = print $ f 2
+ tests/Issue215A.res view
@@ -0,0 +1,1 @@+{ instance: 'Just', slot1: 2 }
+ tests/Js2FayFunc.hs view
@@ -0,0 +1,25 @@+module Js2FayFunc where++import FFI++main :: Fay ()+main = do+  f <- getF+  g <- getG+  h <- getH 0+  ret1 <- f "hey" "world" 123+  ret2 <- f "ahoy" "la" 666+  ret3 <- g "ack"+  putStrLn ret1+  putStrLn ret2+  putStrLn ret3+  putStrLn (h "apples" "pears")++getF :: Fay (String -> String -> Int -> Fay String)+getF = ffi "(function(x,y,z){ return 'getF: ' + x + ', ' + y + ', ' + z; })"++getG :: Fay (String -> Fay String)+getG = ffi "(function(x){ return 'getG: ' + x; })"++getH :: Int -> Fay (String -> String -> String)+getH = ffi "(function(x,y){ return 'getH: ' + x + ', ' + y; })"
+ tests/Js2FayFunc.res view
@@ -0,0 +1,4 @@+getF: hey, world, 123+getF: ahoy, la, 666+getG: ack+getH: apples, pears
+ tests/JsFunctionPassing.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE EmptyDataDecls #-}++module JsFunctionPassing where++import           FFI++data Func++makeFunc0 :: Int -> Func+makeFunc0 = ffi "function() {return %1;}"++callFunc0 :: Func -> Fay Int+callFunc0 = ffi "%1()"++makeFunc1 :: Int -> Func+makeFunc1 = ffi "function(x) {return %1;}"++callFunc1 :: Func -> Fay Int+callFunc1 = ffi "%1(1)"++main = do+  callFunc0 (makeFunc0 1) >>= print+  callFunc1 (makeFunc1 2) >>= print
+ tests/JsFunctionPassing.res view
@@ -0,0 +1,2 @@+1+2
+ 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
@@ -0,0 +1,6 @@+module LazyOperators where++main :: Fay ()+main = print testFn++testFn = let f a b = snd (a/b,10::Double) in f (1::Double) (0::Double)
+ tests/LazyOperators.res view
@@ -0,0 +1,1 @@+10
− tests/List 
@@ -1,1 +0,0 @@-[1,2,3,4,5]
tests/List.hs view
@@ -1,11 +1,17 @@+module List where+ import           FFI-import           Prelude+import           Prelude hiding (take) +main :: Fay () main = putStrLn (showList (take 5 (let ns = 1 : map' (\x -> x + 1) ns in ns))) +take :: Int -> [a] -> [a] take 0 _      = [] take n (x:xs) = x : take (n - 1) xs ++map' :: (a -> b) -> [a] -> [b] map' f []     = [] map' f (x:xs) = f x : map' f xs 
+ tests/List.res view
@@ -0,0 +1,1 @@+[1,2,3,4,5]
− tests/List2 
@@ -1,1 +0,0 @@-[1,61.5,3782.25,232608.375,14305415.0625]
tests/List2.hs view
@@ -1,13 +1,20 @@+module List2 where+ import           FFI-import           Prelude+import           Prelude hiding (take) +main :: Fay () main = putStrLn (showList (take 5 (let ns = 1 : map' (foo 123) ns in ns))) +foo :: Double -> Double -> Double foo x y = x * y / 2 +take :: Int -> [a] -> [a] take 0 _      = [] take n (x:xs) = x : take (n - 1) xs ++map' :: (a -> b) -> [a] -> [b] map' f []     = [] map' f (x:xs) = f x : map' f xs 
+ tests/List2.res view
@@ -0,0 +1,1 @@+[1,61.5,3782.25,232608.375,14305415.0625]
+ 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/ModuleReExport/ExportsIdentifier.hs view
@@ -0,0 +1,8 @@+module ModuleReExport.ExportsIdentifier where++import Prelude++div :: () -> String+div _ = "I am the identifier!"++div' = "bob"
+ tests/ModuleReExport/ExportsIdentifier.res view
+ tests/ModuleReExport/ExportsModule.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}++module ModuleReExport.ExportsModule+  ( module ModuleReExport.ExportsIdentifier+  , module Prelude+  , foo+  )+  where++import ModuleReExport.ExportsIdentifier+import Prelude hiding (div)++foo = div
+ tests/ModuleReExport/ExportsModule.res view
+ tests/ModuleReExports.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module ModuleReExports where++import ModuleReExport.ExportsModule++main = putStrLn (div ())
+ tests/ModuleReExports.res view
@@ -0,0 +1,1 @@+I am the identifier!
+ tests/ModuleRecordClash.hs view
@@ -0,0 +1,10 @@+module ModuleRecordClash (main) where++import ModuleRecordClash.R++data R = R++main :: Fay ()+main = do+  print R+  print i
+ tests/ModuleRecordClash.res view
@@ -0,0 +1,2 @@+{ instance: 'R' }+1
+ tests/ModuleRecordClash/R.hs view
@@ -0,0 +1,6 @@+module ModuleRecordClash.R where++import Prelude++i :: Double+i = 1
+ tests/ModuleRecordClash/R.res view
+ tests/ModuleRecordClash2.hs view
@@ -0,0 +1,9 @@+module ModuleRecordClash2 where++import           FFI+import           ModuleRecordClash2_Hello++alert :: String -> Fay ()+alert = ffi "console.log(%1)"++main = alert (greeting defaultHello)
+ tests/ModuleRecordClash2.res view
@@ -0,0 +1,1 @@+Hello, world!
+ tests/ModuleRecordClash2_Hello.hs view
@@ -0,0 +1,7 @@+-- This module needs to be top level to do the intended test.+module ModuleRecordClash2_Hello where++defaultHello :: ModuleRecordClash2_Hello+defaultHello = ModuleRecordClash2_Hello { greeting = "Hello, world!" }++data ModuleRecordClash2_Hello = ModuleRecordClash2_Hello { greeting :: String }
+ tests/ModuleRecordClash2_Hello.res view
− tests/Monad 
@@ -1,3 +0,0 @@-456-789-101112
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/Monad.res view
@@ -0,0 +1,3 @@+456+789+101112
− tests/Monad2 
@@ -1,1 +0,0 @@-abc: 123
tests/Monad2.hs view
@@ -1,10 +1,7 @@-{-# LANGUAGE EmptyDataDecls    #-}--{-# LANGUAGE RankNTypes        #-}---- | Monads test.+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE RankNTypes     #-} -import           Prelude+module Monad2 where  main :: Fay () main = do
+ tests/Monad2.res view
@@ -0,0 +1,1 @@+abc: 123
+ 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
@@ -0,0 +1,4 @@+module NestedImporting where++r :: Double+r = 1
+ tests/NestedImporting.res view
+ tests/NestedImporting/A.hs view
@@ -0,0 +1,7 @@+module NestedImporting.A where++import Prelude+import NestedImporting++main :: Fay ()+main = print r
+ tests/NestedImporting/A.res view
@@ -0,0 +1,1 @@+1
+ tests/NestedImporting2.hs view
@@ -0,0 +1,6 @@+module NestedImporting2 where++import NestedImporting2.A++main :: Fay ()+main = print r
+ tests/NestedImporting2.res view
@@ -0,0 +1,1 @@+1
+ tests/NestedImporting2/A.hs view
@@ -0,0 +1,6 @@+module NestedImporting2.A where++import Prelude++r :: Double+r = 1
+ tests/NestedImporting2/A.res view
+ tests/NewtypeImport_Export.hs view
@@ -0,0 +1,11 @@+module NewtypeImport_Export where++import FFI++newtype MyInteger = MyInteger Int++data Foo = Bar { bar :: Double }+newtype Baz = Baz { unwrapBaz :: Foo }++getBaz :: Fay Baz+getBaz = ffi "{ instance: 'Bar', bar: 1 }"
+ tests/NewtypeImport_Export.res view
+ tests/NewtypeImport_Import.hs view
@@ -0,0 +1,26 @@+module NewtypeImport_Import where++import           NewtypeImport_Export++x = case MyInteger undefined of+  MyInteger _ -> 1++y = case undefined of+  MyInteger _ -> 1++int :: Int+int = undefined++yInt = case int of+  _ -> 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)
+ tests/NewtypeImport_Import.res view
@@ -0,0 +1,7 @@+1+1+1+{ instance: 'Bar', bar: 1 }+{ instance: 'Bar', bar: 1 }+1+1
+ tests/Nullable.hs view
@@ -0,0 +1,43 @@+module Nullable where++import           FFI++data R = R (Nullable Double)++main :: Fay ()+main = do+  printD $ Nullable (1 :: Double)+  printNS $ Nullable "Hello, World!"+  printSS $ Defined ["Hello,","World!"]+  printD $ (Null :: Nullable Double)+  print' $ R (Nullable 1)+  print' $ R Null+  print' $ r1+  print' $ r2+  print' $ parseInt "3"+  print' $ parseInt "x"+  return ()++printD :: Nullable Double -> Fay ()+printD = ffi "console.log(%1)"++printNS :: Nullable String -> Fay ()+printNS = ffi "console.log(%1)"++printS :: Defined String -> Fay ()+printS = ffi "console.log(%1)"++printSS :: Defined [String] -> Fay ()+printSS = ffi "console.log(%1)"++print' :: Automatic f -> Fay ()+print' = ffi "console.log(%1)"++r1 :: R+r1 = ffi "{ instance: 'R', slot1 : 1 }"++r2 :: R+r2 = ffi "{ instance : 'R', slot1 : null }"++parseInt :: String -> Nullable Int+parseInt = ffi "(function () { var n = parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"
+ tests/Nullable.res view
@@ -0,0 +1,10 @@+1+Hello, World!+[ 'Hello,', 'World!' ]+null+{ instance: 'R', slot1: 1 }+{ instance: 'R', slot1: null }+{ instance: 'R', slot1: 1 }+{ instance: 'R', slot1: null }+{ instance: 'Nullable', slot1: 3 }+{ instance: 'Null' }
+ tests/Num.hs view
@@ -0,0 +1,10 @@+module Num where++main :: Fay ()+main = do+  print (1 + 2::Int)+  print (4 - 1::Int)+  print (3 * 1::Int)+  print (negate (1 - 4::Int))+  print (abs (1 - 4::Int))+  print ((-3) * signum (-10::Int))
+ tests/Num.res view
@@ -0,0 +1,6 @@+3+3+3+3+3+3
+ tests/Ord.hs view
@@ -0,0 +1,22 @@+module Ord where++main :: Fay ()+main = do+  when ((1::Int) < 2) $ putStrLn "Expected <"+  when ((1::Int) < 1) $ putStrLn "Unexpected < (1)"+  when ((2::Int) < 1) $ putStrLn "Unexpected < (2)"+  when ((1::Int) >= 2) $ putStrLn "Unexpected >="+  when ((1::Int) >= 1) $ putStrLn "Expected >= (1)"+  when ((2::Int) >= 1) $ putStrLn "Expected >= (2)"+  when ((1::Int) > 2) $ putStrLn "Unexpected > (1)"+  when ((1::Int) > 1) $ putStrLn "Unexpected > (2)"+  when ((2::Int) > 1) $ putStrLn "Expected >"+  when ((1::Int) <= 2) $ putStrLn "Expected <= (1)"+  when ((1::Int) <= 1) $ putStrLn "Expected <= (2)"+  when ((2::Int) <= 1) $ putStrLn "Unexpected <="+  print $ max 1 (2::Int)+  print $ min 1 (2::Int)+  case compare 1 (2::Int) of+    EQ -> putStrLn "FAIL (EQ)"+    LT -> putStrLn "WIN (LT)"+    GT -> putStrLn "FAIL (GT)"
+ tests/Ord.res view
@@ -0,0 +1,9 @@+Expected <+Expected >= (1)+Expected >= (2)+Expected >+Expected <= (1)+Expected <= (2)+2+1+WIN (LT)
+ 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
@@ -0,0 +1,17 @@+module QualifiedImport where++import           FFI++import qualified QualifiedImport.X+import qualified QualifiedImport.X as X+import qualified QualifiedImport.Y as Y++main :: Fay ()+main = do+  print QualifiedImport.X.x+  print Y.y+  print X.X3 { X.x4 = 1 }+  print $ X.X3 2+  print (X.X3 3) { X.x4 = 4 }+  case X.X3 4 of+    X.X3 { X.x4 = n } -> print n
+ tests/QualifiedImport.res view
@@ -0,0 +1,6 @@+1+2+{ instance: 'X3', x4: 1 }+{ instance: 'X3', x4: 2 }+{ instance: 'X3', x4: 4 }+4
+ tests/QualifiedImport/X.hs view
@@ -0,0 +1,8 @@+module QualifiedImport.X where++import           Prelude++x :: Double+x = 1++data X2 = X3 { x4 :: Double }
+ tests/QualifiedImport/X.res view
+ tests/QualifiedImport/Y.hs view
@@ -0,0 +1,6 @@+module QualifiedImport.Y where++import           Prelude++y :: Double+y = 2
+ tests/QualifiedImport/Y.res view
+ tests/Ratio.hs view
@@ -0,0 +1,9 @@+module Ratio where++import Data.Ratio++main :: Fay ()+main = do+  print $ 3 % 5+  print $ numerator (3 % 5)+  print $ denominator (3 % 5)
+ tests/Ratio.res view
@@ -0,0 +1,3 @@+{ instance: 'Ratio', slot1: 3, slot2: 5 }+3+5
+ tests/ReExport1.hs view
@@ -0,0 +1,4 @@+module ReExport1 where++x = 42+
+ tests/ReExport1.res view
+ tests/ReExport2.hs view
@@ -0,0 +1,3 @@+module ReExport2 (x) where++import ReExport1
+ tests/ReExport2.res view
+ tests/ReExport3.hs view
@@ -0,0 +1,4 @@+import ReExport2++main :: Fay ()+main = print x
+ tests/ReExport3.res view
@@ -0,0 +1,1 @@+42
+ tests/ReExportGlobally.hs view
@@ -0,0 +1,13 @@+module ReExportGlobally (main, x) where++import           FFI++import           ReExportGlobally.A (x)++main :: Fay ()+main = do+  ffi "console.log(ReExportGlobally.x)" :: Fay () -- Re-export to JS+  ffi "console.log('NewTy' in ReExportGlobally.A)" :: Fay () -- Don't add exports for new types+  ffi "console.log('NewTy' in ReExportGlobally)" :: Fay () -- Don't add exports for new types+  ffi "console.log('unNewTy' in ReExportGlobally.A)" :: Fay () -- Don't add exports for new types+  ffi "console.log('unNewTy' in ReExportGlobally)" :: Fay () -- Don't add exports for new types
+ tests/ReExportGlobally.res view
@@ -0,0 +1,5 @@+1+false+false+false+false
+ tests/ReExportGlobally/A.hs view
@@ -0,0 +1,8 @@+module ReExportGlobally.A (x, NewTy(..)) where++import           Prelude++x :: Double+x = 1++newtype NewTy = NewTy { unNewTy :: Double }
+ tests/ReExportGlobally/A.res view
+ tests/ReExportGloballyExplicit.hs view
@@ -0,0 +1,8 @@+module Foo (main, x) where++import           FFI++import           ReExportGlobally.A (x)++main :: Fay ()+main = ffi "console.log(Foo.x)"
+ tests/ReExportGloballyExplicit.res view
@@ -0,0 +1,1 @@+1
+ tests/RealFrac.hs view
@@ -0,0 +1,11 @@+module RealFrac where++main :: Fay ()+main = do+  print $ fst $ properFraction 1.5+  print $ snd $ properFraction 1.5+  print $ truncate (-1.5)+  print $ round (-1.5)+  print $ ceiling (-1.5)+  print $ floor (-1.5)+  return ()
+ tests/RealFrac.res view
@@ -0,0 +1,6 @@+1+0.5+-1+-1+-1+-2
− tests/RecCon 
@@ -1,1 +0,0 @@-123
tests/RecCon.hs view
@@ -1,9 +1,8 @@-import           Prelude+module RecCon where  data Bool = True | False +main :: Fay () main = print (head (fix (\xs -> 123 : xs)))--head (x:xs) = x  fix f = let x = f x in x
+ tests/RecCon.res view
@@ -0,0 +1,1 @@+123
− tests/RecDecl 
@@ -1,12 +0,0 @@-{ instance: 'R', i: 10, c: 'a' }-{ instance: 'R', i: 20, c: 'a' }-{ instance: 'R', i: 123, c: 'b' }-{ instance: 'R', i: 1, c: 'a' }-1-"a"-{ instance: 'R', i: 2, c: 'b' }-{ instance: 'R', c: 'b' }-{ instance: 'R', i: 3, c: 'c' }-{ instance: 'S', slot1: 1, slot2: 'a' }-{ instance: 'X', _x1: 1, _x2: 2 }-{ instance: 'X', _x1: 1, _x2: 2 }
tests/RecDecl.hs view
@@ -1,10 +1,9 @@+module RecDecl where+ import           FFI-import           Prelude  data R = R { i :: Double, c :: Char }-instance Foreign R data S = S Double Char-instance Foreign S  -- RecDecl r1 :: R@@ -28,7 +27,6 @@  -- Multiple fields with the same type data X = X { _x1, _x2 :: Int }-instance Foreign X  x1 = X 1 2 x2 = X { _x1 = 1, _x2 = 2 }@@ -53,4 +51,3 @@   print s1   print x1   print x2-
+ tests/RecDecl.res view
@@ -0,0 +1,12 @@+{ instance: 'R', i: 10, c: 'a' }+{ instance: 'R', i: 20, c: 'a' }+{ instance: 'R', i: 123, c: 'b' }+{ instance: 'R', i: 1, c: 'a' }+1+"a"+{ instance: 'R', i: 2, c: 'b' }+{ instance: 'R', c: 'b' }+{ instance: 'R', i: 3, c: 'c' }+{ instance: 'S', slot1: 1, slot2: 'a' }+{ instance: 'X', _x1: 1, _x2: 2 }+{ instance: 'X', _x1: 1, _x2: 2 }
+ tests/RecordImport2_Export1.hs view
@@ -0,0 +1,6 @@+module RecordImport2_Export1 (main) where++data R = R { wrong :: Double }++main :: Fay ()+main = return ()
+ tests/RecordImport2_Export1.res view
+ tests/RecordImport2_Export2.hs view
@@ -0,0 +1,3 @@+module RecordImport2_Export2 where++data R = R { correct :: Double }
+ tests/RecordImport2_Export2.res view
+ tests/RecordImport2_Import.hs view
@@ -0,0 +1,8 @@+module RecordExport where++import FFI+import RecordImport2_Export1+import RecordImport2_Export2++main :: Fay ()+main = print $ R 1
+ tests/RecordImport2_Import.res view
@@ -0,0 +1,1 @@+{ instance: 'R', correct: 1 }
− tests/RecordImport_Export 
tests/RecordImport_Export.hs view
@@ -1,8 +1,6 @@-{- NOTE: This file is also used in the Api tests. -}+{- NOTE: This file is also used in the Compile tests. -}  module RecordImport_Export where--import           Prelude  data R = R Integer data Fields = Fields { fieldFoo :: Integer, fieldBar :: Integer }
+ tests/RecordImport_Export.res view
− tests/RecordImport_Import 
@@ -1,2 +0,0 @@-R 1-Fields 2 3
tests/RecordImport_Import.hs view
@@ -1,6 +1,7 @@-{- NOTE: This file is also used in the Api tests. -}+{- NOTE: This file is also used in the Compile tests. -} -import           Prelude+module RecordImport_Import where+ import           RecordImport_Export  f :: R -> R
+ tests/RecordImport_Import.res view
@@ -0,0 +1,2 @@+R 1+Fields 2 3
+ tests/Sink.hs view
@@ -0,0 +1,12 @@+-- https://github.com/faylang/fay/issues/285+module Sink where++import FFI++run :: Fay ()+run = runSink (Sink putStrLn) "hello"++newtype Sink a = Sink { runSink :: a -> Fay () }++main :: Fay ()+main = run
+ tests/Sink.res view
@@ -0,0 +1,1 @@+hello
+ tests/SkipLetTypes.hs view
@@ -0,0 +1,5 @@+module SkipLetType where++main = let t :: Bool+           t = True+       in print t
+ tests/SkipLetTypes.res view
@@ -0,0 +1,1 @@+true
+ tests/SkipWhereTypes.hs view
@@ -0,0 +1,6 @@+module SkipWhereTypes where++main = print t+  where+    t :: Bool+    t = True
+ tests/SkipWhereTypes.res view
@@ -0,0 +1,1 @@+true
− tests/String 
@@ -1,1 +0,0 @@-Hello, World!
− tests/String.hs 
@@ -1,4 +0,0 @@-import           Prelude--main = putStrLn "Hello, World!"-
+ tests/StringForcing.hs view
@@ -0,0 +1,9 @@+module StringForcing where++import FFI++main = do+  let s1 = "alma"+  let s2 = s1 ++ map id s1+  putStrLn s1+  putStrLn s2
+ tests/StringForcing.res view
@@ -0,0 +1,2 @@+alma+almaalma
+ 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
@@ -0,0 +1,7 @@+module T190 where++import T190_B+import T190_C++main :: Fay ()+main = foo "Hello"
+ tests/T190.res view
@@ -0,0 +1,1 @@+Hello
+ tests/T190_A.hs view
@@ -0,0 +1,4 @@+module T190_A where++foo :: Int -> Fay ()+foo _ = putStrLn "WRONG!"
+ tests/T190_A.res view
+ tests/T190_B.hs view
@@ -0,0 +1,6 @@+module T190_B where++import           T190_A++main :: Fay ()+main = return ()
+ tests/T190_B.res view
+ tests/T190_C.hs view
@@ -0,0 +1,4 @@+module T190_C where++foo :: String -> Fay ()+foo x = putStrLn x
+ tests/T190_C.res view
+ 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
@@ -0,0 +1,20 @@+module TupleCalls where++import FFI++f :: (Int,Double) -> Double+f = ffi "%1[0]+%1[1]"++g :: Double -> (Int,Double)+g = ffi "[Math.floor(%1),Math.round(100*(%1-Math.floor(%1)))/100]"++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/TupleCalls.res view
@@ -0,0 +1,5 @@+3.3+8+0.76+3+#12#
+ tests/TyVarSerialization.hs view
@@ -0,0 +1,15 @@+module TyVarSerialization where++import FFI++main :: Fay ()+main = do+  printEither (Left [1,2,3])+  printEither (Right "Yow!")+  printTuple ("Hey",["ey","baby"],1,"wanna",["know"],"if you'll be my girl")++printEither :: Either [Int] String -> Fay ()+printEither = ffi "console.log(%1)"++printTuple :: (String,[String],Int,String,[String],String) -> Fay ()+printTuple = ffi "console.log(%1)"
+ tests/TyVarSerialization.res view
@@ -0,0 +1,8 @@+{ instance: 'Left', slot1: [ 1, 2, 3 ] }+{ instance: 'Right', slot1: 'Yow!' }+[ 'Hey',+  [ 'ey', 'baby' ],+  1,+  'wanna',+  [ 'know' ],+  'if you\'ll be my girl' ]
+ 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 
@@ -1,7 +0,0 @@-{ car: { car: 1, cdr: { car: 2, cdr: [Object] } },-  cdr: { car: { car: 1, cdr: [Object] }, cdr: null } }-{ car: { car: 1, cdr: { car: 2, cdr: [Object] } },-  cdr: { car: 1, cdr: { car: [Object], cdr: null } } }-{ car: { car: 1, cdr: { car: 2, cdr: [Object] } },-  cdr: { car: 1, cdr: { car: [Object], cdr: null } } }-{ car: 'o', cdr: { car: 'k', cdr: null } }
tests/asPatternMatch.hs view
@@ -1,4 +1,4 @@-import           Prelude+module AsPatternMatch where  matchSame :: [a] -> ([a],[a]) matchSame x@y = (x,y)
+ tests/asPatternMatch.res view
@@ -0,0 +1,4 @@+[ [ 1, 2, 3 ], [ 1, 2, 3 ] ]+[ [ 1, 2, 3 ], 1, [ 2, 3 ] ]+[ [ 1, 2, 3 ], 1, [ 2, 3 ] ]+[ 'o', 'k' ]
+ tests/automatic.hs view
@@ -0,0 +1,22 @@+module Automatic where++import FFI++func :: Bool -> Int -> Int -> Int+func a b c = if a then b else c++semiAutomatic :: Ptr (Bool -> Int -> Int -> Int) -> Bool -> Int+semiAutomatic = ffi "(function () { return Fay$$fayToJs(['function', 'automatic_function'], %1)(%2, 1, 2); })()"++automatic :: Ptr (Bool -> Int -> Int -> Int) -> Bool -> Int+automatic = ffi "(function () { return Fay$$fayToJs(['automatic'], %1)(%2, 1, 2); })()"++print' :: Ptr a -> Fay ()+print' = ffi "console.log(Fay$$_(%1))"++main :: Fay ()+main = do+  print' (semiAutomatic func True)+  print' (semiAutomatic func False)+  print' (automatic func True)+  print' (automatic func False)
+ tests/automatic.res view
@@ -0,0 +1,4 @@+1+2+1+2
+ tests/baseFixities.hs view
@@ -0,0 +1,15 @@+module BaseFixities where++fmap :: (a -> b) -> Fay a -> Fay b+fmap f m = m >>= (return . f)++-- Note that this fixity declaration doesn't do anything except fix+-- typechecking since Fay ignores fixities other than the baseFixities+-- supplied to HSE. But since <$> is a base operator it's parsed as it+-- should be.+infixl 4 <$>+(<$>) :: (a -> b) -> Fay a -> Fay b+(<$>) = fmap++main :: Fay ()+main = print =<< ((+3) . (+2) <$> (return (1 :: Double)))
+ tests/baseFixities.res view
@@ -0,0 +1,1 @@+6
− tests/basicFunctions 
@@ -1,1 +0,0 @@-Hello, World!
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/basicFunctions.res view
@@ -0,0 +1,1 @@+Hello, World!
− tests/case 
@@ -1,1 +0,0 @@-Hello!
tests/case.hs view
@@ -1,6 +1,5 @@-import           Prelude+module Case where  main = putStrLn (case True of                    True -> "Hello!"                    False -> "Ney!")-
+ tests/case.res view
@@ -0,0 +1,1 @@+Hello!
− tests/case2 
@@ -1,1 +0,0 @@-Ney!
tests/case2.hs view
@@ -1,6 +1,5 @@-import           Prelude+module Case2 where  main = putStrLn (case False of                    True -> "Hello!"                    False -> "Ney!")-
+ tests/case2.res view
@@ -0,0 +1,1 @@+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 
@@ -1,1 +0,0 @@-OK.
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/caseList.res view
@@ -0,0 +1,1 @@+OK.
− tests/caseWildcard 
@@ -1,1 +0,0 @@-Ney!
tests/caseWildcard.hs view
@@ -1,6 +1,5 @@-import           Prelude+module CaseWildcard where  main = putStrLn (case False of                   True -> "Hello!"                   _    -> "Ney!")-
+ tests/caseWildcard.res view
@@ -0,0 +1,1 @@+Ney!
+ tests/circular.hs view
file too large to diff
+ tests/curry.hs view
file too large to diff
+ tests/curry.res view
file too large to diff
+ tests/cycle.hs view
file too large to diff
+ tests/cycle.res view
file too large to diff
− tests/do 
file too large to diff
tests/do.hs view
file too large to diff
+ tests/do.res view
file too large to diff
− tests/doAssingPatternMatch 
file too large to diff
tests/doAssingPatternMatch.hs view
file too large to diff
+ tests/doAssingPatternMatch.res view
file too large to diff
− tests/doBindAssign 
file too large to diff
tests/doBindAssign.hs view
file too large to diff
+ tests/doBindAssign.res view
file too large to diff
+ tests/doLet.hs view
file too large to diff
+ tests/doLet.res view
file too large to diff
− tests/emptyMain 
file too large to diff
tests/emptyMain.hs view
file too large to diff
+ tests/emptyMain.res view
file too large to diff
+ tests/enumFrom.hs view
file too large to diff
+ tests/enumFrom.res view
file too large to diff
+ tests/error.hs view
file too large to diff
+ tests/ffiExpr.hs view
file too large to diff
+ tests/ffiExpr.res view
file too large to diff
+ tests/ffimunging.hs view
file too large to diff
+ tests/ffimunging.res view
file too large to diff
− tests/fix 
file too large to diff
tests/fix.hs view
file too large to diff
+ tests/fix.res view
file too large to diff
− tests/fromInteger 
file too large to diff
tests/fromInteger.hs view
file too large to diff
+ tests/fromInteger.res view
file too large to diff
+ tests/fromIntegral.hs view
file too large to diff
+ tests/fromIntegral.res view
file too large to diff
+ tests/guards.hs view
file too large to diff
+ tests/guards.res view
file too large to diff
− tests/infixDataConst 
file too large to diff
tests/infixDataConst.hs view
file too large to diff
+ tests/infixDataConst.res view
file too large to diff
− tests/ints 
file too large to diff
tests/ints.hs view
file too large to diff
+ tests/ints.res view
file too large to diff
+ tests/linesAndWords.hs view
file too large to diff
+ tests/linesAndWords.res view
file too large to diff
+ tests/listComprehensions.hs view
file too large to diff
+ tests/listComprehensions.res view
file too large to diff
+ tests/listlen.hs view
file too large to diff
+ tests/listlen.res view
file too large to diff
− tests/mutableReference 
file too large to diff
tests/mutableReference.hs view
file too large to diff
+ tests/mutableReference.res view
file too large to diff
+ tests/nameGen.hs view
file too large to diff
+ tests/nameGen.res view
file too large to diff
+ tests/namedFieldPuns.hs view
file too large to diff
+ tests/namedFieldPuns.res view
file too large to diff
+ tests/negation.hs view
file too large to diff
+ tests/negation.res view
file too large to diff
+ tests/newtype.hs view
file too large to diff
+ tests/newtype.res view
file too large to diff
+ tests/newtypeIndirectApp.hs view
file too large to diff
+ tests/newtypeIndirectApp.res view
file too large to diff
+ tests/numTheory.hs view
file too large to diff
+ tests/numTheory.res view
file too large to diff
+ tests/nums.hs view
file too large to diff
+ tests/nums.res view
file too large to diff
+ tests/pats.hs view
file too large to diff
+ tests/pats.res view
file too large to diff
− tests/patternGuards 
file too large to diff
tests/patternGuards.hs view
file too large to diff
+ tests/patternGuards.res view
file too large to diff
tests/patternMatchFail.hs view
file too large to diff
+ tests/patternMatchLet.hs view
file too large to diff
+ tests/patternMatchLet.res view
file too large to diff
+ tests/patternMatchingTuples.hs view
file too large to diff
+ tests/patternMatchingTuples.res view
file too large to diff
− tests/recordFunctionPatternMatch 
file too large to diff
tests/recordFunctionPatternMatch.hs view
file too large to diff
+ tests/recordFunctionPatternMatch.res view
file too large to diff
− tests/recordPatternMatch 
file too large to diff
tests/recordPatternMatch.hs view
file too large to diff
+ tests/recordPatternMatch.res view
file too large to diff
− tests/recordPatternMatch2 
file too large to diff
tests/recordPatternMatch2.hs view
file too large to diff
+ tests/recordPatternMatch2.res view
file too large to diff
− tests/recordUseBeforeDefine 
file too large to diff
tests/recordUseBeforeDefine.hs view
file too large to diff
+ tests/recordUseBeforeDefine.res view
file too large to diff
+ tests/recordWildCards.hs view
file too large to diff
+ tests/recordWildCards_partial.res view
file too large to diff
− tests/records 
file too large to diff
tests/records.hs view
file too large to diff
+ tests/records.res view
file too large to diff
+ tests/recursive.hs view
file too large to diff
+ tests/recursive.res view
file too large to diff
− tests/reservedWords 
file too large to diff
tests/reservedWords.hs view
file too large to diff
+ tests/reservedWords.res view
file too large to diff
+ tests/sections.hs view
file too large to diff
+ tests/sections.res view
file too large to diff
+ tests/seq-fake.hs view
file too large to diff
+ tests/seq-fake.res view
file too large to diff
+ tests/seq.hs view
file too large to diff
− tests/serialization 
file too large to diff
tests/serialization.hs view
file too large to diff
+ tests/serialization.res view
file too large to diff
+ tests/succPred.hs view
file too large to diff
+ tests/succPred.res view
file too large to diff
− tests/tailRecursion 
file too large to diff
tests/tailRecursion.hs view
file too large to diff
+ tests/tailRecursion.res view
file too large to diff
− tests/then 
file too large to diff
tests/then.hs view
file too large to diff
+ tests/then.res view
file too large to diff
+ tests/tupleCon.hs view
file too large to diff
+ tests/tupleCon.res view
file too large to diff
+ tests/tupleSec.hs view
file too large to diff
+ tests/tupleSec.res view
file too large to diff
+ tests/unit.hs view
file too large to diff
+ tests/unit.res view
file too large to diff
− tests/utf8 
file too large to diff
tests/utf8.hs view
file too large to diff
+ tests/utf8.res view
file too large to diff
− tests/where 
file too large to diff
tests/where.hs view
file too large to diff
+ tests/where.res view
file too large to diff
+ tests/whereBind.hs view
file too large to diff
+ tests/whereBind.res view
file too large to diff
+ tests/whereBind2.hs view
file too large to diff
+ tests/whereBind2.res view
file too large to diff
+ tests/whereBind3.hs view
file too large to diff
+ tests/whereBind3.res view
file too large to diff