diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,18 +2,345 @@ See full history at: +### 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 tag that was generated by --html-wrapper +* FFI expressions in top level declarations now produce identical code to a normal top level FFI declaration +* Don't export Data.Ratio and Debug.Trace when using --no-stdlib + +Dependency bumps: +* Allow text 1.1 +* Allow attoparsec 0.11 + + **Note: 0.18.0.1 added source mappings returned by `Fay:compileFile` and friends meaning it should have been a major bump. Sorry about this!** -### 0.18.1.3 (2013-12-14) +#### 0.18.1.3 (2013-12-14) * Add parsing of Integer to Fay.Convert (note that the runtime doesn't have arbitrary precision Integers) * Allow text 1.0.* -### 0.18.1.2 (2013-11-26) +#### 0.18.1.2 (2013-11-26) * Add support for indirect application of newtypes (such as `p = NewType; foo = p x` and `bar = NewType $ y`) -### 0.18.1.1 (2013-11-22) +#### 0.18.1.1 (2013-11-22) * Fix a bug where records with the same name as top level modules wouldn't be initialized correctly. * Fail when using enum syntax on unsupported literal types (for instance ['a'..'z']) @@ -66,8 +393,8 @@ New features: * Support for qualified imports. Note: You still can't have multiple constructors with the same name in the FFI since the `instance` field in the serialization is still unqualified. -* `Automatic` transcoding now works for functions. See [[Calling Fay From JavaScript]] -* `--strict modulename[, ..]` generates strict and transcoding wrappers for a module's exports. See [[Calling Fay From JavaScript]] +* `Automatic` transcoding now works for functions. See [Calling Fay From JavaScript](https://github.com/faylang/fay/wiki/Calling-Fay-from-JavaScript) +* `--strict modulename[, ..]` generates strict and transcoding wrappers for a module's exports. See [Calling Fay From JavaScript](https://github.com/faylang/fay/wiki/Calling-Fay-from-JavaScript) * `--typecheck-only` just runs the GHC type checker with the appropriate Fay flags. * `--runtime-path FILEPATH` allows you to supply a custom runtime. Probably only useful for debugging. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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\ diff --git a/examples/D3TreeSample.hs b/examples/D3TreeSample.hs new file mode 100644 --- /dev/null +++ b/examples/D3TreeSample.hs @@ -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 diff --git a/examples/D3TreeSample.html b/examples/D3TreeSample.html new file mode 100644 --- /dev/null +++ b/examples/D3TreeSample.html @@ -0,0 +1,18 @@ + + + + + + + + + +
+ + diff --git a/examples/calc.hs b/examples/calc.hs --- a/examples/calc.hs +++ b/examples/calc.hs @@ -32,7 +32,7 @@ return () else do setVal (show n) display writeRef appendMore True) - getInput = getVal display >>= (return . parseDouble 10) + getInput = getVal display >>= (return . parseDouble) operator op = do calculate num <- getInput @@ -104,8 +104,8 @@ -------------------------------------------------------------------------------- -- Utilities -parseDouble :: Int -> String -> Double -parseDouble = ffi "parseFloat(%2,%1) || 0" +parseDouble :: String -> Double +parseDouble = ffi "parseFloat(%1) || 0" -------------------------------------------------------------------------------- -- Refs diff --git a/examples/calc.html b/examples/calc.html --- a/examples/calc.html +++ b/examples/calc.html @@ -10,7 +10,7 @@

Calc

A clone of Pit's calculator app

-

JS generated by Fay, a Haskell +

JS generated by Fay, a Haskell subset. Source code

diff --git a/examples/json.hs b/examples/json.hs --- a/examples/json.hs +++ b/examples/json.hs @@ -1,5 +1,3 @@ - - module Console where import FFI @@ -11,10 +9,12 @@ myData :: MyData myData = MyData { xVar = pack "asdfasd", yVar = 9 } - main = do jsonSerialized <- toJSON myData jsonDeserialized <- toMyData jsonSerialized + -- The "instance" field below is required for reliable parsing. + -- If your JSON source doesn't have an "instance" field, you can + -- add one like this: ffi "%1['instance']='MyData',%1" :: Json -> MyData fromStringData <- toMyData "{\"xVar\":3,\"yVar\":-1,\"instance\":\"MyData\"}" print' jsonSerialized diff --git a/examples/oscillator.hs b/examples/oscillator.hs --- a/examples/oscillator.hs +++ b/examples/oscillator.hs @@ -1,12 +1,9 @@ {-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE NoImplicitPrelude #-} module RingOscillator (main) where import FFI -import Prelude - -- System parameters. -- data Params = Params { alpha :: Double @@ -419,14 +416,6 @@ zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) = z a b c d e : zipWith5 z as bs cs ds es zipWith5 _ _ _ _ _ _ = [] - -mapM :: (a -> Fay b) -> [a] -> Fay [b] -mapM m (x:xs) = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs))) -mapM _ [] = return [] - -forM :: [a] -> (a -> Fay b) -> Fay [b] -forM (x:xs) m = m x >>= (\mx -> mapM m xs >>= (\mxs -> return (mx:mxs))) -forM [] _ = return [] replicateM :: Int -> Fay a -> Fay [a] replicateM n x = sequence (replicate n x) diff --git a/fay.cabal b/fay.cabal --- a/fay.cabal +++ b/fay.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: fay -version: 0.18.1.3 +version: 0.24.2.0 synopsis: A compiler for Fay, a Haskell subset that compiles to JavaScript. description: Fay is a proper subset of Haskell which is type-checked with GHC, and compiled to JavaScript. It is lazy, pure, has a Fay monad, @@ -7,18 +8,13 @@ . /Documentation/ . - See + See . /Examples/ . See the examples directory and . - /Release Notes/ - . - See - . - See full history at: -homepage: http://fay-lang.org/ +homepage: https://github.com/faylang/fay/wiki bug-reports: https://github.com/faylang/fay/issues license: BSD3 license-file: LICENSE @@ -27,13 +23,14 @@ copyright: 2012 Chris Done, Adam Bergmark category: Development, Web, Fay build-type: Custom -cabal-version: >=1.8 -data-files: js/runtime.js - src/Fay/FFI.hs +Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.3 +data-files: + src/Fay/FFI.hs extra-source-files: + CHANGELOG.md LICENSE README.md - CHANGELOG.md + src/haskell-names/LICENSE -- Examples examples/*.hs examples/*.html @@ -70,102 +67,158 @@ type: git location: https://github.com/faylang/fay.git +flag test + description: Build the fay-tests executable + manual: True + default: False + +custom-setup + setup-depends: + base + , Cabal + library - hs-source-dirs: src - exposed-modules: Fay - , Fay.Compiler - , Fay.Compiler.Config - , Fay.Control.Monad.Extra - , Fay.Control.Monad.IO - , Fay.Convert - , Fay.Data.List.Extra - , Fay.Exts - , Fay.Exts.Scoped - , Fay.Exts.NoAnnotation - , Fay.FFI - , Fay.System.Directory.Extra - , Fay.System.Process.Extra - , Fay.Types - other-modules: Fay.Compiler.Decl - , Fay.Compiler.Defaults - , Fay.Compiler.Desugar - , Fay.Compiler.Exp - , Fay.Compiler.FFI - , Fay.Compiler.GADT - , Fay.Compiler.Import - , Fay.Compiler.InitialPass - , Fay.Compiler.Misc - , Fay.Compiler.Optimizer - , Fay.Compiler.Packages - , Fay.Compiler.Pattern - , Fay.Compiler.PrimOp - , Fay.Compiler.Print - , Fay.Compiler.QName - , Fay.Compiler.State - , Fay.Compiler.Typecheck - , Paths_fay - ghc-options: -O2 -Wall -fno-warn-name-shadowing - build-depends: base >= 4 && < 5 - , Cabal < 1.19 - , aeson < 0.7 - , attoparsec < 0.11 - , bytestring < 0.11 - , containers < 0.6 - , cpphs < 1.19 - , data-default < 0.6 - , directory < 1.3 - , filepath < 1.4 - , ghc-paths < 0.2 - , haskell-names >= 0.3.1 && < 0.4 - , haskell-packages >= 0.2.3.1 && < 0.3 - , haskell-src-exts >= 1.14 && < 1.15 - , language-ecmascript >= 0.15 && < 1.0 - , mtl < 2.2 - , pretty-show >= 1.6 && < 1.7 - , process < 1.2 - , safe < 0.4 - , split < 0.3 - , syb < 0.5 - , text < 1.1 - , time < 1.5 - , uniplate >= 1.6.11 && < 1.7 - , unordered-containers < 0.3 - , utf8-string < 0.4 - , vector < 0.11 - , sourcemap < 0.2 + default-language: Haskell2010 + ghc-options: -O2 -Wall + hs-source-dirs: + src + src/haskell-names + autogen-modules: + Paths_fay + exposed-modules: + Fay + Fay.Compiler + Fay.Compiler.Desugar + Fay.Compiler.Parse + Fay.Compiler.Prelude + Fay.Config + Fay.Convert + Fay.FFI + Fay.Types + Fay.Types.CompileError + Fay.Types.CompileResult + other-modules: + Fay.Compiler.Decl + Fay.Compiler.Defaults + Fay.Compiler.Desugar.Name + Fay.Compiler.Desugar.Types + Fay.Compiler.Exp + Fay.Compiler.FFI + Fay.Compiler.GADT + Fay.Compiler.Import + Fay.Compiler.InitialPass + Fay.Compiler.Misc + Fay.Compiler.ModuleT + Fay.Compiler.Optimizer + Fay.Compiler.Packages + Fay.Compiler.Pattern + Fay.Compiler.PrimOp + Fay.Compiler.Print + Fay.Compiler.QName + Fay.Compiler.State + Fay.Compiler.Typecheck + Fay.Exts + Fay.Exts.NoAnnotation + Fay.Exts.Scoped + Fay.Runtime + Fay.Types.FFI + Fay.Types.Js + Fay.Types.ModulePath + Fay.Types.Printer + Language.Haskell.Names + Language.Haskell.Names.Annotated + Language.Haskell.Names.Exports + Language.Haskell.Names.GetBound + Language.Haskell.Names.GlobalSymbolTable + Language.Haskell.Names.Imports + Language.Haskell.Names.LocalSymbolTable + Language.Haskell.Names.ModuleSymbols + Language.Haskell.Names.Open.Base + Language.Haskell.Names.Open.Derived + Language.Haskell.Names.Open.Instances + Language.Haskell.Names.RecordWildcards + Language.Haskell.Names.Recursive + Language.Haskell.Names.ScopeUtils + Language.Haskell.Names.SyntaxUtils + Language.Haskell.Names.Types + Paths_fay + build-depends: + base >= 4.9 && < 4.15 + , base-compat >= 0.10 && < 0.12 + , aeson > 0.6 && < 1.6 + , bytestring >= 0.9 && < 0.11 + , containers >= 0.4 && < 0.7 + , data-default >= 0.2 && < 0.8 + , data-lens-light == 0.1.* + , directory >= 1.1 && < 1.4 + , filepath >= 1.3 && < 1.5 + , ghc-paths == 0.1.* + , haskell-src-exts >= 1.20 + , language-ecmascript >= 0.15 && < 0.20 + , mtl >= 2.1 && < 2.3 + , mtl-compat >= 0.1 && < 0.3 + , process >= 1.1 && < 1.7 + , safe >= 0.2 && < 0.4 + , sourcemap == 0.1.* + , split >= 0.1 && < 0.3 + , spoon >= 0.1 && < 0.4 + , syb >= 0.3 && < 0.8 + , text >= 0.11 && < 1.3 + , time >= 1.4 && < 1.10 + , transformers >= 0.3 && < 0.6 + , transformers-compat >= 0.3 && < 0.7 + , traverse-with-class >= 1.0 && < 1.1 + , uniplate >= 1.6.11 && < 1.7 + , unordered-containers == 0.2.* + , utf8-string >= 0.1 && < 1.1 + , vector < 0.13 + , shakespeare < 2.1 + if impl(ghc < 7.8) + build-depends: tagged + executable fay + default-language: Haskell2010 hs-source-dirs: src/main ghc-options: -O2 -Wall - ghc-prof-options: -fprof-auto main-is: Main.hs - build-depends: base - , fay - , data-default - , optparse-applicative >= 0.6 && < 0.8 - , split + build-depends: + base + , fay + , mtl + , optparse-applicative >= 0.11 && < 0.16 + , split + other-modules: + Paths_fay executable fay-tests - hs-source-dirs: src/tests + default-language: Haskell2010 ghc-options: -O2 -Wall -threaded -with-rtsopts=-N - ghc-prof-options: -fprof-auto + hs-source-dirs: src/tests main-is: Tests.hs - other-modules: Test.CommandLine - Test.Compile - Test.Convert - Test.Util - build-depends: base - , fay - , HUnit < 1.3 - , aeson - , attoparsec - , bytestring - , data-default - , directory - , filepath - , haskell-src-exts - , test-framework < 0.9 - , test-framework-hunit < 0.4 - , test-framework-th < 0.3 - , text - , utf8-string + if flag(test) + other-modules: + Test.CommandLine + Test.Compile + Test.Convert + Test.Desugar + Test.Util + Paths_fay + build-depends: + base + , aeson + , attoparsec + , bytestring + , containers + , directory + , fay + , filepath + , haskell-src-exts + , random >= 1.0 && < 1.3 + , tasty >= 0.9 && < 1.5 + , tasty-hunit >= 0.8 && < 0.11 + , tasty-th == 0.1.* + , text + , utf8-string + else + buildable: False diff --git a/js/runtime.js b/js/runtime.js deleted file mode 100644 --- a/js/runtime.js +++ /dev/null @@ -1,750 +0,0 @@ -/******************************************************************************* - * Misc. - */ - -// Workaround for missing functionality in IE 8 and earlier. -if( Object.create === undefined ) { - Object.create = function( o ) { - function F(){} - F.prototype = o; - return new F(); - }; -} - -// Insert properties of b in place into a. -function Fay$$objConcat(a,b){ - for (var p in b) if (b.hasOwnProperty(p)){ - a[p] = b[p]; - } - return a; -} - -/******************************************************************************* - * Thunks. - */ - -// Force a thunk (if it is a thunk) until WHNF. -function Fay$$_(thunkish,nocache){ - while (thunkish instanceof Fay$$$) { - thunkish = thunkish.force(nocache); - } - return thunkish; -} - -// Apply a function to arguments (see method2 in Fay.hs). -function Fay$$__(){ - var f = arguments[0]; - for (var i = 1, len = arguments.length; i < len; i++) { - f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]); - } - return f; -} - -// Thunk object. -function Fay$$$(value){ - this.forced = false; - this.value = value; -} - -// Force the thunk. -Fay$$$.prototype.force = function(nocache) { - return nocache ? - this.value() : - (this.forced ? - this.value : - (this.value = this.value(), this.forced = true, this.value)); -}; - - -function Fay$$seq(x) { - return function(y) { - Fay$$_(x,false); - return y; - } -} - -function Fay$$seq$36$uncurried(x,y) { - Fay$$_(x,false); - return y; -} - -/******************************************************************************* - * Monad. - */ - -function Fay$$Monad(value){ - this.value = value; -} - -// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs. -// >> -function Fay$$then(a){ - return function(b){ - return Fay$$bind(a)(function(_){ - return b; - }); - }; -} - -// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs. -// >> -function Fay$$then$36$uncurried(a,b){ - return Fay$$bind$36$uncurried(a,function(_){ return b; }); -} - -// >>= -// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs. -function Fay$$bind(m){ - return function(f){ - return new Fay$$$(function(){ - var monad = Fay$$_(m,true); - return Fay$$_(f)(monad.value); - }); - }; -} - -// >>= -// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs. -function Fay$$bind$36$uncurried(m,f){ - return new Fay$$$(function(){ - var monad = Fay$$_(m,true); - return Fay$$_(f)(monad.value); - }); -} - -// This is used directly from Fay, but can be rebound or shadowed. -function Fay$$$_return(a){ - return new Fay$$Monad(a); -} - -// Allow the programmer to access thunk forcing directly. -function Fay$$force(thunk){ - return function(type){ - return new Fay$$$(function(){ - Fay$$_(thunk,type); - return new Fay$$Monad(Fay$$unit); - }) - } -} - -// This is used directly from Fay, but can be rebound or shadowed. -function Fay$$return$36$uncurried(a){ - return new Fay$$Monad(a); -} - -// Unit: (). -var Fay$$unit = null; - -/******************************************************************************* - * Serialization. - * Fay <-> JS. Should be bijective. - */ - -// Serialize a Fay object to JS. -function Fay$$fayToJs(type,fayObj){ - var base = type[0]; - var args = type[1]; - var jsObj; - if(base == "action") { - // A nullary monadic action. Should become a nullary JS function. - // Fay () -> function(){ return ... } - return function(){ - return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value); - }; - - } - else if(base == "function") { - // A proper function. - return function(){ - var fayFunc = fayObj; - var return_type = args[args.length-1]; - var len = args.length; - // If some arguments. - if (len > 1) { - // Apply to all the arguments. - fayFunc = Fay$$_(fayFunc,true); - // TODO: Perhaps we should throw an error when JS - // passes more arguments than Haskell accepts. - - // Unserialize the JS values to Fay for the Fay callback. - if (args == "automatic_function") - { - for (var i = 0; i < arguments.length; i++) { - fayFunc = Fay$$fayToJs(["automatic"], Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true)); - } - return fayFunc; - } - - for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) { - fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true); - } - // Finally, serialize the Fay return value back to JS. - var return_base = return_type[0]; - var return_args = return_type[1]; - // If it's a monadic return value, get the value instead. - if(return_base == "action") { - return Fay$$fayToJs(return_args[0],fayFunc.value); - } - // Otherwise just serialize the value direct. - else { - return Fay$$fayToJs(return_type,fayFunc); - } - } else { - throw new Error("Nullary function?"); - } - }; - - } - else if(base == "string") { - return Fay$$fayToJs_string(fayObj); - } - else if(base == "list") { - // Serialize Fay list to JavaScript array. - var arr = []; - fayObj = Fay$$_(fayObj); - while(fayObj instanceof Fay$$Cons) { - arr.push(Fay$$fayToJs(args[0],fayObj.car)); - fayObj = Fay$$_(fayObj.cdr); - } - return arr; - } - else if(base == "tuple") { - // Serialize Fay tuple to JavaScript array. - var arr = []; - fayObj = Fay$$_(fayObj); - var i = 0; - while(fayObj instanceof Fay$$Cons) { - arr.push(Fay$$fayToJs(args[i++],fayObj.car)); - fayObj = Fay$$_(fayObj.cdr); - } - return arr; - } - else if(base == "defined") { - fayObj = Fay$$_(fayObj); - return fayObj instanceof Fay.FFI._Undefined - ? undefined - : Fay$$fayToJs(args[0],fayObj.slot1); - } - else if(base == "nullable") { - fayObj = Fay$$_(fayObj); - return fayObj instanceof Fay.FFI._Null - ? null - : Fay$$fayToJs(args[0],fayObj.slot1); - } - else if(base == "double" || base == "int" || base == "bool") { - // Bools are unboxed. - return Fay$$_(fayObj); - } - else if(base == "ptr" || base == "unknown") - return fayObj; - else if(base == "automatic" && fayObj instanceof Function) { - return Fay$$fayToJs(["function", "automatic_function"], fayObj); - } - else if(base == "automatic" || base == "user") { - fayObj = Fay$$_(fayObj); - - if(fayObj instanceof Fay$$Cons || fayObj === null){ - // Serialize Fay list to JavaScript array. - var arr = []; - while(fayObj instanceof Fay$$Cons) { - arr.push(Fay$$fayToJs(["automatic"],fayObj.car)); - fayObj = Fay$$_(fayObj.cdr); - } - return arr; - } else { - var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance]; - return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj; - } - } - - throw new Error("Unhandled Fay->JS translation type: " + base); -} - -// Stores the mappings from fay types to js objects. -// This will be populated by compiled modules. -var Fay$$fayToJsHash = {}; - -// Specialized serializer for string. -function Fay$$fayToJs_string(fayObj){ - // Serialize Fay string to JavaScript string. - var str = ""; - fayObj = Fay$$_(fayObj); - while(fayObj instanceof Fay$$Cons) { - str += Fay$$_(fayObj.car); - fayObj = Fay$$_(fayObj.cdr); - } - return str; -}; -function Fay$$jsToFay_string(x){ - return Fay$$list(x) -}; - -// Special num/bool serializers. -function Fay$$jsToFay_int(x){return x;} -function Fay$$jsToFay_double(x){return x;} -function Fay$$jsToFay_bool(x){return x;} - -function Fay$$fayToJs_int(x){return Fay$$_(x);} -function Fay$$fayToJs_double(x){return Fay$$_(x);} -function Fay$$fayToJs_bool(x){return Fay$$_(x);} - -// Unserialize an object from JS to Fay. -function Fay$$jsToFay(type,jsObj){ - var base = type[0]; - var args = type[1]; - var fayObj; - if(base == "action") { - // Unserialize a "monadic" JavaScript return value into a monadic value. - return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj)); - } - else if(base == "function") { - // Unserialize a function from JavaScript to a function that Fay can call. - // So - // - // var f = function(x,y,z){ … } - // - // becomes something like: - // - // function(x){ - // return function(y){ - // return function(z){ - // return new Fay$$$(function(){ - // return Fay$$jsToFay(f(Fay$$fayTojs(x), - // Fay$$fayTojs(y), - // Fay$$fayTojs(z)) - // }}}}}; - var returnType = args[args.length-1]; - var funArgs = args.slice(0,-1); - - if (jsObj.length > 0) { - var makePartial = function(args){ - return function(arg){ - var i = args.length; - var fayArg = Fay$$fayToJs(funArgs[i],arg); - var newArgs = args.concat([fayArg]); - if(newArgs.length == funArgs.length) { - return new Fay$$$(function(){ - return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs)); - }); - } else { - return makePartial(newArgs); - } - }; - }; - return makePartial([]); - } - else - return function (arg) { - return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg))); - }; - } - else if(base == "string") { - // Unserialize a JS string into Fay list (String). - // This is a special case, when String is explicit in the type signature, - // with `Automatic' a string would not be decoded. - return Fay$$list(jsObj); - } - else if(base == "list") { - // Unserialize a JS array into a Fay list ([a]). - var serializedList = []; - for (var i = 0, len = jsObj.length; i < len; i++) { - // Unserialize each JS value into a Fay value, too. - serializedList.push(Fay$$jsToFay(args[0],jsObj[i])); - } - // Pop it all in a Fay list. - return Fay$$list(serializedList); - } - else if(base == "tuple") { - // Unserialize a JS array into a Fay tuple ((a,b,c,...)). - var serializedTuple = []; - for (var i = 0, len = jsObj.length; i < len; i++) { - // Unserialize each JS value into a Fay value, too. - serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i])); - } - // Pop it all in a Fay list. - return Fay$$list(serializedTuple); - } - else if(base == "defined") { - return jsObj === undefined - ? new Fay.FFI._Undefined() - : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj)); - } - else if(base == "nullable") { - return jsObj === null - ? new Fay.FFI._Null() - : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj)); - } - else if(base == "int") { - // Int are unboxed, so there's no forcing to do. - // But we can do validation that the int has no decimal places. - // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!" - fayObj = Math.round(jsObj); - if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!"; - return fayObj; - } - else if (base == "double" || - base == "bool" || - base == "ptr" || - base == "unknown") { - return jsObj; - } - else if(base == "automatic" && jsObj instanceof Function) { - var type = [["automatic"]]; - for (var i = 0; i < jsObj.length; i++) - type.push(["automatic"]); - return Fay$$jsToFay(["function", type], jsObj); - } - else if(base == "automatic" || base == "user") { - if (jsObj && jsObj['instance']) { - var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]]; - return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj; - } - else if (jsObj instanceof Array) { - var list = null; - for (var i = jsObj.length - 1; i >= 0; i--) { - list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list); - } - return list; - } - else - return jsObj; - } - - throw new Error("Unhandled JS->Fay translation type: " + base); -} - -// Stores the mappings from js objects to fay types. -// This will be populated by compiled modules. -var Fay$$jsToFayHash = {}; - -/******************************************************************************* - * Lists. - */ - -// Cons object. -function Fay$$Cons(car,cdr){ - this.car = car; - this.cdr = cdr; -} - -// Make a list. -function Fay$$list(xs){ - var out = null; - for(var i=xs.length-1; i>=0;i--) - out = new Fay$$Cons(xs[i],out); - return out; -} - -// Built-in list cons. -function Fay$$cons(x){ - return function(y){ - return new Fay$$Cons(x,y); - }; -} - -// List index. -// `list' is already forced by the time it's passed to this function. -// `list' cannot be null and `index' cannot be out of bounds. -function Fay$$index(index,list){ - for(var i = 0; i < index; i++) { - list = Fay$$_(list.cdr); - } - return list.car; -} - -// List length. -// `list' is already forced by the time it's passed to this function. -function Fay$$listLen(list,max){ - for(var i = 0; list !== null && i < max + 1; i++) { - list = Fay$$_(list.cdr); - } - return i == max; -} - -/******************************************************************************* - * Numbers. - */ - -// Built-in *. -function Fay$$mult(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) * Fay$$_(y); - }); - }; -} - -function Fay$$mult$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) * Fay$$_(y); - }); - -} - -// Built-in +. -function Fay$$add(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) + Fay$$_(y); - }); - }; -} - -// Built-in +. -function Fay$$add$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) + Fay$$_(y); - }); - -} - -// Built-in -. -function Fay$$sub(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) - Fay$$_(y); - }); - }; -} -// Built-in -. -function Fay$$sub$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) - Fay$$_(y); - }); - -} - -// Built-in /. -function Fay$$divi(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) / Fay$$_(y); - }); - }; -} - -// Built-in /. -function Fay$$divi$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) / Fay$$_(y); - }); - -} - -/******************************************************************************* - * Booleans. - */ - -// Are two values equal? -function Fay$$equal(lit1, lit2) { - // Simple case - lit1 = Fay$$_(lit1); - lit2 = Fay$$_(lit2); - if (lit1 === lit2) { - return true; - } - // General case - if (lit1 instanceof Array) { - if (lit1.length != lit2.length) return false; - for (var len = lit1.length, i = 0; i < len; i++) { - if (!Fay$$equal(lit1[i], lit2[i])) return false; - } - return true; - } else if (lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons) { - do { - if (!Fay$$equal(lit1.car,lit2.car)) - return false; - lit1 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr); - if (lit1 === null || lit2 === null) - return lit1 === lit2; - } while (true); - } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 && - lit1.instance === lit2.instance) { - for(var x in lit1) { - if(!Fay$$equal(lit1[x],lit2[x])) - return false; - } - return true; - } else { - return false; - } -} - -// Built-in ==. -function Fay$$eq(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$equal(x,y); - }); - }; -} - -function Fay$$eq$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$equal(x,y); - }); - -} - -// Built-in /=. -function Fay$$neq(x){ - return function(y){ - return new Fay$$$(function(){ - return !(Fay$$equal(x,y)); - }); - }; -} - -// Built-in /=. -function Fay$$neq$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return !(Fay$$equal(x,y)); - }); - -} - -// Built-in >. -function Fay$$gt(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) > Fay$$_(y); - }); - }; -} - -// Built-in >. -function Fay$$gt$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) > Fay$$_(y); - }); - -} - -// Built-in <. -function Fay$$lt(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) < Fay$$_(y); - }); - }; -} - - -// Built-in <. -function Fay$$lt$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) < Fay$$_(y); - }); - -} - - -// Built-in >=. -function Fay$$gte(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) >= Fay$$_(y); - }); - }; -} - -// Built-in >=. -function Fay$$gte$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) >= Fay$$_(y); - }); - -} - -// Built-in <=. -function Fay$$lte(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) <= Fay$$_(y); - }); - }; -} - -// Built-in <=. -function Fay$$lte$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) <= Fay$$_(y); - }); - -} - -// Built-in &&. -function Fay$$and(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) && Fay$$_(y); - }); - }; -} - -// Built-in &&. -function Fay$$and$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) && Fay$$_(y); - }); - ; -} - -// Built-in ||. -function Fay$$or(x){ - return function(y){ - return new Fay$$$(function(){ - return Fay$$_(x) || Fay$$_(y); - }); - }; -} - -// Built-in ||. -function Fay$$or$36$uncurried(x,y){ - - return new Fay$$$(function(){ - return Fay$$_(x) || Fay$$_(y); - }); - -} - -/******************************************************************************* - * Mutable references. - */ - -// Make a new mutable reference. -function Fay$$Ref(x){ - this.value = x; -} - -// Write to the ref. -function Fay$$writeRef(ref,x){ - ref.value = x; -} - -// Get the value from the ref. -function Fay$$readRef(ref,x){ - return ref.value; -} - -/******************************************************************************* - * Dates. - */ -function Fay$$date(str){ - return window.Date.parse(str); -} - -/******************************************************************************* - * Application code. - */ diff --git a/src/Fay.hs b/src/Fay.hs --- a/src/Fay.hs +++ b/src/Fay.hs @@ -1,48 +1,51 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} -- | Main library entry point. module Fay - (module Fay.Types + (module Fay.Config + ,CompileError (..) + ,CompileState (..) + ,CompileResult (..) ,compileFile ,compileFileWithState + ,compileFileWithResult ,compileFromTo ,compileFromToAndGenerateHtml ,toJsName + ,toTsName ,showCompileError - ,getConfigRuntime - ,getRuntime + ,readConfigRuntime ) where +import Fay.Compiler.Prelude + import Fay.Compiler import Fay.Compiler.Misc (ioWarn, printSrcSpanInfo) import Fay.Compiler.Packages import Fay.Compiler.Typecheck +import Fay.Config +import Fay.Runtime import qualified Fay.Exts as F import Fay.Types -import Control.Applicative -import Control.Monad import Data.Aeson (encode) import qualified Data.ByteString.Lazy as L -import Data.Default -import Data.List -import Language.Haskell.Exts.Annotated (prettyPrint) -import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts (prettyPrint) +import Language.Haskell.Exts.Syntax import Language.Haskell.Exts.SrcLoc -import Paths_fay import SourceMap (generate) import SourceMap.Types import System.FilePath -- | Compile the given file and write the output to the given path, or -- if nothing given, stdout. -compileFromTo :: CompileConfig -> FilePath -> Maybe FilePath -> IO () +compileFromTo :: Config -> FilePath -> Maybe FilePath -> IO () compileFromTo cfg filein fileout = if configTypecheckOnly cfg then do @@ -54,15 +57,15 @@ (compileFromToAndGenerateHtml cfg filein) fileout case result of - Right (out,_) -> maybe (putStrLn out) (`writeFile` out) fileout + Right out -> maybe (putStrLn out) (`writeFile` out) fileout Left err -> error $ showCompileError err --- | Compile the given file and write to the output, also generate any HTML. -compileFromToAndGenerateHtml :: CompileConfig -> FilePath -> FilePath -> IO (Either CompileError (String,[Mapping])) +-- | Compile the given file and write to the output, also generates HTML and sourcemap files if configured. +compileFromToAndGenerateHtml :: Config -> FilePath -> FilePath -> IO (Either CompileError String) compileFromToAndGenerateHtml config filein fileout = do - result <- compileFile config { configFilePath = Just filein } filein - case result of - Right (out,mappings) -> do + mres <- compileFileWithResult config { configFilePath = Just filein } filein + case mres of + Right res -> do when (configHtmlWrapper config) $ writeFile (replaceExtension fileout "html") $ unlines [ "" @@ -71,22 +74,23 @@ ," " , unlines . map ((" "++) . makeScriptTagSrc) $ configHtmlJSLibs config , " " ++ makeScriptTagSrc relativeJsPath - , " " , " " , " " , " " , ""] - when (configSourceMap config) $ do - L.writeFile (replaceExtension fileout "map") $ - encode $ - generate SourceMapping - { smFile = fileout - , smSourceRoot = Nothing - , smMappings = mappings - } + case (configSourceMap config, resSourceMappings res) of + (True, Just mappings) -> + L.writeFile (replaceExtension fileout "map") $ + encode $ + generate SourceMapping + { smFile = fileout + , smSourceRoot = Nothing + , smMappings = mappings + } + _ -> return () - return (Right (if configSourceMap config then sourceMapHeader ++ out else out,mappings)) + return $ Right (if configSourceMap config then sourceMapHeader ++ resOutput res else resOutput res) where relativeJsPath = makeRelative (dropFileName fileout) fileout makeScriptTagSrc :: FilePath -> String makeScriptTagSrc s = "" @@ -94,46 +98,60 @@ Left err -> return (Left err) -- | Compile the given file. -compileFile :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping])) -compileFile config filein = fmap (\(src,maps,_) -> (src,maps)) <$> compileFileWithState config filein +compileFile :: Config -> FilePath -> IO (Either CompileError String) +compileFile config filein = fmap (\(src,_,_) -> src) <$> compileFileWithState config filein --- | Compile a file returning the state. -compileFileWithState :: CompileConfig -> FilePath -> IO (Either CompileError (String,[Mapping],CompileState)) +-- | Compile a file returning additional generated metadata. +compileFileWithResult :: Config -> FilePath -> IO (Either CompileError CompileResult) +compileFileWithResult config filein = do + res <- compileFileWithState config filein + return $ do + (s,m,st) <- res + return CompileResult + { resOutput = s + , resImported = map (first F.moduleNameString) $ stateImported st + , resSourceMappings = m + } + +-- | Compile a file returning the resulting internal state of the compiler. +-- Don't use this directly, it's only exposed for the test suite. +compileFileWithState :: Config -> FilePath -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileFileWithState config filein = do - runtime <- getConfigRuntime config + raw <- readConfigRuntime config hscode <- readFile filein - raw <- readFile runtime config' <- resolvePackages config compileToModule filein config' raw (compileToplevelModule filein) hscode -- | Compile the given module to a runnable module. compileToModule :: FilePath - -> CompileConfig -> String -> (F.Module -> Compile [JsStmt]) -> String - -> IO (Either CompileError (String,[Mapping],CompileState)) + -> Config -> String -> (F.Module -> Compile [JsStmt]) -> String + -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileToModule filepath config raw with hscode = do - result <- compileViaStr filepath config printState with hscode + result <- compileViaStr filepath config with hscode return $ case result of Left err -> Left err - Right (PrintState{..},state,_) -> - Right ( generateWrapped (concat $ reverse psOutput) - (stateModuleName state) - , psMappings + Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) -> + Right ( pwOutputString pw + , if null (pwMappings pw) then Nothing else Just (pwMappings pw) , state ) - where - generateWrapped jscode (ModuleName _ modulename) = - unlines $ filter (not . null) - [if configExportRuntime config then raw else "" - ,jscode - ,if not (configLibrary config) - then unlines [";" - ,"Fay$$_(" ++ modulename ++ ".main);" - ] - else "" - ] - printState = def { psPretty = configPrettyPrint config - , psLine = length (lines raw) + 3 - } + where + pw = execPrinter (runtime <> aliases <> printer <> main) pr + runtime = if configExportRuntime config then write raw else mempty + aliases = if configPrettyThunks config + then write . unlines $ [ "var $ = Fay$$$;" + , "var _ = Fay$$_;" + , "var __ = Fay$$__;" + ] + else mempty + main = if not (configLibrary config) + then write $ "Fay$$_(" ++ modulename ++ ".main, true);\n" + else mempty + pr = defaultPrintReader + { prPrettyThunks = configPrettyThunks config + , prPretty = configPrettyPrint config + , prPrettyOperators = configPrettyOperators config + } -- | Convert a Haskell filename to a JS filename. toJsName :: String -> String @@ -141,6 +159,12 @@ ('s':'h':'.': (reverse -> file)) -> file ++ ".js" _ -> x +-- | Convert a Haskell filename to a TypeScript filename. +toTsName :: String -> String +toTsName x = case reverse x of + ('s':'h':'.': (reverse -> file)) -> file ++ ".ts" + _ -> x + -- | Print a compile error for human consumption. showCompileError :: CompileError -> String showCompileError e = case e of @@ -163,13 +187,13 @@ err ++ " at line: " ++ show (srcLine pos) ++ " column:" ++ "\n" ++ show (srcColumn pos) ShouldBeDesugared s -> "Expected this to be desugared (this is a bug): " ++ s - UnableResolveQualified qname -> "unable to resolve qualified names " ++ prettyPrint qname + UnableResolveQualified qname -> "unable to resolve qualified names (this might be a bug):" ++ prettyPrint qname UnsupportedDeclaration d -> "unsupported declaration: " ++ prettyPrint d UnsupportedEnum{} -> "only Int is allowed in enum expressions" UnsupportedExportSpec es -> "unsupported export specification: " ++ prettyPrint es UnsupportedExpression expr -> "unsupported expression syntax: " ++ prettyPrint expr UnsupportedFieldPattern p -> "unsupported field pattern: " ++ prettyPrint p - UnsupportedImport i -> "unsupported import syntax, we're too lazy: " ++ prettyPrint i + UnsupportedImport i -> "unsupported import syntax: " ++ prettyPrint i UnsupportedLet -> "let not supported here" UnsupportedLetBinding d -> "unsupported let binding: " ++ prettyPrint d UnsupportedLiteral lit -> "unsupported literal syntax: " ++ prettyPrint lit @@ -183,9 +207,8 @@ -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists. -getConfigRuntime :: CompileConfig -> IO String -getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg - --- | Get the default JS runtime source. -getRuntime :: IO String -getRuntime = getDataFileName "js/runtime.js" +readConfigRuntime :: Config -> IO String +readConfigRuntime cfg = + case configRuntimePath cfg of + Just path -> readFile path + Nothing -> return $ getRuntimeSource cfg diff --git a/src/Fay/Compiler.hs b/src/Fay/Compiler.hs --- a/src/Fay/Compiler.hs +++ b/src/Fay/Compiler.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -19,7 +20,8 @@ ,parseFay) where -import Fay.Compiler.Config +import Fay.Compiler.Prelude + import Fay.Compiler.Decl import Fay.Compiler.Defaults import Fay.Compiler.Desugar @@ -29,26 +31,23 @@ import Fay.Compiler.InitialPass (initialPass) import Fay.Compiler.Misc import Fay.Compiler.Optimizer +import Fay.Compiler.Parse import Fay.Compiler.PrimOp (findPrimOp) import Fay.Compiler.QName import Fay.Compiler.State import Fay.Compiler.Typecheck -import Fay.Control.Monad.IO +import Fay.Config import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS -import Control.Monad.State +import Control.Monad.Except (throwError) +import Control.Monad.RWS (gets, modify) -import Data.Maybe import qualified Data.Set as S -import Language.Haskell.Exts.Annotated hiding (name) -import Language.Haskell.Names -import Prelude hiding (mod) +import Language.Haskell.Exts hiding (name) +import Language.Haskell.Names (annotateModule) -------------------------------------------------------------------------------- -- Top level entry points @@ -57,17 +56,16 @@ compileViaStr :: FilePath - -> CompileConfig - -> PrintState + -> Config -> (F.Module -> Compile [JsStmt]) -> String - -> IO (Either CompileError (PrintState,CompileState,CompileWriter)) -compileViaStr filepath cfg printState with from = do + -> IO (Either CompileError (Printer,CompileState,CompileWriter)) +compileViaStr filepath cfg with from = do rs <- defaultCompileReader cfg runTopCompile rs defaultCompileState (parseResult (throwError . uncurry ParseError) - (fmap (\x -> execState (runPrinter (printJS x)) printState) . with) + (fmap (mconcat . map printJS) . with) (parseFay filepath from)) -- | Compile the top-level Fay module. @@ -95,18 +93,23 @@ -- | Compile given the location and source string. compileFileWithSource :: FilePath -> String -> Compile ([JsStmt], [JsStmt]) compileFileWithSource filepath contents = do - ((hstmts,fstmts),st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource contents + exportStdlib <- config configExportStdlib + ((hstmts,fstmts),st,wr) <- compileWith filepath compileModuleFromAST compileFileWithSource desugar contents modify $ \s -> s { stateImported = stateImported st , stateJsModulePaths = stateJsModulePaths st } - hstmts' <- maybeOptimize $ hstmts ++ writerCons wr ++ makeTranscoding wr + hstmts' <- maybeOptimize $ hstmts ++ writerCons wr ++ makeTranscoding exportStdlib (stateModuleName st) wr fstmts' <- maybeOptimize fstmts return (hstmts', fstmts') where - makeTranscoding :: CompileWriter -> [JsStmt] - makeTranscoding CompileWriter{..} = - let fay2js = if null writerFayToJs then [] else fayToJsHash writerFayToJs - js2fay = if null writerJsToFay then [] else jsToFayHash writerJsToFay + makeTranscoding :: Bool -> ModuleName a -> CompileWriter -> [JsStmt] + makeTranscoding exportStdlib moduleName CompileWriter{..} = + let fay2js = if null writerFayToJs || (anStdlibModule moduleName && not exportStdlib) + then [] + else fayToJsHash writerFayToJs + js2fay = if null writerJsToFay || (anStdlibModule moduleName && not exportStdlib) + then [] + else jsToFayHash writerJsToFay in fay2js ++ js2fay maybeOptimize :: [JsStmt] -> Compile [JsStmt] maybeOptimize stmts = do @@ -117,62 +120,52 @@ -- | Compile a parse HSE module. compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt]) -compileModuleFromAST (hstmts0, fstmts0) mod''@(Module _ _ pragmas _ _) = do - res <- io $ desugar mod'' - case res of - Left err -> throwError err - Right mod' -> do - mod@(Module _ _ _ _ decls) <- annotateModule Haskell2010 defaultExtensions $ mod' - let modName = unAnn $ F.moduleName mod - modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas - } - current <- compileDecls True decls +compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do + ~mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod' + let modName = unAnn $ F.moduleName mod + modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas + } + current <- compileDecls True decls - exportStdlib <- config configExportStdlib - exportStdlibOnly <- config configExportStdlibOnly - modulePaths <- createModulePath modName - extExports <- generateExports - strictExports <- generateStrictExports - let hstmts = hstmts0 ++ modulePaths ++ current ++ extExports - fstmts = fstmts0 ++ strictExports - return $ if exportStdlibOnly - then if anStdlibModule modName - then (hstmts, fstmts) - else ([], []) - else if not exportStdlib && anStdlibModule modName - then ([], []) - else (hstmts, fstmts) + exportStdlib <- config configExportStdlib + exportStdlibOnly <- config configExportStdlibOnly + modulePaths <- createModulePath modName + extExports <- generateExports + strictExports <- generateStrictExports + let hstmts = hstmts0 ++ modulePaths ++ current ++ extExports + fstmts = fstmts0 ++ strictExports + return $ if exportStdlibOnly + then if anStdlibModule modName + then (hstmts, fstmts) + else ([], []) + else if not exportStdlib && anStdlibModule modName + then ([], []) + else (hstmts, fstmts) compileModuleFromAST _ mod = throwError $ UnsupportedModuleSyntax "compileModuleFromAST" mod -------------------------------------------------------------------------------- -- Misc compilation --- | Check if the given language pragmas are all present. -hasLanguagePragmas :: [String] -> [F.ModulePragma] -> Bool -hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas - where - flattenPragmas :: [F.ModulePragma] -> [String] - flattenPragmas ps = concat $ map pragmaName ps - pragmaName (LanguagePragma _ q) = map unname q - pragmaName _ = [] - -- | For a module A.B, generate -- | var A = {}; -- | A.B = {}; createModulePath :: ModuleName a -> Compile [JsStmt] createModulePath (unAnn -> m) = do cfg <- config id - reg <- liftM concat . mapM modPath . mkModulePaths $ m + let isTs = configTypeScript cfg + reg <- fmap concat . mapM (modPath isTs) . mkModulePaths $ m strict <- if shouldExportStrictWrapper m cfg - then liftM concat . mapM modPath . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m + then fmap concat . mapM (modPath isTs) . mkModulePaths $ (\(ModuleName i n) -> ModuleName i ("Strict." ++ n)) m else return [] return $ reg ++ strict where - modPath :: ModulePath -> Compile [JsStmt] - modPath mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of - [n] -> [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])] + modPath :: Bool -> ModulePath -> Compile [JsStmt] + modPath isTs mp = whenImportNotGenerated mp $ \(unModulePath -> l) -> case l of + [n] -> if isTs + then [JsMapVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])] + else [JsVar (JsNameVar . UnQual () $ Ident () n) (JsObj [])] _ -> [JsSetModule mp (JsObj [])] whenImportNotGenerated :: ModulePath -> (ModulePath -> [JsStmt]) -> Compile [JsStmt] @@ -221,4 +214,4 @@ -- | Is the module a standard module, i.e., one that we'd rather not -- output code for if we're compiling separate files. anStdlibModule :: ModuleName a -> Bool -anStdlibModule (ModuleName _ name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data"] +anStdlibModule (ModuleName _ name) = name `elem` ["Prelude","FFI","Fay.FFI","Data.Data","Data.Ratio","Debug.Trace","Data.Char"] diff --git a/src/Fay/Compiler/Config.hs b/src/Fay/Compiler/Config.hs deleted file mode 100644 --- a/src/Fay/Compiler/Config.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# OPTIONS -fno-warn-orphans #-} - --- | Configuration functions. - -module Fay.Compiler.Config where - -import Fay.Types - -import Data.Default -import Data.Maybe -import Language.Haskell.Exts.Annotated (ModuleName (..)) - --- | Get all include directories without the package mapping. -configDirectoryIncludePaths :: CompileConfig -> [FilePath] -configDirectoryIncludePaths = map snd . configDirectoryIncludes - --- | Get all include directories not included through packages. -nonPackageConfigDirectoryIncludePaths :: CompileConfig -> [FilePath] -nonPackageConfigDirectoryIncludePaths = map snd . filter (isJust . fst) . configDirectoryIncludes - --- | Add a mapping from (maybe) a package to a source directory -addConfigDirectoryInclude :: Maybe String -> FilePath -> CompileConfig -> CompileConfig -addConfigDirectoryInclude pkg fp cfg = cfg { configDirectoryIncludes = (pkg, fp) : configDirectoryIncludes cfg } - --- | Add several include directories. -addConfigDirectoryIncludes :: [(Maybe String,FilePath)] -> CompileConfig -> CompileConfig -addConfigDirectoryIncludes pkgFps cfg = foldl (\c (pkg,fp) -> addConfigDirectoryInclude pkg fp c) cfg pkgFps - --- | Add several include directories without package references. -addConfigDirectoryIncludePaths :: [FilePath] -> CompileConfig -> CompileConfig -addConfigDirectoryIncludePaths fps cfg = foldl (flip (addConfigDirectoryInclude Nothing)) cfg fps - --- | Add a package to compilation -addConfigPackage :: String -> CompileConfig -> CompileConfig -addConfigPackage pkg cfg = cfg { configPackages = pkg : configPackages cfg } - --- | Add several packages to compilation -addConfigPackages :: [String] -> CompileConfig -> CompileConfig -addConfigPackages fps cfg = foldl (flip addConfigPackage) cfg fps - -shouldExportStrictWrapper :: ModuleName a -> CompileConfig -> Bool -shouldExportStrictWrapper (ModuleName _ m) cs = m `elem` configStrict cs - --- | Default configuration. -instance Default CompileConfig where - def = addConfigPackage "fay-base" - CompileConfig - { configOptimize = False - , configFlattenApps = False - , configExportRuntime = True - , configExportStdlib = True - , configExportStdlibOnly = False - , configDirectoryIncludes = [] - , configPrettyPrint = False - , configHtmlWrapper = False - , configHtmlJSLibs = [] - , configLibrary = False - , configWarn = True - , configFilePath = Nothing - , configTypecheck = True - , configWall = False - , configGClosure = False - , configPackageConf = Nothing - , configPackages = [] - , configBasePath = Nothing - , configStrict = [] - , configTypecheckOnly = False - , configRuntimePath = Nothing - , configSourceMap = False - } diff --git a/src/Fay/Compiler/Decl.hs b/src/Fay/Compiler/Decl.hs --- a/src/Fay/Compiler/Decl.hs +++ b/src/Fay/Compiler/Decl.hs @@ -1,6 +1,6 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -8,45 +8,39 @@ module Fay.Compiler.Decl where +import Fay.Compiler.Prelude + import Fay.Compiler.Exp import Fay.Compiler.FFI import Fay.Compiler.GADT import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.State -import Fay.Data.List.Extra import Fay.Exts (convertFieldDecl, fieldDeclNames) import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS -import Language.Haskell.Exts.Annotated +import Control.Monad.Except (throwError) +import Control.Monad.RWS (gets, modify) +import Language.Haskell.Exts hiding (binds, loc, name) +{-# ANN module ("HLint: ignore Reduce duplication"::String) #-} + -- | Compile Haskell declaration. compileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] -compileDecls toplevel decls = case decls of - [] -> return [] - (TypeSig _ _ sig:bind@PatBind{}:decls) -> appendM (compilePatBind toplevel (Just sig) bind) - (compileDecls toplevel decls) - (decl:decls) -> appendM (compileDecl toplevel decl) - (compileDecls toplevel decls) - - where - appendM m n = do x <- m - xs <- n - return (x ++ xs) +compileDecls toplevel = fmap concat . mapM (compileDecl toplevel) -- | Compile a declaration. compileDecl :: Bool -> S.Decl -> Compile [JsStmt] compileDecl toplevel decl = case decl of - pat@PatBind{} -> compilePatBind toplevel Nothing pat + pat@PatBind{} -> compilePatBind toplevel pat FunBind _ matches -> compileFunCase toplevel matches DataDecl _ (DataType _ ) _ (mkTyVars -> tyvars) constructors _ -> compileDataDecl toplevel tyvars constructors GDataDecl _ (DataType _) _l (mkTyVars -> tyvars) _n decls _ -> compileDataDecl toplevel tyvars (map convertGADT decls) - DataDecl _ (NewType _) _ _ _ _ -> return [] + DataDecl _ (NewType _) _ head' constructors _ -> + ifOptimizeNewtypes (return []) + (compileDataDecl toplevel (mkTyVars head') constructors) -- Just ignore type aliases and signatures. TypeDecl {} -> return [] TypeSig {} -> return [] @@ -68,23 +62,34 @@ mkTyVars :: S.DeclHead -> [S.TyVarBind] -mkTyVars (DHead _ _ binds) = binds -mkTyVars (DHInfix _ t1 _ t2) = [t1, t2] -mkTyVars (DHParen _ dh) = mkTyVars dh +mkTyVars x = go x [] + where + go (DHead _ _) = id + go (DHInfix _ r _) = (r:) + go (DHParen _ dh) = go dh + go (DHApp _ dh r) = go dh . (r:) -- | Compile a top-level pattern bind. -compilePatBind :: Bool -> Maybe S.Type -> S.Decl -> Compile [JsStmt] -compilePatBind toplevel sig patDecl = case patDecl of - PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) Nothing -> - case ffiExp rhs of - Just formatstr -> case sig of - Just sig -> compileFFI ident formatstr sig - Nothing -> throwError $ FfiNeedsTypeSig patDecl - _ -> compileUnguardedRhs toplevel srcloc ident rhs +compilePatBind :: Bool -> S.Decl -> Compile [JsStmt] +compilePatBind toplevel patDecl = case patDecl of + PatBind _ (PVar _ name') + (UnGuardedRhs _ + (ExpTypeSig _ + (App _ (Var _ (UnQual _ (Ident _ "ffi"))) + (Lit _ (String _ formatstr _))) + sig)) Nothing -> + let name = unAnn name' + loc = S.srcSpanInfo $ ann name' + in do + fun <- compileFFIExp loc (Just name) formatstr sig + stmt <- bindToplevel toplevel (Just (srcInfoSpan loc)) name fun + return [stmt] + PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) Nothing -> + compileUnguardedRhs toplevel srcloc ident rhs -- TODO: Generalize to all patterns - PatBind srcloc (PVar _ ident) Nothing (UnGuardedRhs _ rhs) (Just bdecls) -> + PatBind srcloc (PVar _ ident) (UnGuardedRhs _ rhs) (Just bdecls) -> compileUnguardedRhs toplevel srcloc ident (Let S.noI bdecls rhs) - PatBind _ pat Nothing (UnGuardedRhs _ rhs) _bdecls -> case pat of + PatBind _ pat (UnGuardedRhs _ rhs) _bdecls -> case pat of PList {} -> compilePatBind' pat rhs PTuple{} -> compilePatBind' pat rhs PApp {} -> compilePatBind' pat rhs @@ -95,10 +100,22 @@ compilePatBind' pat rhs = do exp <- compileExp rhs name <- withScopedTmpJsName return - [JsIf t b1 []] <- compilePat (JsName name) pat [] - let err = [throw ("Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])] - return [JsVar name exp, JsIf t b1 err] + m <- compilePat (JsName name) pat [] + m2 <- interleavePatternMatchFailures m pat m + return (JsVar name exp : m2) + interleavePatternMatchFailures :: [JsStmt] -> S.Pat -> [JsStmt] -> Compile [JsStmt] + interleavePatternMatchFailures original pat = walk + where + walk m = case m of + [JsIf t b1 []] -> do + b2 <- walk b1 + return [JsIf t b2 err] + [JsVar n exp2] -> return [JsVar n exp2] + stmt:stmts -> (stmt:) <$> walk stmts + [] -> error $ "Fay bug! Can't compile pat bind for pattern: " ++ show original + err = [throw ("Irrefutable pattern failed for pattern: " ++ prettyPrint pat) (JsList [])] + -- | Compile a normal simple pattern binding. compileUnguardedRhs :: Bool -> S.X -> S.Name -> S.Exp -> Compile [JsStmt] compileUnguardedRhs toplevel srcloc ident rhs = do @@ -146,7 +163,7 @@ JsSetConstructor qname $ JsFun (Just $ JsConstructor qname) fields - (for fields $ \field -> JsSetProp JsThis field (JsName field)) + (flip fmap fields $ \field -> JsSetProp JsThis field (JsName field)) Nothing -- Creates a function to initialize the record by regular application @@ -191,18 +208,23 @@ (Just (srcInfoSpan (S.srcSpanInfo srcloc))) name (foldr (\arg inner -> JsFun Nothing [arg] [] (Just inner)) - (stmtsThunk (concat pats ++ basecase)) + (stmtsThunk $ deleteAfterReturn (concat pats ++ basecase)) args) return [bind] where + deleteAfterReturn :: [JsStmt] -> [JsStmt] + deleteAfterReturn [] = [] + deleteAfterReturn (x@(JsEarlyReturn _):_) = [x] + deleteAfterReturn (x:xs) = x:deleteAfterReturn xs + args = zipWith const uniqueNames argslen isWildCardMatch (Match _ _ pats _ _) = all isWildCardPat pats isWildCardMatch (InfixMatch _ pat _ pats _ _) = all isWildCardPat (pat:pats) compileCase :: S.Match -> Compile [JsStmt] - compileCase (InfixMatch l pat name pats rhs binds) = - compileCase $ Match l name (pat:pats) rhs binds + compileCase (InfixMatch l pat nm pats rhs binds) = + compileCase $ Match l nm (pat:pats) rhs binds compileCase match@(Match _ _ pats rhs _) = do whereDecls' <- whereDecls match rhsform <- compileRhs rhs diff --git a/src/Fay/Compiler/Defaults.hs b/src/Fay/Compiler/Defaults.hs --- a/src/Fay/Compiler/Defaults.hs +++ b/src/Fay/Compiler/Defaults.hs @@ -4,21 +4,21 @@ module Fay.Compiler.Defaults where -import Fay.Compiler.Config -import Fay.Compiler.Decl (compileDecls) -import Fay.Compiler.Exp (compileLit) +import Fay.Compiler.Decl (compileDecls) +import Fay.Compiler.Exp (compileLit) +import Fay.Config import Fay.Types import Paths_fay -import Data.Map as M -import Data.Set as S +import Data.Map as M +import Data.Set as S -- | The data-files source directory. faySourceDir :: IO FilePath faySourceDir = getDataFileName "src/" -- | The default compiler reader value. -defaultCompileReader :: CompileConfig -> IO CompileReader +defaultCompileReader :: Config -> IO CompileReader defaultCompileReader config = do srcdir <- faySourceDir return CompileReader diff --git a/src/Fay/Compiler/Desugar.hs b/src/Fay/Compiler/Desugar.hs --- a/src/Fay/Compiler/Desugar.hs +++ b/src/Fay/Compiler/Desugar.hs @@ -1,70 +1,59 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} +-- | Desugars a reasonable amount of syntax to reduce duplication in code generation. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE MonoLocalBinds #-} module Fay.Compiler.Desugar - (desugar + ( desugar + , desugar' + , desugarExpParen + , desugarPatParen ) where +import Fay.Compiler.Prelude + +import Fay.Compiler.Desugar.Name +import Fay.Compiler.Desugar.Types +import Fay.Compiler.Misc (ffiExp, hasLanguagePragma) +import Fay.Compiler.QName (unQual, unname) import Fay.Exts.NoAnnotation (unAnn) import Fay.Types (CompileError (..)) -import Control.Applicative -import Control.Monad.Error -import Control.Monad.Reader -import Data.Data (Data) +import Control.Monad.Except (throwError) +import Control.Monad.Reader (asks) import qualified Data.Generics.Uniplate.Data as U -import Data.Maybe -import Data.Typeable (Typeable) -import Language.Haskell.Exts.Annotated hiding (binds, loc) -import Prelude hiding (exp) - --- Types - -data DesugarReader = DesugarReader { readerNameDepth :: Int } - -newtype Desugar a = Desugar - { unDesugar :: (ReaderT DesugarReader - (ErrorT CompileError IO)) - a - } deriving ( MonadReader DesugarReader - , MonadError CompileError - , MonadIO - , Monad - , Functor - , Applicative - ) - -runDesugar :: Desugar a -> IO (Either CompileError a) -runDesugar m = runErrorT (runReaderT (unDesugar m) (DesugarReader 0)) - --- | Generate a temporary, SCOPED name for testing conditions and --- such. We don't have name tracking yet, so instead we use this. -withScopedTmpName :: (Data l, Typeable l) => l -> (Name l -> Desugar a) -> Desugar a -withScopedTmpName l f = do - n <- asks readerNameDepth - local (\r -> DesugarReader $ readerNameDepth r + 1) $ - f $ Ident l $ "$gen" ++ show n - - +import Language.Haskell.Exts hiding (binds, loc, name) -- | Top level, desugar a whole module possibly returning errors -desugar :: (Data l, Typeable l) => Module l -> IO (Either CompileError (Module l)) -desugar md = runDesugar $ +desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l)) +desugar = desugar' "$gen" + +-- | Desugar with the option to specify a prefix for generated names. +-- Useful if you want to provide valid haskell names that HSE can print. +desugar' :: (Data l, Typeable l) => String -> l -> Module l -> IO (Either CompileError (Module l)) +desugar' prefix emptyAnnotation md = runDesugar prefix emptyAnnotation $ checkEnum md >> desugarSection md >>= desugarListComp - >>= return . desugarTupleCon + >>= desugarTupleCon >>= return . desugarPatParen >>= return . desugarFieldPun >>= return . desugarPatFieldPun >>= desugarDo >>= desugarTupleSection - --- | Desugaring + >>= desugarImplicitPrelude + >>= desugarFFITypeSigs + >>= desugarLCase + >>= return . desugarMultiIf + >>= return . desugarInfixOp + >>= return . desugarInfixPat + >>= return . desugarExpParen +{-# ANN desugar' "HLint: ignore Use <$>" #-} -desugarSection :: (Data l, Typeable l) => Module l -> Desugar (Module l) +-- | (a `f`) => \b -> a `f` b +-- (`f` b) => \a -> a `f` b +desugarSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarSection = transformBiM $ \ex -> case ex of LeftSection l e q -> withScopedTmpName l $ \tmp -> return $ Lambda l [PVar l tmp] (InfixApp l e q (Var l (UnQual l tmp))) @@ -72,13 +61,13 @@ return $ Lambda l [PVar l tmp] (InfixApp l (Var l (UnQual l tmp)) q e) _ -> return ex -desugarDo :: (Data l, Typeable l) => Module l -> Desugar (Module l) +-- | Convert do notation into binds and thens. +desugarDo :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarDo = transformBiM $ \ex -> case ex of Do _ stmts -> maybe (throwError EmptyDoBlock) return $ foldl desugarStmt' Nothing (reverse stmts) _ -> return ex --- | Convert do notation into binds and thens. -desugarStmt' :: Maybe (Exp l) -> (Stmt l) -> Maybe (Exp l) +desugarStmt' :: Maybe (Exp l) -> Stmt l -> Maybe (Exp l) desugarStmt' inner stmt = maybe initStmt subsequentStmt inner where @@ -101,39 +90,55 @@ Just $ InfixApp s exp (QVarOp s $ UnQual s $ Symbol s ">>=") - (Lambda s [pat] (inner')) + (Lambda s [pat] inner') -- | (,) => \x y -> (x,y) -- (,,) => \x y z -> (x,y,z) -- etc -desugarTupleCon :: (Data l, Typeable l) => Module l -> Module l -desugarTupleCon = transformBi $ \ex -> case ex of - Var _ (Special _ t@TupleCon{}) -> fromTupleCon ex t - Con _ (Special _ t@TupleCon{}) -> fromTupleCon ex t - _ -> ex +desugarTupleCon :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarTupleCon md = do + prefix <- asks readerTmpNamePrefix + return $ flip transformBi md $ \ex -> case ex of + Var _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t + Con _ (Special _ t@TupleCon{}) -> fromTupleCon prefix ex t + _ -> ex where - fromTupleCon :: Exp l -> SpecialCon l -> Exp l - fromTupleCon e s = fromMaybe e $ case s of + fromTupleCon :: String -> Exp l -> SpecialCon l -> Exp l + fromTupleCon prefix e s = fromMaybe e $ case s of TupleCon l b n -> Just $ Lambda l params body where -- It doesn't matter if these variable names shadow anything since -- this lambda won't have inner scopes. - names = take n $ map (Ident l . ("$gen" ++) . show) [(1::Int)..] + names = take n $ unscopedTmpNames l prefix params = PVar l <$> names body = Tuple l b (Var l . UnQual l <$> names) _ -> Nothing -desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar (Module l) -desugarTupleSection = transformBiM $ \ex -> case ex of - TupleSection l _ mes -> do - (names, lst) <- genSlotNames l mes (varNames l) - return $ Lambda l (map (PVar l) names) (Tuple l Unboxed lst) +-- | \case { ... } => \foo -> case foo of { ... } +desugarLCase :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarLCase = transformBiM $ \ex -> case ex of + LCase l alts -> withScopedTmpName l $ \n -> return $ Lambda l [PVar l n] (Case l (Var l (UnQual l n)) alts) _ -> return ex + +-- | if | p -> x | q -> y => case () of _ | p -> x | q -> y +desugarMultiIf :: (Data l, Typeable l) => Module l -> Module l +desugarMultiIf = transformBi $ \ex -> case ex of + MultiIf l alts -> Case l (Con l (Special l (UnitCon l))) + [Alt l (PWildCard l) (GuardedRhss l alts) Nothing] + _ -> ex + +-- | (a,) => \b -> (a,b) +desugarTupleSection :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarTupleSection md = do + prefix <- asks readerTmpNamePrefix + flip transformBiM md $ \ex -> case ex of + TupleSection l _ mes -> do + (names, lst) <- genSlotNames l mes (unscopedTmpNames l prefix) + return $ Lambda l (map (PVar l) names) (Tuple l Boxed lst) + _ -> return ex where - varNames :: l -> [Name l] - varNames l = map (\i -> Ident l ("$gen_" ++ show i)) [0::Int ..] - genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar ([Name l], [Exp l]) + genSlotNames :: l -> [Maybe (Exp l)] -> [Name l] -> Desugar l ([Name l], [Exp l]) genSlotNames _ [] _ = return ([], []) genSlotNames l (Nothing : rest) ns = do -- it's safe to use head/tail here because ns is an infinite list @@ -149,19 +154,20 @@ PParen _ p -> p _ -> pt +-- | {a} => {a=a} for R{a} expressions desugarFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarFieldPun = transformBi $ \f -> case f of - FieldPun l n -> let dn = UnQual l n in FieldUpdate l dn (Var l dn) + FieldPun l n -> FieldUpdate l n (Var l n) _ -> f +-- | {a} => {a=a} for R{a} patterns desugarPatFieldPun :: (Data l, Typeable l) => Module l -> Module l desugarPatFieldPun = transformBi $ \pf -> case pf of - -- {a} => {a=a} for R{a} - PFieldPun l n -> PFieldPat l (UnQual l n) (PVar l n) + PFieldPun l n -> PFieldPat l n (PVar l (unQual n)) _ -> pf -- | Desugar list comprehensions. -desugarListComp :: (Data l, Typeable l) => Module l -> Desugar (Module l) +desugarListComp :: (Data l, Typeable l) => Module l -> Desugar l (Module l) desugarListComp = transformBiM $ \ex -> case ex of ListComp l exp stmts -> desugarListComp' l exp stmts _ -> return ex @@ -187,7 +193,7 @@ -- syntax to GHC.Base.Enum instead of using our Enum class so we check -- for obviously incorrect usages and throw an error on them. This can -- only checks literals, but it helps a bit. -checkEnum :: (Data l, Typeable l) => Module l -> Desugar () +checkEnum :: (Data l, Typeable l) => Module l -> Desugar l () checkEnum = mapM_ f . universeBi where f ex = case ex of @@ -197,8 +203,8 @@ e@(EnumFromThenTo _ e1 e2 e3) -> checkIntOrUnknown e [e1,e2,e3] _ -> return () - checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar () - checkIntOrUnknown exp es = when (not $ any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp) + checkIntOrUnknown :: Exp l -> [Exp l] -> Desugar l () + checkIntOrUnknown exp es = unless (any isIntOrUnknown es) (throwError . UnsupportedEnum $ unAnn exp) isIntOrUnknown :: Exp l -> Bool isIntOrUnknown e = case e of Con {} -> False @@ -211,6 +217,138 @@ EnumFromThen {} -> False EnumFromThenTo {} -> False _ -> True + +-- | Adds an explicit import Prelude statement when appropriate. +desugarImplicitPrelude :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarImplicitPrelude m = + if preludeNotNeeded + then return m + else addPrelude m + where + preludeNotNeeded = hasExplicitPrelude m || + hasLanguagePragma "NoImplicitPrelude" (getPragmas m) + + getPragmas :: (Data l, Typeable l) => Module l -> [ModulePragma l] + getPragmas = universeBi + + getImportDecls :: Module l -> [ImportDecl l] + getImportDecls (Module _ _ _ decls _) = decls + getImportDecls _ = [] + + setImportDecls :: [ImportDecl l] -> Module l -> Module l + setImportDecls decls (Module a b c _ d) = Module a b c decls d + setImportDecls _ mod = mod + + hasExplicitPrelude :: Module l -> Bool + hasExplicitPrelude = any isPrelude . getImportDecls + + isPrelude :: ImportDecl l -> Bool + isPrelude decl = case importModule decl of + ModuleName _ name -> name == "Prelude" + + addPrelude :: Module l -> Desugar l (Module l) + addPrelude mod = do + let decls = getImportDecls mod + prelude <- getPrelude + return $ setImportDecls (prelude : decls) mod + + getPrelude :: Desugar l (ImportDecl l) + getPrelude = do + noInfo <- asks readerNoInfo + return $ ImportDecl noInfo (ModuleName noInfo "Prelude") False False False Nothing Nothing Nothing + +desugarFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarFFITypeSigs = desugarToplevelFFITypeSigs >=> desugarBindsTypeSigs + +-- | For each toplevel FFI pattern binding, search the module for the relevant +-- type declaration; if found, add a type signature to the ffi expression. +-- e.g. +-- foo :: Int +-- foo = ffi "3" +-- becomes +-- foo :: Int +-- foo = ffi "3" :: Int +desugarToplevelFFITypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarToplevelFFITypeSigs m = case m of + Module a b c d decls -> do + decls' <- addFFIExpTypeSigs decls + return $ Module a b c d decls' + _ -> return m + +desugarBindsTypeSigs :: (Data l, Typeable l) => Module l -> Desugar l (Module l) +desugarBindsTypeSigs = transformBiM $ \(BDecls srcInfo decls) -> do + decls' <- addFFIExpTypeSigs decls + return $ BDecls srcInfo decls' + +addFFIExpTypeSigs :: (Data l, Typeable l) => [Decl l] -> Desugar l [Decl l] +addFFIExpTypeSigs decls = do + let typeSigs = getTypeSigs decls + sequence $ go typeSigs decls + where + -- | Create a lookup list mapping names to types, for all the types declared + -- through standalone (ie: not in an expression) type signatures at this + -- scope level. + getTypeSigs ds = [ (unname n, typ) | TypeSig _ names typ <- ds, n <- names ] + + go typeSigs = map (addTypeSig typeSigs) + + addTypeSig typeSigs decl = case decl of + (PatBind loc pat rhs binds) -> + case getUnguardedRhs rhs of + Just (srcInfo, rhExp) -> + if isFFI rhExp + then do + rhExp' <- addSigToExp typeSigs decl rhExp + return $ PatBind loc pat (UnGuardedRhs srcInfo rhExp') binds + else return decl + _ -> return decl + _ -> return decl + + getUnguardedRhs rhs = case rhs of + (UnGuardedRhs srcInfo exp) -> Just (srcInfo, exp) + _ -> Nothing + + isFFI = isJust . ffiExp + + -- | Adds an explicit type signature to an expression (which is assumed to + -- be the RHS of a declaration). This should only need to be called for FFI + -- function declarations. + -- Arguments: + -- sigs: List of toplevel type signatures + -- decl: The declaration, which should be a PatBind. + -- rhExp: Expression comprising the RHS of the declaration + addSigToExp typeSigs decl rhExp = case getTypeFor typeSigs decl of + Just typ -> do + noInfo <- asks readerNoInfo + return $ ExpTypeSig noInfo rhExp typ + Nothing -> return rhExp + + getTypeFor typeSigs decl = case decl of + (PatBind _ (PVar _ name) _ _) -> lookup (unname name) typeSigs + _ -> Nothing + +-- | a `op` b => op a b +-- a + b => (+) a b +-- for expressions +desugarInfixOp :: (Data l, Typeable l) => Module l -> Module l +desugarInfixOp = transformBi $ \ex -> case ex of + InfixApp l e1 oper e2 -> App l (App l (getOp oper) e1) e2 + where + getOp (QVarOp l' o) = Var l' o + getOp (QConOp l' o) = Con l' o + _ -> ex + +-- | a : b => (:) a b for patterns +desugarInfixPat :: (Data l, Typeable l) => Module l -> Module l +desugarInfixPat = transformBi $ \pt -> case pt of + PInfixApp l p1 iop p2 -> PApp l iop [p1, p2] + _ -> pt + +-- | (a) => a for patterns +desugarExpParen :: (Data l, Typeable l) => Module l -> Module l +desugarExpParen = transformBi $ \ex -> case ex of + Paren _ e -> e + _ -> ex transformBi :: U.Biplate (from a) (to a) => (to a -> to a) -> from a -> from a transformBi = U.transformBi diff --git a/src/Fay/Compiler/Desugar/Name.hs b/src/Fay/Compiler/Desugar/Name.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Desugar/Name.hs @@ -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 diff --git a/src/Fay/Compiler/Desugar/Types.hs b/src/Fay/Compiler/Desugar/Types.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Desugar/Types.hs @@ -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)) diff --git a/src/Fay/Compiler/Exp.hs b/src/Fay/Compiler/Exp.hs --- a/src/Fay/Compiler/Exp.hs +++ b/src/Fay/Compiler/Exp.hs @@ -1,6 +1,6 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -14,60 +14,60 @@ ,compileLit ) where +import Fay.Compiler.Prelude + import Fay.Compiler.FFI (compileFFIExp) import Fay.Compiler.Misc import Fay.Compiler.Pattern import Fay.Compiler.Print import Fay.Compiler.QName -import Fay.Data.List.Extra +import Fay.Config import Fay.Exts.NoAnnotation (unAnn) import Fay.Exts.Scoped (noI) import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (asks, gets) import qualified Data.Char as Char -import Language.Haskell.Exts.Annotated -import Language.Haskell.Names +import Language.Haskell.Exts hiding (alt, binds, name, op) +import Language.Haskell.Names (NameInfo (RecExpWildcard), Scoped (Scoped)) -- | Compile Haskell expression. compileExp :: S.Exp -> Compile JsExp -compileExp exp = case exp of - Paren _ exp -> compileExp exp +compileExp e = case e of Var _ qname -> compileVar qname - Lit _ lit -> compileLit lit + Lit s lit -> compileLit (Signless s) lit + App _ (Var _ (UnQual _ (Ident _ "ffi"))) _ -> throwError $ FfiNeedsTypeSig e App _ exp1 exp2 -> compileApp exp1 exp2 NegApp _ exp -> compileNegApp exp - InfixApp _ exp1 op exp2 -> compileInfixApp exp1 op exp2 Let _ (BDecls _ decls) exp -> compileLet decls exp List _ [] -> return JsNull List _ xs -> compileList xs Tuple _ _boxed xs -> compileList xs If _ cond conseq alt -> compileIf cond conseq alt Case _ exp alts -> compileCase exp alts - Con _ (UnQual _ (Ident _ "True")) -> return (JsLit (JsBool True)) - Con _ (UnQual _ (Ident _ "False")) -> return (JsLit (JsBool False)) + Con _ (UnQual _ (Ident _ "True")) -> return $ JsLit (JsBool True) + Con _ (UnQual _ (Ident _ "False")) -> return $ JsLit (JsBool False) Con _ qname -> compileVar qname Lambda _ pats exp -> compileLambda pats exp EnumFrom _ i -> compileEnumFrom i EnumFromTo _ i i' -> compileEnumFromTo i i' EnumFromThen _ a b -> compileEnumFromThen a b EnumFromThenTo _ a b z -> compileEnumFromThenTo a b z - RecConstr _ name fieldUpdates -> compileRecConstr name fieldUpdates - RecUpdate _ rec fieldUpdates -> compileRecUpdate rec fieldUpdates - ListComp {} -> shouldBeDesugared exp - Do {} -> shouldBeDesugared exp - LeftSection {} -> shouldBeDesugared exp - RightSection {} -> shouldBeDesugared exp - TupleSection {} -> shouldBeDesugared exp - ExpTypeSig _ exp sig -> - case ffiExp exp of - Nothing -> compileExp exp - Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig - - exp -> throwError (UnsupportedExpression exp) + RecConstr _ name fieldUpdates -> compileRecConstr e name fieldUpdates + RecUpdate _ rec fieldUpdates -> compileRecUpdate e rec fieldUpdates + ExpTypeSig _ exp sig -> case ffiExp exp of + Nothing -> compileExp exp + Just formatstr -> compileFFIExp (S.srcSpanInfo $ ann exp) Nothing formatstr sig + ListComp {} -> shouldBeDesugared e + Do {} -> shouldBeDesugared e + LeftSection {} -> shouldBeDesugared e + RightSection {} -> shouldBeDesugared e + TupleSection {} -> shouldBeDesugared e + Paren {} -> shouldBeDesugared e + InfixApp {} -> shouldBeDesugared e + exp -> throwError $ UnsupportedExpression exp -- | Compile variable. compileVar :: S.QName -> Compile JsExp @@ -75,35 +75,42 @@ compileVar qname = do nc <- lookupNewtypeConst qname nd <- lookupNewtypeDest qname - if (nc /= Nothing || nd /= Nothing) + if isJust nc || isJust nd then -- variable is either a newtype constructor or newtype destructor, -- replace it with identity function return idFun - else do - qname <- unsafeResolveName qname - return (JsName (JsNameVar qname)) + else JsName . JsNameVar <$> unsafeResolveName qname where idFun = JsFun Nothing [JsTmp 1] [] (Just (JsName $ JsTmp 1)) -- | Compile Haskell literal. -compileLit :: S.Literal -> Compile JsExp -compileLit lit = case lit of - Char _ ch _ -> return (JsLit (JsChar ch)) - Int _ integer _ -> return (JsLit (JsInt (fromIntegral integer))) -- FIXME: - Frac _ rational _ -> return (JsLit (JsFloating (fromRational rational))) +compileLit :: S.Sign -> S.Literal -> Compile JsExp +compileLit sign lit = case lit of + Char _ ch _ -> return (JsLit (JsChar ch)) + Int _ integer _ -> return (JsLit (JsInt (fromIntegral (applySign integer)))) -- FIXME: + Frac _ rational _ -> return (JsLit (JsFloating (fromRational (applySign rational)))) String _ string _ -> do fromString <- gets stateUseFromString - if fromString - then return (JsLit (JsStr string)) - else return (JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)]) - lit -> throwError (UnsupportedLiteral lit) + return $ if fromString + then JsLit (JsStr string) + else JsApp (JsName (JsBuiltIn "list")) [JsLit (JsStr string)] + _ -> throwError $ UnsupportedLiteral lit + where + applySign :: Num a => a -> a + applySign = case sign of + Signless _ -> id + Negative _ -> negate -- | Compile simple application. compileApp :: S.Exp -> S.Exp -> Compile JsExp compileApp exp1@(Con _ q) exp2 = - maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q + ifOptimizeNewtypes + (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeConst q) + (compileApp' exp1 exp2) compileApp exp1@(Var _ q) exp2 = - maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q + ifOptimizeNewtypes + (maybe (compileApp' exp1 exp2) (const $ compileExp exp2) =<< lookupNewtypeDest q) + (compileApp' exp1 exp2) compileApp exp1 exp2 = compileApp' exp1 exp2 @@ -119,9 +126,9 @@ -- a(a(a(a(a(a(a(a(a(a(L)(c))(b))(0))(0))(y))(t))(a(a(F)(3*a(a(d)+a(a(f)/20))))*a(a(f)/2)))(140+a(f)))(y))(t)}) -- Which might be OK for speed, but increases the JS stack a fair bit. method1 :: JsExp -> S.Exp -> Compile JsExp - method1 exp1 exp2 = - JsApp <$> (forceFlatName <$> return exp1) - <*> fmap return (compileExp exp2) + method1 e1 e2 = + JsApp <$> (forceFlatName <$> return e1) + <*> fmap return (compileExp e2) where forceFlatName name = JsApp (JsName JsForce) [name] @@ -130,9 +137,9 @@ -- d(O,a,b,0,0,B,w,e(d(I,3*e(e(c)+e(e(g)/20))))*e(e(g)/2),140+e(g),B,w)}),d(K,g,e(c)+0.05)) -- Which should be much better for the stack and readability, but probably not great for speed. method2 :: JsExp -> S.Exp -> Compile JsExp - method2 exp1 exp2 = fmap flatten $ - JsApp <$> return exp1 - <*> fmap return (compileExp exp2) + method2 e1 e2 = fmap flatten $ + JsApp <$> return e1 + <*> fmap return (compileExp e2) where flatten (JsApp op args) = case op of @@ -144,21 +151,6 @@ compileNegApp :: S.Exp -> Compile JsExp compileNegApp e = JsNegApp . force <$> compileExp e --- | Compile an infix application, optimizing the JS cases. -compileInfixApp :: S.Exp -> S.QOp -> S.Exp -> Compile JsExp -compileInfixApp exp1 ap exp2 = case exp1 of - Con _ q -> do - newtypeConst <- lookupNewtypeConst q - case newtypeConst of - Just _ -> compileExp exp2 - Nothing -> normalApp - _ -> normalApp - where - normalApp = compileExp (App noI (App noI (Var noI op) exp1) exp2) - op = getOp ap - getOp (QVarOp _ op) = op - getOp (QConOp _ op) = op - -- | Compile a let expression. compileLet :: [S.Decl] -> S.Exp -> Compile JsExp compileLet decls exp = do @@ -171,10 +163,10 @@ compileLetDecl decl = do compileDecls <- asks readerCompileDecls case decl of - decl@PatBind{} -> compileDecls False [decl] - decl@FunBind{} -> compileDecls False [decl] - TypeSig{} -> return [] - _ -> throwError (UnsupportedLetBinding decl) + PatBind{} -> compileDecls False [decl] + FunBind{} -> compileDecls False [decl] + TypeSig{} -> return [] + _ -> throwError $ UnsupportedLetBinding decl -- | Compile a list expression. compileList :: [S.Exp] -> Compile JsExp @@ -191,55 +183,57 @@ -- | Compile case expressions. compileCase :: S.Exp -> [S.Alt] -> Compile JsExp -compileCase exp alts = do - exp <- compileExp exp +compileCase e alts = do + exp <- compileExp e withScopedTmpJsName $ \tmpName -> do - pats <- fmap optimizePatConditions $ mapM (compilePatAlt (JsName tmpName)) alts + pats <- optimizePatConditions <$> mapM (compilePatAlt (JsName tmpName)) alts + let (xx,flag) = deleteAfterReturn (concat pats) return $ JsApp (JsFun Nothing [tmpName] - (concat pats) - (if any isWildCardAlt alts + xx + (if (flag || any isWildCardAlt alts) then Nothing else Just (throwExp "unhandled case" (JsName tmpName)))) [exp] + where + deleteAfterReturn :: [JsStmt] -> ([JsStmt],Bool) + deleteAfterReturn [] = ([],False) + deleteAfterReturn (x@(JsEarlyReturn _):_) = ([x],True) + deleteAfterReturn (x:xs) = ((x:xx),flag) + where (xx,flag) = deleteAfterReturn xs -- | Compile the given pattern against the given expression. compilePatAlt :: JsExp -> S.Alt -> Compile [JsStmt] -compilePatAlt exp alt@(Alt _ pat rhs wheres) = case wheres of - Just (BDecls _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt) - Just (IPBinds _ (_ : _)) -> throwError (UnsupportedWhereInAlt alt) - _ -> do +compilePatAlt exp a@(Alt _ pat rhs wheres) = case wheres of + Just (BDecls _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a + Just (IPBinds _ (_ : _)) -> throwError $ UnsupportedWhereInAlt a + _ -> do alt <- compileGuardedAlt rhs compilePat exp pat [alt] -- | Compile a guarded alt. -compileGuardedAlt :: S.GuardedAlts -> Compile JsStmt +compileGuardedAlt :: S.Rhs -> Compile JsStmt compileGuardedAlt alt = case alt of - UnGuardedAlt _ exp -> JsEarlyReturn <$> compileExp exp - GuardedAlts _ alts -> compileGuards (map altToRhs alts) - where - altToRhs (GuardedAlt l s e) = GuardedRhs l s e + UnGuardedRhs _ exp -> JsEarlyReturn <$> compileExp exp + GuardedRhss _ alts -> compileGuards alts -- | Compile guards compileGuards :: [S.GuardedRhs] -> Compile JsStmt -compileGuards ((GuardedRhs _ (Qualifier _ (Var _ (UnQual _ (Ident _ "otherwise"))):_) exp):_) = - (\e -> JsIf (JsLit $ JsBool True) [JsEarlyReturn e] []) <$> compileExp exp compileGuards (GuardedRhs _ (Qualifier _ guard:_) exp : rest) = makeIf <$> fmap force (compileExp guard) <*> compileExp exp <*> if null rest then return [] else do gs' <- compileGuards rest return [gs'] - where makeIf gs e gss = JsIf gs [JsEarlyReturn e] gss + where makeIf gs e = JsIf gs [JsEarlyReturn e] compileGuards rhss = throwError . UnsupportedRhs . GuardedRhss noI $ rhss -- | Compile a lambda. compileLambda :: [S.Pat] -> S.Exp -> Compile JsExp -compileLambda pats exp = do - exp <- compileExp exp +compileLambda pats = compileExp >=> \exp -> do stmts <- generateStatements exp case stmts of [JsEarlyReturn fun@JsFun{}] -> return fun @@ -250,9 +244,13 @@ generateStatements exp = foldM (\inner (param,pat) -> do stmts <- compilePat (JsName param) pat inner - return [JsEarlyReturn (JsFun Nothing [param] (stmts ++ [unhandledcase param | not allfree]) Nothing)]) + return [JsEarlyReturn (JsFun Nothing [param] (deleteAfterReturn $ stmts ++ [unhandledcase param | not allfree]) Nothing)]) [JsEarlyReturn exp] (reverse (zip uniqueNames pats)) + deleteAfterReturn :: [JsStmt] -> [JsStmt] + deleteAfterReturn [] = [] + deleteAfterReturn (x@(JsEarlyReturn _):_) = [x] + deleteAfterReturn (x:xs) = x:deleteAfterReturn xs -- | Compile [e1..] arithmetic sequences. compileEnumFrom :: S.Exp -> Compile JsExp @@ -290,36 +288,36 @@ -- | Compile a record construction with named fields -- | GHC will warn on uninitialized fields, they will be undefined in JS. -compileRecConstr :: S.QName -> [S.FieldUpdate] -> Compile JsExp -compileRecConstr name fieldUpdates = do +compileRecConstr :: S.Exp -> S.QName -> [S.FieldUpdate] -> Compile JsExp +compileRecConstr origExp name fieldUpdates = do -- var obj = new $_Type() let unQualName = withIdent lowerFirst . unQualify $ unAnn name qname <- unsafeResolveName name let record = JsVar (JsNameVar unQualName) (JsNew (JsConstructor qname) []) - setFields <- liftM concat (forM fieldUpdates (updateStmt name)) + setFields <- concat <$> forM fieldUpdates (updateStmt name) return $ JsApp (JsFun Nothing [] (record:setFields) (Just . JsName . JsNameVar . withIdent lowerFirst . unQualify $ unAnn name)) [] where -- updateStmt :: QName a -> S.FieldUpdate -> Compile [JsStmt] updateStmt (unAnn -> o) (FieldUpdate _ (unAnn -> field) value) = do exp <- compileExp value return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp] - updateStmt o (FieldWildcard (wildcardFields -> fields)) = do - return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o) + updateStmt o (FieldWildcard (wildcardFields -> fields)) = + return $ flip fmap fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o) (JsNameVar fieldName) (JsName $ JsNameVar fieldName) -- I couldn't find a code that generates (FieldUpdate (FieldPun ..)) - updateStmt _ u = error ("updateStmt: " ++ show u) + updateStmt _ _ = throwError $ UnsupportedExpression origExp wildcardFields l = case l of - Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName) . map fst $ es + Scoped (RecExpWildcard es) _ -> map (unQualify . origName2QName . fst) es _ -> [] lowerFirst :: String -> String lowerFirst "" = "" lowerFirst (x:xs) = '_' : Char.toLower x : xs -- | Compile a record update. -compileRecUpdate :: S.Exp -> [S.FieldUpdate] -> Compile JsExp -compileRecUpdate rec fieldUpdates = do +compileRecUpdate :: S.Exp -> S.Exp -> [S.FieldUpdate] -> Compile JsExp +compileRecUpdate origExp rec fieldUpdates = do record <- force <$> compileExp rec let copyName = UnQual () $ Ident () "$_record_to_update" copy = JsVar (JsNameVar copyName) @@ -332,14 +330,14 @@ JsSetProp (JsNameVar copyName) (JsNameVar field) <$> compileExp value updateExp _ f@FieldPun{} = shouldBeDesugared f -- I also couldn't find a code that generates (FieldUpdate FieldWildCard) - updateExp _ FieldWildcard{} = error "unsupported update: FieldWildcard" + updateExp _ FieldWildcard{} = throwError $ UnsupportedExpression origExp -- | Make a Fay list. makeList :: [JsExp] -> JsExp makeList exps = JsApp (JsName $ JsBuiltIn "list") [JsList exps] -- | Optimize short literal [e1..e3] arithmetic sequences. -optEnumFromTo :: CompileConfig -> JsExp -> JsExp -> Maybe JsExp +optEnumFromTo :: Config -> JsExp -> JsExp -> Maybe JsExp optEnumFromTo cfg (JsLit f) (JsLit t) = if configOptimize cfg then case (f,t) of @@ -348,14 +346,14 @@ _ -> Nothing else Nothing where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> Maybe JsExp - strict litfn f t = - if fromEnum t - fromEnum f < maxStrictASLen - then Just . makeList . map (JsLit . litfn) $ enumFromTo f t + strict litfn fr to = + if fromEnum to - fromEnum fr < maxStrictASLen + then Just . makeList . map (JsLit . litfn) $ enumFromTo fr to else Nothing optEnumFromTo _ _ _ = Nothing -- | Optimize short literal [e1,e2..e3] arithmetic sequences. -optEnumFromThenTo :: CompileConfig -> JsExp -> JsExp -> JsExp -> Maybe JsExp +optEnumFromThenTo :: Config -> JsExp -> JsExp -> JsExp -> Maybe JsExp optEnumFromThenTo cfg (JsLit fr) (JsLit th) (JsLit to) = if configOptimize cfg then case (fr,th,to) of @@ -364,10 +362,10 @@ _ -> Nothing else Nothing where strict :: (Enum a, Ord a, Num a) => (a -> JsLit) -> a -> a -> a -> Maybe JsExp - strict litfn fr th to = - if (fromEnum to - fromEnum fr) `div` - (fromEnum th - fromEnum fr) + 1 < maxStrictASLen - then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr th to + strict litfn fr' th' to' = + if (fromEnum to' - fromEnum fr') `div` + (fromEnum th' - fromEnum fr') + 1 < maxStrictASLen + then Just . makeList . map (JsLit . litfn) $ enumFromThenTo fr' th' to' else Nothing optEnumFromThenTo _ _ _ _ = Nothing diff --git a/src/Fay/Compiler/FFI.hs b/src/Fay/Compiler/FFI.hs --- a/src/Fay/Compiler/FFI.hs +++ b/src/Fay/Compiler/FFI.hs @@ -1,106 +1,89 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS -Wall #-} -- | Compile FFI definitions. module Fay.Compiler.FFI (emitFayToJs ,emitJsToFay - ,compileFFI ,compileFFIExp ,jsToFayHash ,fayToJsHash ,typeArity ) where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc -import Fay.Compiler.Print (printJSString) +import Fay.Compiler.Print (printJSString) import Fay.Compiler.QName -import Fay.Exts.NoAnnotation (unAnn) -import qualified Fay.Exts.NoAnnotation as N -import qualified Fay.Exts.Scoped as S +import Fay.Exts.NoAnnotation (unAnn) +import qualified Fay.Exts.NoAnnotation as N +import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative ((<$>), (<*>)) -import Control.Arrow ((***)) -import Control.Monad.Error -import Control.Monad.Writer -import Data.Char +import Control.Monad.Except (throwError) +import Control.Monad.Writer (tell) import Data.Generics.Schemes -import Data.List -import Data.Maybe -import Data.String -import Language.ECMAScript3.Parser as JS +import Language.ECMAScript3.Parser as JS import Language.ECMAScript3.Syntax -import Language.Haskell.Exts.Annotated (SrcSpanInfo, - prettyPrint,srcInfoSpan) -import Language.Haskell.Exts.Annotated.Syntax -import Prelude hiding (exp, mod) -import Safe +import Language.Haskell.Exts (SrcSpanInfo, prettyPrint) +import Language.Haskell.Exts.Syntax --- | Compile an FFI call. -compileFFI :: S.Name -- ^ Name of the to-be binding. - -> String -- ^ The format string. - -> S.Type -- ^ Type signature. - -> Compile [JsStmt] -compileFFI name' formatstr sig = +-- | Compile an FFI expression (also used when compiling top level definitions). +compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp +compileFFIExp loc (fmap unAnn -> nameopt) formatstr sig' = -- substitute newtypes with their child types before calling -- real compileFFI - compileFFI' =<< rmNewtys sig - + compileFFI' . unAnn =<< rmNewtys sig' where rmNewtys :: S.Type -> Compile N.Type - rmNewtys (TyForall _ b c t) = TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t - rmNewtys (TyFun _ t1 t2) = TyFun () <$> rmNewtys t1 <*> rmNewtys t2 - rmNewtys (TyTuple _ b tl) = TyTuple () b <$> mapM rmNewtys tl - rmNewtys (TyList _ t) = TyList () <$> rmNewtys t - rmNewtys (TyApp _ t1 t2) = TyApp () <$> rmNewtys t1 <*> rmNewtys t2 - rmNewtys t@TyVar{} = return (unAnn t) - rmNewtys (TyCon _ qname) = do - newty <- lookupNewtypeConst qname - return $ case newty of - Nothing -> TyCon () (unAnn qname) - Just (_,ty) -> ty - rmNewtys (TyParen _ t) = TyParen () <$> rmNewtys t - rmNewtys (TyInfix _ t1 q t2)= flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2 - rmNewtys (TyKind _ t k) = flip (TyKind ()) (unAnn k) <$> rmNewtys t - - compileFFI' :: N.Type -> Compile [JsStmt] - compileFFI' sig' = do - fun <- compileFFIExp loc (Just name) formatstr sig' - stmt <- bindToplevel True (Just (srcInfoSpan loc)) name fun - return [stmt] - - name = unAnn name' - loc = S.srcSpanInfo $ ann name' - --- | Compile an FFI expression (also used when compiling top level definitions). -compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> (Type a) -> Compile JsExp -compileFFIExp loc (fmap unAnn -> nameopt) formatstr (unAnn -> sig) = do - let name = fromMaybe "" nameopt - inner <- formatFFI loc formatstr (zip params funcFundamentalTypes) - case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of - Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err)) - Right exp -> do - config' <- config id - when (configGClosure config') $ warnDotUses loc inner exp - return (body inner) + rmNewtys typ = case typ of + TyForall _ b c t -> TyForall () (fmap (map unAnn) b) (fmap unAnn c) <$> rmNewtys t + TyFun _ t1 t2 -> TyFun () <$> rmNewtys t1 <*> rmNewtys t2 + TyTuple _ b tl -> TyTuple () b <$> mapM rmNewtys tl + TyList _ t -> TyList () <$> rmNewtys t + TyApp _ t1 t2 -> TyApp () <$> rmNewtys t1 <*> rmNewtys t2 + t@TyVar{} -> return $ unAnn t + TyCon _ qname -> maybe (TyCon () (unAnn qname)) snd <$> lookupNewtypeConst qname + TyParen _ t -> TyParen () <$> rmNewtys t + TyInfix _ t1 q t2 -> flip (TyInfix ()) (unAnn q) <$> rmNewtys t1 <*> rmNewtys t2 + TyKind _ t k -> flip (TyKind ()) (unAnn k) <$> rmNewtys t + TyPromoted {} -> return $ unAnn typ + TyParArray _ t -> TyParArray () <$> rmNewtys t + TyEquals _ t1 t2 -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2 + TySplice {} -> return $ unAnn typ + TyBang _ bt unp t -> TyBang () (unAnn bt) (unAnn unp) <$> rmNewtys t + TyWildCard {} -> error "TyWildCard not supported" + TyQuasiQuote {} -> error "TyQuasiQuote not supported" + TyUnboxedSum {} -> error "TyUnboxedSum not supported" - where - body inner = foldr wrapParam (wrapReturn inner) params - wrapParam pname inner = JsFun Nothing [pname] [] (Just inner) - params = zipWith const uniqueNames [1..typeArity sig] - wrapReturn :: String -> JsExp - wrapReturn inner = thunk $ - case lastMay funcFundamentalTypes of - -- Returns a “pure” value; - Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner) - -- Base case: - Nothing -> JsRawExp inner - funcFundamentalTypes = functionTypeArgs sig - returnType = last funcFundamentalTypes + compileFFI' :: N.Type -> Compile JsExp + compileFFI' sig = do + let name = fromMaybe "" nameopt + inner <- formatFFI loc formatstr (zip params funcFundamentalTypes) + case JS.parse JS.expression (prettyPrint name) (printJSString (wrapReturn inner)) of + Left err -> throwError (FfiFormatInvalidJavaScript loc inner (show err)) + Right exp -> do + config' <- config id + when (configGClosure config') $ warnDotUses loc inner exp + return (body inner) + where + body inner = foldr wrapParam (wrapReturn inner) params + wrapParam pname inner = JsFun Nothing [pname] [] (Just inner) + params = zipWith const uniqueNames [1..typeArity sig] + wrapReturn :: String -> JsExp + wrapReturn inner = thunk $ + case lastMay funcFundamentalTypes of + -- Returns a “pure” value; + Just{} -> jsToFay SerializeAnywhere returnType (JsRawExp inner) + -- Base case: + Nothing -> JsRawExp inner + funcFundamentalTypes = functionTypeArgs sig + returnType = last funcFundamentalTypes -- | Warn about uses of naked x.y which will not play nicely with Google Closure. warnDotUses :: SrcSpanInfo -> String -> Expression SourcePos -> Compile () @@ -130,7 +113,7 @@ globalNames = ["Math","console","JSON"] -- | Make a Fay→JS encoder. -emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], BangType d)] -> Compile () +emitFayToJs :: Name a -> [TyVarBind b] -> [([Name c], Type d)] -> Compile () emitFayToJs (unAnn -> name) (map unAnn -> tyvars) (explodeFields -> fieldTypes) = do qname <- qualify name let ctrName = printJSString $ unQual qname @@ -147,7 +130,7 @@ obj = JsVar obj_ $ JsObj [("instance",JsLit (JsStr (printJSString (unAnn name))))] - fieldStmts :: [(Int,(N.Name,N.BangType))] -> [JsStmt] + fieldStmts :: [(Int,(N.Name,N.Type))] -> [JsStmt] fieldStmts [] = [] fieldStmts ((i,fieldType):fts) = JsVar obj_v field : @@ -163,11 +146,11 @@ obj_ = JsNameVar "obj_" -- Declare/encode Fay→JS field - declField :: Int -> (N.Name,N.BangType) -> (String,JsExp) + declField :: Int -> (N.Name,N.Type) -> (String,JsExp) declField i (fname,typ) = (prettyPrint fname ,fayToJs (SerializeUserArg i) - (argType (bangType typ)) + (argType typ) (JsGetProp (JsName transcodingObjForced) (JsNameVar (UnQual () fname)))) @@ -211,13 +194,6 @@ TyCon _ (UnQual _ user) -> UserDefined user [] _ -> UnknownType --- | Extract the type. -bangType :: N.BangType -> N.Type -bangType typ = case typ of - BangedTy _ ty -> ty - UnBangedTy _ ty -> ty - UnpackedTy _ ty -> ty - -- | Expand a type application. expandApp :: N.Type -> [N.Type] expandApp (TyParen _ t) = expandApp t @@ -353,7 +329,7 @@ jsToFayHash cases = [JsExpStmt $ JsApp (JsName $ JsBuiltIn "objConcat") [JsName $ JsBuiltIn "jsToFayHash", JsObj cases]] -- | Make a JS→Fay decoder. -emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],BangType d)] -> Compile () +emitJsToFay :: Name a -> [TyVarBind b] -> [([Name c],Type d)] -> Compile () emitJsToFay (unAnn -> name) (map unAnn -> tyvars) (map (unAnn *** unAnn) . explodeFields -> fieldTypes) = do qname <- qualify name tell (mempty { writerJsToFay = [(printJSString (unAnn name), translator qname)] }) @@ -364,10 +340,10 @@ (Just $ JsNew (JsConstructor qname) (map (decodeField . getIndex name tyvars) fieldTypes)) -- Decode JS→Fay field - decodeField :: (Int,(N.Name,N.BangType)) -> JsExp + decodeField :: (Int,(N.Name,N.Type)) -> JsExp decodeField (i,(fname,typ)) = jsToFay (SerializeUserArg i) - (argType (bangType typ)) + (argType typ) (JsGetPropExtern (JsName transcodingObj) (prettyPrint fname)) @@ -376,9 +352,9 @@ argTypes = JsNameVar "argTypes" -- | Get the index of a name from the set of type variables bindings. -getIndex :: Name a -> [TyVarBind b] -> (Name c,BangType d) -> (Int,(N.Name,N.BangType)) +getIndex :: Name a -> [TyVarBind b] -> (Name c,Type d) -> (Int,(N.Name,N.Type)) getIndex (unAnn -> name) (map unAnn -> tyvars) (unAnn -> sname,unAnn -> ty) = - case bangType ty of + case ty of TyVar _ tyname -> case elemIndex tyname (map tyvar tyvars) of Nothing -> error $ "unknown type variable " ++ prettyPrint tyname ++ " for " ++ prettyPrint name ++ "." ++ prettyPrint sname ++ "," ++ diff --git a/src/Fay/Compiler/GADT.hs b/src/Fay/Compiler/GADT.hs --- a/src/Fay/Compiler/GADT.hs +++ b/src/Fay/Compiler/GADT.hs @@ -4,18 +4,18 @@ (convertGADT ) where -import Language.Haskell.Exts.Annotated hiding (binds, name) +import Language.Haskell.Exts hiding (name) -- | Convert a GADT to a normal data type. convertGADT :: GadtDecl a -> QualConDecl a convertGADT d = case d of - GadtDecl s name typ -> QualConDecl s tyvars context - (ConDecl s name (convertFunc typ)) + GadtDecl s name tyvars context Nothing typ -> + QualConDecl s tyvars context (ConDecl s name (convertFunc typ)) + GadtDecl s name tyvars context (Just fs) _typ -> + QualConDecl s tyvars context (RecDecl s name fs) where - tyvars = Nothing - context = Nothing - convertFunc :: Type a -> [BangType a] + convertFunc :: Type a -> [Type a] convertFunc (TyCon _ _) = [] - convertFunc (TyFun s x xs) = UnBangedTy s x : convertFunc xs + convertFunc (TyFun _ x xs) = x : convertFunc xs convertFunc (TyParen _ x) = convertFunc x convertFunc _ = [] diff --git a/src/Fay/Compiler/Import.hs b/src/Fay/Compiler/Import.hs --- a/src/Fay/Compiler/Import.hs +++ b/src/Fay/Compiler/Import.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} -- | Handles finding imports and compiling them recursively. -- This is done for each full AST traversal the copmiler does -- which at this point is InitialPass's preprocessing -- and Compiler's code generation module Fay.Compiler.Import - (startCompile - ,compileWith + ( startCompile + , compileWith ) where -import Fay.Compiler.Config +import Fay.Compiler.Prelude + import Fay.Compiler.Misc -import Fay.Control.Monad.IO +import Fay.Compiler.Parse +import Fay.Config import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS -import Language.Haskell.Exts.Annotated hiding (name, var) -import Prelude hiding (mod, read) +import Control.Monad.Except (throwError) +import Control.Monad.RWS (ask, get, gets, lift, listen, modify) +import Language.Haskell.Exts hiding (name) import System.Directory import System.FilePath @@ -33,13 +34,14 @@ -- | Compile a module compileWith - :: Monoid a + :: (Monoid a, Semigroup a) => FilePath -> (a -> F.Module -> Compile a) -> (FilePath -> String -> Compile a) + -> (F.X -> F.Module -> IO (Either CompileError F.Module)) -> String -> Compile (a, CompileState, CompileWriter) -compileWith filepath with compileModule from = do +compileWith filepath with compileModule before from = do rd <- ask st <- get res <- Compile . lift . lift $ @@ -47,7 +49,9 @@ rd st (parseResult (throwError . uncurry ParseError) - (\mod@(Module _ _ _ imports _) -> do + (\mod' -> do + ~mod@(Module _ _ _ imports _) <- + either throwError return =<< io (before F.noI mod') res <- foldr (<>) mempty <$> mapM (compileImport compileModule) imports modify $ \s -> s { stateModuleName = unAnn $ F.moduleName mod } with res mod @@ -94,9 +98,9 @@ -> F.ImportDecl -> Compile a compileImport compileModule i = case i of - -- Package imports are ignored since they are used for some trickery in fay-base. - ImportDecl _ _ _ _ Just{} _ _ -> return mempty - ImportDecl _ name _ _ Nothing _ _ -> compileModuleFromName compileModule name + -- Trickery in fay-base needs this special case + ImportDecl _ _ _ _ _ (Just "base") _ _ -> return mempty + ImportDecl _ name _ _ _ _ _ _ -> compileModuleFromName compileModule name -- | Find an import's filepath and contents from its module name. findImport :: [FilePath] -> ModuleName a -> Compile (FilePath,String) diff --git a/src/Fay/Compiler/InitialPass.hs b/src/Fay/Compiler/InitialPass.hs --- a/src/Fay/Compiler/InitialPass.hs +++ b/src/Fay/Compiler/InitialPass.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -7,24 +8,22 @@ (initialPass ) where +import Fay.Compiler.Prelude + import Fay.Compiler.Desugar import Fay.Compiler.GADT import Fay.Compiler.Import import Fay.Compiler.Misc -import Fay.Control.Monad.IO -import Fay.Data.List.Extra +import Fay.Compiler.Parse import qualified Fay.Exts as F import Fay.Exts.NoAnnotation (unAnn) -import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS +import Control.Monad.Except (throwError) +import Control.Monad.RWS (modify) import qualified Data.Map as M -import Language.Haskell.Exts.Annotated hiding (name, var) -import qualified Language.Haskell.Names as HN -import Prelude hiding (mod, read) +import Language.Haskell.Exts hiding (name) +import qualified Language.Haskell.Names as HN (getInterfaces) -- | Preprocess and collect all information needed during code generation. initialPass :: FilePath -> Compile () @@ -33,7 +32,7 @@ -- | Preprocess a module given its filepath and content. preprocessFileWithSource :: FilePath -> String -> Compile () preprocessFileWithSource filepath contents = do - (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource contents + (_,st,_) <- compileWith filepath preprocessAST preprocessFileWithSource desugar contents -- This is the state we want to keep modify $ \s -> s { stateRecords = stateRecords st , stateRecordTypes = stateRecordTypes st @@ -50,18 +49,15 @@ -- | Preprocess from an AST preprocessAST :: () -> F.Module -> Compile () -preprocessAST () mod'@Module{} = do - res <- io $ desugar mod' - case res of - Left err -> throwError err - Right dmod -> do - let (Module _ _ _ _ decls) = dmod - -- This can only return one element since we only compile one module. - ([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [dmod] - modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } - forM_ decls scanTypeSigs - forM_ decls scanRecordDecls - forM_ decls scanNewtypeDecls +preprocessAST () mod@(Module _ _ _ _ decls) = do + -- This can only return one element since we only compile one module. + ~([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod] + modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } + forM_ decls scanTypeSigs + forM_ decls scanRecordDecls + ifOptimizeNewtypes + (forM_ decls scanNewtypeDecls) + (return ()) preprocessAST () mod = throwError $ UnsupportedModuleSyntax "preprocessAST" mod -------------------------------------------------------------------------------- @@ -80,32 +76,43 @@ RecDecl _ cname [FieldDecl _ [dname] ty] -> addNewtype cname (Just dname) ty x -> error $ "compileNewtypeDecl case: Should be impossible (this is a bug). Got: " ++ show x where - getBangTy :: F.BangType -> N.Type - getBangTy (BangedTy _ t) = unAnn t - getBangTy (UnBangedTy _ t) = unAnn t - getBangTy (UnpackedTy _ t) = unAnn t - addNewtype cname dname ty = do qcname <- qualify cname qdname <- case dname of Nothing -> return Nothing Just n -> Just <$> qualify n modify (\cs@CompileState{stateNewtypes=nts} -> - cs{stateNewtypes=(qcname,qdname,getBangTy ty):nts}) + cs{stateNewtypes=(qcname,qdname,unAnn ty):nts}) compileNewtypeDecl q = error $ "compileNewtypeDecl: Should be impossible (this is a bug). Got: " ++ show q +{-# ANN scanRecordDecls ("HLint: ignore Redundant flip" :: String) #-} -- | Add record declarations to the state scanRecordDecls :: F.Decl -> Compile () scanRecordDecls decl = do case decl of - DataDecl _loc DataType{} _ctx (F.declHeadName -> name) qualcondecls _deriv -> do - let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) - addRecordTypeState name ns + DataDecl _loc ty _ctx (F.declHeadName -> name) qualcondecls _deriv -> do + let addIt = let ns = flip fmap qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) + in addRecordTypeState name ns + case ty of + DataType{} -> addIt + NewType{} -> ifOptimizeNewtypes + (return ()) + addIt _ -> return () case decl of - DataDecl _ DataType{} _ _ constructors _ -> dataDecl constructors - GDataDecl _ DataType{} _ _ _ decls _ -> dataDecl (map convertGADT decls) + DataDecl _ ty _ _ constructors _ -> + case ty of + DataType{} -> dataDecl constructors + NewType{} -> ifOptimizeNewtypes + (return ()) + (dataDecl constructors) + GDataDecl _ ty _ _ _ decls _ -> + case ty of + DataType{} -> dataDecl (map convertGADT decls) + NewType{} -> ifOptimizeNewtypes + (return ()) + (dataDecl (map convertGADT decls)) _ -> return () where @@ -121,7 +128,7 @@ -- | Collect record definitions and store record name and field names. -- A ConDecl will have fields named slot1..slotN dataDecl :: [F.QualConDecl] -> Compile () - dataDecl constructors = do + dataDecl constructors = forM_ constructors $ \(QualConDecl _ _ _ condecl) -> case condecl of ConDecl _ name types -> do diff --git a/src/Fay/Compiler/Misc.hs b/src/Fay/Compiler/Misc.hs --- a/src/Fay/Compiler/Misc.hs +++ b/src/Fay/Compiler/Misc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} @@ -7,30 +8,27 @@ module Fay.Compiler.Misc where +import Fay.Compiler.Prelude + +import Fay.Compiler.ModuleT (runModuleT) import Fay.Compiler.PrimOp -import Fay.Control.Monad.IO -import qualified Fay.Exts as F -import Fay.Exts.NoAnnotation (unAnn) -import qualified Fay.Exts.NoAnnotation as N -import qualified Fay.Exts.Scoped as S +import Fay.Compiler.QName (unname) +import Fay.Config +import qualified Fay.Exts as F +import Fay.Exts.NoAnnotation (unAnn) +import qualified Fay.Exts.NoAnnotation as N +import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.RWS -import Data.Char (isAlpha) -import Data.List -import qualified Data.Map as M -import Data.Maybe -import Data.String -import Data.Version (parseVersion) -import Distribution.HaskellSuite.Modules -import Language.Haskell.Exts.Annotated hiding (name) -import Language.Haskell.Names -import Prelude hiding (exp, mod) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.RWS (asks, gets, modify, runRWST) +import Data.Version (parseVersion) +import Language.Haskell.Exts hiding (name) +import Language.Haskell.Names (GName (GName), NameInfo (GlobalValue, LocalValue, ScopeError), + OrigName, Scoped (Scoped), origGName, origName) import System.IO -import System.Process (readProcess) -import Text.ParserCombinators.ReadP (readP_to_S) +import System.Process (readProcess) +import Text.ParserCombinators.ReadP (readP_to_S) -- | Wrap an expression in a thunk. thunk :: JsExp -> JsExp @@ -113,7 +111,7 @@ Just (cname,_,ty) -> return $ Just (cname,ty) -- | Qualify a name for the current module. -qualify :: Name a -> Compile (N.QName) +qualify :: Name a -> Compile N.QName qualify (Ident _ name) = do modulename <- gets stateModuleName return (Qual () modulename (Ident () name)) @@ -153,19 +151,21 @@ ParseFailed srcloc msg -> die (srcloc,msg) -- | Get a config option. -config :: (CompileConfig -> a) -> Compile a +config :: (Config -> a) -> Compile a config f = asks (f . readerConfig) -- | Optimize pattern matching conditions by merging conditions in common. +-- TODO This is buggy and no longer used. Fails on tests/case3 optimizePatConditions :: [[JsStmt]] -> [[JsStmt]] -optimizePatConditions = concatMap merge . groupBy sameIf where +optimizePatConditions = id + {- concatMap merge . groupBy sameIf where sameIf [JsIf cond1 _ _] [JsIf cond2 _ _] = cond1 == cond2 sameIf _ _ = False merge xs@([JsIf cond _ _]:_) = [[JsIf cond (concat (optimizePatConditions (map getIfConsequent xs))) []]] merge noifs = noifs getIfConsequent [JsIf _ cons _] = cons - getIfConsequent other = other + getIfConsequent other = other -} -- | Throw a JS exception. throw :: String -> JsExp -> JsStmt @@ -215,7 +215,7 @@ warn "" = return () warn w = config id >>= io . (`ioWarn` w) -ioWarn :: CompileConfig -> String -> IO () +ioWarn :: Config -> String -> IO () ioWarn _ "" = return () ioWarn cfg w = when (configWall cfg) $ @@ -237,7 +237,7 @@ typeToRecs (unAnn -> typ) = fromMaybe [] . lookup typ <$> gets stateRecordTypes recToFields :: S.QName -> Compile [N.Name] -recToFields con = do +recToFields con = case tryResolveName con of Nothing -> return [] Just c -> fromMaybe [] . lookup c <$> gets stateRecords @@ -268,72 +268,31 @@ -> CompileState -> Compile a -> IO (Either CompileError (a,CompileState,CompileWriter)) -runTopCompile reader' state' m = fst <$> runModuleT (runErrorT (runRWST (unCompile m) reader' state')) [] "fay" (\_fp -> return undefined) M.empty +runTopCompile reader' state' m = fst <$> runModuleT (runExceptT (runRWST (unCompile m) reader' state')) -- | Runs compilation for a single module. runCompileModule :: CompileReader -> CompileState -> Compile a -> CompileModule a -runCompileModule reader' state' m = runErrorT (runRWST (unCompile m) reader' state') +runCompileModule reader' state' m = runExceptT (runRWST (unCompile m) reader' state') --- | Parse some Fay code. -parseFay :: Parseable ast => FilePath -> String -> ParseResult ast -parseFay filepath = parseWithMode parseMode { parseFilename = filepath } . applyCPP +shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a +shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn --- | Apply incredibly simplistic CPP handling. It only recognizes the following: --- --- > #if FAY --- > #ifdef FAY --- > #ifndef FAY --- > #else --- > #endif --- --- Note that this implementation replaces all removed lines with blanks, so --- that line numbers remain accurate. -applyCPP :: String -> String -applyCPP = - unlines . loop NoCPP . lines +-- | Check if the given language pragmas are all present. +hasLanguagePragmas :: [String] -> [ModulePragma l] -> Bool +hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas where - loop _ [] = [] - loop state' ("#if FAY":rest) = "" : loop (CPPIf True state') rest - loop state' ("#ifdef FAY":rest) = "" : loop (CPPIf True state') rest - loop state' ("#ifndef FAY":rest) = "" : loop (CPPIf False state') rest - loop (CPPIf b oldState') ("#else":rest) = "" : loop (CPPElse (not b) oldState') rest - loop (CPPIf _ oldState') ("#endif":rest) = "" : loop oldState' rest - loop (CPPElse _ oldState') ("#endif":rest) = "" : loop oldState' rest - loop state' (x:rest) = (if toInclude state' then x else "") : loop state' rest - - toInclude NoCPP = True - toInclude (CPPIf x state') = x && toInclude state' - toInclude (CPPElse x state') = x && toInclude state' - --- | The CPP's parsing state. -data CPPState = NoCPP - | CPPIf Bool CPPState - | CPPElse Bool CPPState - --- | The parse mode for Fay. -parseMode :: ParseMode -parseMode = defaultParseMode - { extensions = defaultExtensions - , fixities = Just (preludeFixities ++ baseFixities) - } + flattenPragmas :: [ModulePragma l] -> [String] + flattenPragmas = concatMap pragmaName + pragmaName (LanguagePragma _ q) = map unname q + pragmaName _ = [] -shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a -shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn +hasLanguagePragma :: String -> [ModulePragma l] -> Bool +hasLanguagePragma pr = hasLanguagePragmas [pr] -defaultExtensions :: [Extension] -defaultExtensions = map EnableExtension - [EmptyDataDecls - ,ExistentialQuantification - ,FlexibleContexts - ,FlexibleInstances - ,GADTs - ,KindSignatures - ,NamedFieldPuns - ,PackageImports - ,RecordWildCards - ,StandaloneDeriving - ,TupleSections - ,TypeFamilies - ,TypeOperators - ] ++ map DisableExtension - [ImplicitPrelude] +-- | if then else for when 'configOptimizeNewtypes'. +ifOptimizeNewtypes :: Compile a -> Compile a -> Compile a +ifOptimizeNewtypes then' else' = do + optimize <- config configOptimizeNewtypes + if optimize + then then' + else else' diff --git a/src/Fay/Compiler/ModuleT.hs b/src/Fay/Compiler/ModuleT.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/ModuleT.hs @@ -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) diff --git a/src/Fay/Compiler/Optimizer.hs b/src/Fay/Compiler/Optimizer.hs --- a/src/Fay/Compiler/Optimizer.hs +++ b/src/Fay/Compiler/Optimizer.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} @@ -6,20 +8,15 @@ module Fay.Compiler.Optimizer where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc import Fay.Types -import Control.Applicative -import Control.Arrow (first) -import Control.Monad.Error -import Control.Monad.State -import Control.Monad.Writer -import Data.List -import Data.Maybe +import Control.Monad.State (State, modify, runState) +import Control.Monad.Writer (runWriter, tell) import qualified Fay.Exts.NoAnnotation as N -import Language.Haskell.Exts.Annotated hiding (app, name, op) - -import Prelude hiding (exp) +import Language.Haskell.Exts hiding (app, name, op) -- | The arity of a function. Arity here is defined to be the number -- of arguments that can be directly uncurried from a curried lambda @@ -120,6 +117,7 @@ tco = map inStmt where inStmt stmt = case stmt of JsVar name exp -> JsVar name (inject name exp) + JsSetQName l name exp -> JsSetQName l name (inject (JsNameVar name) exp) e -> e inject name exp = case exp of JsFun nm params [] (Just (JsNew JsThunk [JsFun _ [] stmts ret])) -> @@ -211,10 +209,11 @@ -- | Apply the given function to the top-level expressions in the -- given statement. applyToExpsInStmt :: [FuncArity] -> ([FuncArity] -> JsExp -> Optimize JsExp) -> JsStmt -> Optimize JsStmt -applyToExpsInStmt funcs f stmts = uncurryInStmt stmts where +applyToExpsInStmt funcs f = uncurryInStmt where transform = f funcs uncurryInStmt stmt = case stmt of JsVar name exp -> JsVar name <$> transform exp + JsSetQName l name exp -> JsSetQName l name <$> transform exp JsEarlyReturn exp -> JsEarlyReturn <$> transform exp JsIf op ithen ielse -> JsIf <$> transform op <*> mapM uncurryInStmt ithen @@ -224,7 +223,7 @@ -- | Collect functions and their arity from the whole codeset. collectFuncs :: [JsStmt] -> [FuncArity] collectFuncs = (++ prim) . concatMap collectFunc where - collectFunc (JsVar (JsNameVar name) exp) | arity > 0 = [(name,arity)] + collectFunc (JsSetQName _ name exp) | arity > 0 = [(name,arity)] where arity = expArity exp collectFunc _ = [] prim = map (first (Qual () (ModuleName () "Fay$"))) (unary ++ binary) @@ -245,6 +244,8 @@ funBinding stmt = case stmt of JsVar (JsNameVar name) body | name == qname -> JsVar (JsNameVar (renameUncurried name)) <$> uncurryIt body + JsSetQName l name body + | name == qname -> JsSetQName l (renameUncurried name) <$> uncurryIt body _ -> Nothing uncurryIt = Just . go [] where diff --git a/src/Fay/Compiler/Packages.hs b/src/Fay/Compiler/Packages.hs --- a/src/Fay/Compiler/Packages.hs +++ b/src/Fay/Compiler/Packages.hs @@ -1,32 +1,27 @@ -{-# LANGUAGE TupleSections #-} - +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} -- | Dealing with Cabal packages in Fay's own special way. - module Fay.Compiler.Packages where -import Fay.Compiler.Config -import Fay.Control.Monad.Extra -import Fay.System.Process.Extra -import Fay.Types +import Fay.Compiler.Prelude + +import Fay.Config import Paths_fay -import Control.Applicative -import Control.Monad -import Data.List -import Data.Maybe import Data.Version import GHC.Paths import System.Directory import System.FilePath +import System.Environment -- | Given a configuration, resolve any packages specified to their -- data file directories for importing the *.hs sources. -resolvePackages :: CompileConfig -> IO CompileConfig +resolvePackages :: Config -> IO Config resolvePackages config = foldM resolvePackage config (configPackages config) -- | Resolve package. -resolvePackage :: CompileConfig -> String -> IO CompileConfig +resolvePackage :: Config -> String -> IO Config resolvePackage config name = do desc <- describePackage (configPackageConf config) name case packageVersion desc of @@ -40,9 +35,12 @@ exists <- mapM doesSourceDirExist includes if or exists then return (addConfigDirectoryIncludes (map (Just nameVer,) includes) config) - else error $ "unable to find (existing) package's share dir: " ++ name ++ "\n" ++ - "tried: " ++ unlines includes ++ "\n" ++ - "but none of them seem to have Haskell files in them." + else error $ concat + [ "unable to find (existing) package's share dir: ", name, "\n" + , "tried: ", unlines includes, "\n" + , "but none of them seem to have Haskell files in them.\n" + , "If you are using a sandbox you need to specify the HASKELL_PACKAGE_SANDBOX environment variable or use --package-conf." + ] -- | Does a directory exist and does it contain any Haskell sources? doesSourceDirExist :: FilePath -> IO Bool @@ -57,12 +55,24 @@ -- | Describe the given package. describePackage :: Maybe FilePath -> String -> IO String describePackage db name = do - result <- readAllFromProcess ghc_pkg args "" + exists <- doesFileExist ghc_pkg + stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL") + let command = if exists + then if (isInfixOf ".stack" ghc_pkg || stackInNixShell) + then "stack" + else ghc_pkg + else "ghc-pkg" + extraArgs = case command of + "stack" -> ["exec","--","ghc-pkg"] + _ -> [] + args = extraArgs ++ ["describe",name] ++ ["--expand-env-vars", "-v2"] + ++ ["--package-db=" ++ db' | Just db' <- [db]] + when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL") + result <- readAllFromProcess command args "" + when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1") case result of - Left (err,_out) -> error $ "ghc-pkg describe error:\n" ++ err + Left (err,out) -> error $ "ghc-pkg describe error:\n" ++ err ++ "\n" ++ out Right (_err,out) -> return out - - where args = ["describe",name] ++ ["-f" ++ db' | Just db' <- [db]] -- | Get the package version from the package description. packageVersion :: String -> Maybe String diff --git a/src/Fay/Compiler/Parse.hs b/src/Fay/Compiler/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Parse.hs @@ -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 + ] diff --git a/src/Fay/Compiler/Pattern.hs b/src/Fay/Compiler/Pattern.hs --- a/src/Fay/Compiler/Pattern.hs +++ b/src/Fay/Compiler/Pattern.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-warn-name-shadowing #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -6,6 +6,8 @@ module Fay.Compiler.Pattern where +import Fay.Compiler.Prelude + import Fay.Compiler.Misc import Fay.Compiler.QName import Fay.Exts.NoAnnotation (unAnn) @@ -13,11 +15,10 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Applicative -import Control.Monad.Error -import Control.Monad.Reader -import Language.Haskell.Exts.Annotated -import Language.Haskell.Names +import Control.Monad.Except (throwError) +import Control.Monad.Reader (ask) +import Language.Haskell.Exts hiding (name) +import Language.Haskell.Names (NameInfo (RecPatWildcard), Scoped (Scoped)) -- | Compile the given pattern against the given expression. compilePat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] @@ -26,17 +27,17 @@ PApp _ cons pats -> do newty <- lookupNewtypeConst cons case newty of - Nothing -> compilePApp cons pats exp body + Nothing -> compilePApp pat cons pats exp body Just _ -> compileNewtypePat pats exp body - PLit _ literal -> compilePLit exp literal body - PParen{} -> shouldBeDesugared pat + PLit _ sign lit -> compilePLit exp sign lit body PWildCard _ -> return body - pat@PInfixApp{} -> compileInfixPat exp pat body PList _ pats -> compilePList pats body exp PTuple _ _bx pats -> compilePList pats body exp - PAsPat _ name pat -> compilePAsPat exp name pat body + PAsPat _ name pt -> compilePAsPat exp name pt body PRec _ name pats -> compilePatFields exp name pats body - pat -> throwError (UnsupportedPattern pat) + PParen{} -> shouldBeDesugared pat + PInfixApp{} -> shouldBeDesugared pat + _ -> throwError (UnsupportedPattern pat) -- | Compile a pattern variable e.g. x. compilePVar :: S.Name -> JsExp -> [JsStmt] -> Compile [JsStmt] @@ -46,7 +47,7 @@ -- | Compile a record field pattern. compilePatFields :: JsExp -> S.QName -> [S.PatField] -> [JsStmt] -> Compile [JsStmt] compilePatFields exp name pats body = do - c <- liftM (++ body) (compilePats' [] pats) + c <- (++ body) <$> compilePats' [] pats qname <- unsafeResolveName name return [JsIf (force exp `JsInstanceOf` JsConstructor qname) c []] where @@ -77,10 +78,10 @@ _ -> [] -- | Compile a literal value from a pattern match. -compilePLit :: JsExp -> S.Literal -> [JsStmt] -> Compile [JsStmt] -compilePLit exp literal body = do +compilePLit :: JsExp -> S.Sign -> S.Literal -> [JsStmt] -> Compile [JsStmt] +compilePLit exp sign literal body = do c <- ask - lit <- readerCompileLit c literal + lit <- readerCompileLit c sign literal return [JsIf (equalExps exp lit) body []] @@ -107,13 +108,26 @@ compileNewtypePat ps _ _ = error $ "compileNewtypePat: Should be impossible (this is a bug). Got: " ++ show ps -- | Compile a pattern application. -compilePApp :: S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] -compilePApp cons pats exp body = do +compilePApp :: S.Pat -> S.QName -> [S.Pat] -> JsExp -> [JsStmt] -> Compile [JsStmt] +compilePApp origPat cons pats exp body = do let forcedExp = force exp let boolIf b = return [JsIf (JsEq forcedExp (JsLit (JsBool b))) body []] case cons of -- Special-casing on the booleans. Special _ (UnitCon _) -> return (JsExpStmt forcedExp : body) + Special _ Cons{} -> case pats of + [left, right] -> + withScopedTmpJsName $ \tmpName -> do + let forcedList = JsName tmpName + x = JsGetProp forcedList (JsNameVar "car") + xs = JsGetProp forcedList (JsNameVar "cdr") + rightMatch <- compilePat xs right body + leftMatch <- compilePat x left rightMatch + return [JsVar tmpName (force exp) + ,JsIf (JsInstanceOf forcedList (JsBuiltIn "Cons")) + leftMatch + []] + _ -> throwError $ UnsupportedPattern origPat UnQual _ (Ident _ "True") -> boolIf True UnQual _ (Ident _ "False") -> boolIf False -- Everything else, generic: @@ -123,8 +137,8 @@ Nothing -> error $ "Constructor '" ++ prettyPrint n ++ "' could not be resolved" Just _ -> do recordFields <- map (UnQual ()) <$> recToFields n - substmts <- foldM (\body (field,pat) -> - compilePat (JsGetProp forcedExp (JsNameVar field)) pat body) + substmts <- foldM (\bd (field,pat) -> + compilePat (JsGetProp forcedExp (JsNameVar field)) pat bd) body (reverse (zip recordFields pats)) qcons <- unsafeResolveName cons @@ -138,30 +152,13 @@ return [JsIf (JsEq (force exp) JsNull) body []] compilePList pats body exp = do let forcedExp = force exp - stmts <- foldM (\body (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index")) - [JsLit (JsInt i),forcedExp]) - pat - body) + stmts <- foldM (\bd (i,pat) -> compilePat (JsApp (JsName (JsBuiltIn "index")) + [JsLit (JsInt i),forcedExp]) + pat + bd) body (reverse (zip [0..] pats)) let patsLen = JsLit (JsInt (length pats)) return [JsIf (JsApp (JsName (JsBuiltIn "listLen")) [forcedExp,patsLen]) stmts []] - --- | Compile an infix pattern (e.g. cons and tuples.) -compileInfixPat :: JsExp -> S.Pat -> [JsStmt] -> Compile [JsStmt] -compileInfixPat exp pat@(PInfixApp _ left (Special _ cons) right) body = case cons of - Cons _ -> - withScopedTmpJsName $ \tmpName -> do - let forcedExp = JsName tmpName - x = JsGetProp forcedExp (JsNameVar "car") - xs = JsGetProp forcedExp (JsNameVar "cdr") - rightMatch <- compilePat xs right body - leftMatch <- compilePat x left rightMatch - return [JsVar tmpName (force exp) - ,JsIf (JsInstanceOf forcedExp (JsBuiltIn "Cons")) - leftMatch - []] - _ -> throwError (UnsupportedPattern pat) -compileInfixPat _ pat _ = throwError (UnsupportedPattern pat) diff --git a/src/Fay/Compiler/Prelude.hs b/src/Fay/Compiler/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Compiler/Prelude.hs @@ -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) diff --git a/src/Fay/Compiler/PrimOp.hs b/src/Fay/Compiler/PrimOp.hs --- a/src/Fay/Compiler/PrimOp.hs +++ b/src/Fay/Compiler/PrimOp.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} @@ -21,13 +22,14 @@ , resolvePrimOp ) where +import Fay.Compiler.Prelude + import Fay.Exts.NoAnnotation (unAnn) import qualified Fay.Exts.NoAnnotation as N import Data.Map (Map) import qualified Data.Map as M -import Language.Haskell.Exts.Annotated hiding (binds, name) -import Prelude hiding (mod) +import Language.Haskell.Exts -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a diff --git a/src/Fay/Compiler/Print.hs b/src/Fay/Compiler/Print.hs --- a/src/Fay/Compiler/Print.hs +++ b/src/Fay/Compiler/Print.hs @@ -1,214 +1,200 @@ -{-# OPTIONS -fno-warn-orphans #-} -{-# OPTIONS -fno-warn-unused-do-bind #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | Simple code (non-pretty) printing. --- --- No clever printing is done here. If you want pretty printing, use a --- JS pretty printer. The output should be passed directly to a JS --- compressor, anyway. +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Code printers. Can be used to produce both pretty and not +-- pretty output. -- -- Special constructors and symbols in Haskell are encoded to -- JavaScript appropriately. - module Fay.Compiler.Print where +import Fay.Compiler.Prelude + import Fay.Compiler.PrimOp -import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Monad -import Control.Monad.State -import Data.Aeson.Encode -import qualified Data.ByteString.Lazy.UTF8 as UTF8 -import Data.Default -import Data.List -import Data.String -import Language.Haskell.Exts.Annotated -import Prelude hiding (exp) -import SourceMap.Types +import Data.Aeson +import qualified Data.ByteString.Lazy.UTF8 as UTF8 +import Language.Haskell.Exts hiding (alt, name, op, sym) -------------------------------------------------------------------------------- -- Printing -- | Print the JS to a flat string. printJSString :: Printable a => a -> String -printJSString x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def +printJSString x = pwOutputString (execPrinter (printJS x) defaultPrintReader) -- | Print the JS to a pretty string. printJSPretty :: Printable a => a -> String -printJSPretty x = concat $ reverse $ psOutput $ execState (runPrinter (printJS x)) def { psPretty = True } +printJSPretty x = pwOutputString (execPrinter (printJS x) defaultPrintReader{ prPretty = True }) --- | Print literals. These need some special encoding for --- JS-format literals. Could use the Text.JSON library. +-- | Encode String to JS-format lterals. Could use the +-- Text.JSON library. +toJsStringLit :: String -> String +toJsStringLit = UTF8.toString . encode + +-- | Print literals. instance Printable JsLit where - printJS typ = write $ - let u8 = UTF8.toString . encode . UTF8.fromString - in case typ of - (JsChar char) -> u8 [char] - (JsStr str) -> u8 str + printJS typ = write $ case typ of + (JsChar char) -> toJsStringLit [char] + (JsStr str) -> toJsStringLit str (JsInt int) -> show int (JsFloating rat) -> show rat (JsBool b) -> if b then "true" else "false" -- | Print (and properly encode to JS) a qualified name. -instance Printable N.QName where +instance Printable (QName l) where printJS qname = case qname of - Qual _ (ModuleName _ "Fay$") name -> "Fay$$" +> name - Qual _ moduleName name -> moduleName +> "." +> name + Qual _ (ModuleName _ "Fay$") name -> "Fay$$" <> printJS name + Qual _ moduleName name -> printJS moduleName <> printProp name UnQual _ name -> printJS name Special _ con -> printJS con +-- | Prints pretty operators. +-- prPrettyOperator flag determines the way of accessing operators (e.g. `($)`) and +-- identifiers with apostrophes (e.g. `length'`). If prPrettyOperators is set true, +-- then these will be accessed with square brackets (e.g. Prelude["$"] or +-- Prelude["length'"]). Otherwise special characters will be escaped and accessed +-- with dot (e.g. Prelude.$36$ or Prelude.length$39$). Alphanumeric_ identifiers are +-- always accessed with dot operator (e.g. Prelude.length) +printProp :: Name l -> Printer +printProp name = askIf prPrettyOperators pretty ugly + where pretty = if all (`elem` allowedNameChars) nameString then dot else brackets + ugly = dot + dot = "." <> printJS name + brackets = "[" <> write (toJsStringLit nameString) <> "]" + nameString = case name of + Ident _ s -> s + Symbol _ s -> s + -- | Print module name. -instance Printable N.ModuleName where - printJS (ModuleName _ "Fay$") = - write "Fay$" +instance Printable (ModuleName l) where + printJS (ModuleName _ "Fay$") = "Fay$" printJS (ModuleName _ moduleName) = write $ go moduleName - where go ('.':xs) = '.' : go xs go (x:xs) = normalizeName [x] ++ go xs go [] = [] +-- | Print (and properly encode) a name. +instance Printable (Name l) where + printJS = write . encodeName + + -- | Print special constructors (tuples, list, etc.) -instance Printable N.SpecialCon where +instance Printable (SpecialCon l) where printJS specialCon = printJS $ fayBuiltin () $ case specialCon of UnitCon _ -> "unit" Cons _ -> "cons" - _ -> error $ "Special constructor not supported: " ++ show specialCon + _ -> error $ "Special constructor not supported: " ++ + show (void specialCon) --- | Print (and properly encode) a name. -instance Printable N.Name where - printJS name = write $ - case name of - Ident _ idn -> encodeName idn - Symbol _ sym -> encodeName sym -- | Print a list of statements. -instance Printable [JsStmt] where - printJS = mapM_ printJS +printStmts :: [JsStmt] -> Printer +printStmts = mconcat . map printJS -- | Print a single statement. instance Printable JsStmt where printJS (JsExpStmt e) = - printJS e +> ";" +> newline + printJS e <> ";" <> newline printJS (JsBlock stmts) = - "{ " +> stmts +> "}" + "{ " <> printStmts stmts <> "}" + printJS (JsMapVar name expr) = + "var " <> printJS name <> " : {[key: string]: any;} = " <> printJS expr <> ";" <> newline printJS (JsVar name expr) = - "var " +> name +> " = " +> expr +> ";" +> newline + "var " <> printJS name <> " = " <> printJS expr <> ";" <> newline printJS (JsUpdate name expr) = - name +> " = " +> expr +> ";" +> newline + printJS name <> " = " <> printJS expr <> ";" <> newline printJS (JsSetProp name prop expr) = - name +> "." +> prop +> " = " +> expr +> ";" +> newline - printJS (JsSetQName msrcloc name expr) = do - maybe (return ()) mapping msrcloc - name +> " = " +> expr +> ";" +> newline + printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ";" <> newline + printJS (JsSetQName msrcloc name expr) = + maybe mempty mapping msrcloc <> printJS name <> " = " <> printJS expr <> ";" <> newline printJS (JsSetConstructor name expr) = - printCons name +> " = " +> expr +> ";" +> newline +> + printCons name <> " = " <> printJS expr <> ";" <> newline <> -- The unqualifiedness here is bad. - printCons name +> ".prototype.instance = \"" +> printConsUnQual name +> "\";" +> newline + printCons name <> ".prototype.instance = \"" <> printConsUnQual name <> "\";" <> newline printJS (JsSetModule mp expr) = - mp +> " = " +> expr +> ";" +> newline + printJS mp <> " = " <> printJS expr <> ";" <> newline printJS (JsSetPropExtern name prop expr) = - name +> "['" +> prop +> "'] = " +> expr +> ";" +> newline - printJS (JsIf exp thens elses) = - "if (" +> exp +> ") {" +> newline +> - indented (printJS thens) +> - "}" +> - (when (length elses > 0) $ " else {" +> - indented (printJS elses) +> - "}") +> newline - printJS (JsEarlyReturn exp) = - "return " +> exp +> ";" +> newline - printJS (JsThrow exp) = do - "throw " +> exp +> ";" +> newline + printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ";" <> newline + printJS (JsIf expr thens elses) = + "if (" <> printJS expr <> ") {" <> newline <> + indented (printStmts thens) <> + "}" <> + (if null elses + then mempty + else " else {" <> newline <> + indented (printStmts elses) <> + "}") <> newline + printJS (JsEarlyReturn expr) = + "return " <> printJS expr <> ";" <> newline + printJS (JsThrow expr) = + "throw " <> printJS expr <> ";" <> newline printJS (JsWhile cond stmts) = - "while (" +> cond +> ") {" +> newline +> - indented (printJS stmts) +> - "}" +> newline - printJS JsContinue = - printJS "continue;" +> newline + "while (" <> printJS cond <> ") {" <> newline <> + indented (printStmts stmts) <> + "}" <> newline + printJS JsContinue = "continue;" <> newline -- | Print a module path. instance Printable ModulePath where - printJS (unModulePath -> l) = write $ intercalate "." l + printJS = write . intercalate "." . unModulePath -- | Print an expression. instance Printable JsExp where - printJS (JsSeq es) = "(" +> intercalateM "," (map printJS es) +> ")" + printJS (JsSeq es) = "(" <> mintercalate "," (map printJS es) <> ")" printJS (JsRawExp e) = write e printJS (JsName name) = printJS name - printJS (JsThrowExp exp) = - "(function(){ throw (" +> exp +> "); })()" - printJS JsNull = - printJS "null" - printJS JsUndefined = - printJS "undefined" - printJS (JsLit lit) = - printJS lit - printJS (JsParen exp) = - "(" +> exp +> ")" - printJS (JsList exps) = - "[" +> intercalateM "," (map printJS exps) +> printJS "]" - printJS (JsNew name args) = - "new " +> (JsApp (JsName name) args) - printJS (JsIndex i exp) = - "(" +> exp +> ")[" +> show i +> "]" - printJS (JsEq exp1 exp2) = - exp1 +> " === " +> exp2 - printJS (JsNeq exp1 exp2) = - exp1 +> " !== " +> exp2 - printJS (JsGetProp exp prop) = exp +> "." +> prop - printJS (JsLookup exp1 exp2) = - exp1 +> "[" +> exp2 +> "]" + printJS (JsThrowExp expr) = "(function(){ throw (" <> printJS expr <> "); })()" + printJS JsNull = "null" + printJS JsUndefined = "undefined" + printJS (JsLit lit) = printJS lit + printJS (JsParen expr) = "(" <> printJS expr <> ")" + printJS (JsList exprs) = "[" <> mintercalate "," (map printJS exprs) <> "]" + printJS (JsNew name args) = "new " <> printJS (JsApp (JsName name) args) + printJS (JsIndex i expr) = "(" <> printJS expr <> ")[" <> write (show i) <> "]" + printJS (JsEq expr1 expr2) = printJS expr1 <> " === " <> printJS expr2 + printJS (JsNeq expr1 expr2) = printJS expr1 <> " !== " <> printJS expr2 + printJS (JsGetProp expr prop) = printJS expr <> "." <> printJS prop + printJS (JsLookup expr1 expr2) = printJS expr1 <> "[" <> printJS expr2 <> "]" printJS (JsUpdateProp name prop expr) = - "(" +> name +> "." +> prop +> " = " +> expr +> ")" - printJS (JsInfix op x y) = - x +> " " +> op +> " " +> y - printJS (JsGetPropExtern exp prop) = - exp +> "[" +> (JsLit . JsStr) prop +> "]" + "(" <> printJS name <> "." <> printJS prop <> " = " <> printJS expr <> ")" + printJS (JsInfix op x y) = printJS x <> " " <> write op <> " " <> printJS y + printJS (JsGetPropExtern expr prop) = + printJS expr <> "[" <> write (toJsStringLit prop) <> "]" printJS (JsUpdatePropExtern name prop expr) = - "(" +> name +> "['" +> prop +> "'] = " +> expr +> ")" + "(" <> printJS name <> "['" <> printJS prop <> "'] = " <> printJS expr <> ")" printJS (JsTernaryIf cond conseq alt) = - cond +> " ? " +> conseq +> " : " +> alt - printJS (JsInstanceOf exp classname) = - exp +> " instanceof " +> classname + printJS cond <> " ? " <> printJS conseq <> " : " <> printJS alt + printJS (JsInstanceOf expr classname) = + printJS expr <> " instanceof " <> printJS classname printJS (JsObj assoc) = - "{" +> (intercalateM "," (map cons assoc)) +> "}" - where cons (key,value) = "\"" +> key +> "\": " +> value - printJS (JsLitObj assoc) = - "{" +> (intercalateM "," (map cons assoc)) +> "}" - where - cons :: (N.Name, JsExp) -> Printer () - cons (key,value) = "\"" +> key +> "\": " +> value + "{" <> mintercalate "," (map cons assoc) <> "}" + where cons (key,value) = write (toJsStringLit key) <> ": " <> printJS value + printJS (JsLitObj assoc) = "{" <> mintercalate "," (map cons assoc) <> "}" + where cons (key,value) = "\"" <> printJS key <> ": " <> printJS value printJS (JsFun nm params stmts ret) = "function" - +> maybe (return ()) ((" " +>) . printJS . ident) nm - +> "(" - +> (intercalateM "," (map printJS params)) - +> "){" +> newline - +> indented (stmts +> + <> maybe mempty ((" " <>) . printJS . ident) nm + <> "(" + <> mintercalate "," (map printJS params) + <> "){" <> newline + <> indented (printStmts stmts <> case ret of - Just ret' -> "return " +> ret' +> ";" +> newline - Nothing -> return ()) - +> "}" + Just ret' -> "return " <> printJS ret' <> ";" <> newline + Nothing -> mempty) + <> "}" printJS (JsApp op args) = - (if isFunc op then JsParen op else op) - +> "(" - +> (intercalateM "," (map printJS args)) - +> ")" - where isFunc JsFun{..} = True; isFunc _ = False - printJS (JsNegApp args) = - "(-(" +> printJS args +> "))" - printJS (JsAnd a b) = - printJS a +> "&&" +> printJS b - printJS (JsOr a b) = - printJS a +> "||" +> printJS b + printJS (case op of JsFun {} -> JsParen op; _ -> op) + <> "(" + <> mintercalate "," (map printJS args) + <> ")" + printJS (JsNegApp args) = "(-(" <> printJS args <> "))" + printJS (JsAnd a b) = printJS a <> "&&" <> printJS b + printJS (JsOr a b) = printJS a <> "||" <> printJS b -- | Unqualify a JsName. ident :: JsName -> JsName @@ -221,40 +207,32 @@ printJS name = case name of JsNameVar qname -> printJS qname - JsThis -> write "this" - JsThunk -> write "Fay$$$" - JsForce -> write "Fay$$_" - JsApply -> write "Fay$$__" - JsParam i -> write ("$p" ++ show i) - JsTmp i -> write ("$tmp" ++ show i) + JsThis -> "this" + JsThunk -> askIf prPrettyThunks "$" "Fay$$$" + JsForce -> askIf prPrettyThunks "_" "Fay$$_" + JsApply -> askIf prPrettyThunks "__" "Fay$$__" + JsParam i -> "$p" <> write (show i) + JsTmp i -> "$tmp" <> write (show i) JsConstructor qname -> printCons qname - JsBuiltIn qname -> "Fay$$" +> printJS qname - JsParametrizedType -> write "type" + JsBuiltIn qname -> "Fay$$" <> printJS qname + JsParametrizedType -> "type" JsModuleName (ModuleName _ m) -> write m -- | Print a constructor name given a QName. -printCons :: N.QName -> Printer () +printCons :: QName l -> Printer printCons (UnQual _ n) = printConsName n -printCons (Qual _ (ModuleName _ m) n) = printJS m +> "." +> printConsName n -printCons (Special {}) = error "qname2String Special" +printCons (Qual _ (ModuleName _ m) n) = write m <> "." <> printConsName n +printCons Special {} = error "qname2String Special" -- | Print an unqualified name. -printConsUnQual :: N.QName -> Printer () +printConsUnQual :: QName l -> Printer printConsUnQual (UnQual _ x) = printJS x printConsUnQual (Qual _ _ n) = printJS n -printConsUnQual (Special {}) = error "printConsUnqual Special" +printConsUnQual Special {} = error "printConsUnqual Special" -- | Print a constructor name given a Name. Helper for printCons. -printConsName :: N.Name -> Printer () -printConsName n = write "_" >> printJS n - --- | Just write out strings. -instance Printable String where - printJS = write - --- | A printer is a printable. -instance Printable (Printer ()) where - printJS = id +printConsName :: Name l -> Printer +printConsName = ("_" <>) . printJS -------------------------------------------------------------------------------- -- Name encoding @@ -276,91 +254,31 @@ -- The problem only occurs if there is a module A.B and a constructor B in module A. ++ ["__defineGetter__", "__defineSetter__", "__lookupGetter__", "__lookupSetter__", "constructor", "force", "forced", "hasOwnProperty", "isPrototypeOf", "propertyIsEnumerable", "toLocaleString", "toString", "value", "valueOf"] +allowedNameChars :: String +allowedNameChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" -- | Encode a Haskell name to JavaScript. -encodeName :: String -> String +encodeName :: Name l -> String + -- | This is a hack for names generated in the Haskell AST. Should be -- removed once it's no longer needed. -encodeName ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name -encodeName name - | name `elem` reservedWords = "$_" ++ normalizeName name - | otherwise = normalizeName name +encodeName n = case n of + (Ident _ idn) -> encodeString idn + (Symbol _ sym) -> encodeString sym + where encodeString ('$':'g':'e':'n':name) = "$gen_" ++ normalizeName name + encodeString name + | name `elem` reservedWords = "$_" ++ normalizeName name + | otherwise = normalizeName name -- | Normalize the given name to JavaScript-valid names. normalizeName :: String -> String -normalizeName name = - concatMap encodeChar name - +normalizeName = concatMap encodeChar where - encodeChar c | c `elem` allowed = [c] - | otherwise = escapeChar c - allowed = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" + encodeChar c | c `elem` allowedNameChars = [c] + | otherwise = escapeChar c escapeChar c = "$" ++ charId c ++ "$" charId c = show (fromEnum c) - --------------------------------------------------------------------------------- --- Printing - - --- | Print the given printer indented. -indented :: Printer a -> Printer () -indented p = do - PrintState{..} <- get - if psPretty - then do modify $ \s -> s { psIndentLevel = psIndentLevel + 1 } - p - modify $ \s -> s { psIndentLevel = psIndentLevel } - else p >> return () - --- | Output a newline. -newline :: Printer () -newline = do - PrintState{..} <- get - when psPretty $ do - write "\n" - modify $ \s -> s { psNewline = True } - --- | Write out a string, updating the current position information. -write :: String -> Printer () -write x = do - PrintState{..} <- get - let out = if psNewline then replicate (2*psIndentLevel) ' ' ++ x else x - modify $ \s -> s { psOutput = out : psOutput - , psLine = psLine + additionalLines - , psColumn = if additionalLines > 0 - then length (concat (take 1 (reverse srclines))) - else psColumn + length x - , psNewline = False - } - return (error "Nothing to return for writer string.") - - where srclines = lines x - additionalLines = length (filter (=='\n') x) - --- | Generate a mapping from the Haskell location to the current point in the output. -mapping :: SrcSpan -> Printer () -mapping SrcSpan{..} = do - modify $ \s -> s { psMappings = m s : psMappings s } - return () - - where m ps = Mapping { mapGenerated = Pos (fromIntegral (psLine ps)) - (fromIntegral (psColumn ps)) - , mapOriginal = Just (Pos (fromIntegral srcSpanStartLine) - (fromIntegral srcSpanStartColumn - 1)) - , mapSourceFile = Just srcSpanFilename - , mapName = Nothing - } - --- | Intercalate monadic action. -intercalateM :: String -> [Printer a] -> Printer () -intercalateM _ [] = return () -intercalateM _ [x] = x >> return () -intercalateM str (x:xs) = do - x - write str - intercalateM str xs - --- | Concatenate two printables. -(+>) :: (Printable a, Printable b) => a -> b -> Printer () -pa +> pb = printJS pa >> printJS pb +-- | Intercalate monoids. +mintercalate :: String -> [Printer] -> Printer +mintercalate str xs = mconcat $ intersperse (write str) xs diff --git a/src/Fay/Compiler/QName.hs b/src/Fay/Compiler/QName.hs --- a/src/Fay/Compiler/QName.hs +++ b/src/Fay/Compiler/QName.hs @@ -2,7 +2,7 @@ module Fay.Compiler.QName where -import Language.Haskell.Exts.Annotated +import Language.Haskell.Exts -- | Extract the module name from a qualified name. qModName :: QName a -> Maybe (ModuleName a) diff --git a/src/Fay/Compiler/State.hs b/src/Fay/Compiler/State.hs --- a/src/Fay/Compiler/State.hs +++ b/src/Fay/Compiler/State.hs @@ -12,7 +12,7 @@ import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S -import Language.Haskell.Names +import Language.Haskell.Names (sv_origName, Symbols (Symbols), SymValueInfo (SymValue, SymMethod, SymSelector, SymConstructor), OrigName, sv_typeName) -- | Get all non local identifiers that should be exported in the JS module scope. getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName) @@ -40,10 +40,10 @@ -- | Is this *resolved* name a new type constructor or destructor? isNewtype :: SymValueInfo OrigName -> CompileState -> Bool isNewtype s cs = case s of - SymValue{} -> False - SymMethod{} -> False - SymSelector { sv_typeName } -> not . (`isNewtypeDest` cs) . origName2QName $ sv_typeName - SymConstructor { sv_typeName } -> not . (`isNewtypeCons` cs) . origName2QName $ sv_typeName + SymValue{} -> False + SymMethod{} -> False + SymSelector { sv_typeName = tn } -> not . (`isNewtypeDest` cs) . origName2QName $ tn + SymConstructor { sv_typeName = tn } -> not . (`isNewtypeCons` cs) . origName2QName $ tn -- | Is this *resolved* name a new type destructor? isNewtypeDest :: N.QName -> CompileState -> Bool @@ -61,6 +61,6 @@ addedModulePath :: ModulePath -> CompileState -> Bool addedModulePath mp CompileState { stateJsModulePaths } = mp `S.member` stateJsModulePaths - +-- | Find the type signature of a top level name findTypeSig :: N.QName -> CompileState -> Maybe N.Type findTypeSig n = M.lookup n . stateTypeSigs diff --git a/src/Fay/Compiler/Typecheck.hs b/src/Fay/Compiler/Typecheck.hs --- a/src/Fay/Compiler/Typecheck.hs +++ b/src/Fay/Compiler/Typecheck.hs @@ -2,17 +2,20 @@ module Fay.Compiler.Typecheck where +import Fay.Compiler.Prelude + import Fay.Compiler.Defaults import Fay.Compiler.Misc -import Fay.System.Process.Extra +import Fay.Config import Fay.Types -import Data.List -import Data.Maybe -import qualified GHC.Paths as GHCPaths +import qualified GHC.Paths as GHCPaths +import System.Directory +import System.Environment + -- | Call out to GHC to type-check the file. -typecheck :: CompileConfig -> FilePath -> IO (Either CompileError String) +typecheck :: Config -> FilePath -> IO (Either CompileError String) typecheck cfg fp = do faydir <- faySourceDir let includes = configDirectoryIncludes cfg @@ -29,8 +32,7 @@ return [flag ++ '=' : pk] let flags = [ "-fno-code" - , "-XNoImplicitPrelude" - , "-hide-package base" + , "-hide-all-packages" , "-cpp", "-pgmPcpphs", "-optP--cpp" , "-optP-C" -- Don't let hse-cpp remove //-style comments. , "-DFAY=1" @@ -38,7 +40,21 @@ , "Language.Fay.DummyMain" , "-i" ++ intercalate ":" includeDirs , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages - res <- readAllFromProcess GHCPaths.ghc flags "" + exists <- doesFileExist GHCPaths.ghc + stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL") + let ghcPath = if exists + then if (isInfixOf ".stack" GHCPaths.ghc || stackInNixShell) + then "stack" + else GHCPaths.ghc + else "ghc" + extraFlags = case ghcPath of + "stack" -> ["exec","--","ghc"] + _ -> [] + when (configShowGhcCalls cfg) $ + putStrLn . unwords $ ghcPath : (extraFlags ++ flags) + when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL") + res <- readAllFromProcess ghcPath (extraFlags ++ flags) "" + when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1") either (return . Left . GHCError . fst) (return . Right . fst) res where wallF | configWall cfg = ["-Wall"] diff --git a/src/Fay/Config.hs b/src/Fay/Config.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Config.hs @@ -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 diff --git a/src/Fay/Control/Monad/Extra.hs b/src/Fay/Control/Monad/Extra.hs deleted file mode 100644 --- a/src/Fay/Control/Monad/Extra.hs +++ /dev/null @@ -1,31 +0,0 @@ --- | Extra monadic functions. - -module Fay.Control.Monad.Extra where - -import Control.Monad -import Data.Maybe - --- | Word version of flip (>>=). -bind :: (Monad m) => (a -> m b) -> m a -> m b -bind = flip (>>=) - --- | When the value is Just. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) m = m a -whenJust Nothing _ = return () - --- | Wrap up a form in a Maybe. -just :: Functor m => m a -> m (Maybe a) -just = fmap Just - --- | Flip of mapMaybe. -forMaybe :: [a] -> (a -> Maybe b) -> [b] -forMaybe = flip mapMaybe - --- | Monadic version of maybe. -maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a -maybeM nil cons a = maybe (return nil) cons a - --- | Do any of the (monadic) predicates match? -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM p l = return . not . null =<< filterM p l diff --git a/src/Fay/Control/Monad/IO.hs b/src/Fay/Control/Monad/IO.hs deleted file mode 100644 --- a/src/Fay/Control/Monad/IO.hs +++ /dev/null @@ -1,9 +0,0 @@ --- | Alias of MonadIO. - -module Fay.Control.Monad.IO where - -import Control.Monad.Trans - --- | Alias of liftIO, I hate typing it. Hate reading it. -io :: MonadIO m => IO a -> m a -io = liftIO diff --git a/src/Fay/Convert.hs b/src/Fay/Convert.hs --- a/src/Fay/Convert.hs +++ b/src/Fay/Convert.hs @@ -1,234 +1,252 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS -fno-warn-type-defaults #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | Convert a Haskell value to a (JSON representation of a) Fay value. module Fay.Convert (showToFay - ,readFromFay) + ,readFromFay + ,readFromFay' + ,encodeFay + ,decodeFay) where -import Control.Applicative -import Control.Monad -import Control.Monad.State +import Fay.Compiler.Prelude + +import Control.Monad.State (evalStateT, get, lift, put) +import Control.Spoon import Data.Aeson -import Data.Attoparsec.Number -import Data.Char +import Data.Aeson.Types (parseEither) import Data.Data -import Data.Function import Data.Generics.Aliases -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as Map -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Vector (Vector) -import qualified Data.Vector as Vector -import Numeric -import Safe -import qualified Text.Show.Pretty as Show +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Clock (UTCTime) +import Data.Vector (Vector) +import qualified Data.Vector as Vector -------------------------------------------------------------------------------- -- The conversion functions. --- | Convert a Haskell value to a value representing a Fay value. -showToFay :: Show a => a -> Maybe Value -showToFay = Show.reify >=> convert where - convert value = case value of - -- Special cases - Show.Con "True" _ -> return (Bool True) - Show.Con "False" _ -> return (Bool False) - - -- Objects/records - Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :)) - (slots values) - Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :)) - (mapM (uncurry keyval) fields) - Show.InfixCons _ _ -> Nothing -- TODO https://github.com/faylang/fay/issues/316 - - -- () - Show.Tuple [] -> return Null - - -- List types - Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values) - Show.List values -> fmap (Array . Vector.fromList) (mapM convert values) - - -- Text types - Show.String chars -> fmap string (readMay chars) - Show.Char char -> fmap (string.return) (readMay char) +-- | Convert a Haskell value to a Fay json value. This can fail when primitive +-- values aren't handled by explicit cases. 'encodeFay' can be used to +-- resolve this issue. +showToFay :: Data a => a -> Maybe Value +showToFay = spoon . encodeFay id - -- Numeric types (everything treated as a double) - Show.Neg{} -> double <|> int - Show.Integer{} -> int - Show.Float{} -> double - Show.Ratio{} -> double - where double = convertDouble value - int = convertInt value +-- | Convert a Haskell value to a Fay json value. This can fail when primitive +-- values aren't handled by explicit cases. When this happens, you can add +-- additional cases via the first parameter. +-- +-- The first parameter is a function that can be used to override the +-- conversion. This usually looks like using 'extQ' to additional type- +-- specific cases. +encodeFay :: (GenericQ Value -> GenericQ Value) -> GenericQ Value +encodeFay specialCases = specialCases $ + encodeGeneric rec + `extQ` unit + `extQ` Bool + `extQ` (toJSON :: Int -> Value) + `extQ` (toJSON :: Float -> Value) + `extQ` (toJSON :: Double -> Value) + `extQ` (toJSON :: UTCTime -> Value) + `ext1Q` list + `extQ` string + `extQ` char + `extQ` text + where + rec :: GenericQ Value + rec = encodeFay specialCases + unit () = Null + list :: Data a => [a] -> Value + list = Array . Vector.fromList . map rec + string = String . Text.pack + char = String . Text.pack . (:[]) + text = String - -- Number converters - convertDouble = fmap (Number . D) . pDouble - convertInt = fmap (Number . I) . pInt +encodeGeneric :: GenericQ Value -> GenericQ Value +encodeGeneric rec x = + case constrName of + '(':(dropWhile (==',') -> ")") -> + Array $ Vector.fromList $ gmapQ rec x + _ -> Object $ Map.fromList $ map (first Text.pack) fields + where + fields = + ("instance", String $ Text.pack constrName) : + zip labels (gmapQ rec x) + constrName = showConstr constr + constr = toConstr x + -- Note: constrFields can throw errors for non-algebraic datatypes. These + -- ought to be taken care of in the other cases of encodeFay. + labels = case constrFields constr of + [] -> map (("slot"++).show) [1::Int ..] + ls -> ls - -- Number parsers - pDouble :: Show.Value -> Maybe Double - pDouble value = case value of - Show.Float str -> getDouble str - Show.Ratio x y -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y) - Show.Neg str -> fmap (* (-1)) (pDouble str) - _ -> Nothing - pInt value = case value of - Show.Integer str -> getInt str - Show.Neg str -> fmap (* (-1)) (pInt str) - _ -> Nothing +-- | Convert a Fay json value to a Haskell value. +readFromFay :: Data a => Value -> Maybe a +readFromFay = either (const Nothing) Just . decodeFay (const id) - -- Number readers - getDouble :: String -> Maybe Double - getDouble = fmap fst . listToMaybe . readFloat - getInt :: String -> Maybe Integer - getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt - where charToInt c = fromEnum c - fromEnum '0' +-- | Convert a Fay json value to a Haskell value. This is like readFromFay, +-- except it yields helpful error messages on failure. +readFromFay' :: Data a => Value -> Either String a +readFromFay' = decodeFay (const id) - -- Utilities - string = String . Text.pack - slots = zipWithM keyval (map (("slot"++).show) [1::Int ..]) - keyval key val = fmap (Text.pack key,) (convert val) +-- | Convert a Fay json value to a Haskell value. +-- +-- The first parameter is a function that can be used to override the +-- conversion. This usually looks like using 'extR' to additional type- +-- specific cases. +decodeFay :: Data b + => (forall a. Data a => Value -> Either String a -> Either String a) + -> Value + -> Either String b +decodeFay specialCases value = specialCases value $ + parseDataOrTuple rec value + `extR` parseUnit value + `extR` parseBool value + `extR` parseInt value + `extR` parseFloat value + `extR` parseDouble value + `ext1R` parseArray rec value + `extR` parseUTCTime value + `extR` parseString value + `extR` parseChar value + `extR` parseText value + where + rec :: GenericParser + rec = decodeFay specialCases --- | Convert a value representing a Fay value to a Haskell value. -readFromFay :: Data a => Value -> Maybe a -readFromFay value = - parseDataOrTuple value - `ext1R` parseArray value - `extR` parseDouble value - `extR` parseInt value - `extR` parseInteger value - `extR` parseBool value - `extR` parseString value - `extR` parseChar value - `extR` parseText value - `extR` parseUnit value +type GenericParser = forall a. Data a => Value -> Either String a -- | Parse a data type or record or tuple. -parseDataOrTuple :: Data a => Value -> Maybe a -parseDataOrTuple value = result where +parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a +parseDataOrTuple rec value = result where result = getAndParse value - typ = dataTypeOf (fromJust result) + typ = dataTypeOf (undefined :: a) getAndParse x = case x of - Object obj -> parseObject typ obj - Array tuple -> parseTuple typ tuple - _ -> mzero + Object obj -> parseObject rec typ obj + Array tuple -> parseTuple rec typ tuple + _ -> badData value -- | Parse a tuple. -parseTuple :: Data a => DataType -> Vector Value -> Maybe a -parseTuple typ arr = +parseTuple :: Data a => GenericParser -> DataType -> Vector Value -> Either String a +parseTuple rec typ arr = case dataTypeConstrs typ of - [cons] -> evalStateT (fromConstrM (do i:next <- get + [cons] -> evalStateT (fromConstrM (do ~(i:next) <- get put next value <- lift (Vector.indexM arr i) - lift (readFromFay value)) + lift (rec value)) cons) [0..] - _ -> Nothing + _ -> badData (Array arr) -- | Parse a data constructor from an object. -parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a -parseObject typ obj = listToMaybe (catMaybes choices) where - choices = map makeConstructor constructors - constructors = dataTypeConstrs typ - makeConstructor cons = do - name <- Map.lookup (Text.pack "instance") obj >>= parseString - guard (showConstr cons == name) - if null fields - then makeSimple obj cons - else makeRecord obj cons fields - - where fields = constrFields cons +parseObject :: Data a => GenericParser -> DataType -> HashMap Text Value -> Either String a +parseObject rec typ obj = + case Map.lookup (Text.pack "instance") obj of + Just (parseString -> Right name) -> + case filter (\con -> showConstr con == name) (dataTypeConstrs typ) of + [con] -> + let fields = constrFields con + in if null fields + then makeSimple rec obj con + else makeRecord rec obj con fields + _ -> badData (Object obj) + _ -> badData (Object obj) -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2 -makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a -makeSimple obj cons = - evalStateT (fromConstrM (do i:next <- get +makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a +makeSimple rec obj cons = + evalStateT (fromConstrM (do ~(i:next) <- get put next - value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj) - lift (readFromFay value)) + value <- lift (lookupField obj (Text.pack ("slot" ++ show i))) + lift (rec value)) cons) - [1..] + [(1::Integer)..] -- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 } -makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a -makeRecord obj cons fields = - evalStateT (fromConstrM (do key:next <- get - put next - value <- lift (Map.lookup (Text.pack key) obj) - lift (readFromFay value)) - cons) - fields +makeRecord :: Data a => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a +makeRecord rec obj cons = + evalStateT $ + fromConstrM + (do ~(key:next) <- get + put next + value <- lift (lookupField obj (Text.pack key)) + lift $ rec value) + cons --- | Parse a double. -parseDouble :: Value -> Maybe Double -parseDouble value = do - number <- parseNumber value - case number of - I n -> return (fromIntegral n) - D n -> return n +lookupField :: HashMap Text Value -> Text -> Either String Value +lookupField obj key = + justRight ("Missing field " ++ Text.unpack key ++ " in " ++ show (Object obj)) $ + Map.lookup key obj --- | Parse an int. -parseInt :: Value -> Maybe Int -parseInt value = do - number <- parseNumber value - case number of - I n -> return (fromIntegral n) - _ -> mzero +-- | Parse a float. +parseFloat :: Value -> Either String Float +parseFloat = parseEither parseJSON --- | Parse an integer. -parseInteger :: Value -> Maybe Integer -parseInteger value = do - number <- parseNumber value - case number of - I n -> return n - _ -> mzero +-- | Parse a double. +parseDouble :: Value -> Either String Double +parseDouble = parseEither parseJSON --- | Parse a number. -parseNumber :: Value -> Maybe Number -parseNumber value = case value of - Number n -> return n - _ -> mzero +-- | Parse an int. +parseInt :: Value -> Either String Int +parseInt = parseEither parseJSON -- | Parse a bool. -parseBool :: Value -> Maybe Bool +parseBool :: Value -> Either String Bool parseBool value = case value of Bool n -> return n - _ -> mzero + _ -> badData value -- | Parse a string. -parseString :: Value -> Maybe String +parseString :: Value -> Either String String parseString value = case value of String s -> return (Text.unpack s) - _ -> mzero + _ -> badData value +parseUTCTime :: Value -> Either String UTCTime +parseUTCTime value = case fromJSON value of + Success t -> Right t + Error _ -> badData value + -- | Parse a char. -parseChar :: Value -> Maybe Char +parseChar :: Value -> Either String Char parseChar value = case value of String s | Just (c,_) <- Text.uncons s -> return c - _ -> mzero + _ -> badData value -- | Parse a Text. -parseText :: Value -> Maybe Text +parseText :: Value -> Either String Text parseText value = case value of String s -> return s - _ -> mzero + _ -> badData value -- | Parse an array. -parseArray :: Data a => Value -> Maybe [a] -parseArray value = case value of - Array xs -> mapM readFromFay (Vector.toList xs) - _ -> mzero +parseArray :: Data a => GenericParser -> Value -> Either String [a] +parseArray rec value = case value of + Array xs -> mapM rec (Vector.toList xs) + _ -> badData value -- | Parse unit. -parseUnit :: Value -> Maybe () +parseUnit :: Value -> Either String () parseUnit value = case value of Null -> return () - _ -> mzero + _ -> badData value + +badData :: forall a. Data a => Value -> Either String a +badData value = Left $ + "Bad data in decodeFay - expected valid " ++ + show (typeOf (undefined :: a)) ++ + ", but got:\n" ++ + show value + +justRight :: b -> Maybe a -> Either b a +justRight x Nothing = Left x +justRight _ (Just y) = Right y diff --git a/src/Fay/Data/List/Extra.hs b/src/Fay/Data/List/Extra.hs deleted file mode 100644 --- a/src/Fay/Data/List/Extra.hs +++ /dev/null @@ -1,14 +0,0 @@ --- | Extra list functions. - -module Fay.Data.List.Extra where - -import Data.List hiding (map) -import Prelude hiding (map) - --- | Get the union of a list of lists. -unionOf :: (Eq a) => [[a]] -> [a] -unionOf = foldr union [] - --- | Flip of map. -for :: (Functor f) => f a -> (a -> b) -> f b -for = flip fmap diff --git a/src/Fay/Exts.hs b/src/Fay/Exts.hs --- a/src/Fay/Exts.hs +++ b/src/Fay/Exts.hs @@ -1,6 +1,6 @@ module Fay.Exts where -import qualified Language.Haskell.Exts.Annotated as A +import qualified Language.Haskell.Exts as A type X = A.SrcSpanInfo @@ -15,7 +15,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X -type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X @@ -46,7 +45,7 @@ moduleExports :: A.Module X -> Maybe (A.ExportSpecList X) moduleExports (A.Module _ (Just (A.ModuleHead _ _ _ e)) _ _ _) = e moduleExports (A.Module _ Nothing _ _ _) = Nothing -moduleExports m = error $ ("moduleExports: " ++ A.prettyPrint m) +moduleExports m = error $ "moduleExports: " ++ A.prettyPrint m moduleNameString :: A.ModuleName t -> String moduleNameString (A.ModuleName _ n) = n @@ -57,7 +56,7 @@ noI :: A.SrcSpanInfo noI = A.noInfoSpan (A.mkSrcSpan A.noLoc A.noLoc) -convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.BangType a) +convertFieldDecl :: A.FieldDecl a -> ([A.Name a], A.Type a) convertFieldDecl (A.FieldDecl _ ns b) = (ns, b) fieldDeclNames :: A.FieldDecl a -> [A.Name a] @@ -65,6 +64,7 @@ declHeadName :: A.DeclHead a -> A.Name a declHeadName d = case d of - A.DHead _ n _ -> n - A.DHInfix _ _ n _ -> n + A.DHead _ n -> n + A.DHInfix _ _ n -> n A.DHParen _ h -> declHeadName h + A.DHApp _ h _ -> declHeadName h diff --git a/src/Fay/Exts/NoAnnotation.hs b/src/Fay/Exts/NoAnnotation.hs --- a/src/Fay/Exts/NoAnnotation.hs +++ b/src/Fay/Exts/NoAnnotation.hs @@ -2,12 +2,11 @@ {-# LANGUAGE FlexibleInstances #-} module Fay.Exts.NoAnnotation where +import Fay.Compiler.Prelude -import Data.Char (isAlpha) -import Data.List (intercalate) import Data.List.Split (splitOn) import Data.String -import qualified Language.Haskell.Exts.Annotated as A +import qualified Language.Haskell.Exts as A type Alt = A.Alt () type BangType = A.BangType () @@ -20,7 +19,6 @@ type FieldDecl = A.FieldDecl () type FieldUpdate = A.FieldUpdate () type GadtDecl = A.GadtDecl () -type GuardedAlts = A.GuardedAlts () type GuardedRhs = A.GuardedRhs () type ImportDecl = A.ImportDecl () type ImportSpec = A.ImportSpec () @@ -37,6 +35,7 @@ type QualConDecl = A.QualConDecl () type QualStmt = A.QualStmt () type Rhs = A.Rhs () +type Sign = A.Sign () type SpecialCon = A.SpecialCon () type SrcLoc = A.SrcLoc type SrcSpan = A.SrcSpan @@ -46,7 +45,7 @@ type Type = A.Type () unAnn :: Functor f => f a -> f () -unAnn = fmap (const ()) +unAnn = void -- | Helpful for some things. instance IsString (A.Name ()) where diff --git a/src/Fay/Exts/Scoped.hs b/src/Fay/Exts/Scoped.hs --- a/src/Fay/Exts/Scoped.hs +++ b/src/Fay/Exts/Scoped.hs @@ -2,8 +2,8 @@ import qualified Fay.Exts as F -import qualified Language.Haskell.Exts.Annotated as A -import qualified Language.Haskell.Names as HN +import qualified Language.Haskell.Exts as A +import qualified Language.Haskell.Names as HN (Scoped (Scoped), NameInfo (None)) type X = HN.Scoped A.SrcSpanInfo @@ -19,7 +19,6 @@ type FieldDecl = A.FieldDecl X type FieldUpdate = A.FieldUpdate X type GadtDecl = A.GadtDecl X -type GuardedAlts = A.GuardedAlts X type GuardedRhs = A.GuardedRhs X type ImportDecl = A.ImportDecl X type ImportSpec = A.ImportSpec X @@ -36,6 +35,7 @@ type QualConDecl = A.QualConDecl X type QualStmt = A.QualStmt X type Rhs = A.Rhs X +type Sign = A.Sign X type SpecialCon = A.SpecialCon X type SrcLoc = A.SrcLoc type Stmt = A.Stmt X diff --git a/src/Fay/FFI.hs b/src/Fay/FFI.hs --- a/src/Fay/FFI.hs +++ b/src/Fay/FFI.hs @@ -14,7 +14,7 @@ import Data.String (IsString) import Fay.Types -import Prelude (Bool, Char, Double, Int, Maybe, String, error) +import Prelude (error) -- | Values that may be null -- Nullable x decodes to x, Null decodes to null. diff --git a/src/Fay/Runtime.hs b/src/Fay/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Runtime.hs @@ -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. + */ + +|] diff --git a/src/Fay/System/Directory/Extra.hs b/src/Fay/System/Directory/Extra.hs deleted file mode 100644 --- a/src/Fay/System/Directory/Extra.hs +++ /dev/null @@ -1,21 +0,0 @@ --- | Extra directory functions. -module Fay.System.Directory.Extra where - -import Control.Monad (forM) -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) - --- | Get all files in a folder and its subdirectories. --- Taken from Real World Haskell --- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html -getRecursiveContents :: FilePath -> IO [FilePath] -getRecursiveContents topdir = do - names <- getDirectoryContents topdir - let properNames = filter (`notElem` [".", ".."]) names - paths <- forM properNames $ \name -> do - let path = topdir name - isDirectory <- doesDirectoryExist path - if isDirectory - then getRecursiveContents path - else return [path] - return (concat paths) diff --git a/src/Fay/System/Process/Extra.hs b/src/Fay/System/Process/Extra.hs deleted file mode 100644 --- a/src/Fay/System/Process/Extra.hs +++ /dev/null @@ -1,15 +0,0 @@ --- | Extra process functions. - -module Fay.System.Process.Extra where - -import System.Exit -import System.Process - --- | Read from a process returning both std err and out. -readAllFromProcess :: FilePath -> [String] -> String -> IO (Either (String,String) (String,String)) -readAllFromProcess program flags input = do - (code,out,err) <- readProcessWithExitCode program flags input - return $ case code of - ExitFailure 127 -> Left ("cannot find executable " ++ program, "") - ExitFailure _ -> Left (err, out) - ExitSuccess -> Right (err, out) diff --git a/src/Fay/Types.hs b/src/Fay/Types.hs --- a/src/Fay/Types.hs +++ b/src/Fay/Types.hs @@ -1,102 +1,73 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} -- | All Fay types and instances. module Fay.Types - (JsStmt(..) - ,JsExp(..) - ,JsLit(..) - ,JsName(..) - ,CompileError(..) - ,Compile(..) - ,CompileResult - ,CompileModule - ,Printable(..) - ,Fay - ,CompileReader(..) - ,CompileWriter(..) - ,CompileConfig(..) - ,CompileState(..) - ,FundamentalType(..) - ,PrintState(..) - ,Printer(..) - ,SerializeContext(..) - ,ModulePath (unModulePath) - ,mkModulePath - ,mkModulePaths - ,mkModulePathFromQName + ( JsStmt(..) + , JsExp(..) + , JsLit(..) + , JsName(..) + , CompileError(..) + , Compile(..) + , CompileModule + , Printable(..) + , Fay + , CompileReader(..) + , CompileResult(..) + , CompileWriter(..) + , Config(..) + , CompileState(..) + , FundamentalType(..) + , PrintState(..) + , defaultPrintState + , PrintReader(..) + , defaultPrintReader + , PrintWriter(..) + , pwOutputString + , Printer(..) + , execPrinter + , indented + , askIf + , newline + , write + , mapping + , SerializeContext(..) + , ModulePath (unModulePath) + , mkModulePath + , mkModulePaths + , mkModulePathFromQName ) where -import Fay.Compiler.QName -import qualified Fay.Exts as F -import qualified Fay.Exts.NoAnnotation as N -import qualified Fay.Exts.Scoped as S +import Fay.Compiler.Prelude +import Fay.Compiler.ModuleT +import Fay.Config +import qualified Fay.Exts.NoAnnotation as N +import qualified Fay.Exts.Scoped as S +import Fay.Types.CompileError +import Fay.Types.CompileResult +import Fay.Types.FFI +import Fay.Types.Js +import Fay.Types.ModulePath +import Fay.Types.Printer + +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative -import Control.Monad.Error (Error, ErrorT, MonadError) -import Control.Monad.Identity (Identity) -import Control.Monad.RWS -import Control.Monad.State -import Data.Default -import Data.List -import Data.List.Split -import Data.Map (Map) -import Data.Set (Set) -import Data.String -import Distribution.HaskellSuite.Modules -import Language.Haskell.Exts.Annotated -import Language.Haskell.Names (Symbols) -import SourceMap.Types +#endif +import Control.Monad.Except (ExceptT, MonadError) +import Control.Monad.Identity (Identity) +import Control.Monad.RWS (MonadIO, MonadReader, MonadState, MonadWriter, RWST, lift) +import Data.Map (Map) +import Data.Set (Set) +import Language.Haskell.Names (Symbols) +import Data.Semigroup (Semigroup) -------------------------------------------------------------------------------- -- Compiler types --- | Configuration of the compiler. -data CompileConfig = CompileConfig - { configOptimize :: Bool -- ^ Run optimizations - , configFlattenApps :: Bool -- ^ Flatten function application? - , configExportRuntime :: Bool -- ^ Export the runtime? - , configExportStdlib :: Bool -- ^ Export the stdlib? - , configExportStdlibOnly :: Bool -- ^ Export /only/ the stdlib? - , configDirectoryIncludes :: [(Maybe String, FilePath)] -- ^ Possibly a fay package name, and a include directory. - , configPrettyPrint :: Bool -- ^ Pretty print the JS output? - , configHtmlWrapper :: Bool -- ^ Output a HTML file including the produced JS. - , configSourceMap :: Bool -- ^ Output a source map file as outfile.map. - , configHtmlJSLibs :: [FilePath] -- ^ Any JS files to link to in the HTML. - , configLibrary :: Bool -- ^ Don't invoke main in the produced JS. - , configWarn :: Bool -- ^ Warn on dubious stuff, not related to typechecking. - , configFilePath :: Maybe FilePath -- ^ File path to output to. - , configTypecheck :: Bool -- ^ Typecheck with GHC. - , configWall :: Bool -- ^ Typecheck with -Wall. - , configGClosure :: Bool -- ^ Run Google Closure on the produced JS. - , configPackageConf :: Maybe FilePath -- ^ The package config e.g. packages-6.12.3. - , configPackages :: [String] -- ^ Included Fay packages. - , configBasePath :: Maybe FilePath -- ^ Custom source location for fay-base - , configStrict :: [String] -- ^ Produce strict and uncurried wrappers for all functions with type signatures in the given module - , configTypecheckOnly :: Bool -- ^ Only invoke GHC for typechecking, don't produce any output - , configRuntimePath :: Maybe FilePath - } deriving (Show) - --- | The name of a module split into a list for code generation. -newtype ModulePath = ModulePath { unModulePath :: [String] } - deriving (Eq, Ord, Show) - --- | Construct the complete ModulePath from a ModuleName. -mkModulePath :: ModuleName a -> ModulePath -mkModulePath (ModuleName _ m) = ModulePath . splitOn "." $ m - --- | Construct intermediate module paths from a ModuleName. --- mkModulePaths "A.B" => [["A"], ["A","B"]] -mkModulePaths :: ModuleName a -> [ModulePath] -mkModulePaths (ModuleName _ m) = map ModulePath . tail . inits . splitOn "." $ m - --- | Converting a QName to a ModulePath is only relevant for constructors since --- they can conflict with module names. -mkModulePathFromQName :: QName a -> ModulePath -mkModulePathFromQName (Qual _ (ModuleName _ m) n) = mkModulePath $ ModuleName F.noI $ m ++ "." ++ unname n -mkModulePathFromQName _ = error "mkModulePathFromQName: Not a qualified name" - -- | State of the compiler. data CompileState = CompileState -- TODO Change N.QName to GName? They can never be special so it would simplify. @@ -117,228 +88,56 @@ { writerCons :: [JsStmt] -- ^ Constructors. , writerFayToJs :: [(String,JsExp)] -- ^ Fay to JS dispatchers. , writerJsToFay :: [(String,JsExp)] -- ^ JS to Fay dispatchers. - } - deriving (Show) + } deriving (Show) -- | Simple concatenating instance. +instance Semigroup CompileWriter where + (CompileWriter a b c) <> (CompileWriter x y z) = + CompileWriter (a++x) (b++y) (c++z) + +-- | Simple concatenating instance. instance Monoid CompileWriter where mempty = CompileWriter [] [] [] - mappend (CompileWriter a b c) (CompileWriter x y z) = - CompileWriter (a++x) (b++y) (c++z) + mappend = (<>) -- | Configuration and globals for the compiler. data CompileReader = CompileReader - { readerConfig :: CompileConfig -- ^ The compilation configuration. - , readerCompileLit :: S.Literal -> Compile JsExp + { readerConfig :: Config -- ^ The compilation configuration. + , readerCompileLit :: S.Sign -> S.Literal -> Compile JsExp , readerCompileDecls :: Bool -> [S.Decl] -> Compile [JsStmt] } -- | Compile monad. newtype Compile a = Compile - { unCompile :: (RWST CompileReader - CompileWriter - CompileState - (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO))) - a -- ^ Uns the compiler - } - deriving (MonadState CompileState - ,MonadError CompileError - ,MonadReader CompileReader - ,MonadWriter CompileWriter - ,MonadIO - ,Monad - ,Functor - ,Applicative - ) - -type CompileResult a - = Either CompileError - (a, CompileState, CompileWriter) + { unCompile :: RWST CompileReader CompileWriter CompileState + (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO)) + a -- ^ Uns the compiler + } deriving + ( Applicative + , Functor + , Monad + , MonadError CompileError + , MonadIO + , MonadReader CompileReader + , MonadState CompileState + , MonadWriter CompileWriter + ) -type CompileModule a - = ModuleT Symbols - IO - (CompileResult a) +type CompileModule a = ModuleT Symbols IO (Either CompileError (a, CompileState, CompileWriter)) instance MonadModule Compile where type ModuleInfo Compile = Symbols lookupInCache = liftModuleT . lookupInCache insertInCache n m = liftModuleT $ insertInCache n m - getPackages = liftModuleT $ getPackages readModuleInfo fps n = liftModuleT $ readModuleInfo fps n liftModuleT :: ModuleT Symbols IO a -> Compile a liftModuleT = Compile . lift . lift --- | The state of the pretty printer. -data PrintState = PrintState - { psPretty :: Bool -- ^ Are we to pretty print? - , psLine :: Int -- ^ The current line. - , psColumn :: Int -- ^ Current column. - , psMappings :: [Mapping] -- ^ Source mappings. - , psIndentLevel :: Int -- ^ Current indentation level. - , psOutput :: [String] -- ^ The current output. TODO: Make more efficient. - , psNewline :: Bool -- ^ Just outputted a newline? - } - --- | Default state. -instance Default PrintState where - def = PrintState False 0 0 [] 0 [] False - --- | The printer monad. -newtype Printer a = Printer { runPrinter :: State PrintState a } - deriving (Monad,Functor,MonadState PrintState) - --- | Print some value. -class Printable a where - printJS :: a -> Printer () - --- | Error type. -data CompileError - = Couldn'tFindImport N.ModuleName [FilePath] - | EmptyDoBlock - | FfiFormatBadChars SrcSpanInfo String - | FfiFormatIncompleteArg SrcSpanInfo - | FfiFormatInvalidJavaScript SrcSpanInfo String String - | FfiFormatNoSuchArg SrcSpanInfo Int - | FfiNeedsTypeSig S.Decl - | GHCError String - | InvalidDoBlock - | ParseError S.SrcLoc String - | ShouldBeDesugared String - | UnableResolveQualified N.QName - | UnsupportedDeclaration S.Decl - | UnsupportedEnum N.Exp - | UnsupportedExportSpec N.ExportSpec - | UnsupportedExpression S.Exp - | UnsupportedFieldPattern S.PatField - | UnsupportedImport F.ImportDecl - | UnsupportedLet - | UnsupportedLetBinding S.Decl - | UnsupportedLiteral S.Literal - | UnsupportedModuleSyntax String F.Module - | UnsupportedPattern S.Pat - | UnsupportedQualStmt S.QualStmt - | UnsupportedRecursiveDo - | UnsupportedRhs S.Rhs - | UnsupportedWhereInAlt S.Alt - | UnsupportedWhereInMatch S.Match - deriving (Show) -instance Error CompileError - -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a) - deriving Monad - --------------------------------------------------------------------------------- --- JS AST types - --- | Statement type. -data JsStmt - = JsVar JsName JsExp - | JsIf JsExp [JsStmt] [JsStmt] - | JsEarlyReturn JsExp - | JsThrow JsExp - | JsWhile JsExp [JsStmt] - | JsUpdate JsName JsExp - | JsSetProp JsName JsName JsExp - | JsSetQName (Maybe SrcSpan) N.QName JsExp - | JsSetModule ModulePath JsExp - | JsSetConstructor N.QName JsExp - | JsSetPropExtern JsName JsName JsExp - | JsContinue - | JsBlock [JsStmt] - | JsExpStmt JsExp - deriving (Show,Eq) - --- | Expression type. -data JsExp - = JsName JsName - | JsRawExp String - | JsSeq [JsExp] - | JsFun (Maybe JsName) [JsName] [JsStmt] (Maybe JsExp) - | JsLit JsLit - | JsApp JsExp [JsExp] - | JsNegApp JsExp - | JsTernaryIf JsExp JsExp JsExp - | JsNull - | JsParen JsExp - | JsGetProp JsExp JsName - | JsLookup JsExp JsExp - | JsUpdateProp JsExp JsName JsExp - | JsGetPropExtern JsExp String - | JsUpdatePropExtern JsExp JsName JsExp - | JsList [JsExp] - | JsNew JsName [JsExp] - | JsThrowExp JsExp - | JsInstanceOf JsExp JsName - | JsIndex Int JsExp - | JsEq JsExp JsExp - | JsNeq JsExp JsExp - | JsInfix String JsExp JsExp -- Used to optimize *, /, +, etc - | JsObj [(String,JsExp)] - | JsLitObj [(N.Name,JsExp)] - | JsUndefined - | JsAnd JsExp JsExp - | JsOr JsExp JsExp - deriving (Show,Eq) - --- | A name of some kind. -data JsName - = JsNameVar N.QName - | JsThis - | JsParametrizedType - | JsThunk - | JsForce - | JsApply - | JsParam Integer - | JsTmp Integer - | JsConstructor N.QName - | JsBuiltIn N.Name - | JsModuleName N.ModuleName - deriving (Eq,Show) - --- | Literal value type. -data JsLit - = JsChar Char - | JsStr String - | JsInt Int - | JsFloating Double - | JsBool Bool - deriving (Show,Eq) - --- | Just handy to have. -instance IsString JsLit where fromString = JsStr - --- | These are the data types that are serializable directly to native --- JS data types. Strings, floating points and arrays. The others are: --- actions in the JS monad, which are thunks that shouldn't be forced --- when serialized but wrapped up as JS zero-arg functions, and --- unknown types can't be converted but should at least be forced. -data FundamentalType - -- Recursive types. - = FunctionType [FundamentalType] - | JsType FundamentalType - | ListType FundamentalType - | TupleType [FundamentalType] - | UserDefined N.Name [FundamentalType] - | Defined FundamentalType - | Nullable FundamentalType - -- Simple types. - | DateType - | StringType - | DoubleType - | IntType - | BoolType - | PtrType - -- Automatically serialize this type. - | Automatic - -- Unknown. - | UnknownType - deriving (Show) - --- | The serialization context indicates whether we're currently --- serializing some value or a particular field in a user-defined data --- type. -data SerializeContext = SerializeAnywhere | SerializeUserArg Int - deriving (Read,Show,Eq) + deriving + ( Applicative + , Functor + , Monad + ) diff --git a/src/Fay/Types/CompileError.hs b/src/Fay/Types/CompileError.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/CompileError.hs @@ -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" #-} diff --git a/src/Fay/Types/CompileResult.hs b/src/Fay/Types/CompileResult.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/CompileResult.hs @@ -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 diff --git a/src/Fay/Types/FFI.hs b/src/Fay/Types/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/FFI.hs @@ -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) diff --git a/src/Fay/Types/Js.hs b/src/Fay/Types/Js.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/Js.hs @@ -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 diff --git a/src/Fay/Types/ModulePath.hs b/src/Fay/Types/ModulePath.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/ModulePath.hs @@ -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" diff --git a/src/Fay/Types/Printer.hs b/src/Fay/Types/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Fay/Types/Printer.hs @@ -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] } diff --git a/src/haskell-names/LICENSE b/src/haskell-names/LICENSE new file mode 100644 --- /dev/null +++ b/src/haskell-names/LICENSE @@ -0,0 +1,3 @@ +Forked from haskell-names +Licensed as BSD3 +Authors: Roman Cheplyaka, Lennart Augustsson diff --git a/src/haskell-names/Language/Haskell/Names.hs b/src/haskell-names/Language/Haskell/Names.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/Annotated.hs b/src/haskell-names/Language/Haskell/Names/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Annotated.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Exports.hs b/src/haskell-names/Language/Haskell/Names/Exports.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Exports.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/GetBound.hs b/src/haskell-names/Language/Haskell/Names/GetBound.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GetBound.hs @@ -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 _ = [] diff --git a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot @@ -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 + diff --git a/src/haskell-names/Language/Haskell/Names/Imports.hs b/src/haskell-names/Language/Haskell/Names/Imports.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Imports.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs b/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs @@ -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 + ] diff --git a/src/haskell-names/Language/Haskell/Names/Open/Base.hs b/src/haskell-names/Language/Haskell/Names/Open/Base.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Base.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Open/Derived.hs b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Derived.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Open/Instances.hs b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Open/Instances.hs @@ -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 + + diff --git a/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs b/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs @@ -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 diff --git a/src/haskell-names/Language/Haskell/Names/Recursive.hs b/src/haskell-names/Language/Haskell/Names/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Recursive.hs @@ -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" diff --git a/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs @@ -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) diff --git a/src/haskell-names/Language/Haskell/Names/Types.hs b/src/haskell-names/Language/Haskell/Names/Types.hs new file mode 100644 --- /dev/null +++ b/src/haskell-names/Language/Haskell/Names/Types.hs @@ -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 diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -1,69 +1,75 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -- | Main compiler executable. module Main where import Fay -import Fay.Compiler.Config -import Paths_fay (version) +import Paths_fay (version) -import qualified Control.Exception as E +import Control.Applicative ((<|>), (<$>), (<*>)) +import qualified Control.Exception as E import Control.Monad -import Data.Default -import Data.List.Split (wordsBy) +import Control.Monad.Reader +import Data.List.Split (wordsBy) import Data.Maybe -import Data.Version (showVersion) -import Options.Applicative -import Options.Applicative.Types -import System.Environment +import Data.Monoid ((<>)) +import Data.Version (showVersion) +import Options.Applicative (Mod, OptionFields, Parser, argument, execParser, fullDesc, header, help, + helper, info, long, many, metavar, option, optional, short, strOption, + switch, value) +import Options.Applicative.Types (ReadM (ReadM)) -- | Options and help. data FayCompilerOptions = FayCompilerOptions - { optLibrary :: Bool - , optFlattenApps :: Bool - , optHTMLWrapper :: Bool - , optHTMLJSLibs :: [String] - , optInclude :: [String] - , optPackages :: [String] - , optWall :: Bool - , optNoGHC :: Bool - , optStdout :: Bool - , optVersion :: Bool - , optOutput :: Maybe String - , optPretty :: Bool - , optOptimize :: Bool - , optGClosure :: Bool - , optPackageConf :: Maybe String - , optNoRTS :: Bool - , optNoStdlib :: Bool - , optPrintRuntime :: Bool - , optStdlibOnly :: Bool - , optBasePath :: Maybe FilePath - , optStrict :: [String] - , optTypecheckOnly :: Bool - , optRuntimePath :: Maybe FilePath - , optSourceMap :: Bool - , optFiles :: [String] + { optBasePath :: Maybe FilePath + , optGClosure :: Bool + , optFlattenApps :: Bool + , optHTMLJSLibs :: [String] + , optHTMLWrapper :: Bool + , optInclude :: [String] + , optLibrary :: Bool + , optNoGHC :: Bool + , optNoOptimizeNewtypes :: Bool + , optNoRTS :: Bool + , optNoStdlib :: Bool + , optOptimize :: Bool + , optOutput :: Maybe String + , optPackages :: [String] + , optPackageConf :: Maybe String + , optPrettyAll :: Bool + , optPretty :: Bool + , optPrettyOperators :: Bool + , optPrettyThunks :: Bool + , optPrintRuntime :: Bool + , optRuntimePath :: Maybe FilePath + , optSourceMap :: Bool + , optStdlibOnly :: Bool + , optStdout :: Bool + , optStrict :: [String] + , optTypecheckOnly :: Bool + , optVersion :: Bool + , optWall :: Bool + , optShowGhcCalls :: Bool + , optTypeScript :: Bool + , optFiles :: [String] } -- | Main entry point. main :: IO () main = do - packageConf <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - opts <- execParser parser + config' <- defaultConfigWithSandbox + opts <- execParser parser let config = addConfigDirectoryIncludePaths ("." : optInclude opts) $ - addConfigPackages (optPackages opts) $ def + addConfigPackages (optPackages opts) $ config' { configOptimize = optOptimize opts , configFlattenApps = optFlattenApps opts - , configPrettyPrint = optPretty opts + , configPrettyPrint = optPretty opts || optPrettyAll opts , configLibrary = optLibrary opts , configHtmlWrapper = optHTMLWrapper opts , configHtmlJSLibs = optHTMLJSLibs opts , configTypecheck = not $ optNoGHC opts , configWall = optWall opts , configGClosure = optGClosure opts - , configPackageConf = optPackageConf opts <|> packageConf + , configPackageConf = optPackageConf opts <|> configPackageConf config' , configExportRuntime = not (optNoRTS opts) , configExportStdlib = not (optNoStdlib opts) , configExportStdlibOnly = optStdlibOnly opts @@ -72,11 +78,16 @@ , configTypecheckOnly = optTypecheckOnly opts , configRuntimePath = optRuntimePath opts , configSourceMap = optSourceMap opts + , configOptimizeNewtypes = not $ optNoOptimizeNewtypes opts + , configPrettyThunks = optPrettyThunks opts || optPrettyAll opts + , configPrettyOperators = optPrettyOperators opts || optPrettyAll opts + , configShowGhcCalls = optShowGhcCalls opts + , configTypeScript = optTypeScript opts } if optVersion opts then runCommandVersion else if optPrintRuntime opts - then getConfigRuntime config >>= readFile >>= putStr + then readConfigRuntime config >>= putStr else do void $ incompatible htmlAndStdout opts "Html wrapping and stdout are incompatible" case optFiles opts of @@ -88,41 +99,49 @@ parser = info (helper <*> options) (fullDesc <> header helpTxt) outPutFile :: FayCompilerOptions -> String -> FilePath - outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts + outPutFile opts file = fromMaybe (if optTypeScript opts then toTsName file else toJsName file) $ optOutput opts -- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions - <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript") + <$> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly") + <*> switch (long "closure" <> help "Provide help with Google Closure") <*> switch (long "flatten-apps" <> help "flatten function applicaton") - <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript") <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]" <> help "javascript files to add to if using option html-wrapper") + <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript") <*> strsOption (long "include" <> metavar "dir1[, ..]" <> help "additional directories for include") - <*> strsOption (long "package" <> metavar "package[, ..]" - <> help "packages to use for compilation") - <*> switch (long "Wall" <> help "Typecheck with -Wall") + <*> switch (long "library" <> help "Don't automatically call main in generated JavaScript") <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files") - <*> switch (long "stdout" <> short 's' <> help "Output to stdout") - <*> switch (long "version" <> help "Output version number") - <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file")) - <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output") - <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code") - <*> switch (long "closure" <> help "Provide help with Google Closure") - <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file")) + <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types") <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS") <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI") + <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code") + <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file")) + <*> strsOption (long "package" <> metavar "package[, ..]" + <> help "packages to use for compilation") + <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file")) + <*> switch (long "pretty-all" <> help "Pretty print, pretty operators and pretty thunks") + <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output") + <*> switch (long "pretty-operators" <> help "Use pretty operators") + <*> switch (long "pretty-thunks" <> help "Use pretty thunk names") <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout") + <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it") + <*> switch (long "sourcemap" <> help "Produce a source map in .map") <*> switch (long "stdlib" <> help "Only output the stdlib") - <*> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly") + <*> switch (long "stdout" <> short 's' <> help "Output to stdout") <*> strsOption (long "strict" <> metavar "modulename[, ..]" <> help "Generate strict and uncurried exports for the supplied modules. Simplifies calling Fay from JS") <*> switch (long "typecheck-only" <> help "Only invoke GHC for typechecking, don't produce any output") - <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it") - <*> switch (long "sourcemap" <> help "Produce a source map in .map") - <*> arguments Just (metavar "...") - where strsOption m = nullOption (m <> reader (ReadM . Right . wordsBy (== ',')) <> value []) + <*> switch (long "version" <> help "Output version number") + <*> switch (long "Wall" <> help "Typecheck with -Wall") + <*> switch (long "show-ghc-calls" <> help "Print commands sent to ghc") + <*> switch (long "ts" <> help "Output TypeScript instead of JavaScript") + <*> many (argument (ReadM ask) (metavar "...")) + where + strsOption :: Mod OptionFields [String] -> Parser [String] + strsOption m = option (ReadM . fmap (wordsBy (== ',')) $ ask) (m <> value []) -- | Make incompatible options. incompatible :: Monad m @@ -134,10 +153,9 @@ -- | The basic help text. helpTxt :: String -helpTxt = concat - ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n" - ," fay ... processes each .hs file" - ] +helpTxt + = "fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n" + ++ " fay ... processes each .hs file" -- | Print the command version. runCommandVersion :: IO () diff --git a/src/tests/Test/CommandLine.hs b/src/tests/Test/CommandLine.hs --- a/src/tests/Test/CommandLine.hs +++ b/src/tests/Test/CommandLine.hs @@ -2,20 +2,17 @@ module Test.CommandLine (tests) where -import Fay.System.Process.Extra +import Fay.Compiler.Prelude +import Test.Util -import Control.Applicative -import Data.Maybe import System.Directory import System.Environment import System.FilePath -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.TH -import Test.HUnit (Assertion, assertBool) -import Test.Util +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH -tests :: Test +tests :: TestTree tests = $testGroupGenerator compileFile :: [String] -> IO (Either String String) @@ -42,4 +39,6 @@ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] ++ ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ]) - assertBool (fromLeft res) (isRight res) + case res of + Left e -> assertFailure $ "Compilation failed: " ++ e + Right _ -> assertBool "impossible" True diff --git a/src/tests/Test/Compile.hs b/src/tests/Test/Compile.hs --- a/src/tests/Test/Compile.hs +++ b/src/tests/Test/Compile.hs @@ -1,39 +1,31 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Test.Compile (tests) where +module Test.Compile (tests,runScriptFile) where import Fay -import Fay.Compiler.Config -import Fay.System.Process.Extra -import Fay.Types () +import Fay.Compiler.Prelude -import Control.Applicative -import Control.Monad -import Data.Default -import Data.Maybe -import Language.Haskell.Exts.Annotated -import System.Environment -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.TH -import Test.HUnit (Assertion, assertBool, assertEqual, assertFailure) -import Test.Util +import Language.Haskell.Exts +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.TH -tests :: Test +tests :: TestTree tests = $testGroupGenerator case_imports :: Assertion case_imports = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFile defConf { configPackageConf = whatAGreatFramework } fp + cfg <- defConf + res <- compileFile cfg fp assertBool "Could not compile file with imports" (isRight res) case_importedList :: Assertion case_importedList = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } fp + cfg <- defConf + res <- compileFileWithState cfg fp case res of Left err -> error (show err) Right (_,_,r) -> assertBool "RecordImport_Export was not added to stateImported" . @@ -44,8 +36,8 @@ case_stateRecordTypes :: Assertion case_stateRecordTypes = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/Records.hs" + cfg <- defConf + res <- compileFileWithState cfg "tests/Compile/Records.hs" case res of Left err -> error (show err) Right (_,_,r) -> @@ -54,12 +46,12 @@ [ ("Compile.Records.T", ["Compile.Records.:+"]) , ("Compile.Records.R", ["Compile.Records.R","Compile.Records.S"]) ] - (stateRecordTypes r) + (filter (isFromMod "Compile.Records") $ stateRecordTypes r) case_importStateRecordTypes :: Assertion case_importStateRecordTypes = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFileWithState defConf { configPackageConf = whatAGreatFramework } "tests/Compile/ImportRecords.hs" + cfg <- defConf + res <- compileFileWithState cfg "tests/Compile/ImportRecords.hs" case res of Left err -> error (show err) Right (_,_,r) -> @@ -68,40 +60,91 @@ [ ("Compile.Records.T",["Compile.Records.:+"]) , ("Compile.Records.R",["Compile.Records.R", "Compile.Records.S"]) ] - (stateRecordTypes r) + (filter (isFromMod "Compile.Records") $ stateRecordTypes r) +isFromMod :: String -> (QName (),[QName ()]) -> Bool +isFromMod modName = (==) modName . getModuleName . fst + where + getModuleName (Qual _ (ModuleName _ n) _) = n + getModuleName x = error $ "getModuleName: expected qualified name: " ++ show x + case_typecheckCPP :: Assertion case_typecheckCPP = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs" + cfg <- defConf + res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/CPPTypecheck.hs" } "tests/Compile/CPPTypecheck.hs" either (assertFailure . show) (const $ return ()) res case_cppMultiLineStrings :: Assertion case_cppMultiLineStrings = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/CPPMultiLineStrings.hs" } "tests/Compile/CPPMultiLineStrings.hs" + cfg <- defConf + res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/CPPMultiLineStrings.hs" } "tests/Compile/CPPMultiLineStrings.hs" either (assertFailure . show) (const $ return ()) res case_strictWrapper :: Assertion case_strictWrapper = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs" - (\a b -> either a b res) (assertFailure . show) $ \(js,_) -> do - writeFile "tests/Compile/StrictWrapper.js" js - (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] "" + cfg <- defConf + res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs" + let isTs = configTypeScript cfg + suffix = if isTs then ".ts" else ".js" + (\a b -> either a b res) (assertFailure . show) $ \js -> do + writeFile ("tests/Compile/StrictWrapper" ++ suffix) js + (err, out) <- either id id <$> runScriptFile isTs ("tests/Compile/StrictWrapper" ++ suffix) when (err /= "") $ assertFailure err expected <- readFile "tests/Compile/StrictWrapper.res" assertEqual "strictWrapper node stdout" expected out -defConf :: CompileConfig -defConf = addConfigDirectoryIncludePaths ["tests/"] - $ def { configTypecheck = False } +assertPretty :: Config -> String -> Assertion +assertPretty cfg flagName = do + let isTs = configTypeScript cfg + suffix = if isTs then ".ts" else ".js" + res <- compileFile cfg $ "tests/Compile/" ++ flagName ++ ".hs" + case res of + Left l -> assertFailure $ "Should compile, but failed with: " ++ show l + Right js -> do + writeFile ("tests/Compile/" ++ flagName ++ suffix) js + (err, out) <- either id id <$> runScriptFile isTs + ("tests/Compile/" ++ flagName ++ suffix) + when (err /= "") $ assertFailure err + expected <- readFile $ "tests/Compile/" ++ flagName ++ ".res" + assertEqual (flagName ++ " node stdout") expected out +case_pretty :: Assertion +case_pretty = do + cfg <- defConf + assertPretty cfg { configPrettyPrint = True } "pretty" + +case_prettyThunks :: Assertion +case_prettyThunks = do + cfg <- defConf + assertPretty cfg { configPrettyThunks = True } "prettyThunks" + +case_prettyOperators :: Assertion +case_prettyOperators = do + cfg <- defConf + assertPretty cfg { configPrettyOperators = True } "prettyOperators" + case_charEnum :: Assertion case_charEnum = do - whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - res <- compileFile defConf { configPackageConf = whatAGreatFramework, configTypecheck = True, configFilePath = Just "tests/Compile/EnumChar.hs" } "tests/Compile/EnumChar.hs" + cfg <- defConf + res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/EnumChar.hs" } "tests/Compile/EnumChar.hs" case res of Left UnsupportedEnum{} -> return () Left l -> assertFailure $ "Should have failed with UnsupportedEnum, but failed with: " ++ show l - Right _ -> assertFailure $ "Should have failed with UnsupportedEnum, but compiled" + Right _ -> assertFailure "Should have failed with UnsupportedEnum, but compiled" + +defConf :: IO Config +defConf = do + cfg <- defaultConfigWithSandbox + return $ addConfigDirectoryIncludePaths ["tests/"] cfg { configTypecheck = False } + +-- | Run a JS or TS file. +runScriptFile :: Bool -- ^ If a file-format is TypeScript, this is True. + -> String -- ^ A name of script file + -> IO (Either (String,String) (String,String)) +runScriptFile True file = do + tsc_ret <- readAllFromProcess "tsc" [file] "" + case tsc_ret of + Left _ -> return tsc_ret + Right _ -> readAllFromProcess "node" [(reverse (drop 3 (reverse file))) ++ ".js" ] "" + +runScriptFile False file = readAllFromProcess "node" [file] "" diff --git a/src/tests/Test/Convert.hs b/src/tests/Test/Convert.hs --- a/src/tests/Test/Convert.hs +++ b/src/tests/Test/Convert.hs @@ -3,19 +3,18 @@ module Test.Convert (tests) where +import Fay.Convert + import qualified Data.Aeson.Parser as Aeson import Data.Attoparsec.ByteString import qualified Data.ByteString as Bytes import qualified Data.ByteString.UTF8 as UTF8 import Data.Data -import Data.Ratio import Data.Text (Text, pack) -import Fay.Convert -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit (assertEqual) +import Test.Tasty +import Test.Tasty.HUnit -tests :: Test +tests :: TestTree tests = testGroup "Test.Convert" [reading, showing] where reading = testGroup "reading" $ flip map readTests $ \(ReadTest value) -> @@ -35,7 +34,7 @@ -- Test cases -- | A test. -data Testcase = forall x. Show x => Testcase x Bytes.ByteString +data Testcase = forall x. (Show x,Data x) => Testcase x Bytes.ByteString -- | A read test. data ReadTest = forall x. (Data x,Show x,Eq x,Read x) => ReadTest x @@ -69,9 +68,10 @@ showTests = -- Fundamental data types [(1 :: Int) → "1" + ,(1 :: Float) → "1.0" + ,(1/2 :: Float) → "0.5" ,(1 :: Double) → "1.0" ,(1/2 :: Double) → "0.5" - ,(1%2 :: Rational) → "0.5" ,([1,2] :: [Int]) → "[1,2]" ,((1,2) :: (Int,Int)) → "[1,2]" ,"abc" → "\"abc\"" @@ -122,7 +122,7 @@ -- | Labelled record. data LabelledRecord = LabelledRecord { barInt :: Int, barDouble :: Double } - | LabelledRecord2 { bar :: Int, bob :: Double } + | LabelledRecord2 { bar :: Int, bob :: Float } deriving (Show,Data,Typeable,Read,Eq) -- | Order matters in unlabelled constructors. diff --git a/src/tests/Test/Desugar.hs b/src/tests/Test/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/tests/Test/Desugar.hs @@ -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 diff --git a/src/tests/Test/Util.hs b/src/tests/Test/Util.hs --- a/src/tests/Test/Util.hs +++ b/src/tests/Test/Util.hs @@ -1,14 +1,14 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} module Test.Util ( fayPath - , isRight - , fromLeft + , getRecursiveContents ) where -import Fay.System.Process.Extra (readAllFromProcess) +import Fay.Compiler.Prelude -import Control.Applicative -import Prelude hiding (pred) import System.Directory +import System.FilePath -- Path to the fay executable, looks in cabal-dev, dist, PATH in that order. fayPath :: IO (Maybe FilePath) @@ -20,20 +20,27 @@ usingWhich = fmap (concat . lines . snd) . hush <$> readAllFromProcess "which" ["fay"] "" firstWhereM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) -firstWhereM pred ins = case ins of +firstWhereM p ins = case ins of [] -> return Nothing - a:as -> pred a >>= \b -> + a:as -> p a >>= \b -> if b then return (Just a) - else firstWhereM pred as + else firstWhereM p as -- from the package `errors` hush :: Either a b -> Maybe b hush = either (const Nothing) Just -isRight :: Either a b -> Bool -isRight (Right _) = True -isRight (Left _) = False - -fromLeft :: Either a b -> a -fromLeft (Left a) = a -fromLeft (Right _) = error "fromLeft got Right" +-- | Get all files in a folder and its subdirectories. +-- Taken from Real World Haskell +-- http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + names <- getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [path] + return (concat paths) diff --git a/src/tests/Tests.hs b/src/tests/Tests.hs --- a/src/tests/Tests.hs +++ b/src/tests/Tests.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} -- | Generate the web site/documentation for the Fay project. -- @@ -7,66 +8,113 @@ module Main where +import Fay.Compiler.Prelude + import Fay -import Fay.Compiler.Config -import Fay.System.Directory.Extra -import Fay.System.Process.Extra +import qualified Test.CommandLine as Cmd +import qualified Test.Compile as Compile +import qualified Test.Convert as Convert +import qualified Test.Desugar as Desugar +import Test.Util -import Control.Applicative -import Data.Char -import Data.Default -import Data.List -import Data.Maybe -import Data.Ord +import Data.Set (Set) +import qualified Data.Set as S import System.Directory import System.Environment import System.FilePath -import qualified Test.CommandLine as Cmd -import qualified Test.Compile as Compile -import qualified Test.Convert as C -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.HUnit (assertEqual, assertFailure) +import System.Random +import Test.Tasty +import Test.Tasty.HUnit -- | Main test runner. main :: IO () main = do sandbox <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment - (packageConf,args) <- fmap (prefixed (=="-package-conf")) getArgs - let (basePath,args') = prefixed (=="-base-path") args - compiler <- makeCompilerTests (packageConf <|> sandbox) basePath - defaultMainWithArgs [Compile.tests, Cmd.tests, compiler, C.tests] - args' + (packageConf,args) <- prefixed (== "-package-conf") <$> getArgs + let (basePath,args') = prefixed (== "-base-path" ) args + let (testCount, args'') = first (readMay =<<) $ prefixed (== "-random") args' + let (isTs, args''') = case args'' of + ("-ts":xs) -> (True,xs) + _ -> (False,args'') + (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath testCount isTs + withArgs args''' $ defaultMain $ testGroup "Fay" + [ Desugar.tests + , Convert.tests + , codegen + , Cmd.tests + , Compile.tests + , runtime + ] -- | Extract the element prefixed by the given element in the list. prefixed :: (a -> Bool) -> [a] -> (Maybe a,[a]) prefixed f (break f -> (x,y)) = (listToMaybe (drop 1 y),x ++ drop 2 y) -- | Make the case-by-case unit tests. -makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> IO Test -makeCompilerTests packageConf basePath = do - files <- sortBy (comparing (map toLower)) . filter (\v -> not (isInfixOf "/Compile/" v) && not (isInfixOf "/regressions/" v)) . filter (isSuffixOf ".hs") <$> getRecursiveContents "tests" - return $ testGroup "Tests" $ flip map files $ \file -> testCase file $ do - testFile packageConf basePath False file - testFile packageConf basePath True file +makeCompilerTests :: Maybe FilePath -> Maybe FilePath -> Maybe Int -> Bool -> IO (TestTree,TestTree) +makeCompilerTests packageConf basePath rand isTs = do + runtimeFiles' <- runtimeTestFiles + runtimeFiles <- maybe (return runtimeFiles') (randomize runtimeFiles') rand + codegenFiles <- codegenTestFiles + return + ( makeTestGroup "Runtime tests" + runtimeFiles + (\file -> do testFile packageConf basePath False isTs file + testFile packageConf basePath True isTs file) + , makeTestGroup "Codegen tests" + codegenFiles + (testCodegen packageConf basePath isTs)) + where + makeTestGroup title files inner = + testGroup title $ flip map files $ \file -> + testCase file $ inner file + runtimeTestFiles = + filter (not . nonRuntime) <$> testFiles + codegenTestFiles = + filter (isInfixOf "/codegen/") <$> testFiles + testFiles = + sortBy (comparing (map toLower)) . filter (isSuffixOf ".hs") <$> + getRecursiveContents "tests" + nonRuntime x = + any (`isInfixOf` x) ["/Compile/","/regressions/","/codegen/"] + randomize :: [String] -> Int -> IO [String] + randomize l i = do + is <- randomizeAux S.empty i (0,length l - 1) + return . map (l !!) $ S.toList is + randomizeAux :: Set Int -> Int -> (Int,Int) -> IO (Set Int) + randomizeAux s count b = do + i <- randomRIO b + let s' = S.insert i s + if S.size s' == count + then return s' + else randomizeAux (S.insert i s) count b -testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO () -testFile packageConf basePath opt file = do - let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file - out = toJsName file - resf = root <.> "res" +fns :: Bool -> String -> (String, String, FilePath) +fns isTs file = + ( root + , if isTs then toTsName file else toJsName file + , root <.> "res" + ) + where + root = reverse . drop 1 . dropWhile (/='.') . reverse $ file + +testFile :: Maybe FilePath -> Maybe FilePath -> Bool -> Bool -> String -> IO () +testFile packageConf basePath opt isTs file = do + let (root, out, resf) = fns isTs file config = - addConfigDirectoryIncludePaths ["tests/"] $ - def { configOptimize = opt - , configTypecheck = False - , configPackageConf = packageConf - , configBasePath = basePath - } + addConfigDirectoryIncludePaths ["tests/"] + defaultConfig + { configOptimize = opt + , configTypecheck = False + , configPackageConf = packageConf + , configBasePath = basePath + , configTypeScript = isTs + } resExists <- doesFileExist resf let partialName = root ++ "_partial.res" partialExists <- doesFileExist partialName compileFromTo config file (Just out) - result <- runJavaScriptFile out + result <- Compile.runScriptFile isTs out if resExists then do output <- readFile resf assertEqual file output (either show snd result) @@ -79,6 +127,29 @@ Right (err,res) -> assertFailure $ "Did not fail:\n stdout: " ++ res ++ "\n\nstderr: " ++ err else assertEqual (file ++ ": Expected program to fail") True (either (const True) (const False) result) --- | Run a JS file. -runJavaScriptFile :: String -> IO (Either (String,String) (String,String)) -runJavaScriptFile file = readAllFromProcess "node" [file] "" +-- | Test the generated code output for the given file with +-- optimizations turned on. This disables runtime generation and +-- things like that; it's only concerned with the core of the program. +testCodegen :: Maybe FilePath -> Maybe FilePath -> Bool -> String -> IO () +testCodegen packageConf basePath isTs file = do + let (_, out, resf) = fns isTs file + config = + addConfigDirectoryIncludePaths ["tests/codegen/"] + defaultConfig + { configOptimize = True + , configTypecheck = False + , configPackageConf = packageConf + , configBasePath = basePath + , configExportStdlib = False + , configPrettyPrint = True + , configLibrary = True + , configExportRuntime = False + , configTypeScript = isTs + } + compileFromTo config file (Just out) + actual <- readStripped out + expected <- readStripped $ resf ++ (if isTs then "_ts" else "") + assertEqual file expected actual + where readStripped = + fmap (unlines . filter (not . null) . lines) . readFile + diff --git a/tests/AllBaseModules.hs b/tests/AllBaseModules.hs new file mode 100644 --- /dev/null +++ b/tests/AllBaseModules.hs @@ -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" diff --git a/tests/AllBaseModules.res b/tests/AllBaseModules.res new file mode 100644 --- /dev/null +++ b/tests/AllBaseModules.res @@ -0,0 +1,1 @@ +ok diff --git a/tests/AutomaticList.hs b/tests/AutomaticList.hs --- a/tests/AutomaticList.hs +++ b/tests/AutomaticList.hs @@ -1,6 +1,5 @@ module AutomaticList where -import Prelude import FFI main :: Fay () diff --git a/tests/Bool.hs b/tests/Bool.hs --- a/tests/Bool.hs +++ b/tests/Bool.hs @@ -1,4 +1,2 @@ -import Prelude - main :: Fay () main = print True diff --git a/tests/CPP.hs b/tests/CPP.hs --- a/tests/CPP.hs +++ b/tests/CPP.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + #ifdef FAY import Prelude #else diff --git a/tests/Char.hs b/tests/Char.hs --- a/tests/Char.hs +++ b/tests/Char.hs @@ -1,10 +1,38 @@ module Char where -import Prelude import FFI +import Data.Char + main :: Fay () main = do print 'a' putStrLn ('a' : "bc") print (head "abc") + print (ord 'a') + print (chr 97) + print (chr (ord 'a')) + print (ord (chr 97)) + print (isAscii 'a') + print (isAscii (chr 128)) + print (isLatin1 (chr 255)) + print (isLatin1 (chr 256)) + print (toUpper 'a') + print (toLower 'A') + print (toLower (toUpper 'a')) + print (isAsciiLower 'a') + print (isAsciiLower 'A') + print (isAsciiUpper 'Z') + print (isAsciiUpper 'z') + print (isAsciiUpper (toUpper 'a')) + print (isAsciiUpper (toLower 'A')) + print (isAsciiLower (toLower 'Z')) + print (isAsciiLower (toUpper 'z')) + print (all isDigit "0123456789") + print (isDigit 'a') + print (all isOctDigit "01234567") + print (any isOctDigit ['8', '9']) + print (all isHexDigit "0123456789ABCDEFabcdef") + print (any isHexDigit "ghijklmnopqrstuvwxyzGHIJKLMNOPQRSTUVWXYZ") + print (all isSpace [' ', '\t', '\n', '\r', '\f', '\v', '\xa0', '\x3000']) + diff --git a/tests/Char.res b/tests/Char.res --- a/tests/Char.res +++ b/tests/Char.res @@ -1,3 +1,29 @@ a abc a +97 +a +a +97 +true +false +true +false +A +a +a +true +false +true +false +true +false +true +false +true +false +true +false +true +false +true diff --git a/tests/Compile/StrictWrapper.hs b/tests/Compile/StrictWrapper.hs --- a/tests/Compile/StrictWrapper.hs +++ b/tests/Compile/StrictWrapper.hs @@ -1,4 +1,8 @@ -module StrictWrapper (f,g,h,r,clog) where +module StrictWrapper ( + f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth, + sumInt, sumIntWrapped, zipWithPlus, zipWithPlusWrapped, + sumPair, sumPairWrapped, zipPairs, zipPairsWrapped +) where import FFI import Prelude @@ -20,6 +24,45 @@ clog :: a -> Fay () clog = ffi "console.log(%1)" +-- FFI Expressions +logInlineOnly = ffi "console.log(%1)" :: a -> Fay () + +logSeparateOnly :: a -> Fay () +logSeparateOnly = ffi "console.log(%1)" + +logBoth :: a -> Fay () +logBoth = ffi "console.log(%1)" :: a -> Fay () + +-- lists +sumInt :: [Int] -> Int +sumInt xs = sum xs + +zipWithPlus :: [Int] -> [Int] -> [Int] +zipWithPlus xs ys = zipWith (+) xs ys + +data IntList = IntList { list :: [Int] } + +sumIntWrapped :: IntList -> Int +sumIntWrapped (IntList xs) = sumInt xs + +zipWithPlusWrapped :: IntList -> IntList -> IntList +zipWithPlusWrapped (IntList x) (IntList y) = IntList $ zipWithPlus x y + +-- tuples +sumPair :: (Int, Int) -> Int +sumPair (x,y) = x + y + +zipPairs :: (Int, Int) -> (Int, Int) -> (Int, Int) +zipPairs (x1,y1) (x2,y2) = (x1 + x2, y1 + y2) + +data IntPair = IntPair { pair :: (Int, Int) } + +sumPairWrapped :: IntPair -> Int +sumPairWrapped (IntPair x) = sumPair x + +zipPairsWrapped :: IntPair -> IntPair -> IntPair +zipPairsWrapped (IntPair x) (IntPair y) = IntPair $ zipPairs x y + -- You should probably not use the strict wrapper from Fay, this is just for the sake of the test. main :: Fay () main = do @@ -28,3 +71,18 @@ ffi "console.log(Strict.StrictWrapper.h({instance:'R',i:1}))" :: Fay () ffi "console.log(Strict.StrictWrapper.r)" :: Fay () ffi "Strict.StrictWrapper.clog(123)" :: Fay () + ffi "Strict.StrictWrapper.logInlineOnly('inlineOnly')" :: Fay () + ffi "Strict.StrictWrapper.logSeparateOnly('separateOnly')" :: Fay () + ffi "Strict.StrictWrapper.logBoth('both')" :: Fay () + + -- lists + (ffi "console.log(Strict.StrictWrapper.sumInt(%1))" :: [Int] -> Fay ()) [1, 2, 3] + (ffi "console.log(Strict.StrictWrapper.sumIntWrapped(%1))" :: IntList -> Fay ()) (IntList [1, 2, 3]) + (ffi "console.log(Strict.StrictWrapper.zipWithPlus(%1, %2))" :: [Int] -> [Int] -> Fay ()) [1, 2, 3] [1, 2, 3] + (ffi "console.log(Strict.StrictWrapper.zipWithPlusWrapped(%1, %2))" :: IntList -> IntList -> Fay ()) (IntList [1, 2, 3]) (IntList [1, 2, 3]) + + -- tuples + (ffi "console.log(Strict.StrictWrapper.sumPair(%1))" :: (Int, Int) -> Fay ()) (1, 3) + (ffi "console.log(Strict.StrictWrapper.sumPairWrapped(%1))" :: IntPair -> Fay ()) (IntPair (1, 3)) + (ffi "console.log(Strict.StrictWrapper.zipPairs(%1, %2))" :: (Int, Int) -> (Int, Int) -> Fay ()) (1, 3) (1, 3) + (ffi "console.log(Strict.StrictWrapper.zipPairsWrapped(%1, %2))" :: IntPair -> IntPair -> Fay ()) (IntPair (1, 3)) (IntPair (1, 3)) diff --git a/tests/Compile/StrictWrapper.res b/tests/Compile/StrictWrapper.res --- a/tests/Compile/StrictWrapper.res +++ b/tests/Compile/StrictWrapper.res @@ -3,3 +3,14 @@ { instance: 'R', i: 2 } { instance: 'R', i: 2 } 123 +inlineOnly +separateOnly +both +6 +6 +[ 2, 4, 6 ] +{ instance: 'IntList', list: [ 2, 4, 6 ] } +4 +4 +[ 2, 6 ] +{ instance: 'IntPair', pair: [ 2, 6 ] } diff --git a/tests/Compile/pretty.hs b/tests/Compile/pretty.hs new file mode 100644 --- /dev/null +++ b/tests/Compile/pretty.hs @@ -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" diff --git a/tests/Compile/pretty.res b/tests/Compile/pretty.res new file mode 100644 --- /dev/null +++ b/tests/Compile/pretty.res @@ -0,0 +1,7 @@ +4 +F +odd +even +odd +even +odd diff --git a/tests/Compile/prettyOperators.hs b/tests/Compile/prettyOperators.hs new file mode 100644 --- /dev/null +++ b/tests/Compile/prettyOperators.hs @@ -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" diff --git a/tests/Compile/prettyOperators.res b/tests/Compile/prettyOperators.res new file mode 100644 --- /dev/null +++ b/tests/Compile/prettyOperators.res @@ -0,0 +1,7 @@ +4 +F +odd +even +odd +even +odd diff --git a/tests/Compile/prettyThunks.hs b/tests/Compile/prettyThunks.hs new file mode 100644 --- /dev/null +++ b/tests/Compile/prettyThunks.hs @@ -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" diff --git a/tests/Compile/prettyThunks.res b/tests/Compile/prettyThunks.res new file mode 100644 --- /dev/null +++ b/tests/Compile/prettyThunks.res @@ -0,0 +1,7 @@ +4 +F +odd +even +odd +even +odd diff --git a/tests/Defined.hs b/tests/Defined.hs --- a/tests/Defined.hs +++ b/tests/Defined.hs @@ -1,5 +1,4 @@ import FFI -import Prelude data R = R (Defined Double) diff --git a/tests/DesugarFFI.hs b/tests/DesugarFFI.hs new file mode 100644 --- /dev/null +++ b/tests/DesugarFFI.hs @@ -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 diff --git a/tests/DesugarFFI.res b/tests/DesugarFFI.res new file mode 100644 --- /dev/null +++ b/tests/DesugarFFI.res @@ -0,0 +1,1 @@ +10 diff --git a/tests/DoLet2.hs b/tests/DoLet2.hs --- a/tests/DoLet2.hs +++ b/tests/DoLet2.hs @@ -1,6 +1,5 @@ module DoLet2 where -import Prelude import FFI main = do diff --git a/tests/DoLet3.hs b/tests/DoLet3.hs --- a/tests/DoLet3.hs +++ b/tests/DoLet3.hs @@ -1,6 +1,5 @@ module DoLet3 where -import Prelude import FFI data R = R Int diff --git a/tests/Double.hs b/tests/Double.hs --- a/tests/Double.hs +++ b/tests/Double.hs @@ -1,3 +1,4 @@ -import Prelude +module Double where +main :: Fay () main = print ((2 * 4 / 2) :: Double) diff --git a/tests/Double2.hs b/tests/Double2.hs --- a/tests/Double2.hs +++ b/tests/Double2.hs @@ -1,3 +1,4 @@ -import Prelude +module Double2 where +main :: Fay () main = print ((10 + (2 * (4 / 2))) :: Double) diff --git a/tests/Double3.hs b/tests/Double3.hs --- a/tests/Double3.hs +++ b/tests/Double3.hs @@ -1,3 +1,4 @@ -import Prelude +module Double3 where +main :: Fay () main = print ((5 * 3 / 2) :: Double) diff --git a/tests/Double4.hs b/tests/Double4.hs --- a/tests/Double4.hs +++ b/tests/Double4.hs @@ -1,4 +1,4 @@ -import Prelude +module Double4 where +main :: Fay () main = print 1 - diff --git a/tests/Either.hs b/tests/Either.hs --- a/tests/Either.hs +++ b/tests/Either.hs @@ -1,4 +1,4 @@ -import Prelude +module Either where raw :: Either Int Int -> Int raw x = case x of Left a -> a + 1 diff --git a/tests/EmptyDataDeclArray.hs b/tests/EmptyDataDeclArray.hs new file mode 100644 --- /dev/null +++ b/tests/EmptyDataDeclArray.hs @@ -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 diff --git a/tests/EmptyDataDeclArray.res b/tests/EmptyDataDeclArray.res new file mode 100644 --- /dev/null +++ b/tests/EmptyDataDeclArray.res @@ -0,0 +1,3 @@ +[] +1 +[ 5 ] diff --git a/tests/Eq.hs b/tests/Eq.hs --- a/tests/Eq.hs +++ b/tests/Eq.hs @@ -1,4 +1,4 @@ -import Prelude +module Eq where main = do when (1 == 1) $ putStrLn "Expected ==" diff --git a/tests/ExportEThingAll.hs b/tests/ExportEThingAll.hs --- a/tests/ExportEThingAll.hs +++ b/tests/ExportEThingAll.hs @@ -1,6 +1,5 @@ module ExportEThingAll where -import Prelude import ExportEThingAll_Export main = print Barbles diff --git a/tests/ExportList.hs b/tests/ExportList.hs --- a/tests/ExportList.hs +++ b/tests/ExportList.hs @@ -1,6 +1,5 @@ -module Main (main) where +module ExportList (main) where -import Prelude import ExportList_A import FFI @@ -15,4 +14,3 @@ print $ b1 b print c print d - diff --git a/tests/ExportList_A.hs b/tests/ExportList_A.hs --- a/tests/ExportList_A.hs +++ b/tests/ExportList_A.hs @@ -1,7 +1,6 @@ module ExportList_A (x, A (..), B (B, b1), module ExportList_B) where import ExportList_B -import Prelude x :: Double x = 1 diff --git a/tests/ExportList_B.hs b/tests/ExportList_B.hs --- a/tests/ExportList_B.hs +++ b/tests/ExportList_B.hs @@ -2,7 +2,6 @@ import ExportList_C import ExportList_D -import Prelude y :: Double y = 2 diff --git a/tests/ExportQualified_Export.hs b/tests/ExportQualified_Export.hs --- a/tests/ExportQualified_Export.hs +++ b/tests/ExportQualified_Export.hs @@ -2,8 +2,7 @@ module ExportQualified_Export (main, X.X) where import Prelude - -import "foo" X +import "base" X main :: Fay () main = return () diff --git a/tests/ExportType.hs b/tests/ExportType.hs --- a/tests/ExportType.hs +++ b/tests/ExportType.hs @@ -8,7 +8,6 @@ ) where import FFI -import Prelude data X = X diff --git a/tests/Floating.hs b/tests/Floating.hs --- a/tests/Floating.hs +++ b/tests/Floating.hs @@ -1,4 +1,4 @@ -import Prelude +module Floating where main = do print $ exp 0 diff --git a/tests/FromString.hs b/tests/FromString.hs --- a/tests/FromString.hs +++ b/tests/FromString.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings, RebindableSyntax #-} module FromString where -import Prelude import FromString.FayText import FromString.Dep (myString, depTest) +import Prelude main :: Fay () main = do @@ -12,4 +12,3 @@ putStrLn myString print myString depTest - diff --git a/tests/GADTs_without_records.hs b/tests/GADTs_without_records.hs --- a/tests/GADTs_without_records.hs +++ b/tests/GADTs_without_records.hs @@ -2,14 +2,12 @@ module GADTs_without_records where -import Prelude - data Expr a where I :: Int -> Expr Int Plus :: Expr Int -> Expr Int -> Expr Int B :: Bool -> Expr Bool IfThenElse :: Expr Bool -> Expr a -> Expr a -> Expr a - + false :: Expr Bool false = B False @@ -23,7 +21,7 @@ eval (IfThenElse p e1 e2) = case eval p of True -> eval e1 False -> eval e2 - + n5 = I 5 n2 = I 2 diff --git a/tests/GuardWhere.hs b/tests/GuardWhere.hs --- a/tests/GuardWhere.hs +++ b/tests/GuardWhere.hs @@ -1,4 +1,4 @@ -import Prelude +module GuardWhere where poseL :: Bool -> String poseL y | y == True = "Not OK" diff --git a/tests/HidePreludeImport_Import.hs b/tests/HidePreludeImport_Import.hs --- a/tests/HidePreludeImport_Import.hs +++ b/tests/HidePreludeImport_Import.hs @@ -1,6 +1,4 @@ module HidePreludeImport_Import where -import Prelude - last :: Double last = 1 diff --git a/tests/HierarchicalImport.hs b/tests/HierarchicalImport.hs --- a/tests/HierarchicalImport.hs +++ b/tests/HierarchicalImport.hs @@ -1,6 +1,6 @@ -import Prelude +module HierarchicalImport where + import Hierarchical.Export main :: Fay () main = putStrLn exported - diff --git a/tests/ImplicitPrelude.hs b/tests/ImplicitPrelude.hs new file mode 100644 --- /dev/null +++ b/tests/ImplicitPrelude.hs @@ -0,0 +1,7 @@ +module ImplicitPrelude where + +result :: Int +result = 3 + 4 + +main :: Fay () +main = putStrLn (show result) diff --git a/tests/ImplicitPrelude.res b/tests/ImplicitPrelude.res new file mode 100644 --- /dev/null +++ b/tests/ImplicitPrelude.res @@ -0,0 +1,1 @@ +7 diff --git a/tests/ImportHiding.hs b/tests/ImportHiding.hs --- a/tests/ImportHiding.hs +++ b/tests/ImportHiding.hs @@ -1,4 +1,4 @@ -import Prelude +module ImportHiding where import ImportList1.A hiding (y) import ImportList1.B hiding (x) diff --git a/tests/ImportIThingAll.hs b/tests/ImportIThingAll.hs --- a/tests/ImportIThingAll.hs +++ b/tests/ImportIThingAll.hs @@ -1,4 +1,5 @@ -import Prelude +module ImportIThingAll where + import FFI import ImportList1.C (A (..)) diff --git a/tests/ImportList.hs b/tests/ImportList.hs --- a/tests/ImportList.hs +++ b/tests/ImportList.hs @@ -1,6 +1,5 @@ module ImportList where -import Prelude import FFI import ImportList1.A (x) diff --git a/tests/ImportListType.hs b/tests/ImportListType.hs --- a/tests/ImportListType.hs +++ b/tests/ImportListType.hs @@ -1,3 +1,5 @@ +module ImportListType where + import Prelude (Fay, putStrLn) main :: Fay () diff --git a/tests/ImportType.hs b/tests/ImportType.hs --- a/tests/ImportType.hs +++ b/tests/ImportType.hs @@ -1,4 +1,4 @@ -import Prelude +module ImportType where import ExportType @@ -14,4 +14,3 @@ print w' print (V 1 2) print (v1 (V 1 2)) - diff --git a/tests/ImportType2.hs b/tests/ImportType2.hs --- a/tests/ImportType2.hs +++ b/tests/ImportType2.hs @@ -3,4 +3,5 @@ import ImportType2I.A (foo) import ImportType2I.B (Foo) +main :: Fay () main = foo diff --git a/tests/ImportType2I/A.hs b/tests/ImportType2I/A.hs --- a/tests/ImportType2I/A.hs +++ b/tests/ImportType2I/A.hs diff --git a/tests/ImportType2I/B.hs b/tests/ImportType2I/B.hs --- a/tests/ImportType2I/B.hs +++ b/tests/ImportType2I/B.hs diff --git a/tests/Integer.hs b/tests/Integer.hs new file mode 100644 --- /dev/null +++ b/tests/Integer.hs @@ -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 diff --git a/tests/Integer.res b/tests/Integer.res new file mode 100644 --- /dev/null +++ b/tests/Integer.res @@ -0,0 +1,5 @@ +true +false +false +true +1024 diff --git a/tests/Integral.hs b/tests/Integral.hs --- a/tests/Integral.hs +++ b/tests/Integral.hs @@ -1,4 +1,4 @@ -import Prelude +module Integral where printPair :: (Int,Int) -> Fay () printPair (x,y) = print x >> print y diff --git a/tests/Issue215A.hs b/tests/Issue215A.hs --- a/tests/Issue215A.hs +++ b/tests/Issue215A.hs @@ -1,7 +1,5 @@ module Issue215A where -import Prelude import Issue215.B -main = do - print $ f 2 +main = print $ f 2 diff --git a/tests/Js2FayFunc.hs b/tests/Js2FayFunc.hs --- a/tests/Js2FayFunc.hs +++ b/tests/Js2FayFunc.hs @@ -1,6 +1,8 @@ +module Js2FayFunc where + import FFI -import Prelude +main :: Fay () main = do f <- getF g <- getG diff --git a/tests/JsFunctionPassing.hs b/tests/JsFunctionPassing.hs --- a/tests/JsFunctionPassing.hs +++ b/tests/JsFunctionPassing.hs @@ -1,7 +1,8 @@ {-# LANGUAGE EmptyDataDecls #-} +module JsFunctionPassing where + import FFI -import Prelude data Func diff --git a/tests/LambdaCase.hs b/tests/LambdaCase.hs new file mode 100644 --- /dev/null +++ b/tests/LambdaCase.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE LambdaCase #-} +module LambdaCase where + +f :: Int -> Bool +f = \case + 2 -> True + _ -> False + +main :: Fay () +main = do + print (f 2) diff --git a/tests/LambdaCase.res b/tests/LambdaCase.res new file mode 100644 --- /dev/null +++ b/tests/LambdaCase.res @@ -0,0 +1,1 @@ +true diff --git a/tests/LazyOperators.hs b/tests/LazyOperators.hs --- a/tests/LazyOperators.hs +++ b/tests/LazyOperators.hs @@ -1,7 +1,5 @@ module LazyOperators where -import Prelude - main :: Fay () main = print testFn diff --git a/tests/List.hs b/tests/List.hs --- a/tests/List.hs +++ b/tests/List.hs @@ -1,3 +1,5 @@ +module List where + import FFI import Prelude hiding (take) diff --git a/tests/List2.hs b/tests/List2.hs --- a/tests/List2.hs +++ b/tests/List2.hs @@ -1,6 +1,9 @@ +module List2 where + import FFI import Prelude hiding (take) +main :: Fay () main = putStrLn (showList (take 5 (let ns = 1 : map' (foo 123) ns in ns))) foo :: Double -> Double -> Double diff --git a/tests/ListEq.hs b/tests/ListEq.hs new file mode 100644 --- /dev/null +++ b/tests/ListEq.hs @@ -0,0 +1,7 @@ +module ListEq where + +main :: Fay () +main = do + print $ [] == [] + print $ [1,2,3] == [1,2,3] + print $ ["a"] == ["b"] diff --git a/tests/ListEq.res b/tests/ListEq.res new file mode 100644 --- /dev/null +++ b/tests/ListEq.res @@ -0,0 +1,3 @@ +true +true +false diff --git a/tests/MainThunk.hs b/tests/MainThunk.hs new file mode 100644 --- /dev/null +++ b/tests/MainThunk.hs @@ -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)" diff --git a/tests/MainThunk.res b/tests/MainThunk.res new file mode 100644 --- /dev/null +++ b/tests/MainThunk.res @@ -0,0 +1,3 @@ +Hey ho! +Hello, World! +Hello, World! diff --git a/tests/ModuleReExports.hs b/tests/ModuleReExports.hs --- a/tests/ModuleReExports.hs +++ b/tests/ModuleReExports.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} module ModuleReExports where diff --git a/tests/ModuleRecordClash.hs b/tests/ModuleRecordClash.hs --- a/tests/ModuleRecordClash.hs +++ b/tests/ModuleRecordClash.hs @@ -1,6 +1,5 @@ module ModuleRecordClash (main) where -import Prelude import ModuleRecordClash.R data R = R diff --git a/tests/ModuleRecordClash2.hs b/tests/ModuleRecordClash2.hs --- a/tests/ModuleRecordClash2.hs +++ b/tests/ModuleRecordClash2.hs @@ -1,11 +1,9 @@ -module Main where +module ModuleRecordClash2 where import FFI import ModuleRecordClash2_Hello -import Prelude alert :: String -> Fay () alert = ffi "console.log(%1)" -main = do - alert (greeting defaultHello) +main = alert (greeting defaultHello) diff --git a/tests/ModuleRecordClash2_Hello.hs b/tests/ModuleRecordClash2_Hello.hs --- a/tests/ModuleRecordClash2_Hello.hs +++ b/tests/ModuleRecordClash2_Hello.hs @@ -1,8 +1,6 @@ -- This module needs to be top level to do the intended test. module ModuleRecordClash2_Hello where -import Prelude - defaultHello :: ModuleRecordClash2_Hello defaultHello = ModuleRecordClash2_Hello { greeting = "Hello, world!" } diff --git a/tests/Monad.hs b/tests/Monad.hs --- a/tests/Monad.hs +++ b/tests/Monad.hs @@ -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 - diff --git a/tests/Monad2.hs b/tests/Monad2.hs --- a/tests/Monad2.hs +++ b/tests/Monad2.hs @@ -1,10 +1,7 @@ {-# LANGUAGE EmptyDataDecls #-} - {-# LANGUAGE RankNTypes #-} --- | Monads test. - -import Prelude +module Monad2 where main :: Fay () main = do diff --git a/tests/MultiWayIf.hs b/tests/MultiWayIf.hs new file mode 100644 --- /dev/null +++ b/tests/MultiWayIf.hs @@ -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) diff --git a/tests/MultiWayIf.res b/tests/MultiWayIf.res new file mode 100644 --- /dev/null +++ b/tests/MultiWayIf.res @@ -0,0 +1,3 @@ +a +b +c diff --git a/tests/NestedImporting.hs b/tests/NestedImporting.hs --- a/tests/NestedImporting.hs +++ b/tests/NestedImporting.hs @@ -1,6 +1,4 @@ module NestedImporting where -import Prelude - r :: Double r = 1 diff --git a/tests/NestedImporting2.hs b/tests/NestedImporting2.hs --- a/tests/NestedImporting2.hs +++ b/tests/NestedImporting2.hs @@ -1,6 +1,5 @@ module NestedImporting2 where -import Prelude import NestedImporting2.A main :: Fay () diff --git a/tests/NewtypeImport_Export.hs b/tests/NewtypeImport_Export.hs --- a/tests/NewtypeImport_Export.hs +++ b/tests/NewtypeImport_Export.hs @@ -1,7 +1,6 @@ module NewtypeImport_Export where import FFI -import Prelude newtype MyInteger = MyInteger Int diff --git a/tests/NewtypeImport_Import.hs b/tests/NewtypeImport_Import.hs --- a/tests/NewtypeImport_Import.hs +++ b/tests/NewtypeImport_Import.hs @@ -1,25 +1,26 @@ -import Prelude +module NewtypeImport_Import where + import NewtypeImport_Export x = case MyInteger undefined of - MyInteger _ -> 1 + MyInteger _ -> 1 y = case undefined of - MyInteger _ -> 1 + MyInteger _ -> 1 int :: Int int = undefined yInt = case int of - _ -> 1 + _ -> 1 main = do - print x - print y - print yInt - print (Baz (Bar 1)) - baz <- getBaz - print baz - case baz of - Baz (Bar i) -> print i - print (bar $ unwrapBaz baz) + print x + print y + print yInt + print (Baz (Bar 1)) + baz <- getBaz + print baz + case baz of + Baz (Bar i) -> print i + print (bar $ unwrapBaz baz) diff --git a/tests/Nullable.hs b/tests/Nullable.hs --- a/tests/Nullable.hs +++ b/tests/Nullable.hs @@ -1,5 +1,6 @@ +module Nullable where + import FFI -import Prelude data R = R (Nullable Double) @@ -39,4 +40,4 @@ r2 = ffi "{ instance : 'R', slot1 : null }" parseInt :: String -> Nullable Int -parseInt = ffi "(function () { var n = global.parseInt(%1, 10); if (isNaN(n)) return null; return n; })()" +parseInt = ffi "(function () { var n = parseInt(%1, 10); if (isNaN(n)) return null; return n; })()" diff --git a/tests/Num.hs b/tests/Num.hs --- a/tests/Num.hs +++ b/tests/Num.hs @@ -1,7 +1,6 @@ module Num where -import Prelude - +main :: Fay () main = do print (1 + 2::Int) print (4 - 1::Int) diff --git a/tests/Ord.hs b/tests/Ord.hs --- a/tests/Ord.hs +++ b/tests/Ord.hs @@ -1,7 +1,6 @@ module Ord where -import Prelude - +main :: Fay () main = do when ((1::Int) < 2) $ putStrLn "Expected <" when ((1::Int) < 1) $ putStrLn "Unexpected < (1)" diff --git a/tests/PrefixOpPat.hs b/tests/PrefixOpPat.hs new file mode 100644 --- /dev/null +++ b/tests/PrefixOpPat.hs @@ -0,0 +1,7 @@ +module PrefixOpPat where + +f ((:) x y) = x + +main :: Fay () +main = do + print $ f [1,2] diff --git a/tests/PrefixOpPat.res b/tests/PrefixOpPat.res new file mode 100644 --- /dev/null +++ b/tests/PrefixOpPat.res @@ -0,0 +1,1 @@ +1 diff --git a/tests/QualifiedImport.hs b/tests/QualifiedImport.hs --- a/tests/QualifiedImport.hs +++ b/tests/QualifiedImport.hs @@ -1,7 +1,6 @@ module QualifiedImport where import FFI -import Prelude import qualified QualifiedImport.X import qualified QualifiedImport.X as X diff --git a/tests/Ratio.hs b/tests/Ratio.hs --- a/tests/Ratio.hs +++ b/tests/Ratio.hs @@ -1,6 +1,5 @@ module Ratio where -import Prelude import Data.Ratio main :: Fay () diff --git a/tests/ReExport3.hs b/tests/ReExport3.hs --- a/tests/ReExport3.hs +++ b/tests/ReExport3.hs @@ -1,4 +1,3 @@ -import Prelude import ReExport2 main :: Fay () diff --git a/tests/ReExportGlobally.hs b/tests/ReExportGlobally.hs --- a/tests/ReExportGlobally.hs +++ b/tests/ReExportGlobally.hs @@ -1,7 +1,6 @@ module ReExportGlobally (main, x) where import FFI -import Prelude import ReExportGlobally.A (x) diff --git a/tests/ReExportGloballyExplicit.hs b/tests/ReExportGloballyExplicit.hs --- a/tests/ReExportGloballyExplicit.hs +++ b/tests/ReExportGloballyExplicit.hs @@ -1,7 +1,6 @@ module Foo (main, x) where import FFI -import Prelude import ReExportGlobally.A (x) diff --git a/tests/RealFrac.hs b/tests/RealFrac.hs --- a/tests/RealFrac.hs +++ b/tests/RealFrac.hs @@ -1,5 +1,6 @@ -import Prelude +module RealFrac where +main :: Fay () main = do print $ fst $ properFraction 1.5 print $ snd $ properFraction 1.5 diff --git a/tests/RecCon.hs b/tests/RecCon.hs --- a/tests/RecCon.hs +++ b/tests/RecCon.hs @@ -1,7 +1,8 @@ -import Prelude +module RecCon where data Bool = True | False +main :: Fay () main = print (head (fix (\xs -> 123 : xs))) fix f = let x = f x in x diff --git a/tests/RecDecl.hs b/tests/RecDecl.hs --- a/tests/RecDecl.hs +++ b/tests/RecDecl.hs @@ -1,5 +1,6 @@ +module RecDecl where + import FFI -import Prelude data R = R { i :: Double, c :: Char } data S = S Double Char diff --git a/tests/RecordImport2_Export1.hs b/tests/RecordImport2_Export1.hs --- a/tests/RecordImport2_Export1.hs +++ b/tests/RecordImport2_Export1.hs @@ -1,5 +1,5 @@ module RecordImport2_Export1 (main) where -import Prelude + data R = R { wrong :: Double } main :: Fay () diff --git a/tests/RecordImport2_Export2.hs b/tests/RecordImport2_Export2.hs --- a/tests/RecordImport2_Export2.hs +++ b/tests/RecordImport2_Export2.hs @@ -1,3 +1,3 @@ module RecordImport2_Export2 where -import Prelude + data R = R { correct :: Double } diff --git a/tests/RecordImport2_Import.hs b/tests/RecordImport2_Import.hs --- a/tests/RecordImport2_Import.hs +++ b/tests/RecordImport2_Import.hs @@ -1,6 +1,5 @@ module RecordExport where -import Prelude import FFI import RecordImport2_Export1 import RecordImport2_Export2 diff --git a/tests/RecordImport_Export.hs b/tests/RecordImport_Export.hs --- a/tests/RecordImport_Export.hs +++ b/tests/RecordImport_Export.hs @@ -2,7 +2,5 @@ module RecordImport_Export where -import Prelude - data R = R Integer data Fields = Fields { fieldFoo :: Integer, fieldBar :: Integer } diff --git a/tests/RecordImport_Import.hs b/tests/RecordImport_Import.hs --- a/tests/RecordImport_Import.hs +++ b/tests/RecordImport_Import.hs @@ -1,6 +1,7 @@ {- NOTE: This file is also used in the Compile tests. -} -import Prelude +module RecordImport_Import where + import RecordImport_Export f :: R -> R diff --git a/tests/Sink.hs b/tests/Sink.hs --- a/tests/Sink.hs +++ b/tests/Sink.hs @@ -1,12 +1,10 @@ -- https://github.com/faylang/fay/issues/285 -module Main where +module Sink where -import Prelude import FFI run :: Fay () -run = do - runSink (Sink putStrLn) "hello" +run = runSink (Sink putStrLn) "hello" newtype Sink a = Sink { runSink :: a -> Fay () } diff --git a/tests/SkipLetTypes.hs b/tests/SkipLetTypes.hs --- a/tests/SkipLetTypes.hs +++ b/tests/SkipLetTypes.hs @@ -1,6 +1,5 @@ -import Prelude +module SkipLetType where main = let t :: Bool t = True in print t - diff --git a/tests/SkipWhereTypes.hs b/tests/SkipWhereTypes.hs --- a/tests/SkipWhereTypes.hs +++ b/tests/SkipWhereTypes.hs @@ -1,7 +1,6 @@ -import Prelude +module SkipWhereTypes where main = print t where t :: Bool t = True - diff --git a/tests/String.hs b/tests/String.hs deleted file mode 100644 --- a/tests/String.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Prelude - -main = putStrLn "Hello, World!" - diff --git a/tests/String.res b/tests/String.res deleted file mode 100644 --- a/tests/String.res +++ /dev/null @@ -1,1 +0,0 @@ -Hello, World! diff --git a/tests/StringForcing.hs b/tests/StringForcing.hs --- a/tests/StringForcing.hs +++ b/tests/StringForcing.hs @@ -1,6 +1,5 @@ module StringForcing where -import Prelude import FFI main = do diff --git a/tests/Strings.hs b/tests/Strings.hs new file mode 100644 --- /dev/null +++ b/tests/Strings.hs @@ -0,0 +1,3 @@ +module Strings where + +main = putStrLn "Hello, World!" diff --git a/tests/Strings.res b/tests/Strings.res new file mode 100644 --- /dev/null +++ b/tests/Strings.res @@ -0,0 +1,1 @@ +Hello, World! diff --git a/tests/T190.hs b/tests/T190.hs --- a/tests/T190.hs +++ b/tests/T190.hs @@ -1,7 +1,5 @@ module T190 where -import Prelude - import T190_B import T190_C diff --git a/tests/T190_A.hs b/tests/T190_A.hs --- a/tests/T190_A.hs +++ b/tests/T190_A.hs @@ -1,6 +1,4 @@ module T190_A where -import Prelude - foo :: Int -> Fay () foo _ = putStrLn "WRONG!" diff --git a/tests/T190_B.hs b/tests/T190_B.hs --- a/tests/T190_B.hs +++ b/tests/T190_B.hs @@ -1,6 +1,5 @@ module T190_B where -import Prelude import T190_A main :: Fay () diff --git a/tests/T190_C.hs b/tests/T190_C.hs --- a/tests/T190_C.hs +++ b/tests/T190_C.hs @@ -1,6 +1,4 @@ module T190_C where -import Prelude - foo :: String -> Fay () foo x = putStrLn x diff --git a/tests/TextOrd.hs b/tests/TextOrd.hs new file mode 100644 --- /dev/null +++ b/tests/TextOrd.hs @@ -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)) diff --git a/tests/TextOrd.res b/tests/TextOrd.res new file mode 100644 --- /dev/null +++ b/tests/TextOrd.res @@ -0,0 +1,4 @@ +true +true +true +false diff --git a/tests/Trace.hs b/tests/Trace.hs new file mode 100644 --- /dev/null +++ b/tests/Trace.hs @@ -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 diff --git a/tests/Trace.res b/tests/Trace.res new file mode 100644 --- /dev/null +++ b/tests/Trace.res @@ -0,0 +1,13 @@ +fac +5 +fac +4 +fac +3 +fac +2 +fac +1 +fac +0 +120 diff --git a/tests/TupleCalls.hs b/tests/TupleCalls.hs --- a/tests/TupleCalls.hs +++ b/tests/TupleCalls.hs @@ -1,5 +1,6 @@ +module TupleCalls where + import FFI -import Prelude f :: (Int,Double) -> Double f = ffi "%1[0]+%1[1]" @@ -10,10 +11,10 @@ h :: (String,Int) -> (Int,String) h = ffi "[%1[0]['length'],'#'+%1[1]['toString']()+'#']" +main :: Fay () main = do print $ f (1,2.3) print $ fst (g 8.76) print $ snd (g 8.76) print $ fst (h ("abc",12)) putStrLn $ snd (h ("abc",12)) - diff --git a/tests/TyVarSerialization.hs b/tests/TyVarSerialization.hs --- a/tests/TyVarSerialization.hs +++ b/tests/TyVarSerialization.hs @@ -1,6 +1,5 @@ module TyVarSerialization where -import Prelude import FFI main :: Fay () diff --git a/tests/Var.hs b/tests/Var.hs new file mode 100644 --- /dev/null +++ b/tests/Var.hs @@ -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) diff --git a/tests/Var.res b/tests/Var.res new file mode 100644 --- /dev/null +++ b/tests/Var.res @@ -0,0 +1,5 @@ +v changed: 4 +v changed: 9 +s signalled: 567 +ref: 123 +ref(2): 666 diff --git a/tests/VarPtr.hs b/tests/VarPtr.hs new file mode 100644 --- /dev/null +++ b/tests/VarPtr.hs @@ -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 diff --git a/tests/VarPtr.res b/tests/VarPtr.res new file mode 100644 --- /dev/null +++ b/tests/VarPtr.res @@ -0,0 +1,2 @@ +5 +10 diff --git a/tests/WhenUnlessRecursion.hs b/tests/WhenUnlessRecursion.hs new file mode 100644 --- /dev/null +++ b/tests/WhenUnlessRecursion.hs @@ -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) diff --git a/tests/WhenUnlessRecursion.res b/tests/WhenUnlessRecursion.res new file mode 100644 --- /dev/null +++ b/tests/WhenUnlessRecursion.res @@ -0,0 +1,3 @@ +loopIf +loopWhen +loopUnless diff --git a/tests/asPatternMatch.hs b/tests/asPatternMatch.hs --- a/tests/asPatternMatch.hs +++ b/tests/asPatternMatch.hs @@ -1,4 +1,4 @@ -import Prelude +module AsPatternMatch where matchSame :: [a] -> ([a],[a]) matchSame x@y = (x,y) diff --git a/tests/automatic.hs b/tests/automatic.hs --- a/tests/automatic.hs +++ b/tests/automatic.hs @@ -1,4 +1,5 @@ -import Prelude +module Automatic where + import FFI func :: Bool -> Int -> Int -> Int @@ -19,4 +20,3 @@ print' (semiAutomatic func False) print' (automatic func True) print' (automatic func False) - diff --git a/tests/baseFixities.hs b/tests/baseFixities.hs --- a/tests/baseFixities.hs +++ b/tests/baseFixities.hs @@ -1,4 +1,4 @@ -import Prelude +module BaseFixities where fmap :: (a -> b) -> Fay a -> Fay b fmap f m = m >>= (return . f) diff --git a/tests/basicFunctions.hs b/tests/basicFunctions.hs --- a/tests/basicFunctions.hs +++ b/tests/basicFunctions.hs @@ -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 - diff --git a/tests/case.hs b/tests/case.hs --- a/tests/case.hs +++ b/tests/case.hs @@ -1,6 +1,5 @@ -import Prelude +module Case where main = putStrLn (case True of True -> "Hello!" False -> "Ney!") - diff --git a/tests/case2.hs b/tests/case2.hs --- a/tests/case2.hs +++ b/tests/case2.hs @@ -1,6 +1,5 @@ -import Prelude +module Case2 where main = putStrLn (case False of True -> "Hello!" False -> "Ney!") - diff --git a/tests/case3.hs b/tests/case3.hs new file mode 100644 --- /dev/null +++ b/tests/case3.hs @@ -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) diff --git a/tests/case3.res b/tests/case3.res new file mode 100644 --- /dev/null +++ b/tests/case3.res @@ -0,0 +1,3 @@ +1 +2 +3 diff --git a/tests/caseList.hs b/tests/caseList.hs --- a/tests/caseList.hs +++ b/tests/caseList.hs @@ -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.") - diff --git a/tests/caseWildcard.hs b/tests/caseWildcard.hs --- a/tests/caseWildcard.hs +++ b/tests/caseWildcard.hs @@ -1,6 +1,5 @@ -import Prelude +module CaseWildcard where main = putStrLn (case False of True -> "Hello!" _ -> "Ney!") - diff --git a/tests/circular.hs b/tests/circular.hs --- a/tests/circular.hs +++ b/tests/circular.hs @@ -1,7 +1,5 @@ module Circular where -import Prelude - main :: Fay () main = let y = x + 1::Double x = y + 1 diff --git a/tests/curry.hs b/tests/curry.hs --- a/tests/curry.hs +++ b/tests/curry.hs @@ -1,4 +1,4 @@ -import Prelude +module Curry where f :: Int -> Int -> Int f x y = x + y diff --git a/tests/cycle.hs b/tests/cycle.hs --- a/tests/cycle.hs +++ b/tests/cycle.hs @@ -1,3 +1,4 @@ -import Prelude +module Cycle where +main :: Fay () main = mapM_ putStrLn (take 5 (cycle ["a", "b", "c"])) diff --git a/tests/do.hs b/tests/do.hs --- a/tests/do.hs +++ b/tests/do.hs @@ -1,4 +1,4 @@ -import Prelude +module Do where +main :: Fay () main = do putStrLn "Hello,"; putStrLn "World!" - diff --git a/tests/doAssingPatternMatch.hs b/tests/doAssingPatternMatch.hs --- a/tests/doAssingPatternMatch.hs +++ b/tests/doAssingPatternMatch.hs @@ -1,6 +1,6 @@ -import Prelude +module DoAssingPatternMatch where +main :: Fay () main = do [1,2] <- return [1,2] putStrLn "OK." - diff --git a/tests/doBindAssign.hs b/tests/doBindAssign.hs --- a/tests/doBindAssign.hs +++ b/tests/doBindAssign.hs @@ -1,6 +1,6 @@ -import Prelude +module DoBindAssign where +main :: Fay () main = do x <- return "Hello, World!" >>= return putStrLn x - diff --git a/tests/doLet.hs b/tests/doLet.hs --- a/tests/doLet.hs +++ b/tests/doLet.hs @@ -1,4 +1,4 @@ -import Prelude +module DoLet where main = do first @@ -7,6 +7,7 @@ fourth fifth sixth + newtyp first = do let x = 123 @@ -44,3 +45,10 @@ print y print x +newtype I = I Int +newtyp = do + putStrLn "newtype" + I i <- return (I 1) + print i + let I j = I 2 + print j diff --git a/tests/doLet.res b/tests/doLet.res --- a/tests/doLet.res +++ b/tests/doLet.res @@ -11,3 +11,6 @@ 10 777 123 +newtype +1 +2 diff --git a/tests/emptyMain.hs b/tests/emptyMain.hs --- a/tests/emptyMain.hs +++ b/tests/emptyMain.hs @@ -1,3 +1,4 @@ -import Prelude +module EmptyMain where +main :: Fay () main = return () diff --git a/tests/enumFrom.hs b/tests/enumFrom.hs --- a/tests/enumFrom.hs +++ b/tests/enumFrom.hs @@ -1,4 +1,4 @@ -import Prelude +module EnumFrom where main :: Fay () main = do diff --git a/tests/error.hs b/tests/error.hs --- a/tests/error.hs +++ b/tests/error.hs @@ -1,3 +1,3 @@ -import Prelude +module Error where main = error "This is an error" diff --git a/tests/ffiExpr.hs b/tests/ffiExpr.hs --- a/tests/ffiExpr.hs +++ b/tests/ffiExpr.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} -module Main where +module FfiExpr where -import Prelude import FFI main :: Fay () diff --git a/tests/ffimunging.hs b/tests/ffimunging.hs --- a/tests/ffimunging.hs +++ b/tests/ffimunging.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Maybe where +module FfiMunging where import FFI -import Prelude data Munge a b = Fudge a b diff --git a/tests/fix.hs b/tests/fix.hs --- a/tests/fix.hs +++ b/tests/fix.hs @@ -1,5 +1,6 @@ -import Prelude +module Fix where +main :: Fay () main = print (head (tail (fix (\xs -> 123 : xs)))) fix f = let x = f x in x diff --git a/tests/fromInteger.hs b/tests/fromInteger.hs --- a/tests/fromInteger.hs +++ b/tests/fromInteger.hs @@ -1,4 +1,4 @@ -import Prelude +module FromInteger where main :: Fay () main = putStrLn $ show $ fromInteger 5 diff --git a/tests/fromIntegral.hs b/tests/fromIntegral.hs --- a/tests/fromIntegral.hs +++ b/tests/fromIntegral.hs @@ -1,4 +1,7 @@ -import Prelude +module FromIntegral where main :: Fay () -main = putStrLn $ show $ fromIntegral 5 +main = print $ fromIntegral' 5 + +fromIntegral' :: Int -> Double +fromIntegral' = fromIntegral diff --git a/tests/guards.hs b/tests/guards.hs --- a/tests/guards.hs +++ b/tests/guards.hs @@ -1,4 +1,4 @@ -import Prelude +module Guards where f :: Int -> Int f n | n <= 0 = 0 diff --git a/tests/infixDataConst.hs b/tests/infixDataConst.hs --- a/tests/infixDataConst.hs +++ b/tests/infixDataConst.hs @@ -1,4 +1,4 @@ -import Prelude +module InfixDataConst where data Ty1 = Integer `InfixConst1` Integer diff --git a/tests/ints.hs b/tests/ints.hs --- a/tests/ints.hs +++ b/tests/ints.hs @@ -1,5 +1,5 @@ -import Prelude +module Ints where +main :: Fay () main = do - print 123 - + print (123 :: Int) diff --git a/tests/linesAndWords.hs b/tests/linesAndWords.hs --- a/tests/linesAndWords.hs +++ b/tests/linesAndWords.hs @@ -1,7 +1,8 @@ -import Prelude +module LinesAndWords where quote s = "\"" ++ s ++ "\"" +main :: Fay () main = do mapM_ (putStrLn . quote) $ words " this is\ta\n\r\ftest " putStrLn $ quote $ unwords ["this", "is", "too"] diff --git a/tests/listComprehensions.hs b/tests/listComprehensions.hs --- a/tests/listComprehensions.hs +++ b/tests/listComprehensions.hs @@ -1,4 +1,4 @@ -import Prelude +module ListComprehensions where main :: Fay () main = putStrLn $ show $ sum [ x*x | x <- [1::Int, 2, 3, 4, 5], let y = x + 4, y < 8] diff --git a/tests/listlen.hs b/tests/listlen.hs --- a/tests/listlen.hs +++ b/tests/listlen.hs @@ -1,7 +1,6 @@ module Listlen (main) where import FFI -import Prelude -- Test provided by ticket go :: [Double] -> [Double] diff --git a/tests/mutableReference.hs b/tests/mutableReference.hs --- a/tests/mutableReference.hs +++ b/tests/mutableReference.hs @@ -1,9 +1,7 @@ --- | Mutable references. - -{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE EmptyDataDecls #-} +module MutableReference where import FFI -import Prelude main :: Fay () main = do diff --git a/tests/nameGen.hs b/tests/nameGen.hs --- a/tests/nameGen.hs +++ b/tests/nameGen.hs @@ -1,4 +1,4 @@ -import Prelude +module NameGen where data SomeRec = SomeRec { a :: Integer, b :: Integer } | Y | X @@ -12,4 +12,3 @@ putStrLn $ case t of SomeRec _ _ -> "Bad" Y -> "OK." - diff --git a/tests/namedFieldPuns.hs b/tests/namedFieldPuns.hs --- a/tests/namedFieldPuns.hs +++ b/tests/namedFieldPuns.hs @@ -1,9 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} +module NamedFieldPuns where import FFI -import Prelude -data SomeRec = SomeRec { a :: Integer, b :: Integer } | Y | X +data SomeRec = SomeRec { a :: Int, b :: Int } | Y | X fun :: SomeRec -> SomeRec fun SomeRec{a} = SomeRec{a=a+1, b=10} diff --git a/tests/negation.hs b/tests/negation.hs --- a/tests/negation.hs +++ b/tests/negation.hs @@ -1,8 +1,9 @@ -import Prelude +module Negation where print' :: Double -> Fay () print' = print +main :: Fay () main = do print' $ (-7/2) print' $ (-7)/2 print' $ -f x/y diff --git a/tests/newtype.hs b/tests/newtype.hs --- a/tests/newtype.hs +++ b/tests/newtype.hs @@ -1,5 +1,6 @@ +module Newtype where + import FFI -import Prelude newtype MyInteger = MyInteger Int @@ -21,13 +22,30 @@ getBaz :: Fay Baz getBaz = ffi "{ instance: 'Bar', bar: 1 }" +getBazExpr = ffi "{ instance: 'Bar', bar : 2 }" :: Fay Baz + +getBazExpr' = f (Baz (Bar 2)) (ffi "{ instance: 'Bar', bar : 3 }" :: Baz) +f :: Baz -> Baz -> Baz +f (Baz x) (Baz y) = Baz (Bar (bar x + bar y)) + + main = do print x print y print yInt print (Baz (Bar 1)) + baz <- getBaz print baz - case baz of - Baz (Bar i) -> print i + case baz of Baz (Bar i) -> print i print (bar $ unwrapBaz baz) + + bazExpr <- getBazExpr + print bazExpr + case bazExpr of Baz (Bar i) -> print i + print (bar $ unwrapBaz bazExpr) + + let bazExpr' = getBazExpr' + print bazExpr' + case bazExpr' of Baz (Bar i) -> print i + print (bar $ unwrapBaz bazExpr') diff --git a/tests/newtype.res b/tests/newtype.res --- a/tests/newtype.res +++ b/tests/newtype.res @@ -5,3 +5,9 @@ { instance: 'Bar', bar: 1 } 1 1 +{ instance: 'Bar', bar: 2 } +2 +2 +{ instance: 'Bar', bar: 5 } +5 +5 diff --git a/tests/newtypeIndirectApp.hs b/tests/newtypeIndirectApp.hs --- a/tests/newtypeIndirectApp.hs +++ b/tests/newtypeIndirectApp.hs @@ -1,6 +1,4 @@ -module Main where - -import Prelude +module NewtypeIndirectApp where newtype Parser a = Parser { runParser :: Char -> Either Char (a, Char) } diff --git a/tests/numTheory.hs b/tests/numTheory.hs --- a/tests/numTheory.hs +++ b/tests/numTheory.hs @@ -1,4 +1,4 @@ -import Prelude +module NumTheory where main = do print $ (subtract 3 5 :: Int) diff --git a/tests/nums.hs b/tests/nums.hs --- a/tests/nums.hs +++ b/tests/nums.hs @@ -1,5 +1,4 @@ -import Prelude +module Nums where main :: Fay () main = print (-10 :: Double) - diff --git a/tests/pats.hs b/tests/pats.hs --- a/tests/pats.hs +++ b/tests/pats.hs @@ -1,4 +1,4 @@ -import Prelude +module Pats where main :: Fay () main = do diff --git a/tests/patternGuards.hs b/tests/patternGuards.hs --- a/tests/patternGuards.hs +++ b/tests/patternGuards.hs @@ -1,9 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} --- | As pattern matches +module PatternGuards where import FFI -import Prelude isPositive :: Double -> Bool isPositive x | x > 0 = True diff --git a/tests/patternMatchFail.hs b/tests/patternMatchFail.hs --- a/tests/patternMatchFail.hs +++ b/tests/patternMatchFail.hs @@ -1,4 +1,4 @@ -import Prelude +module PatternMatchFail where +main :: Fay () main = putStrLn ((\a 'a' -> "OK.") 0 'b') - diff --git a/tests/patternMatchLet.hs b/tests/patternMatchLet.hs new file mode 100644 --- /dev/null +++ b/tests/patternMatchLet.hs @@ -0,0 +1,10 @@ +module PatternMatchLet where + +first3 :: String -> Fay () +first3 cs = do + let (a:b:c:_) = cs + putStrLn [a, b, c] + +main :: Fay () +main = first3 "abcd" + diff --git a/tests/patternMatchLet.res b/tests/patternMatchLet.res new file mode 100644 --- /dev/null +++ b/tests/patternMatchLet.res @@ -0,0 +1,1 @@ +abc diff --git a/tests/patternMatchingTuples.hs b/tests/patternMatchingTuples.hs --- a/tests/patternMatchingTuples.hs +++ b/tests/patternMatchingTuples.hs @@ -1,8 +1,4 @@ --- compile with fay --html-wrapper --- error thrown as soon as HTML page is loaded: --- Uncaught TypeError: Cannot read property 'car' of null - -import Prelude +module PatternMatchingTuples where main :: Fay () main = putStrLn doTest diff --git a/tests/recordFunctionPatternMatch.hs b/tests/recordFunctionPatternMatch.hs --- a/tests/recordFunctionPatternMatch.hs +++ b/tests/recordFunctionPatternMatch.hs @@ -1,11 +1,11 @@ -import Prelude +module RecordFunctionPatternMatch where data Person = Person String String Int +main :: Fay () main = putStrLn (foo (Person "Chris" "Done" 14)) foo (Person "Chris" "Done" 13) = "Foo!" foo (Person "Chris" "Barf" 14) = "Bar!" foo (Person "Chris" "Done" 14) = "Hello!" foo _ = "World!" - diff --git a/tests/recordPatternMatch.hs b/tests/recordPatternMatch.hs --- a/tests/recordPatternMatch.hs +++ b/tests/recordPatternMatch.hs @@ -1,8 +1,7 @@ -import Prelude +module RecordPatternMatch where data Person = Person String String Int main = putStrLn (case Person "Chris" "Done" 14 of Person "Chris" "Done" 13 -> "Hello!" _ -> "World!") - diff --git a/tests/recordPatternMatch2.hs b/tests/recordPatternMatch2.hs --- a/tests/recordPatternMatch2.hs +++ b/tests/recordPatternMatch2.hs @@ -1,4 +1,4 @@ -import Prelude +module RecordPatternMatch2 where data Person = Person String String Int @@ -7,4 +7,3 @@ Person "Chris" "Barf" 14 -> "Bar!" Person "Chris" "Done" 14 -> "Hello!" _ -> "World!") - diff --git a/tests/recordUseBeforeDefine.hs b/tests/recordUseBeforeDefine.hs --- a/tests/recordUseBeforeDefine.hs +++ b/tests/recordUseBeforeDefine.hs @@ -1,4 +1,4 @@ -import Prelude +module RecordUseBeforeDefine where import Hierarchical.RecordDefined @@ -10,4 +10,3 @@ print $ g (Callback 1) data R = R Double - diff --git a/tests/recordWildCards.hs b/tests/recordWildCards.hs --- a/tests/recordWildCards.hs +++ b/tests/recordWildCards.hs @@ -1,8 +1,9 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} +module RecordWildCards where + import FFI -import Prelude data C = C { a :: Int, b :: Int, c :: Int, d :: Int } diff --git a/tests/records.hs b/tests/records.hs --- a/tests/records.hs +++ b/tests/records.hs @@ -1,4 +1,4 @@ -import Prelude +module Records where data Person1 = Person1 String String Int data Person2 = Person2 { fname :: String, sname :: String, age :: Int } @@ -14,4 +14,3 @@ putStrLn (case p2 of Person2 "Chris" "Done" 13 -> "Hello!") putStrLn (case p2a of Person2 "Chris" "Done" 13 -> "Hello!") putStrLn (case p3 of Person3 "Chris" "Done" 13 -> "Hello!") - diff --git a/tests/recursive.hs b/tests/recursive.hs --- a/tests/recursive.hs +++ b/tests/recursive.hs @@ -1,6 +1,4 @@ -module Main where - -import Prelude +module Recursive where ones :: [Int] ones = 1 : ones diff --git a/tests/reservedWords.hs b/tests/reservedWords.hs --- a/tests/reservedWords.hs +++ b/tests/reservedWords.hs @@ -1,6 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} -import Prelude +module ReservedWords where main = do -- All reserved words @@ -43,4 +43,3 @@ putStrLn "" -- Stdlib functions that need to be encoded putStrLn $ const "stdconst" 2 - diff --git a/tests/sections.hs b/tests/sections.hs --- a/tests/sections.hs +++ b/tests/sections.hs @@ -1,7 +1,5 @@ module Sections where -import Prelude - withTwo :: (Int -> Int) -> Int withTwo f = f 2 diff --git a/tests/seq-fake.hs b/tests/seq-fake.hs --- a/tests/seq-fake.hs +++ b/tests/seq-fake.hs @@ -1,4 +1,4 @@ -import Prelude +module SeqFake where fakeSeq :: a -> b -> b fakeSeq x y = y diff --git a/tests/seq.hs b/tests/seq.hs --- a/tests/seq.hs +++ b/tests/seq.hs @@ -1,3 +1,3 @@ -import Prelude +module Seq where main = error "You shall not pass!" `seq` return () diff --git a/tests/serialization.hs b/tests/serialization.hs --- a/tests/serialization.hs +++ b/tests/serialization.hs @@ -1,4 +1,5 @@ -import Prelude +module Serialization where + import FFI data Parametric a = Parametric a @@ -10,8 +11,8 @@ printMaybeConcrete (Just (ConcreteRecord 42)) printMaybeAutomatic (Just (ConcreteRecord 42)) printMaybe (Just (ConcreteRecord 42)) - printUnknown (error "do not want") - printUnknownField (Just (error "do not want")) + printUnknown 42 + printUnknownField (Just 42) printAutomatic (Just (ConcreteRecord 42)) printParametricButConcreteType :: Parametric ConcreteRecord -> Fay () diff --git a/tests/serialization.res b/tests/serialization.res --- a/tests/serialization.res +++ b/tests/serialization.res @@ -3,15 +3,14 @@ { instance: 'Parametric', slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Parametric', - slot1: { forced: false, value: [Function] } } + slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just', - slot1: { forced: false, value: [Function] } } -{ forced: false, value: [Function] } -{ instance: 'Just', - slot1: { forced: false, value: [Function] } } + slot1: { instance: 'ConcreteRecord', concreteField: 42 } } +42 +{ instance: 'Just', slot1: 42 } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } } diff --git a/tests/succPred.hs b/tests/succPred.hs --- a/tests/succPred.hs +++ b/tests/succPred.hs @@ -1,4 +1,4 @@ -import Prelude +module SuccPred where main = do print (succ 1 :: Int) diff --git a/tests/tailRecursion.hs b/tests/tailRecursion.hs --- a/tests/tailRecursion.hs +++ b/tests/tailRecursion.hs @@ -1,5 +1,5 @@ -- | This is to test tail-recursive calls are iterative. -import Prelude +module TailRecursion where main = do print (sumTo 1000 0 :: Double) diff --git a/tests/then.hs b/tests/then.hs --- a/tests/then.hs +++ b/tests/then.hs @@ -1,4 +1,3 @@ -import Prelude +module Then where main = putStrLn "Hello," >> putStrLn "World!" - diff --git a/tests/tupleCon.hs b/tests/tupleCon.hs --- a/tests/tupleCon.hs +++ b/tests/tupleCon.hs @@ -1,4 +1,4 @@ -import Prelude +module TupleCon where main = do print $ (,) 1 2 diff --git a/tests/tupleSec.hs b/tests/tupleSec.hs --- a/tests/tupleSec.hs +++ b/tests/tupleSec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE TupleSections #-} -import Prelude +module TupleSec where main = do print $ (,2) 1 diff --git a/tests/unit.hs b/tests/unit.hs --- a/tests/unit.hs +++ b/tests/unit.hs @@ -1,4 +1,5 @@ -import Prelude +module Unit where + main = case (f ()) of () -> print 123 diff --git a/tests/utf8.hs b/tests/utf8.hs --- a/tests/utf8.hs +++ b/tests/utf8.hs @@ -1,8 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} --- | Unicode test. - -import Prelude +module Utf8 where main :: Fay () main = do @@ -131,4 +129,3 @@ putStrLn "ﹰ ﹱ ﹲ ﹴ ﹶ ﹷ ﹸ ﹹ ﹺ ﹻ ﹼ ﹽ ﹾ ﹿ ﺀ ﺁ ﺂ ﺃ ﺄ ﺅ ﺆ ﺇ ﺈ ﺉ ﺊ ﺋ ﺌ ﺍ ﺎ ﺏ ﺐ ﺑ ﺒ ﺓ ﺔ ﺕ ﺖ ﺗ ﺘ ﺙ ﺚ ﺛ ﺜ ﺝ ﺞ ﺟ ﺠ ﺡ ﺢ ﺣ ﺤ ﺥ ﺦ ﺧ ﺨ ﺩ ﺪ ﺫ ﺬ ﺭ ﺮ ﺯ ﺰ ﺱ ﺲ ﺳ ﺴ ﺵ ﺶ ﺷ ﺸ ﺹ ﺺ ﺻ ﺼ ﺽ ﺾ ﺿ ﻀ ﻁ ﻂ ﻃ ﻄ ﻅ ﻆ ﻇ ﻈ ﻉ ﻊ ﻋ ﻌ ﻍ ﻎ ﻏ ﻐ ﻑ ﻒ ﻓ ﻔ ﻕ ﻖ ﻗ ﻘ ﻙ ﻚ ﻛ ﻜ ﻝ ﻞ ﻟ ﻠ ﻡ ﻢ ﻣ ﻤ ﻥ ﻦ ﻧ ﻨ ﻩ ﻪ ﻫ ﻬ ﻭ ﻮ ﻯ ﻰ ﻱ ..." -- Halfwidth and Fullwidth Forms putStrLn "！ ＂ ＃ ＄ ％ ＆ ＇ （ ） ＊ ＋ ， － ． ／ ０ １ ２ ３ ４ ５ ６ ７ ８ ９ ： ； ＜ ＝ ＞ ？ ＠ Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ Ｉ Ｊ Ｋ Ｌ Ｍ Ｎ Ｏ Ｐ Ｑ Ｒ Ｓ Ｔ Ｕ Ｖ Ｗ Ｘ Ｙ Ｚ ［ ＼ ］ ＾ ＿ ｀ ａ ｂ ｃ ｄ ｅ ｆ ｇ ｈ ｉ ｊ ｋ ｌ ｍ ｎ ｏ ｐ ｑ ｒ ｓ ｔ ｕ ｖ ｗ ｘ ｙ ｚ ｛ ｜ ｝ ～ ｡ ｢ ｣ ､ ･ ｦ ｧ ｨ ｩ ｪ ｫ ｬ ｭ ｮ ｯ ｰ ｱ ｲ ｳ ｴ ｵ ｶ ｷ ｸ ｹ ｺ ｻ ｼ ｽ ｾ ｿ ﾀ ﾁ ﾂ ..." - diff --git a/tests/where.hs b/tests/where.hs --- a/tests/where.hs +++ b/tests/where.hs @@ -1,6 +1,5 @@ -import Prelude +module Where where main = putStrLn $ "Hello " ++ friends ++ family where friends = "my friends" family = " and family" - diff --git a/tests/whereBind.hs b/tests/whereBind.hs --- a/tests/whereBind.hs +++ b/tests/whereBind.hs @@ -1,4 +1,4 @@ -import Prelude +module WhereBind where main :: Fay () main = diff --git a/tests/whereBind2.hs b/tests/whereBind2.hs --- a/tests/whereBind2.hs +++ b/tests/whereBind2.hs @@ -1,4 +1,4 @@ -import Prelude +module WhereBind2 where someFun :: Int -> String someFun x = fun x diff --git a/tests/whereBind3.hs b/tests/whereBind3.hs --- a/tests/whereBind3.hs +++ b/tests/whereBind3.hs @@ -1,4 +1,4 @@ -import Prelude +module WhereBind3 where f :: String -> String f x = friends ++ family @@ -6,4 +6,3 @@ family = " and family" main = putStrLn (f "my friends") -