fay 0.21.2 → 0.24.2.0
raw patch · 95 files changed
Files
- CHANGELOG.md +157/−0
- Setup.hs +2/−16
- examples/D3TreeSample.hs +96/−0
- examples/D3TreeSample.html +18/−0
- examples/calc.hs +3/−3
- fay.cabal +76/−35
- js/runtime.js +0/−818
- src/Fay.hs +41/−36
- src/Fay/Compiler.hs +17/−15
- src/Fay/Compiler/Decl.hs +27/−8
- src/Fay/Compiler/Desugar.hs +7/−4
- src/Fay/Compiler/Desugar/Name.hs +1/−1
- src/Fay/Compiler/Desugar/Types.hs +10/−6
- src/Fay/Compiler/Exp.hs +20/−9
- src/Fay/Compiler/FFI.hs +15/−10
- src/Fay/Compiler/GADT.hs +3/−5
- src/Fay/Compiler/Import.hs +7/−7
- src/Fay/Compiler/InitialPass.hs +7/−6
- src/Fay/Compiler/Misc.hs +17/−17
- src/Fay/Compiler/ModuleT.hs +134/−0
- src/Fay/Compiler/Optimizer.hs +4/−3
- src/Fay/Compiler/Packages.hs +17/−6
- src/Fay/Compiler/Parse.hs +1/−1
- src/Fay/Compiler/Pattern.hs +5/−5
- src/Fay/Compiler/Prelude.hs +20/−22
- src/Fay/Compiler/PrimOp.hs +1/−1
- src/Fay/Compiler/Print.hs +152/−229
- src/Fay/Compiler/QName.hs +1/−1
- src/Fay/Compiler/State.hs +1/−1
- src/Fay/Compiler/Typecheck.hs +16/−2
- src/Fay/Config.hs +14/−5
- src/Fay/Convert.hs +17/−17
- src/Fay/Exts.hs +1/−1
- src/Fay/Exts/NoAnnotation.hs +1/−1
- src/Fay/Exts/Scoped.hs +2/−2
- src/Fay/Runtime.hs +842/−0
- src/Fay/Types.hs +57/−65
- src/Fay/Types/CompileError.hs +2/−3
- src/Fay/Types/Js.hs +2/−1
- src/Fay/Types/ModulePath.hs +1/−1
- src/Fay/Types/Printer.hs +140/−0
- src/haskell-names/LICENSE +3/−0
- src/haskell-names/Language/Haskell/Names.hs +17/−0
- src/haskell-names/Language/Haskell/Names/Annotated.hs +100/−0
- src/haskell-names/Language/Haskell/Names/Exports.hs +144/−0
- src/haskell-names/Language/Haskell/Names/GetBound.hs +157/−0
- src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs +114/−0
- src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot +10/−0
- src/haskell-names/Language/Haskell/Names/Imports.hs +274/−0
- src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs +34/−0
- src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs +161/−0
- src/haskell-names/Language/Haskell/Names/Open/Base.hs +152/−0
- src/haskell-names/Language/Haskell/Names/Open/Derived.hs +88/−0
- src/haskell-names/Language/Haskell/Names/Open/Instances.hs +361/−0
- src/haskell-names/Language/Haskell/Names/RecordWildcards.hs +145/−0
- src/haskell-names/Language/Haskell/Names/Recursive.hs +132/−0
- src/haskell-names/Language/Haskell/Names/ScopeUtils.hs +87/−0
- src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs +136/−0
- src/haskell-names/Language/Haskell/Names/Types.hs +293/−0
- src/main/Main.hs +61/−44
- src/tests/Test/CommandLine.hs +3/−1
- src/tests/Test/Compile.hs +48/−7
- src/tests/Test/Desugar.hs +17/−11
- src/tests/Test/Util.hs +0/−12
- src/tests/Tests.hs +57/−32
- tests/Compile/StrictWrapper.hs +46/−1
- tests/Compile/StrictWrapper.res +8/−0
- tests/Compile/pretty.hs +9/−0
- tests/Compile/pretty.res +7/−0
- tests/Compile/prettyOperators.hs +9/−0
- tests/Compile/prettyOperators.res +7/−0
- tests/Compile/prettyThunks.hs +9/−0
- tests/Compile/prettyThunks.res +7/−0
- tests/ExportQualified_Export.hs +1/−1
- tests/ImportType2I/A.hs +0/−0
- tests/ImportType2I/B.hs +0/−0
- tests/ListEq.hs +7/−0
- tests/ListEq.res +3/−0
- tests/Nullable.hs +1/−1
- tests/String.hs +0/−3
- tests/String.res +0/−1
- tests/Strings.hs +3/−0
- tests/Strings.res +1/−0
- tests/TextOrd.hs +15/−0
- tests/TextOrd.res +4/−0
- tests/VarPtr.hs +11/−0
- tests/VarPtr.res +2/−0
- tests/WhenUnlessRecursion.hs +22/−0
- tests/WhenUnlessRecursion.res +3/−0
- tests/doLet.hs +9/−0
- tests/doLet.res +3/−0
- tests/patternMatchLet.hs +10/−0
- tests/patternMatchLet.res +1/−0
- tests/serialization.hs +2/−2
- tests/serialization.res +4/−5
CHANGELOG.md view
@@ -2,6 +2,163 @@ See full history at: <https://github.com/faylang/fay/commits> +### 0.24.2.0 (2021-01-10)++* Drop GHC 8.0 support.+* Cabal upgraded to 2.0 spec-version.+* Travis CI refactored to allow cabal-install 3.2.0.0 builds.++### 0.24.1.1 (2021-01-08)++* Relax boundaries for aeson, tasty, base-compat. Allow builds for Gentoo (#469).++### 0.24.1.0 (2020-03-26)++* GHC 8.10.1 support.++#### 0.24.0.5 (2020-03-10)++* GHC 8.8 support.++#### 0.24.0.4 (2019-12-03)++* Fixes stack nix integration broken.++#### 0.24.0.3 (2019-04-29)++* Dependency updates including GHC-8.6 support.+* Added stack compatibility.++#### 0.24.0.2++* Fix dependent compilation fail when building project with stack (#457).++#### 0.24.0.1++* Dependency updates incl GHC 8.4 support++## 0.24.0.0++* Add the option to generate typescript output, thanks to Junji Hashimoto.++### 0.23.2.0++* GHC 8.2 support+* Use traverse-with-class 1.0.*, and as a result drop support for GHC < 8.++#### 0.23.1.16++* Fix build on GHC 7.4++#### 0.23.1.15++* Allow optparse-applicative 0.13.*.++#### 0.23.1.14++* Fix a compilation error introduced in 0.23.1.13.++#### 0.23.1.13++* Add support for haskell-src-exts 1.18.1.++#### 0.23.1.12++* Fix compilation on GHC < 7.8.++#### 0.23.1.11++* Tighten some impossible lower bounds we can't support.++#### 0.23.1.10++* Don't compile with `-fprof-auto` by default.++#### 0.23.1.9++* Allow and require `haskell-src-exts 1.17.*`++#### 0.23.1.8++* Allow `vector 0.11.*`++#### 0.23.1.7++* Fix panic when compiling irrefutable pattern matches on lists (thanks Christopher Parks)++#### 0.23.1.6++* Allow `syb 0.5.*`++#### 0.23.1.5++* Allow `aeson 0.9.*`++#### 0.23.1.4++* Fix compilation on at least GHC 7.6 (maybe older versions as well...)++#### 0.23.1.3++* Inline parts of `haskell-names 0.4.1` and `haskell-packages` to drop transitive dependencies on Cabal and other packages.++#### 0.23.1.2++* Allow filepath 1.4.*++#### 0.23.1.1++* Allow do let bindings of newtypes.++### 0.23.1.0++* Add `--show-ghc-calls` and `configShowGhcCalls` to print invocations to GHC.++#### 0.23.0.1++* Allow `mtl-compat 0.2.*` and `transformers-compat 0.4.*"`.++## 0.23.0.0++New features:++* GHC 7.10 support+* Add a `--pretty-operators` flag to replace the escaped operator names with their actual names - By Michal Seweryn+* Add a `--pretty-all` flag that enables `--pretty`, `--pretty-operators`, and `--pretty-thunks` - By Michal Seweryn+* De/serialize type variables as 'automatic'. You no longer have to annotate FFI functions with Automatic, this is now the default. If you need the old behavior, use Ptr. For most existing cases this change shouldn't change anything. - By Zachary Mason++Example output with `--pretty-all`:+```javascript+Main.main = new $(function(){+ return _(_(Prelude["$"])(Prelude.print))(_(_(Prelude["++"])(Main.g))(Fay$$list("b")));+});+```+++API changes - By Michal Seweryn:++* Export CompileResult from Fay.Types+* Export PrintReader and PrintWriter, and reducing number of PrintState fields (these are moved to PrinterReader and PrintWriter)+* In the meanwhile PrintWriter field type changed - output is now stored as ShowS - tests run faster now+* Replace monadic functions (askP, getP, ...) with higher level ones: indented, askIf, newline, write, mapping. askIf is pretty much like previous askP, but works like if-then-else.+* Internally we are now using `ExceptT` instead of `ErrorT`. This fixes deprecation warnings when using `transformers 0.4.*`.++Bug fixes:+* Defer automatic_function fayToJs call until after argument application - by Zachary Mason++Dependency bumps:+* Allow `utf8-string 1.0.*`+* Allow `time == 1.5.*`++## 0.22.0.0++* Add a `--pretty-thunks` flag and compiler option that replaces `Fay$$_` and `Fay$$$` with `_` and `$` respectively. Consider this a development flag since it may clash with JS libraries (notably jQuery and underscore)+* Allow `language-ecmascript 0.17.*`++#### 0.21.2.1 (2014-11-10)++* Hide all packages by default when typechecking. This avoids conflicting with packages that haven't been specified on the command-line with `--package`, e.g. the `text` package when you import `Data.Text`.+ ### 0.21.2 (2014-10-21) * Previously all package imports were ignored, now we only ignore `"base"` package imports.
Setup.hs view
@@ -7,24 +7,10 @@ import Distribution.PackageDescription import Distribution.Simple -main = do+main = defaultMainWithHooks simpleUserHooks- { preConf = \_args _flags -> do putStrLn reminder- return emptyHookedBuildInfo- , postInst = (\_ _ _ _ -> putStrLn fayBaseReminder)+ { postInst = \_ _ _ _ -> putStrLn fayBaseReminder }--reminder =- " \n\- \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n\- \ \n\- \ REMEMBER: This compiler is in flux, supercalifragelistic style. You should \n\- \ read the CHANGELOG for this release as the changes probably \n\- \ affect you. \n\- \ \n\- \ \n\- \ \n\- \- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -\n" fayBaseReminder = " \n\
+ examples/D3TreeSample.hs view
@@ -0,0 +1,96 @@+module D3TreeSample where++import FFI+import Data.Char++data Event+data D3SvgCanvas+data D3SvgDiagonal+data D3SvgLink+data D3SvgNode+data D3LayoutTree+data D3LayoutTreeNodes+data D3LayoutTreeLinks++--------- D3: A JavaScript visualization library for HTML and SVG. http://d3js.org+--------- Usage example with Fay++--------- JSON FEED++data JsonTree = JsonNode { name :: String, children :: JsonForest }+type JsonForest = [JsonTree]++unfoldTree :: (Int -> (String, [Int])) -> Int -> JsonTree+unfoldTree f b = let (a, bs) = f b in JsonNode a (unfoldForest f bs)++unfoldForest :: (Int -> (String, [Int])) -> [Int] -> JsonForest+unfoldForest f = map (unfoldTree f)++createJson :: Int -> JsonTree+createJson = unfoldTree (\n -> ([chr (n + ord 'a')], replicate n (n-1)))++--------- FFI++addWindowEvent :: String -> (Event -> Fay ()) -> Fay ()+addWindowEvent = ffi "window.addEventListener(%1, %2)"++createSvgCanvas :: Int -> Int -> Fay D3SvgCanvas+createSvgCanvas = ffi "d3.select('#viz')\+ \.append('svg:svg').attr('width', %1).attr('height', %2)\+ \.append('svg:g').attr('transform', 'translate(40, 40)')"++createTree :: Int -> Int -> Fay D3LayoutTree+createTree = ffi "d3.layout.tree().size([%1,%2])"++createDiagonal :: Fay D3SvgDiagonal+createDiagonal = ffi "d3.svg.diagonal().projection(function(d) { return [d.x, d.y]; })"++createNodes :: D3LayoutTree -> JsonTree -> Fay D3LayoutTreeNodes+createNodes = ffi "%1.nodes(%2)"++createLinks :: D3LayoutTree -> D3LayoutTreeNodes -> Fay D3LayoutTreeLinks+createLinks = ffi "%1.links(%2)"++displayLinks :: D3SvgCanvas -> D3LayoutTreeLinks -> D3SvgDiagonal -> Fay D3SvgLink+displayLinks = ffi "%1.selectAll('pathlink').data(%2)\+ \.enter().append('svg:path')\+ \.attr('class', 'link')\+ \.attr('d', %3)"++displayNodes :: D3SvgCanvas -> D3LayoutTreeNodes -> Fay D3SvgNode+displayNodes = ffi "%1.selectAll('g.node').data(%2)\+ \.enter().append('svg:g')\+ \.attr('transform', \+ \function(d) { return 'translate(' + d.x + ',' + d.y + ')'; })"++addDotToNodes :: D3SvgNode -> Double -> Fay ()+addDotToNodes = ffi "%1.append('svg:circle').attr('r', %2)"++addTextToNodes :: D3SvgNode -> Fay()+addTextToNodes = ffi "%1.append('svg:text')\+ \.attr('dx', function(d) { return d.children ? -8 : 8; })\+ \.attr('dy', 3)\+ \.attr('text-anchor', function(d) { return d.children ? 'end' : 'start'; })\+ \.text(function(d) { return d.name; })"++--------- START++d3TreeSample :: Event -> Fay()+d3TreeSample event = do+ svgCanvas <- createSvgCanvas 800 600+ d3Tree <- createTree 600 300+ diagonal <- createDiagonal++ nodes <- createNodes d3Tree (createJson 4)+ links <- createLinks d3Tree nodes++ svgLink <- displayLinks svgCanvas links diagonal+ svgNode <- displayNodes svgCanvas nodes++ addDotToNodes svgNode 2.5+ addTextToNodes svgNode+++main :: Fay ()+main = do+ addWindowEvent "load" d3TreeSample
+ examples/D3TreeSample.html view
@@ -0,0 +1,18 @@+<!doctype html>+<html>+ <head>+ <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>+ <script src="https://cdnjs.cloudflare.com/ajax/libs/d3/3.5.5/d3.min.js" charset="utf-8"></script>+ <script type="text/javascript" src="D3TreeSample.js"></script>+ <style>+ .link {+ fill: none;+ stroke: #ccc;+ stroke-width: 2.5px;+ }+ </style>+ </head>+ <body>+ <div id="viz"></div>+ </body>+</html>
examples/calc.hs view
@@ -32,7 +32,7 @@ return () else do setVal (show n) display writeRef appendMore True)- getInput = getVal display >>= (return . parseDouble 10)+ getInput = getVal display >>= (return . parseDouble) operator op = do calculate num <- getInput@@ -104,8 +104,8 @@ -------------------------------------------------------------------------------- -- Utilities -parseDouble :: Int -> String -> Double-parseDouble = ffi "parseFloat(%2,%1) || 0"+parseDouble :: String -> Double+parseDouble = ffi "parseFloat(%1) || 0" -------------------------------------------------------------------------------- -- Refs
fay.cabal view
@@ -1,5 +1,6 @@+cabal-version: 2.0 name: fay-version: 0.21.2+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,@@ -22,14 +23,14 @@ copyright: 2012 Chris Done, Adam Bergmark category: Development, Web, Fay build-type: Custom-cabal-version: >=1.8+Tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.3 data-files:- js/runtime.js src/Fay/FFI.hs extra-source-files: CHANGELOG.md LICENSE README.md+ src/haskell-names/LICENSE -- Examples examples/*.hs examples/*.html@@ -71,9 +72,19 @@ manual: True default: False +custom-setup+ setup-depends:+ base+ , Cabal+ library+ default-language: Haskell2010 ghc-options: -O2 -Wall- hs-source-dirs: src+ hs-source-dirs:+ src+ src/haskell-names+ autogen-modules:+ Paths_fay exposed-modules: Fay Fay.Compiler@@ -97,6 +108,7 @@ Fay.Compiler.Import Fay.Compiler.InitialPass Fay.Compiler.Misc+ Fay.Compiler.ModuleT Fay.Compiler.Optimizer Fay.Compiler.Packages Fay.Compiler.Pattern@@ -108,53 +120,80 @@ 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 && < 4.8- , aeson > 0.6 && < 0.9- , bytestring < 0.11- , containers < 0.6- , data-default < 0.6- , directory < 1.3- , filepath < 1.4- , ghc-paths < 0.2- , haskell-names >= 0.3.1 && < 0.5- , haskell-packages == 0.2.3.1 || > 0.2.3.2 && < 0.3- , haskell-src-exts >= 1.16 && < 1.17- , language-ecmascript >= 0.15 && < 0.17- , mtl < 2.3- , process < 1.3- , safe < 0.4- , sourcemap < 0.2- , split < 0.3- , spoon < 0.4- , syb < 0.5- , text < 1.3- , time >= 1 && < 1.5- , transformers >= 0.3 && < 0.4 || > 0.4.1 && < 0.5+ 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.3- , utf8-string < 0.4- , vector < 0.11+ , 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 , mtl- , optparse-applicative == 0.11.*+ , optparse-applicative >= 0.11 && < 0.16 , split+ other-modules:+ Paths_fay executable fay-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 if flag(test)@@ -164,18 +203,20 @@ Test.Convert Test.Desugar Test.Util+ Paths_fay build-depends: base , aeson , attoparsec , bytestring+ , containers , directory , fay , filepath- , groom == 0.1.* , haskell-src-exts- , tasty >= 0.9 && < 0.11- , tasty-hunit >= 0.8 && < 0.10+ , random >= 1.0 && < 1.3+ , tasty >= 0.9 && < 1.5+ , tasty-hunit >= 0.8 && < 0.11 , tasty-th == 0.1.* , text , utf8-string
− js/runtime.js
@@ -1,818 +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" && 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,x){- return ref.value;-}--/*******************************************************************************- * Dates.- */-function Fay$$date(str){- return window.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(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(var len = exceptions.length, i = 0; i < len; i++) {- (function(exception) {- window.setTimeout(function() { throw exception; }, 0);- })(exceptions[i]);- }- }-}--function Fay$$setValue(self, val, force){- if (self instanceof Fay$$Ref2) {- self.val = val;- } else if (self instanceof Fay$$Var) {- self.val = val;- Fay$$broadcastInternal(self, val, force);- } else if (self instanceof Fay$$Sig) {- Fay$$broadcastInternal(self, val, force);- } else {- throw "Fay$$setValue given something that's not a Ref2, Var, or Sig"- }-}--function Fay$$subscribe(self, f){- var key = {};- self.handlers.push([key,f]);- var searchStart = self.handlers.length - 1;- return function(_){- for(var i = Math.min(searchStart, self.handlers.length - 1); i >= 0; i--) {- if(self.handlers[i][0] == key) {- self.handlers = self.handlers.slice(0,i).concat(self.handlers.slice(i+1));- return;- }- }- return _; // This variable has to be used, otherwise Closure- // strips it out and Fay serialization breaks.- };-}--/*******************************************************************************- * Application code.- */
src/Fay.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -18,27 +18,27 @@ ,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.Prelude import Fay.Compiler.Typecheck import Fay.Config+import Fay.Runtime import qualified Fay.Exts as F import Fay.Types-import Fay.Types.CompileResult import Data.Aeson (encode) import qualified Data.ByteString.Lazy as L-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@@ -117,9 +117,8 @@ -- 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 @@ -128,30 +127,31 @@ -> Config -> String -> (F.Module -> Compile [JsStmt]) -> String -> IO (Either CompileError (String,Maybe [Mapping],CompileState)) compileToModule filepath config raw with hscode = do- result <- compileViaStr filepath config printState with hscode+ result <- compileViaStr filepath config with hscode return $ case result of Left err -> Left err- Right (ps,state,_) ->- Right ( generateWrapped (concat . reverse $ psOutput ps)- (stateModuleName state)- , if null (psMappings ps) then Nothing else Just (psMappings ps)+ Right (printer,state@CompileState{ stateModuleName = (ModuleName _ modulename) },_) ->+ Right ( 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,true);"- ]- else ""- ]- printState = defaultPrintState- { 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@@ -159,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@@ -201,9 +207,8 @@ -- | Get the JS runtime source. -- This will return the user supplied runtime if it exists.-getConfigRuntime :: Config -> IO String-getConfigRuntime cfg = maybe getRuntime return $ configRuntimePath cfg---- | Get the default JS runtime source.-getRuntime :: IO String-getRuntime = getDataFileName "js/runtime.js"+readConfigRuntime :: Config -> IO String+readConfigRuntime cfg =+ case configRuntimePath cfg of+ Just path -> readFile path+ Nothing -> return $ getRuntimeSource cfg
src/Fay/Compiler.hs view
@@ -42,12 +42,12 @@ import qualified Fay.Exts.NoAnnotation as N import Fay.Types -import Control.Monad.Error-import Control.Monad.RWS-import Control.Monad.State+import Control.Monad.Except (throwError)+import Control.Monad.RWS (gets, modify)+ import qualified Data.Set as S-import Language.Haskell.Exts.Annotated hiding (name)-import Language.Haskell.Names+import Language.Haskell.Exts hiding (name)+import Language.Haskell.Names (annotateModule) -------------------------------------------------------------------------------- -- Top level entry points@@ -57,16 +57,15 @@ :: FilePath -> Config- -> PrintState -> (F.Module -> Compile [JsStmt]) -> String- -> IO (Either CompileError (PrintState,CompileState,CompileWriter))-compileViaStr filepath cfg printState with from = do+ -> IO (Either CompileError (Printer,CompileState,CompileWriter))+compileViaStr filepath cfg with from = do rs <- defaultCompileReader cfg runTopCompile rs defaultCompileState (parseResult (throwError . uncurry ParseError)- (fmap (\x -> execState (runPrinter (printJS x)) printState) . with)+ (fmap (mconcat . map printJS) . with) (parseFay filepath from)) -- | Compile the top-level Fay module.@@ -122,7 +121,7 @@ -- | Compile a parse HSE module. compileModuleFromAST :: ([JsStmt], [JsStmt]) -> F.Module -> Compile ([JsStmt], [JsStmt]) compileModuleFromAST (hstmts0, fstmts0) mod'@Module{} = do- mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod'+ ~mod@(Module _ _ pragmas _ decls) <- annotateModule Haskell2010 defaultExtensions mod' let modName = unAnn $ F.moduleName mod modify $ \s -> s { stateUseFromString = hasLanguagePragmas ["OverloadedStrings", "RebindableSyntax"] pragmas }@@ -154,16 +153,19 @@ 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]
src/Fay/Compiler/Decl.hs view
@@ -21,10 +21,12 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Error-import Control.Monad.RWS-import Language.Haskell.Exts.Annotated hiding (binds, loc, name)+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 = fmap concat . mapM (compileDecl toplevel)@@ -98,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@@ -149,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@@ -194,10 +208,15 @@ (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
src/Fay/Compiler/Desugar.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE MonoLocalBinds #-}+ module Fay.Compiler.Desugar ( desugar , desugar'@@ -14,21 +16,21 @@ import Fay.Compiler.Desugar.Name import Fay.Compiler.Desugar.Types import Fay.Compiler.Misc (ffiExp, hasLanguagePragma)-import Fay.Compiler.QName (unname, unQual)+import Fay.Compiler.QName (unQual, unname) import Fay.Exts.NoAnnotation (unAnn) import Fay.Types (CompileError (..)) -import Control.Monad.Error+import Control.Monad.Except (throwError) import Control.Monad.Reader (asks) import qualified Data.Generics.Uniplate.Data as U-import Language.Haskell.Exts.Annotated hiding (binds, loc, name)+import Language.Haskell.Exts hiding (binds, loc, name) -- | Top level, desugar a whole module possibly returning errors desugar :: (Data l, Typeable l) => l -> Module l -> IO (Either CompileError (Module l)) desugar = desugar' "$gen" -- | Desugar with the option to specify a prefix for generated names.--- Useful if you want to provide valid haskell name that HSE can print.+-- 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@@ -47,6 +49,7 @@ >>= return . desugarInfixOp >>= return . desugarInfixPat >>= return . desugarExpParen+{-# ANN desugar' "HLint: ignore Use <$>" #-} -- | (a `f`) => \b -> a `f` b -- (`f` b) => \a -> a `f` b
src/Fay/Compiler/Desugar/Name.hs view
@@ -9,7 +9,7 @@ import Fay.Compiler.Desugar.Types import Control.Monad.Reader (asks, local)-import Language.Haskell.Exts.Annotated (Name (..))+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.
src/Fay/Compiler/Desugar/Types.hs view
@@ -1,19 +1,23 @@--- | The transformer stack used during desugaring.+{-# 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.Compiler.Prelude- import Fay.Types (CompileError (..)) -import Control.Monad.Error+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad.Except import Control.Monad.Reader data DesugarReader l = DesugarReader@@ -24,7 +28,7 @@ newtype Desugar l a = Desugar { unDesugar :: (ReaderT (DesugarReader l)- (ErrorT CompileError IO))+ (ExceptT CompileError IO)) a } deriving ( MonadReader (DesugarReader l) , MonadError CompileError@@ -36,4 +40,4 @@ runDesugar :: String -> l -> Desugar l a -> IO (Either CompileError a) runDesugar tmpNamePrefix emptyAnnotation m =- runErrorT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))+ runExceptT (runReaderT (unDesugar m) (DesugarReader 0 emptyAnnotation tmpNamePrefix))
src/Fay/Compiler/Exp.hs view
@@ -27,11 +27,11 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Error (throwError)+import Control.Monad.Except (throwError) import Control.Monad.RWS (asks, gets) import qualified Data.Char as Char-import Language.Haskell.Exts.Annotated hiding (alt, binds, name, op)-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@@ -187,14 +187,21 @@ exp <- compileExp e withScopedTmpJsName $ \tmpName -> do 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]@@ -220,7 +227,7 @@ <*> 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 @@ -237,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@@ -283,7 +294,7 @@ 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]@@ -291,7 +302,7 @@ exp <- compileExp value return [JsSetProp (JsNameVar $ withIdent lowerFirst $ unQualify o) (JsNameVar $ unQualify field) exp] updateStmt o (FieldWildcard (wildcardFields -> fields)) =- return $ for fields $ \fieldName -> JsSetProp (JsNameVar . withIdent lowerFirst . unQualify . unAnn $ o)+ 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 ..))
src/Fay/Compiler/FFI.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-}@@ -17,20 +18,20 @@ 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.Monad.Error-import Control.Monad.Writer+import Control.Monad.Except (throwError)+import Control.Monad.Writer (tell) import Data.Generics.Schemes-import Language.ECMAScript3.Parser as JS+import Language.ECMAScript3.Parser as JS import Language.ECMAScript3.Syntax-import Language.Haskell.Exts.Annotated (SrcSpanInfo, prettyPrint)-import Language.Haskell.Exts.Annotated.Syntax+import Language.Haskell.Exts (SrcSpanInfo, prettyPrint)+import Language.Haskell.Exts.Syntax -- | Compile an FFI expression (also used when compiling top level definitions). compileFFIExp :: SrcSpanInfo -> Maybe (Name a) -> String -> S.Type -> Compile JsExp@@ -55,7 +56,11 @@ TyParArray _ t -> TyParArray () <$> rmNewtys t TyEquals _ t1 t2 -> TyEquals () <$> rmNewtys t1 <*> rmNewtys t2 TySplice {} -> return $ unAnn typ- TyBang _ bt t -> TyBang () (unAnn bt) <$> rmNewtys t+ 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"+ compileFFI' :: N.Type -> Compile JsExp compileFFI' sig = do let name = fromMaybe "<exp>" nameopt
src/Fay/Compiler/GADT.hs view
@@ -4,18 +4,16 @@ (convertGADT ) where -import Language.Haskell.Exts.Annotated hiding (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 Nothing typ ->+ GadtDecl s name tyvars context Nothing typ -> QualConDecl s tyvars context (ConDecl s name (convertFunc typ))- GadtDecl s name (Just fs) _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 -> [Type a] convertFunc (TyCon _ _) = [] convertFunc (TyFun _ x xs) = x : convertFunc xs
src/Fay/Compiler/Import.hs view
@@ -7,8 +7,8 @@ -- 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.Prelude@@ -20,9 +20,9 @@ import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -import Control.Monad.Error-import Control.Monad.RWS-import Language.Haskell.Exts.Annotated hiding (name, var)+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 @@ -34,7 +34,7 @@ -- | Compile a module compileWith- :: Monoid a+ :: (Monoid a, Semigroup a) => FilePath -> (a -> F.Module -> Compile a) -> (FilePath -> String -> Compile a)@@ -50,7 +50,7 @@ st (parseResult (throwError . uncurry ParseError) (\mod' -> do- mod@(Module _ _ _ imports _) <-+ ~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 }
src/Fay/Compiler/InitialPass.hs view
@@ -19,11 +19,11 @@ import Fay.Exts.NoAnnotation (unAnn) import Fay.Types -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 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 ()@@ -51,7 +51,7 @@ preprocessAST :: () -> F.Module -> Compile () preprocessAST () mod@(Module _ _ _ _ decls) = do -- This can only return one element since we only compile one module.- ([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod]+ ~([exports],_) <- HN.getInterfaces Haskell2010 defaultExtensions [mod] modify $ \s -> s { stateInterfaces = M.insert (stateModuleName s) exports $ stateInterfaces s } forM_ decls scanTypeSigs forM_ decls scanRecordDecls@@ -85,12 +85,13 @@ 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 ty _ctx (F.declHeadName -> name) qualcondecls _deriv -> do- let addIt = let ns = for qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl)+ let addIt = let ns = flip fmap qualcondecls (\(QualConDecl _loc' _tyvarbinds _ctx' condecl) -> conDeclName condecl) in addRecordTypeState name ns case ty of DataType{} -> addIt
src/Fay/Compiler/Misc.hs view
@@ -10,25 +10,25 @@ import Fay.Compiler.Prelude +import Fay.Compiler.ModuleT (runModuleT) import Fay.Compiler.PrimOp-import Fay.Compiler.QName (unname)+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 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.Monad.Error-import Control.Monad.RWS-import qualified Data.Map as M-import Data.Version (parseVersion)-import Distribution.HaskellSuite.Modules-import Language.Haskell.Exts.Annotated hiding (name)-import Language.Haskell.Names+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@@ -268,11 +268,11 @@ -> 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') shouldBeDesugared :: (Functor f, Show (f ())) => f l -> Compile a shouldBeDesugared = throwError . ShouldBeDesugared . show . unAnn@@ -282,7 +282,7 @@ hasLanguagePragmas pragmas modulePragmas = (== length pragmas) . length . filter (`elem` pragmas) $ flattenPragmas modulePragmas where flattenPragmas :: [ModulePragma l] -> [String]- flattenPragmas ps = concatMap pragmaName ps+ flattenPragmas = concatMap pragmaName pragmaName (LanguagePragma _ q) = map unname q pragmaName _ = []
+ src/Fay/Compiler/ModuleT.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Fay.Compiler.ModuleT+ (+ -- * Module monad+ -- | When you need to resolve modules, you work in a 'ModuleT' monad (or+ -- another monad that is an instance of 'MonadModule') and use the+ -- 'getModuleInfo' function.+ --+ -- It finds an installed module by its name and reads (and caches) its+ -- info from the info file. Then you run a 'ModuleT' monadic action+ -- using 'evalModuleT' or 'runModuleT'.+ --+ -- To run a 'ModuleT' action you'll also need to provide the set of+ -- packages (represented by their 'InstalledPackageInfo') in which to+ -- search for modules. You can get such a set from either+ -- 'getInstalledPackages' or 'readPackagesInfo', depending on your use+ -- case.+ ModuleT+ , getModuleInfo+ , runModuleT+ , MonadModule (..)+ -- * Module names+ , ModName (..)+ ) where++import Fay.Compiler.Prelude++import Control.Monad.Reader+import Control.Monad.State+import qualified Data.Char as Char (isAlphaNum, isUpper)+import qualified Data.Map as Map++-- ModuleName extracted from Cabal, (c) 2008 Duncan Coutts, Licensed as BSD3+newtype ModuleName = ModuleName [String]+ deriving (Eq, Ord, Show)++fromString :: String -> ModuleName+fromString string+ | all validModuleComponent components' = ModuleName components'+ | otherwise = error $ "ModuleName.fromString: invalid module name " ++ show string++ where+ components' = split string++ split cs = case break (=='.') cs of+ (chunk,[]) -> [chunk]+ (chunk,_:rest) -> chunk : split rest++ validModuleComponent :: String -> Bool+ validModuleComponent [] = False+ validModuleComponent (c:cs) = Char.isUpper c+ && all validModuleChar cs++ validModuleChar :: Char -> Bool+ validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''+++-- | This class defines the interface that is used by 'getModuleInfo', so+-- that you can use it in monads other than 'ModuleT'.+--+-- You don't typically have to define your own instances of this class, but+-- here are a couple of cases when you might:+--+-- * A pure (non-'MonadIO') mockup module monad for testing purposes+--+-- * A transformer over 'ModuleT'+--+-- * You need a more complex way to retrieve the module info+class Monad m => MonadModule m where+ -- | The type of module info+ type ModuleInfo m+ lookupInCache :: ModName n => n -> m (Maybe (ModuleInfo m))+ insertInCache :: ModName n => n -> ModuleInfo m -> m ()++ -- | Read the module info, given a list of search paths and the module+ -- name+ readModuleInfo :: ModName n => [FilePath] -> n -> m (ModuleInfo m)++-- | Different libraries (Cabal, haskell-src-exts, ...) use different types+-- to represent module names. Hence this class.+class ModName n where+ modToString :: n -> String++instance ModName String where+ modToString = id++-- | Convert module name from arbitrary representation to Cabal's one+convertModuleName :: ModName n => n -> ModuleName+convertModuleName = fromString . modToString++-- | Tries to find the module in the current set of packages, then find the+-- module's info file, and reads and caches its contents.+--+-- Returns 'Nothing' if the module could not be found in the current set of+-- packages. If the module is found, but something else goes wrong (e.g.+-- there's no info file for it), an exception is thrown.+getModuleInfo :: (MonadModule m, ModName n) => n -> m (Maybe (ModuleInfo m))+getModuleInfo = lookupInCache++-- | A standard module monad transformer.+--+-- @i@ is the type of module info, @m@ is the underlying monad.+newtype ModuleT i m a =+ ModuleT+ (StateT (Map.Map ModuleName i)+ (ReaderT ([FilePath] -> ModuleName -> m i) m) a)+ deriving (Functor, Applicative, Monad)++instance MonadTrans (ModuleT i) where+ lift = ModuleT . lift . lift++instance MonadIO m => MonadIO (ModuleT i m) where+ liftIO = ModuleT . liftIO++instance (Functor m, Monad m) => MonadModule (ModuleT i m) where+ type ModuleInfo (ModuleT i m) = i+ lookupInCache n = ModuleT $ Map.lookup (convertModuleName n) <$> get+ insertInCache n i = ModuleT $ modify $ Map.insert (convertModuleName n) i+ readModuleInfo dirs mod' =+ lift =<< ModuleT ask <*> pure dirs <*> pure (convertModuleName mod')++-- | Run a 'ModuleT' action+runModuleT+ :: (Monad m, Monoid i)+ => ModuleT i m a -- ^ the monadic action to run+ -> m (a, Map.Map ModuleName i)+ -- ^ return value, plus all cached module infos (that is, the initial set+ -- plus all infos that have been read by the action itself)+runModuleT (ModuleT a) =+ runReaderT (runStateT a Map.empty) (\_ _ -> return mempty)
src/Fay/Compiler/Optimizer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-}@@ -12,10 +13,10 @@ import Fay.Compiler.Misc import Fay.Types -import Control.Monad.State-import Control.Monad.Writer+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 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
src/Fay/Compiler/Packages.hs view
@@ -1,7 +1,6 @@-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-} -- | Dealing with Cabal packages in Fay's own special way.- module Fay.Compiler.Packages where import Fay.Compiler.Prelude@@ -13,6 +12,7 @@ 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.@@ -56,12 +56,23 @@ describePackage :: Maybe FilePath -> String -> IO String describePackage db name = do exists <- doesFileExist ghc_pkg- result <- readAllFromProcess (if exists then ghc_pkg else "ghc-pkg") args ""+ 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 ++ "\n" ++ out Right (_err,out) -> return out-- where args = ["describe",name] ++ ["-f" ++ db' | Just db' <- [db]] -- | Get the package version from the package description. packageVersion :: String -> Maybe String
src/Fay/Compiler/Parse.hs view
@@ -3,7 +3,7 @@ , defaultExtensions ) where -import Language.Haskell.Exts.Annotated hiding (name)+import Language.Haskell.Exts -- | Parse some Fay code. parseFay :: Parseable ast => FilePath -> String -> ParseResult ast
src/Fay/Compiler/Pattern.hs view
@@ -15,10 +15,10 @@ import qualified Fay.Exts.Scoped as S import Fay.Types -import Control.Monad.Error-import Control.Monad.Reader-import Language.Haskell.Exts.Annotated hiding (name)-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]@@ -47,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
src/Fay/Compiler/Prelude.hs view
@@ -1,49 +1,51 @@ -- | 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 -- Partial+ ( module Prelude.Compat -- Partial -- * Control modules , module Control.Applicative , module Control.Arrow -- Partial- , module Control.Monad+ , module Control.Monad.Compat -- * Data modules- , module Data.Char -- Partial- , module Data.Data -- Partial+ , module Data.Char -- Partial+ , module Data.Data -- Partial , module Data.Either , module Data.Function- , module Data.List -- Partial+ , module Data.List.Compat -- Partial , module Data.Maybe- , module Data.Monoid -- Partial+ , module Data.Monoid -- Partial , module Data.Ord+ , module Data.Traversable -- * Safe , module Safe -- * Additions , anyM- , for , io , readAllFromProcess ) where import Control.Applicative-import Control.Arrow (first, second, (&&&), (***), (+++), (|||))-import Control.Monad hiding (guard)-import Data.Char hiding (GeneralCategory (..))-import Data.Data (Data (..), Typeable)+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 hiding (delete)+import Data.Function (on)+import Data.List.Compat import Data.Maybe-import Data.Monoid (Monoid (..), (<>))+import Data.Monoid (Monoid (..)) import Data.Ord-import Prelude hiding (exp, mod)+import Data.Traversable+import Prelude.Compat hiding (exp, mod) import Safe -import Control.Monad.Error+import Control.Monad.Except hiding (filterM) import System.Exit import System.Process @@ -52,12 +54,8 @@ io = liftIO -- | 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---- | Flip of map.-for :: (Functor f) => f a -> (a -> b) -> f b-for = flip fmap+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))
src/Fay/Compiler/PrimOp.hs view
@@ -29,7 +29,7 @@ import Data.Map (Map) import qualified Data.Map as M-import Language.Haskell.Exts.Annotated hiding (binds, name)+import Language.Haskell.Exts -- | Make an identifier from the built-in HJ module. fayBuiltin :: a -> String -> QName a
src/Fay/Compiler/Print.hs view
@@ -1,211 +1,200 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NoImplicitPrelude #-}-{-# 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.State-import Data.Aeson.Encode+import Data.Aeson import qualified Data.ByteString.Lazy.UTF8 as UTF8-import Language.Haskell.Exts.Annotated hiding (alt, name, op, sym)-import SourceMap.Types+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)) defaultPrintState+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)) defaultPrintState { 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- 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) +>- "}" +>- (unless (null elses) $ " else {" +>- indented (printJS elses) +>- "}") +> newline- printJS (JsEarlyReturn exp) =- "return " +> exp +> ";" +> newline- printJS (JsThrow exp) =- "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@@ -218,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@@ -273,89 +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 = 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 }- void p- modify $ \s -> s { psIndentLevel = psIndentLevel }- else void p---- | 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] = void x-intercalateM str (x:xs) = do- void x- write str- intercalateM str xs---- | Concatenate two printables.-(+>) :: (Printable a, Printable b) => a -> b -> Printer ()-pa +> pb = printJS pa >> printJS pb+-- | Intercalate monoids.+mintercalate :: String -> [Printer] -> Printer+mintercalate str xs = mconcat $ intersperse (write str) xs
src/Fay/Compiler/QName.hs view
@@ -2,7 +2,7 @@ module Fay.Compiler.QName where -import Language.Haskell.Exts.Annotated+import Language.Haskell.Exts -- | Extract the module name from a qualified name. qModName :: QName a -> Maybe (ModuleName a)
src/Fay/Compiler/State.hs view
@@ -12,7 +12,7 @@ import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S-import Language.Haskell.Names+import Language.Haskell.Names (sv_origName, Symbols (Symbols), SymValueInfo (SymValue, SymMethod, SymSelector, SymConstructor), OrigName, sv_typeName) -- | Get all non local identifiers that should be exported in the JS module scope. getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)
src/Fay/Compiler/Typecheck.hs view
@@ -12,6 +12,7 @@ import qualified GHC.Paths as GHCPaths import System.Directory+import System.Environment -- | Call out to GHC to type-check the file. typecheck :: Config -> FilePath -> IO (Either CompileError String)@@ -31,7 +32,7 @@ return [flag ++ '=' : pk] let flags = [ "-fno-code"- , "-hide-package base"+ , "-hide-all-packages" , "-cpp", "-pgmPcpphs", "-optP--cpp" , "-optP-C" -- Don't let hse-cpp remove //-style comments. , "-DFAY=1"@@ -40,7 +41,20 @@ , "-i" ++ intercalate ":" includeDirs , fp ] ++ ghcPackageDbArgs ++ wallF ++ map ("-package " ++) packages exists <- doesFileExist GHCPaths.ghc- res <- readAllFromProcess (if exists then GHCPaths.ghc else "ghc") flags ""+ stackInNixShell <- fmap isJust (lookupEnv "STACK_IN_NIX_SHELL")+ let ghcPath = if exists+ then if (isInfixOf ".stack" GHCPaths.ghc || stackInNixShell)+ then "stack"+ else GHCPaths.ghc+ else "ghc"+ extraFlags = case ghcPath of+ "stack" -> ["exec","--","ghc"]+ _ -> []+ when (configShowGhcCalls cfg) $+ putStrLn . unwords $ ghcPath : (extraFlags ++ flags)+ when stackInNixShell (unsetEnv "STACK_IN_NIX_SHELL")+ res <- readAllFromProcess ghcPath (extraFlags ++ flags) ""+ when stackInNixShell (setEnv "STACK_IN_NIX_SHELL" "1") either (return . Left . GHCError . fst) (return . Right . fst) res where wallF | configWall cfg = ["-Wall"]
src/Fay/Config.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE NoImplicitPrelude #-} -- | Configuring the compiler- module Fay.Config ( Config ( configOptimize@@ -23,6 +23,10 @@ , configTypecheckOnly , configRuntimePath , configOptimizeNewtypes+ , configPrettyThunks+ , configPrettyOperators+ , configShowGhcCalls+ , configTypeScript ) , defaultConfig , defaultConfigWithSandbox@@ -42,7 +46,7 @@ import Data.Default import Data.Maybe ()-import Language.Haskell.Exts.Annotated (ModuleName (..))+import Language.Haskell.Exts (ModuleName (..)) import System.Environment -- | Configuration of the compiler.@@ -72,9 +76,12 @@ , 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@@ -101,6 +108,10 @@ , configRuntimePath = Nothing , configSourceMap = False , configOptimizeNewtypes = True+ , configPrettyThunks = False+ , configPrettyOperators = False+ , configShowGhcCalls = False+ , configTypeScript = False } defaultConfigWithSandbox :: IO Config@@ -135,8 +146,6 @@ -- | 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]
src/Fay/Convert.hs view
@@ -1,10 +1,9 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-}-{-# OPTIONS -fno-warn-type-defaults #-} -- | Convert a Haskell value to a (JSON representation of a) Fay value. @@ -18,7 +17,7 @@ import Fay.Compiler.Prelude -import Control.Monad.State+import Control.Monad.State (evalStateT, get, lift, put) import Control.Spoon import Data.Aeson import Data.Aeson.Types (parseEither)@@ -39,7 +38,7 @@ -- values aren't handled by explicit cases. 'encodeFay' can be used to -- resolve this issue. showToFay :: Data a => a -> Maybe Value-showToFay = spoon . encodeFay (\x -> x)+showToFay = spoon . encodeFay id -- | 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@@ -91,12 +90,12 @@ -- | Convert a Fay json value to a Haskell value. readFromFay :: Data a => Value -> Maybe a-readFromFay = either (\_ -> Nothing) Just . decodeFay (\_ -> id)+readFromFay = either (const Nothing) Just . decodeFay (const id) -- | 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 (\_ -> id)+readFromFay' = decodeFay (const id) -- | Convert a Fay json value to a Haskell value. --@@ -123,7 +122,7 @@ rec :: GenericParser rec = decodeFay specialCases -type GenericParser = Data a => Value -> Either String a+type GenericParser = forall a. Data a => Value -> Either String a -- | Parse a data type or record or tuple. parseDataOrTuple :: forall a. Data a => GenericParser -> Value -> Either String a@@ -140,7 +139,7 @@ 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 (rec value))@@ -165,22 +164,23 @@ -- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2 makeSimple :: Data a => GenericParser -> HashMap Text Value -> Constr -> Either String a makeSimple rec obj cons =- evalStateT (fromConstrM (do i:next <- get+ evalStateT (fromConstrM (do ~(i:next) <- get put next 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 => GenericParser -> HashMap Text Value -> Constr -> [String] -> Either String a-makeRecord rec obj cons fields =- evalStateT (fromConstrM (do key:next <- get- put next- value <- lift (lookupField obj (Text.pack key))- lift (rec value))- cons)- fields+makeRecord rec obj cons =+ evalStateT $+ fromConstrM+ (do ~(key:next) <- get+ put next+ value <- lift (lookupField obj (Text.pack key))+ lift $ rec value)+ cons lookupField :: HashMap Text Value -> Text -> Either String Value lookupField obj key =
src/Fay/Exts.hs view
@@ -1,6 +1,6 @@ module Fay.Exts where -import qualified Language.Haskell.Exts.Annotated as A+import qualified Language.Haskell.Exts as A type X = A.SrcSpanInfo
src/Fay/Exts/NoAnnotation.hs view
@@ -6,7 +6,7 @@ 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 ()
src/Fay/Exts/Scoped.hs view
@@ -2,8 +2,8 @@ import qualified Fay.Exts as F -import qualified Language.Haskell.Exts.Annotated as A-import qualified Language.Haskell.Names as HN+import qualified Language.Haskell.Exts as A+import qualified Language.Haskell.Names as HN (Scoped (Scoped), NameInfo (None)) type X = HN.Scoped A.SrcSpanInfo
+ src/Fay/Runtime.hs view
@@ -0,0 +1,842 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++module Fay.Runtime where++import Text.Shakespeare.Text+import Data.Text.Lazy as T+import Fay.Config++-- | Get the default runtime source.+getRuntimeSource :: Config -> String+getRuntimeSource cfg =+ let ifTs :: T.Text -> T.Text+ ifTs a = if configTypeScript cfg then a else ""+ ifTsJs :: T.Text -> T.Text -> T.Text+ ifTsJs a b = if configTypeScript cfg then a else b+ in T.unpack [lt|+/*******************************************************************************+ * Misc.+ */+#{ifTs "var Fay:{[key:string]: any;} = {};"}++// Workaround for missing functionality in IE 8 and earlier.+if( Object.create === undefined ) {+ Object.create = function( o ) {+ function F(){}+ F.prototype = o;+ return new F();+ };+}++// Insert properties of b in place into a.+function Fay$$objConcat(a,b){+ for (var p in b) if (b.hasOwnProperty(p)){+ a[p] = b[p];+ }+ return a;+}++/*******************************************************************************+ * Thunks.+ */++// Force a thunk (if it is a thunk) until WHNF.+function Fay$$_(thunkish,nocache#{ifTs "?: boolean"}){+ while (thunkish instanceof Fay$$$) {+ thunkish = thunkish.force(nocache);+ }+ return thunkish;+}++// Apply a function to arguments (see method2 in Fay.hs).+function Fay$$__(){+ var f = arguments[0];+ for (var i = 1, len = arguments.length; i < len; i++) {+ f = (f instanceof Fay$$$? Fay$$_(f) : f)(arguments[i]);+ }+ return f;+}++// Thunk object.+function Fay$$$(value){+ this.forced = false;+ this.value = value;+}++// Force the thunk.+Fay$$$.prototype.force = function(nocache) {+ return nocache ?+ this.value() :+ (this.forced ?+ this.value :+ (this.value = this.value(), this.forced = true, this.value));+};+++function Fay$$seq(x) {+ return function(y) {+ Fay$$_(x,false);+ return y;+ }+}++function Fay$$seq$36$uncurried(x,y) {+ Fay$$_(x,false);+ return y;+}++/*******************************************************************************+ * Monad.+ */++function Fay$$Monad(value){+ this.value = value;+}++// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+function Fay$$then(a){+ return function(b){+ return Fay$$bind(a)(function(_){+ return b;+ });+ };+}++// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+// >>+function Fay$$then$36$uncurried(a,b){+ return Fay$$bind$36$uncurried(a,function(_){ return b; });+}++// >>=+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind(m){+ return function(f){+ return new Fay$$$(function(){+ var monad = Fay$$_(m,true);+ return Fay$$_(f)(monad.value);+ });+ };+}++// >>=+// This is used directly from Fay, but can be rebound or shadowed. See primOps in Types.hs.+function Fay$$bind$36$uncurried(m,f){+ return new Fay$$$(function(){+ var monad = Fay$$_(m,true);+ return Fay$$_(f)(monad.value);+ });+}++// This is used directly from Fay, but can be rebound or shadowed.+function Fay$$$_return(a){+ return new Fay$$Monad(a);+}++// Allow the programmer to access thunk forcing directly.+function Fay$$force(thunk){+ return function(type){+ return new Fay$$$(function(){+ Fay$$_(thunk,type);+ return new Fay$$Monad(Fay$$unit);+ })+ }+}++// This is used directly from Fay, but can be rebound or shadowed.+function Fay$$return$36$uncurried(a){+ return new Fay$$Monad(a);+}++// Unit: ().+var Fay$$unit = null;++/*******************************************************************************+ * Serialization.+ * Fay <-> JS. Should be bijective.+ */++// Serialize a Fay object to JS.+function Fay$$fayToJs(type,fayObj){+ var base = type[0];+ var args = type[1];+ var jsObj;+ if(base == "action") {+ // A nullary monadic action. Should become a nullary JS function.+ // Fay () -> function(){ return ... }+ return function(){+ return Fay$$fayToJs(args[0],Fay$$_(fayObj,true).value);+ };++ }+ else if(base == "function") {+ // A proper function.+ return function(){+ var fayFunc = fayObj;+ var return_type = args[args.length-1];+ var len = args.length;+ // If some arguments.+ if (len > 1) {+ // Apply to all the arguments.+ fayFunc = Fay$$_(fayFunc,true);+ // TODO: Perhaps we should throw an error when JS+ // passes more arguments than Haskell accepts.++ // Unserialize the JS values to Fay for the Fay callback.+ if (args == "automatic_function")+ {+ for (var i = 0; i < arguments.length; i++) {+ fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(["automatic"],arguments[i])),true);+ }+ return Fay$$fayToJs(["automatic"], fayFunc);+ }++ for (var i = 0, len = len; i < len - 1 && fayFunc instanceof Function; i++) {+ fayFunc = Fay$$_(fayFunc(Fay$$jsToFay(args[i],arguments[i])),true);+ }+ // Finally, serialize the Fay return value back to JS.+ var return_base = return_type[0];+ var return_args = return_type[1];+ // If it's a monadic return value, get the value instead.+ if(return_base == "action") {+ return Fay$$fayToJs(return_args[0],fayFunc.value);+ }+ // Otherwise just serialize the value direct.+ else {+ return Fay$$fayToJs(return_type,fayFunc);+ }+ } else {+ throw new Error("Nullary function?");+ }+ };++ }+ else if(base == "string") {+ return Fay$$fayToJs_string(fayObj);+ }+ else if(base == "list") {+ // Serialize Fay list to JavaScript array.+ var arr = [];+ fayObj = Fay$$_(fayObj);+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(args[0],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ }+ else if(base == "tuple") {+ // Serialize Fay tuple to JavaScript array.+ var arr = [];+ fayObj = Fay$$_(fayObj);+ var i = 0;+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(args[i++],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ }+ else if(base == "defined") {+ fayObj = Fay$$_(fayObj);+ return fayObj instanceof Fay.FFI._Undefined+ ? undefined+ : Fay$$fayToJs(args[0],fayObj.slot1);+ }+ else if(base == "nullable") {+ fayObj = Fay$$_(fayObj);+ return fayObj instanceof Fay.FFI._Null+ ? null+ : Fay$$fayToJs(args[0],fayObj.slot1);+ }+ else if(base == "double" || base == "int" || base == "bool") {+ // Bools are unboxed.+ return Fay$$_(fayObj);+ }+ else if(base == "ptr")+ return fayObj;+ else if(base == "unknown")+ return Fay$$fayToJs(["automatic"], fayObj);+ else if(base == "automatic" && fayObj instanceof Function) {+ return Fay$$fayToJs(["function", "automatic_function"], fayObj);+ }+ else if(base == "automatic" || base == "user") {+ fayObj = Fay$$_(fayObj);++ if(fayObj instanceof Fay$$Cons || fayObj === null){+ // Serialize Fay list to JavaScript array.+ var arr = [];+ while(fayObj instanceof Fay$$Cons) {+ arr.push(Fay$$fayToJs(["automatic"],fayObj.car));+ fayObj = Fay$$_(fayObj.cdr);+ }+ return arr;+ } else {+ var fayToJsFun = fayObj && fayObj.instance && Fay$$fayToJsHash[fayObj.instance];+ return fayToJsFun ? fayToJsFun(type,type[2],fayObj) : fayObj;+ }+ }++ throw new Error("Unhandled Fay->JS translation type: " + base);+}++// Stores the mappings from fay types to js objects.+// This will be populated by compiled modules.+var Fay$$fayToJsHash = {};++// Specialized serializer for string.+function Fay$$fayToJs_string(fayObj){+ // Serialize Fay string to JavaScript string.+ var str = "";+ fayObj = Fay$$_(fayObj);+ while(fayObj instanceof Fay$$Cons) {+ str += Fay$$_(fayObj.car);+ fayObj = Fay$$_(fayObj.cdr);+ }+ return str;+};+function Fay$$jsToFay_string(x){+ return Fay$$list(x)+};++// Special num/bool serializers.+function Fay$$jsToFay_int(x){return x;}+function Fay$$jsToFay_double(x){return x;}+function Fay$$jsToFay_bool(x){return x;}++function Fay$$fayToJs_int(x){return Fay$$_(x);}+function Fay$$fayToJs_double(x){return Fay$$_(x);}+function Fay$$fayToJs_bool(x){return Fay$$_(x);}++// Unserialize an object from JS to Fay.+function Fay$$jsToFay(type,jsObj){+ var base = type[0];+ var args = type[1];+ var fayObj;+ if(base == "action") {+ // Unserialize a "monadic" JavaScript return value into a monadic value.+ return new Fay$$Monad(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "function") {+ // Unserialize a function from JavaScript to a function that Fay can call.+ // So+ //+ // var f = function(x,y,z){ … }+ //+ // becomes something like:+ //+ // function(x){+ // return function(y){+ // return function(z){+ // return new Fay$$$(function(){+ // return Fay$$jsToFay(f(Fay$$fayTojs(x),+ // Fay$$fayTojs(y),+ // Fay$$fayTojs(z))+ // }}}}};+ var returnType = args[args.length-1];+ var funArgs = args.slice(0,-1);++ if (jsObj.length > 0) {+ var makePartial = function(args){+ return function(arg){+ var i = args.length;+ var fayArg = Fay$$fayToJs(funArgs[i],arg);+ var newArgs = args.concat([fayArg]);+ if(newArgs.length == funArgs.length) {+ return new Fay$$$(function(){+ return Fay$$jsToFay(returnType,jsObj.apply(this,newArgs));+ });+ } else {+ return makePartial(newArgs);+ }+ };+ };+ return makePartial([]);+ }+ else+ return function (arg) {+ return Fay$$jsToFay(["automatic"], jsObj(Fay$$fayToJs(["automatic"], arg)));+ };+ }+ else if(base == "string") {+ // Unserialize a JS string into Fay list (String).+ // This is a special case, when String is explicit in the type signature,+ // with `Automatic' a string would not be decoded.+ return Fay$$list(jsObj);+ }+ else if(base == "list") {+ // Unserialize a JS array into a Fay list ([a]).+ var serializedList = [];+ for (var i = 0, len = jsObj.length; i < len; i++) {+ // Unserialize each JS value into a Fay value, too.+ serializedList.push(Fay$$jsToFay(args[0],jsObj[i]));+ }+ // Pop it all in a Fay list.+ return Fay$$list(serializedList);+ }+ else if(base == "tuple") {+ // Unserialize a JS array into a Fay tuple ((a,b,c,...)).+ var serializedTuple = [];+ for (var i = 0, len = jsObj.length; i < len; i++) {+ // Unserialize each JS value into a Fay value, too.+ serializedTuple.push(Fay$$jsToFay(args[i],jsObj[i]));+ }+ // Pop it all in a Fay list.+ return Fay$$list(serializedTuple);+ }+ else if(base == "defined") {+ return jsObj === undefined+ ? new Fay.FFI._Undefined()+ : new Fay.FFI._Defined(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "nullable") {+ return jsObj === null+ ? new Fay.FFI._Null()+ : new Fay.FFI.Nullable(Fay$$jsToFay(args[0],jsObj));+ }+ else if(base == "int") {+ // Int are unboxed, so there's no forcing to do.+ // But we can do validation that the int has no decimal places.+ // E.g. Math.round(x)!=x? throw "NOT AN INTEGER, GET OUT!"+ fayObj = Math.round(jsObj);+ if(fayObj!==jsObj) throw "Argument " + jsObj + " is not an integer!";+ return fayObj;+ }+ else if (base == "double" ||+ base == "bool" ||+ base == "ptr") {+ return jsObj;+ }+ else if(base == "unknown")+ return Fay$$jsToFay(["automatic"], jsObj);+ else if(base == "automatic" && jsObj instanceof Function) {+ #{ifTsJs "let type: string[][]" "var type"} = [["automatic"]];+ for (var i = 0; i < jsObj.length; i++)+ type.push(["automatic"]);+ return Fay$$jsToFay(["function", type], jsObj);+ }+ else if(base == "automatic" && jsObj instanceof Array) {+ var list = null;+ for (var i = jsObj.length - 1; i >= 0; i--) {+ list = new Fay$$Cons(Fay$$jsToFay([base], jsObj[i]), list);+ }+ return list;+ }+ else if(base == "automatic" || base == "user") {+ if (jsObj && jsObj['instance']) {+ var jsToFayFun = Fay$$jsToFayHash[jsObj["instance"]];+ return jsToFayFun ? jsToFayFun(type,type[2],jsObj) : jsObj;+ }+ else+ return jsObj;+ }++ throw new Error("Unhandled JS->Fay translation type: " + base);+}++// Stores the mappings from js objects to fay types.+// This will be populated by compiled modules.+var Fay$$jsToFayHash = {};++/*******************************************************************************+ * Lists.+ */++// Cons object.+function Fay$$Cons(car,cdr){+ this.car = car;+ this.cdr = cdr;+}++// Make a list.+function Fay$$list(xs){+ var out = null;+ for(var i=xs.length-1; i>=0;i--)+ out = new Fay$$Cons(xs[i],out);+ return out;+}++// Built-in list cons.+function Fay$$cons(x){+ return function(y){+ return new Fay$$Cons(x,y);+ };+}++// List index.+// `list' is already forced by the time it's passed to this function.+// `list' cannot be null and `index' cannot be out of bounds.+function Fay$$index(index,list){+ for(var i = 0; i < index; i++) {+ list = Fay$$_(list.cdr);+ }+ return list.car;+}++// List length.+// `list' is already forced by the time it's passed to this function.+function Fay$$listLen(list,max){+ for(var i = 0; list !== null && i < max + 1; i++) {+ list = Fay$$_(list.cdr);+ }+ return i == max;+}++/*******************************************************************************+ * Numbers.+ */++// Built-in *.+function Fay$$mult(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) * Fay$$_(y);+ });+ };+}++function Fay$$mult$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) * Fay$$_(y);+ });++}++// Built-in +.+function Fay$$add(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) + Fay$$_(y);+ });+ };+}++// Built-in +.+function Fay$$add$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) + Fay$$_(y);+ });++}++// Built-in -.+function Fay$$sub(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) - Fay$$_(y);+ });+ };+}+// Built-in -.+function Fay$$sub$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) - Fay$$_(y);+ });++}++// Built-in /.+function Fay$$divi(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) / Fay$$_(y);+ });+ };+}++// Built-in /.+function Fay$$divi$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) / Fay$$_(y);+ });++}++/*******************************************************************************+ * Booleans.+ */++// Are two values equal?+function Fay$$equal(lit1, lit2) {+ // Simple case+ lit1 = Fay$$_(lit1);+ lit2 = Fay$$_(lit2);+ if (lit1 === lit2) {+ return true;+ }+ // General case+ if (lit1 instanceof Array) {+ if (lit1.length != lit2.length) return false;+ for (var len = lit1.length, i = 0; i < len; i++) {+ if (!Fay$$equal(lit1[i], lit2[i])) return false;+ }+ return true;+ } else if (lit1 instanceof Fay$$Cons && lit2 instanceof Fay$$Cons) {+ do {+ if (!Fay$$equal(lit1.car,lit2.car))+ return false;+ lit1 = Fay$$_(lit1.cdr), lit2 = Fay$$_(lit2.cdr);+ if (lit1 === null || lit2 === null)+ return lit1 === lit2;+ } while (true);+ } else if (typeof lit1 == 'object' && typeof lit2 == 'object' && lit1 && lit2 &&+ lit1.instance === lit2.instance) {+ for(var x in lit1) {+ if(!Fay$$equal(lit1[x],lit2[x]))+ return false;+ }+ return true;+ } else {+ return false;+ }+}++// Built-in ==.+function Fay$$eq(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$equal(x,y);+ });+ };+}++function Fay$$eq$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$equal(x,y);+ });++}++// Built-in /=.+function Fay$$neq(x){+ return function(y){+ return new Fay$$$(function(){+ return !(Fay$$equal(x,y));+ });+ };+}++// Built-in /=.+function Fay$$neq$36$uncurried(x,y){++ return new Fay$$$(function(){+ return !(Fay$$equal(x,y));+ });++}++// Built-in >.+function Fay$$gt(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) > Fay$$_(y);+ });+ };+}++// Built-in >.+function Fay$$gt$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) > Fay$$_(y);+ });++}++// Built-in <.+function Fay$$lt(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) < Fay$$_(y);+ });+ };+}+++// Built-in <.+function Fay$$lt$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) < Fay$$_(y);+ });++}+++// Built-in >=.+function Fay$$gte(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) >= Fay$$_(y);+ });+ };+}++// Built-in >=.+function Fay$$gte$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) >= Fay$$_(y);+ });++}++// Built-in <=.+function Fay$$lte(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) <= Fay$$_(y);+ });+ };+}++// Built-in <=.+function Fay$$lte$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) <= Fay$$_(y);+ });++}++// Built-in &&.+function Fay$$and(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) && Fay$$_(y);+ });+ };+}++// Built-in &&.+function Fay$$and$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) && Fay$$_(y);+ });+ ;+}++// Built-in ||.+function Fay$$or(x){+ return function(y){+ return new Fay$$$(function(){+ return Fay$$_(x) || Fay$$_(y);+ });+ };+}++// Built-in ||.+function Fay$$or$36$uncurried(x,y){++ return new Fay$$$(function(){+ return Fay$$_(x) || Fay$$_(y);+ });++}++/*******************************************************************************+ * Mutable references.+ */++// Make a new mutable reference.+function Fay$$Ref(x){+ this.value = x;+}++// Write to the ref.+function Fay$$writeRef(ref,x){+ ref.value = x;+}++// Get the value from the ref.+function Fay$$readRef(ref){+ return ref.value;+}++/*******************************************************************************+ * Dates.+ */+function Fay$$date(str){+ return Date.parse(str);+}++/*******************************************************************************+ * Data.Var+ */++function Fay$$Ref2(val){+ this.val = val;+}++function Fay$$Sig(){+ this.handlers = [];+}++function Fay$$Var(val){+ this.val = val;+ this.handlers = [];+}++// Helper used by Fay$$setValue and for merging+function Fay$$broadcastInternal(self, val, force){+ var handlers = self.handlers;+ var exceptions = [];+ for(#{ifTsJs "let" "var"} len = handlers.length, i = 0; i < len; i++) {+ try {+ force(handlers[i][1](val), true);+ } catch (e) {+ exceptions.push(e);+ }+ }+ // Rethrow the encountered exceptions.+ if (exceptions.length > 0) {+ console.error("Encountered " + exceptions.length + " exception(s) while broadcasing a change to ", self);+ for(#{ifTsJs "let len: number" "var len"} = exceptions.length, i = 0; i < len; i++) {+ (function(exception) {+ setTimeout(function() { throw exception; }, 0);+ })(exceptions[i]);+ }+ }+}++function Fay$$setValue(self, val, force){+ if (self instanceof Fay$$Ref2) {+ self.val = val;+ } else if (self instanceof Fay$$Var) {+ self.val = val;+ Fay$$broadcastInternal(self, val, force);+ } else if (self instanceof Fay$$Sig) {+ Fay$$broadcastInternal(self, val, force);+ } else {+ throw "Fay$$setValue given something that's not a Ref2, Var, or Sig"+ }+}++function Fay$$subscribe(self, f){+ var key = {};+ self.handlers.push([key,f]);+ var searchStart = self.handlers.length - 1;+ return function(_){+ for(var i = Math.min(searchStart, self.handlers.length - 1); i >= 0; i--) {+ if(self.handlers[i][0] == key) {+ self.handlers = self.handlers.slice(0,i).concat(self.handlers.slice(i+1));+ return;+ }+ }+ return _; // This variable has to be used, otherwise Closure+ // strips it out and Fay serialization breaks.+ };+}++/*******************************************************************************+ * Application code.+ */++|]
src/Fay/Types.hs view
@@ -1,52 +1,69 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TypeFamilies #-} -- | All Fay types and instances. module Fay.Types- (JsStmt(..)- ,JsExp(..)- ,JsLit(..)- ,JsName(..)- ,CompileError(..)- ,Compile(..)- ,CompileModule- ,Printable(..)- ,Fay- ,CompileReader(..)- ,CompileWriter(..)- ,Config(..)- ,CompileState(..)- ,FundamentalType(..)- ,PrintState(..)- ,defaultPrintState- ,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.Prelude +import Fay.Compiler.ModuleT import Fay.Config-import qualified Fay.Exts.NoAnnotation as N-import qualified Fay.Exts.Scoped as S+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 -import Control.Monad.Error (ErrorT, MonadError)-import Control.Monad.Identity (Identity)-import Control.Monad.RWS-import Control.Monad.State-import Data.Map (Map)-import Data.Set (Set)-import Distribution.HaskellSuite.Modules-import Language.Haskell.Names (Symbols)-import SourceMap.Types+#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Monad.Except (ExceptT, MonadError)+import Control.Monad.Identity (Identity)+import Control.Monad.RWS (MonadIO, MonadReader, MonadState, MonadWriter, RWST, lift)+import Data.Map (Map)+import Data.Set (Set)+import Language.Haskell.Names (Symbols)+import Data.Semigroup (Semigroup) -------------------------------------------------------------------------------- -- Compiler types@@ -74,10 +91,14 @@ } 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@@ -89,7 +110,7 @@ -- | Compile monad. newtype Compile a = Compile { unCompile :: RWST CompileReader CompileWriter CompileState- (ErrorT CompileError (ModuleT (ModuleInfo Compile) IO))+ (ExceptT CompileError (ModuleT (ModuleInfo Compile) IO)) a -- ^ Uns the compiler } deriving ( Applicative@@ -108,39 +129,10 @@ 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.-defaultPrintState :: PrintState-defaultPrintState = PrintState False 0 0 [] 0 [] False---- | The printer monad.-newtype Printer a = Printer { runPrinter :: State PrintState a }- deriving- ( Applicative- , Functor- , Monad- , MonadState PrintState- )---- | Print some value.-class Printable a where- printJS :: a -> Printer () -- | The JavaScript FFI interfacing monad. newtype Fay a = Fay (Identity a)
src/Fay/Types/CompileError.hs view
@@ -4,8 +4,7 @@ import qualified Fay.Exts.NoAnnotation as N import qualified Fay.Exts.Scoped as S -import Control.Monad.Error (Error)-import Language.Haskell.Exts.Annotated+import Language.Haskell.Exts -- | Error type. data CompileError@@ -38,4 +37,4 @@ | UnsupportedWhereInAlt S.Alt | UnsupportedWhereInMatch S.Match deriving (Show)-instance Error CompileError+{-# ANN module "HLint: ignore Use camelCase" #-}
src/Fay/Types/Js.hs view
@@ -11,11 +11,12 @@ import Fay.Types.ModulePath import Data.String-import Language.Haskell.Exts.Annotated+import Language.Haskell.Exts -- | Statement type. data JsStmt = JsVar JsName JsExp+ | JsMapVar JsName JsExp | JsIf JsExp [JsStmt] [JsStmt] | JsEarlyReturn JsExp | JsThrow JsExp
src/Fay/Types/ModulePath.hs view
@@ -10,7 +10,7 @@ import Data.List import Data.List.Split-import Language.Haskell.Exts.Annotated+import Language.Haskell.Exts -- | The name of a module split into a list for code generation. newtype ModulePath = ModulePath { unModulePath :: [String] }
+ src/Fay/Types/Printer.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE FlexibleContexts #-}+module Fay.Types.Printer+ ( PrintReader(..)+ , defaultPrintReader+ , PrintWriter(..)+ , pwOutputString+ , PrintState(..)+ , defaultPrintState+ , Printer(..)+ , Printable(..)+ , execPrinter+ , indented+ , newline+ , write+ , askIf+ , mapping+ ) where++import Fay.Compiler.Prelude++import Control.Monad.RWS (RWS, asks, execRWS, get, modify, put, tell)+import Data.List (elemIndex)+import Data.Maybe (fromMaybe)+import Data.String+import Language.Haskell.Exts+import SourceMap.Types+import qualified Data.Semigroup as SG++-- | Global options of the printer+data PrintReader = PrintReader+ { prPretty :: Bool -- ^ Are we to pretty print?+ , prPrettyThunks :: Bool -- ^ Use pretty thunk names?+ , prPrettyOperators :: Bool -- ^ Use pretty operators?+ }++-- | default printer options (non-pretty printing)+defaultPrintReader :: PrintReader+defaultPrintReader = PrintReader False False False++-- | Output of printer+data PrintWriter = PrintWriter+ { pwMappings :: [Mapping] -- ^ Source mappings.+ , pwOutput :: ShowS -- ^ The current output.+ }++pwOutputString :: PrintWriter -> String+pwOutputString (PrintWriter _ out) = out ""++instance SG.Semigroup PrintWriter where+ (PrintWriter a b) <> (PrintWriter x y) = PrintWriter (a ++ x) (b . y)++-- | Output concatenation+instance Monoid PrintWriter where+ mempty = PrintWriter [] id+ mappend = (<>)++-- | The state of the pretty printer.+data PrintState = PrintState+ { psLine :: Int -- ^ The current line.+ , psColumn :: Int -- ^ Current column.+ , psIndentLevel :: Int -- ^ Current indentation level.+ , psNewline :: Bool -- ^ Just outputted a newline?+ }++-- | Default state.+defaultPrintState :: PrintState+defaultPrintState = PrintState 0 0 0 False++-- | The printer.+newtype Printer = Printer+ { runPrinter :: RWS PrintReader PrintWriter PrintState () }++execPrinter :: Printer -> PrintReader -> PrintWriter+execPrinter (Printer p) r = snd $ execRWS p r defaultPrintState++instance SG.Semigroup Printer where+ (Printer p) <> (Printer q) = Printer (p >> q)++instance Monoid Printer where+ mempty = Printer $ return ()+ mappend = (<>)++-- | Print some value.+class Printable a where+ printJS :: a -> Printer++-- | Print the given printer indented.+indented :: Printer -> Printer+indented (Printer p) = Printer $ asks prPretty >>= \pretty ->+ when pretty (addToIndentLevel 1) >> p >> when pretty (addToIndentLevel (-1))+ where addToIndentLevel d = modify (\ps -> ps { psIndentLevel = psIndentLevel ps + d })++-- | Output a newline and makes next line indented when prPretty is True.+-- Does nothing when prPretty is False+newline :: Printer+newline = Printer $ asks prPretty >>= flip when writeNewline+ where writeNewline = writeRWS "\n" >> modify (\s -> s { psNewline = True })++-- | Write out a raw string, respecting the indentation+-- Note: if you pass a string with newline characters, it will print them+-- out even if prPretty is set to False. Also next line won't be indented.+-- If you want write a smart newline (that is the one which will be written+-- out only if prPretty is true, and after which the line will be indented)+-- use `newline`)+write :: String -> Printer+write = Printer . writeRWS++writeRWS :: String -> RWS PrintReader PrintWriter PrintState ()+writeRWS x = do+ ps <- get+ let out = if psNewline ps+ then replicate (2 * psIndentLevel ps) ' ' ++ x+ else x+ tell mempty { pwOutput = (out++) }++ let newLines = length (filter (== '\n') x)+ put ps { psLine = psLine ps + newLines+ , psColumn = fromMaybe (psColumn ps + length x) . elemIndex '\n' $ reverse x+ , psNewline = False+ }++-- | Write out a string, updating the current position information.+instance IsString Printer where+ fromString = write++-- | exec one of Printers depending on PrintReader property.+askIf :: (PrintReader -> Bool) -> Printer -> Printer -> Printer+askIf f (Printer p) (Printer q) = Printer $ asks f >>= (\b -> if b then p else q)++-- | Generate a mapping from the Haskell location to the current point in the output.+mapping :: SrcSpan -> Printer+mapping srcSpan = Printer $ get >>= \ps ->+ let m = Mapping { mapGenerated = Pos (fromIntegral (psLine ps))+ (fromIntegral (psColumn ps))+ , mapOriginal = Just (Pos (fromIntegral (srcSpanStartLine srcSpan))+ (fromIntegral (srcSpanStartColumn srcSpan) - 1))+ , mapSourceFile = Just (srcSpanFilename srcSpan)+ , mapName = Nothing+ }+ in tell $ mempty { pwMappings = [m] }
+ src/haskell-names/LICENSE view
@@ -0,0 +1,3 @@+Forked from haskell-names+Licensed as BSD3+Authors: Roman Cheplyaka, Lennart Augustsson
+ src/haskell-names/Language/Haskell/Names.hs view
@@ -0,0 +1,17 @@+module Language.Haskell.Names+ (+ -- * Core functions+ annotateModule+ , getInterfaces+ -- * Types+ , SymValueInfo(..)+ , Symbols(..)+ , Scoped(..)+ , NameInfo(..)+ , GName(..)+ , OrigName(..)+ , HasOrigName(..)+ ) where++import Language.Haskell.Names.Types (Symbols (..), SymValueInfo (..), Scoped (..), NameInfo (..), GName (..), OrigName (..), HasOrigName (..))+import Language.Haskell.Names.Recursive (getInterfaces, annotateModule)
+ src/haskell-names/Language/Haskell/Names/Annotated.hs view
@@ -0,0 +1,100 @@+-- This module uses the open recursion interface+-- ("Language.Haskell.Names.Open") to annotate the AST with binding+-- information.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+module Language.Haskell.Names.Annotated+ ( Scoped (..)+ , NameInfo (..)+ , annotate+ ) where++import Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable as Local+import Language.Haskell.Names.Open.Base+import Language.Haskell.Names.Open.Instances ()+import Language.Haskell.Names.RecordWildcards+import Language.Haskell.Names.Types++import Data.Lens.Light+import Data.Proxy+import Language.Haskell.Exts+import Data.Typeable ( eqT, (:~:)(Refl) )++annotate+ :: forall a l .+ (Resolvable (a (Scoped l)), Functor a, Typeable l)+ => Scope -> a l -> a (Scoped l)+annotate sc = annotateRec (Proxy :: Proxy l) sc . fmap (Scoped None)++annotateRec+ :: forall a l .+ (Typeable l, Resolvable a)+ => Proxy l -> Scope -> a -> a+annotateRec _ sc a = go sc a where+ go :: forall a . Resolvable a => Scope -> a -> a+ go sc a+ | ReferenceV <- getL nameCtx sc+ , Just (Refl :: QName (Scoped l) :~: a) <- eqT+ = lookupValue (fmap sLoc a) sc <$ a+ | ReferenceT <- getL nameCtx sc+ , Just (Refl :: QName (Scoped l) :~: a) <- eqT+ = lookupType (fmap sLoc a) sc <$ a+ | BindingV <- getL nameCtx sc+ , Just (Refl :: Name (Scoped l) :~: a) <- eqT+ = Scoped ValueBinder (sLoc . ann $ a) <$ a+ | BindingT <- getL nameCtx sc+ , Just (Refl :: Name (Scoped l) :~: a) <- eqT+ = Scoped TypeBinder (sLoc . ann $ a) <$ a+ | Just (Refl :: FieldUpdate (Scoped l) :~: a) <- eqT+ = case a of+ FieldPun l n -> FieldPun l (lookupValue (sLoc <$> n) sc <$ n)+ FieldWildcard l ->+ let+ namesUnres = sc ^. wcNames+ resolve n =+ let Scoped info _ = lookupValue (sLoc l <$ UnQual () n) sc+ in info+ namesRes =+ map+ (\f -> (wcFieldOrigName f, resolve $ wcFieldName f))+ namesUnres+ in FieldWildcard $ Scoped (RecExpWildcard namesRes) (sLoc l)+ _ -> rmap go sc a+ | Just (Refl :: PatField (Scoped l) :~: a) <- eqT+ , PFieldWildcard l <- a+ = PFieldWildcard $+ Scoped+ (RecPatWildcard $ map wcFieldOrigName $ sc ^. wcNames)+ (sLoc l)+ | otherwise+ = rmap go sc a++lookupValue :: QName l -> Scope -> Scoped l+lookupValue qn sc = Scoped nameInfo (ann qn)+ where+ nameInfo =+ case Local.lookupValue qn $ getL lTable sc of+ Right r -> LocalValue r+ _ ->+ case Global.lookupValue qn $ getL gTable sc of+ Global.Result r -> GlobalValue r+ Global.Error e -> ScopeError e+ Global.Special -> None++lookupType :: QName l -> Scope -> Scoped l+lookupType qn sc = Scoped nameInfo (ann qn)+ where+ nameInfo =+ case Global.lookupType qn $ getL gTable sc of+ Global.Result r -> GlobalType r+ Global.Error e -> ScopeError e+ Global.Special -> None
+ src/haskell-names/Language/Haskell/Names/Exports.hs view
@@ -0,0 +1,144 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoMonoLocalBinds #-}+{-# LANGUAGE TypeFamilies #-}+module Language.Haskell.Names.Exports+ ( processExports+ ) where++import Fay.Compiler.Prelude++import Fay.Compiler.ModuleT+import Language.Haskell.Names.GlobalSymbolTable as Global+import Language.Haskell.Names.ModuleSymbols+import Language.Haskell.Names.ScopeUtils+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types (Error (..), GName (..), ModuleNameS, NameInfo (..),+ Scoped (..), Symbols (..), mkTy, mkVal, st_origName)++import Control.Monad.Writer (WriterT (WriterT), runWriterT)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Language.Haskell.Exts++processExports+ :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, Eq l)+ => Global.Table+ -> Module l+ -> m (Maybe (ExportSpecList (Scoped l)), Symbols)+processExports tbl m =+ case getExportSpecList m of+ Nothing ->+ return (Nothing, moduleSymbols tbl m)+ Just exp ->+ liftM (first Just) $ resolveExportSpecList tbl exp++resolveExportSpecList+ :: (MonadModule m, ModuleInfo m ~ Symbols)+ => Global.Table+ -> ExportSpecList l+ -> m (ExportSpecList (Scoped l), Symbols)+resolveExportSpecList tbl (ExportSpecList l specs) =+ liftM (first $ ExportSpecList $ none l) $+ runWriterT $+ mapM (WriterT . resolveExportSpec tbl) specs++resolveExportSpec+ :: (MonadModule m, ModuleInfo m ~ Symbols)+ => Global.Table+ -> ExportSpec l+ -> m (ExportSpec (Scoped l), Symbols)+resolveExportSpec tbl exp =+ case exp of+ EVar l qn -> return $+ case Global.lookupValue qn tbl of+ Global.Error err ->+ (scopeError err exp, mempty)+ Global.Result i ->+ let s = mkVal i+ in+ (EVar (Scoped (Export s) l)+ (Scoped (GlobalValue i) <$> qn), s)+ Global.Special {} -> error "Global.Special in export list?"+ EAbs l ns qn -> return $+ case Global.lookupType qn tbl of+ Global.Error err ->+ (scopeError err exp, mempty)+ Global.Result i ->+ let s = mkTy i+ in+ (EAbs (Scoped (Export s) l) (noScope ns)+ (Scoped (GlobalType i) <$> qn), s)+ Global.Special {} -> error "Global.Special in export list?"+ EThingWith l (EWildcard wcl wcn) qn [] -> return $+ case Global.lookupType qn tbl of+ Global.Error err ->+ (scopeError err exp, mempty)+ Global.Result i ->+ let+ subs = mconcat+ [ mkVal info+ | info <- allValueInfos+ , Just n' <- return $ sv_parent info+ , n' == st_origName i ]+ s = mkTy i <> subs+ in+ ( EThingWith (Scoped (Export s) l)+ (EWildcard (Scoped (Export s) wcl) wcn)+ (Scoped (GlobalType i) <$> qn)+ []+ , s+ )+ Global.Special {} -> error "Global.Special in export list?"+ EThingWith _ (EWildcard _ _) _qn _cns -> error "Name resolution: CNames are not supported in wildcard exports"+ EThingWith l (NoWildcard wcl) qn cns -> return $+ case Global.lookupType qn tbl of+ Global.Error err ->+ (scopeError err exp, mempty)+ Global.Result i ->+ let+ (cns', subs) =+ resolveCNames+ (Global.toSymbols tbl)+ (st_origName i)+ (\cn -> ENotInScope (UnQual (ann cn) (unCName cn))) -- FIXME better error+ cns+ s = mkTy i <> subs+ in+ ( EThingWith (Scoped (Export s) l)+ (NoWildcard (Scoped (Export s) wcl))+ (Scoped (GlobalType i) <$> qn)+ cns'+ , s+ )+ Global.Special {} -> error "Global.Special in export list?"+ EModuleContents _ (ModuleName _ mod) ->+ -- FIXME ambiguity check+ let+ filterByPrefix+ :: Ord i+ => ModuleNameS+ -> Map.Map GName (Set.Set i)+ -> Set.Set i+ filterByPrefix prefix m =+ Set.unions+ [ i | (GName { gModule = prefix' }, i) <- Map.toList m, prefix' == prefix ]++ filterEntities+ :: Ord i+ => Map.Map GName (Set.Set i)+ -> Set.Set i+ filterEntities ents =+ Set.intersection+ (filterByPrefix mod ents)+ (filterByPrefix "" ents)++ eVals = filterEntities $ Global.values tbl+ eTyps = filterEntities $ Global.types tbl++ s = Symbols eVals eTyps+ in+ return (Scoped (Export s) <$> exp, s)+ where+ allValueInfos =+ Set.toList $ Map.foldl' Set.union Set.empty $ Global.values tbl
+ src/haskell-names/Language/Haskell/Names/GetBound.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+module Language.Haskell.Names.GetBound+ ( GetBound(..)+ ) where++import Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import Language.Haskell.Names.RecordWildcards+import Language.Haskell.Names.SyntaxUtils++import Data.Generics.Uniplate.Data+import Language.Haskell.Exts+++-- | Get bound value identifiers.+class GetBound a l | a -> l where+ -- | For record wildcards we need to know which fields the given+ -- constructor has. So we pass the global table for that.+ getBound :: Global.Table -> a -> [Name l]++-- XXX account for shadowing?+instance (GetBound a l) => GetBound [a] l where+ getBound ctx xs = concatMap (getBound ctx) xs++instance (GetBound a l) => GetBound (Maybe a) l where+ getBound ctx = maybe [] (getBound ctx)++instance (GetBound a l, GetBound b l) => GetBound (a, b) l where+ getBound ctx (a, b) = getBound ctx a ++ getBound ctx b++instance (Data l) => GetBound (Binds l) l where+ getBound ctx e = case e of+ BDecls _ ds -> getBound ctx ds+ IPBinds _ _ -> [] -- XXX doesn't bind regular identifiers++instance (Data l) => GetBound (Decl l) l where+ getBound ctx e = case e of+ TypeDecl{} -> []+ TypeFamDecl{} -> []+ DataDecl _ _ _ _ ds _ -> getBound ctx ds+ GDataDecl _ _ _ _ _ ds _ -> getBound ctx ds+ DataFamDecl{} -> []+ TypeInsDecl{} -> []+ DataInsDecl _ _ _ ds _ -> getBound ctx ds+ GDataInsDecl _ _ _ _ ds _ -> getBound ctx ds+ ClassDecl _ _ _ _ mds -> getBound ctx mds+ InstDecl{} -> []+ DerivDecl{} -> []+ InfixDecl{} -> []+ DefaultDecl{} -> []+ SpliceDecl{} -> []+ TypeSig{} -> []+ FunBind _ [] -> error "getBound: FunBind []"+ FunBind _ (Match _ n _ _ _ : _) -> [n]+ FunBind _ (InfixMatch _ _ n _ _ _ : _) -> [n]+ PatBind _ p _ _ -> getBound ctx p+ ForImp _ _ _ _ n _ -> [n]+ ForExp _ _ _ n _ -> [n]+ RulePragmaDecl{} -> []+ DeprPragmaDecl{} -> []+ WarnPragmaDecl{} -> []+ InlineSig{} -> []+ SpecSig{} -> []+ SpecInlineSig{} -> []+ InstSig{} -> []+ AnnPragma{} -> []+ InlineConlikeSig{} -> []+ ClosedTypeFamDecl{} -> []+ MinimalPragma{} -> []+ _ -> error "Unsupported syntax"++instance (Data l) => GetBound (QualConDecl l) l where+ getBound ctx (QualConDecl _ _ _ d) = getBound ctx d++instance (Data l) => GetBound (GadtDecl l) l where+ getBound _ctx (GadtDecl _l conName _tyvarBinds _context mbFieldDecls _ty) =+ -- GADT constructor name+ [conName] +++ -- GADT selector names+ [ fieldName+ | Just fieldDecls <- return mbFieldDecls+ , FieldDecl _l' fieldNames _fieldTy <- fieldDecls+ , fieldName <- fieldNames+ ]++instance (Data l) => GetBound (ConDecl l) l where+ getBound ctx e = case e of+ ConDecl _ n _ -> [n]+ InfixConDecl _ _ n _ -> [n]+ RecDecl _ n fs -> n : getBound ctx fs++instance (Data l) => GetBound (FieldDecl l) l where+ getBound _ctx (FieldDecl _ ns _) = ns++instance (Data l) => GetBound (ClassDecl l) l where+ getBound _ctx e = case e of+ ClsDecl _ d -> getBoundSign d+ ClsDataFam{} -> []+ ClsTyFam{} -> []+ ClsTyDef{} -> []+ ClsDefSig{} -> []++instance (Data l) => GetBound (Match l) l where+ getBound _ctx e = case e of+ Match _ n _ _ _ -> [n]+ InfixMatch _ _ n _ _ _ -> [n]++instance (Data l) => GetBound (Stmt l) l where+ getBound ctx e =+ case e of+ Generator _ pat _ -> getBound ctx pat+ LetStmt _ bnds -> getBound ctx bnds+ RecStmt _ stmts -> getBound ctx stmts+ Qualifier {} -> []++instance (Data l) => GetBound (QualStmt l) l where+ getBound ctx e =+ case e of+ QualStmt _ stmt -> getBound ctx stmt+ _ -> []++instance (Data l) => GetBound (Pat l) l where+ getBound gt p =+ [ n | p' <- universe $ transform dropExp p, n <- varp p' ]++ where++ varp (PVar _ n) = [n]+ varp (PAsPat _ n _) = [n]+ varp (PNPlusK _ n _) = [n]+ varp (PRec _ con fs) =+ [ n+ | -- (lazily) compute elided fields for the case when 'f' below is a wildcard+ let elidedFields = map wcFieldName $ patWcNames gt con fs+ , f <- fs+ , n <- getRecVars elidedFields f+ ]+ varp _ = []++ -- must remove nested Exp so universe doesn't descend into them+ dropExp (PViewPat _ _ x) = x+ dropExp x = x++ getRecVars :: [Name ()] -> PatField l -> [Name l]+ getRecVars _ PFieldPat {} = [] -- this is already found by the generic algorithm+ getRecVars _ (PFieldPun _ qn) = [qNameToName qn]+ getRecVars elidedFields (PFieldWildcard l) = map (l <$) elidedFields++getBoundSign :: Decl l -> [Name l]+getBoundSign (TypeSig _ ns _) = ns+getBoundSign _ = []
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE NoImplicitPrelude #-}+-- | This module is designed to be imported qualified.+module Language.Haskell.Names.GlobalSymbolTable+ ( Table+ , empty+ , Result(..)+ , lookupValue+ , lookupType+ , fromLists+ , types+ , values+ , toSymbols+ ) where++import Fay.Compiler.Prelude hiding (empty)+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Data.Lens.Light+import qualified Data.Map as Map+import qualified Data.Set as Set+import Language.Haskell.Exts as HSE+import Data.Semigroup (Semigroup)++-- | Global symbol table — contains global names+data Table =+ Table+ (Map.Map GName (Set.Set (SymValueInfo OrigName)))+ (Map.Map GName (Set.Set (SymTypeInfo OrigName)))+ deriving (Eq, Ord, Show, Data, Typeable)++valLens :: Lens Table (Map.Map GName (Set.Set (SymValueInfo OrigName)))+valLens = lens (\(Table vs _) -> vs) (\vs (Table _ ts) -> Table vs ts)++tyLens :: Lens Table (Map.Map GName (Set.Set (SymTypeInfo OrigName)))+tyLens = lens (\(Table _ ts) -> ts) (\ts (Table vs _) -> Table vs ts)++instance Semigroup Table where+ (Table vs1 ts1) <> (Table vs2 ts2) =+ Table (j vs1 vs2) (j ts1 ts2)+ where+ j :: (Ord i, Ord k)+ => Map.Map k (Set.Set i)+ -> Map.Map k (Set.Set i)+ -> Map.Map k (Set.Set i)+ j = Map.unionWith Set.union+instance Monoid Table where+ mempty = empty+ mappend = (<>)++toGName :: QName l -> GName+toGName (UnQual _ n) = GName "" (nameToString n)+toGName (Qual _ (ModuleName _ m) n) = GName m (nameToString n)+toGName (HSE.Special _ _) = error "toGName: Special"++empty :: Table+empty = Table Map.empty Map.empty++lookupL+ :: HasOrigName i+ => Lens Table (Map.Map GName (Set.Set (i OrigName)))+ -> QName l+ -> Table+ -> Result l (i OrigName)+lookupL _ (HSE.Special {}) _ =+ Language.Haskell.Names.GlobalSymbolTable.Special+lookupL lens qn tbl =+ case Set.toList <$> (Map.lookup (toGName qn) $ getL lens tbl) of+ Nothing -> Error $ ENotInScope qn+ Just [] -> Error $ ENotInScope qn+ Just [i] -> Result i+ Just is -> Error $ EAmbiguous qn (map origName is)++data Result l a+ = Result a+ | Error (Error l)+ | Special++lookupValue :: QName l -> Table -> Result l (SymValueInfo OrigName)+lookupValue = lookupL valLens++lookupType :: QName l -> Table -> Result l (SymTypeInfo OrigName)+lookupType = lookupL tyLens++fromMaps+ :: Map.Map GName (Set.Set (SymValueInfo OrigName))+ -> Map.Map GName (Set.Set (SymTypeInfo OrigName))+ -> Table+fromMaps = Table++fromLists+ :: ([(GName, SymValueInfo OrigName)],+ [(GName, SymTypeInfo OrigName)])+ -> Table+fromLists (vs, ts) =+ fromMaps+ (Map.fromListWith Set.union $ map (second Set.singleton) vs)+ (Map.fromListWith Set.union $ map (second Set.singleton) ts)++values :: Table -> Map.Map GName (Set.Set (SymValueInfo OrigName))+types :: Table -> Map.Map GName (Set.Set (SymTypeInfo OrigName))+values = getL valLens+types = getL tyLens++toSymbols :: Table -> Symbols+toSymbols tbl =+ Symbols+ (gather $ values tbl)+ (gather $ types tbl)+ where+ gather :: Ord a => Map.Map k (Set.Set a) -> Set.Set a+ gather = Map.foldl' Set.union Set.empty
+ src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot view
@@ -0,0 +1,10 @@+module Language.Haskell.Names.GlobalSymbolTable where++import Data.Data++data Table deriving Typeable+instance Eq Table+instance Ord Table+instance Show Table+instance Data Table+
+ src/haskell-names/Language/Haskell/Names/Imports.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-} -- ModName (ModuleName l)+module Language.Haskell.Names.Imports (processImports) where++import Fay.Compiler.Prelude++import Fay.Compiler.ModuleT+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import Language.Haskell.Names.ScopeUtils+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Control.Monad.Writer (WriterT (WriterT), runWriterT)+import Data.Foldable (fold)+import Data.Lens.Light+import qualified Data.Map as Map+import qualified Data.Set as Set+import Language.Haskell.Exts++instance ModName (ModuleName l) where+ modToString (ModuleName _ s) = s++preludeName :: String+preludeName = "Prelude"++processImports+ :: (MonadModule m, ModuleInfo m ~ Symbols)+ => ExtensionSet+ -> [ImportDecl l]+ -> m ([ImportDecl (Scoped l)], Global.Table)+processImports exts importDecls = do++ (annotated, tbl) <- runWriterT $ mapM (WriterT . processImport) importDecls++ let+ isPreludeImported = not . null $+ [ () | ImportDecl { importModule = ModuleName _ modName } <- importDecls+ , modName == preludeName ]++ importPrelude =+ ImplicitPrelude `Set.member` exts &&+ not isPreludeImported++ tbl' <-+ if not importPrelude+ then return tbl+ else do+ -- FIXME currently we don't have a way to signal an error when+ -- Prelude cannot be found+ syms <- fold `liftM` getModuleInfo preludeName+ return $ tbl <>+ computeSymbolTable+ False -- not qualified+ (ModuleName () preludeName)+ syms++ return (annotated, tbl')++processImport+ :: (MonadModule m, ModuleInfo m ~ Symbols)+ => ImportDecl l+ -> m (ImportDecl (Scoped l), Global.Table)+processImport imp = do+ mbi <- getModuleInfo (importModule imp)+ case mbi of+ Nothing ->+ let e = EModNotFound (importModule imp)+ in return (scopeError e imp, Global.empty)+ Just syms -> return $ resolveImportDecl syms imp++resolveImportDecl+ :: Symbols+ -> ImportDecl l+ -> (ImportDecl (Scoped l), Global.Table)+resolveImportDecl syms (ImportDecl l mod qual src impSafe pkg mbAs mbSpecList) =+ let+ (mbSpecList', impSyms) =+ (fmap fst &&& maybe syms snd) $+ resolveImportSpecList mod syms <$> mbSpecList+ tbl = computeSymbolTable qual (fromMaybe mod mbAs) impSyms+ info =+ case mbSpecList' of+ Just sl | Scoped (ScopeError e) _ <- ann sl ->+ ScopeError e+ _ -> Import tbl+ in+ (ImportDecl+ (Scoped info l)+ (Scoped (ImportPart syms) <$> mod)+ qual+ src+ impSafe+ pkg+ (fmap noScope mbAs)+ mbSpecList'+ , tbl)++resolveImportSpecList+ :: ModuleName l+ -> Symbols+ -> ImportSpecList l+ -> (ImportSpecList (Scoped l), Symbols)+resolveImportSpecList mod allSyms (ImportSpecList l isHiding specs) =+ let specs' = map (resolveImportSpec mod isHiding allSyms) specs+ mentionedSyms = mconcat $ rights $ map ann2syms specs'+ importedSyms = computeImportedSymbols isHiding allSyms mentionedSyms+ newAnn = Scoped (ImportPart importedSyms) l+ in+ (ImportSpecList newAnn isHiding specs', importedSyms)++-- | This function takes care of the possible 'hiding' clause+computeImportedSymbols+ :: Bool+ -> Symbols -- ^ all symbols+ -> Symbols -- ^ mentioned symbols+ -> Symbols -- ^ imported symbols+computeImportedSymbols isHiding (Symbols vs ts) mentionedSyms =+ case isHiding of+ False -> mentionedSyms+ True ->+ let+ Symbols hvs hts = mentionedSyms+ allTys = symbolMap st_origName ts+ hidTys = symbolMap st_origName hts+ allVls = symbolMap sv_origName vs+ hidVls = symbolMap sv_origName hvs+ in+ Symbols+ (Set.fromList $ Map.elems $ allVls Map.\\ hidVls)+ (Set.fromList $ Map.elems $ allTys Map.\\ hidTys)++symbolMap+ :: Ord s+ => (a -> s)+ -> Set.Set a+ -> Map.Map s a+symbolMap f is = Map.fromList [(f i, i) | i <- Set.toList is]++resolveImportSpec+ :: ModuleName l+ -> Bool+ -> Symbols+ -> ImportSpec l+ -> ImportSpec (Scoped l)+-- NB: this can be made more efficient+resolveImportSpec mod isHiding syms spec =+ case spec of+ IVar _ n ->+ let+ matches = mconcat $+ -- Strictly speaking, the isConstructor check is unnecessary+ -- because constructors are lexically different from anything+ -- else.+ [ mkVal info+ | info <- vs+ , not (isConstructor info)+ , sv_origName info ~~ n]+ in+ checkUnique+ (ENotExported Nothing n mod)+ matches+ spec+ -- FIXME think about data families etc.+ IAbs _ _ n+ | isHiding ->+ -- This is a bit special. 'C' may match both types/classes and+ -- data constructors.+ -- FIXME Still check for uniqueness?+ let+ Symbols vlMatches tyMatches =+ mconcat [ mkVal info | info <- vs, sv_origName info ~~ n]+ <>+ mconcat [ mkTy info | info <- ts, st_origName info ~~ n]+ in+ if Set.null tyMatches && Set.null vlMatches+ then+ scopeError (ENotExported Nothing n mod) spec+ else+ Scoped (ImportPart (Symbols vlMatches tyMatches)) <$> spec+ | otherwise ->+ let+ matches = mconcat+ [mkTy info | info <- ts, st_origName info ~~ n]+ in+ checkUnique+ (ENotExported Nothing n mod)+ matches+ spec+ -- FIXME+ -- What about things like:+ -- head(..)+ -- String(..)+ -- ?+ IThingAll l n ->+ let+ matches = [ info | info <- ts, st_origName info ~~ n]+ subs = mconcat+ [ mkVal info+ | n <- matches+ , info <- vs+ , Just n' <- return $ sv_parent info+ , n' == st_origName n ]+ n' =+ checkUnique+ (ENotExported Nothing n mod)+ (foldMap mkTy matches)+ n+ in+ case ann n' of+ e@(Scoped ScopeError{} _) -> IThingAll e n'+ _ ->+ IThingAll+ (Scoped+ (ImportPart (subs <> foldMap mkTy matches))+ l+ )+ n'++ IThingWith l n cns ->+ let+ matches = [info | info <- ts, st_origName info ~~ n]+ n' =+ checkUnique+ (ENotExported Nothing n mod)+ (foldMap mkTy matches)+ n+ typeName = st_origName $ head matches -- should be safe+ (cns', cnSyms) =+ resolveCNames+ syms+ typeName+ (\cn -> ENotExported (Just n) (unCName cn) mod)+ cns+ in+ IThingWith+ (Scoped+ (ImportPart (cnSyms <> foldMap mkTy matches))+ l+ )+ n'+ cns'+ where+ (~~) :: OrigName -> Name l -> Bool+ OrigName { origGName = GName { gName = n } } ~~ n' = n == nameToString n'++ isConstructor :: SymValueInfo n -> Bool+ isConstructor SymConstructor {} = True+ isConstructor _ = False++ vs = Set.toList $ syms^.valSyms+ ts = Set.toList $ syms^.tySyms++ann2syms :: Annotated a => a (Scoped l) -> Either (Error l) (Symbols)+ann2syms a =+ case ann a of+ Scoped (ScopeError e) _ -> Left e+ Scoped (ImportPart syms) _ -> Right syms+ _ -> Left $ EInternal "ann2syms"++checkUnique+ :: Functor f =>+ Error l ->+ Symbols ->+ f l ->+ f (Scoped l)+checkUnique notFound syms@(Symbols vs ts) f =+ case Set.size vs + Set.size ts of+ 0 -> scopeError notFound f+ 1 -> Scoped (ImportPart syms) <$> f+ -- there should be no clashes, and it should be checked elsewhere+ _ -> scopeError (EInternal "ambiguous import") f
+ src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs view
@@ -0,0 +1,34 @@+-- | This module is designed to be imported qualified.+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude #-}+module Language.Haskell.Names.LocalSymbolTable+ ( Table+ , empty+ , lookupValue+ , addValue+ ) where++import Fay.Compiler.Prelude hiding (empty)+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import qualified Data.Map as Map+import Language.Haskell.Exts+import Data.Semigroup ()++-- | Local symbol table — contains locally bound names+newtype Table = Table (Map.Map NameS SrcLoc)+ deriving Semigroup++addValue :: SrcInfo l => Name l -> Table -> Table+addValue n (Table vs) =+ Table (Map.insert (nameToString n) (getPointLoc $ ann n) vs)++lookupValue :: QName l -> Table -> Either (Error l) SrcLoc+lookupValue qn@(UnQual _ n) (Table vs) =+ maybe (Left $ ENotInScope qn) Right $+ Map.lookup (nameToString n) vs+lookupValue qn _ = Left $ ENotInScope qn++empty :: Table+empty = Table Map.empty
+ src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+module Language.Haskell.Names.ModuleSymbols+ ( moduleSymbols+ , moduleTable+ )+ where++import Fay.Compiler.Prelude++import Language.Haskell.Exts+import Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import Language.Haskell.Names.ScopeUtils+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Data.Lens.Light+import qualified Data.Map as Map+import qualified Data.Set as Set++-- | Compute module's global table. It contains both the imported entities+-- and the global entities defined in this module.+moduleTable+ :: (Eq l, Data l)+ => Global.Table -- ^ the import table for this module+ -> Module l+ -> Global.Table+moduleTable impTbl m =+ impTbl <>+ computeSymbolTable False (getModuleName m) (moduleSymbols impTbl m)++-- | Compute the symbols that are defined in the given module.+--+-- The import table is needed to resolve possible top-level record+-- wildcard bindings, such as+--+-- >A {..} = foo+moduleSymbols+ :: (Eq l, Data l)+ => Global.Table -- ^ the import table for this module+ -> Module l+ -> Symbols+moduleSymbols impTbl m =+ let (vs,ts) =+ partitionEithers $+ concatMap+ (getTopDeclSymbols impTbl $ getModuleName m)+ (getModuleDecls m)+ in+ setL valSyms (Set.fromList vs) $+ setL tySyms (Set.fromList ts) mempty++type TypeName = GName+type ConName = Name ()+type SelectorName = Name ()+type Constructors = [(ConName, [SelectorName])]++-- Extract names that get bound by a top level declaration.+getTopDeclSymbols+ :: forall l . (Eq l, Data l)+ => Global.Table -- ^ the import table for this module+ -> ModuleName l+ -> Decl l+ -> [Either (SymValueInfo OrigName) (SymTypeInfo OrigName)]+getTopDeclSymbols impTbl mdl d =+ map (either (Left . fmap OrigName) (Right . fmap OrigName)) $+ case d of+ TypeDecl _ dh _ ->+ let tn = hname dh+ in [ Right (SymType { st_origName = tn, st_fixity = Nothing })]++ TypeFamDecl _loc dh _mrs _mk ->+ let tn = hname dh+ in [ Right (SymTypeFam { st_origName = tn, st_fixity = Nothing })]++ DataDecl _ dataOrNew _ dh qualConDecls _ ->+ let+ cons :: Constructors+ cons = do -- list monad+ QualConDecl _ _ _ conDecl <- qualConDecls+ case conDecl of+ ConDecl _ n _ -> return (void n, [])+ InfixConDecl _ _ n _ -> return (void n, [])+ RecDecl _ n fields ->+ return (void n , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++ dq = hname dh++ infos = constructorsToInfos dq cons++ in+ Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++ GDataDecl _ dataOrNew _ dh _ gadtDecls _ ->+ -- FIXME: We shouldn't create selectors for fields with existential type variables!+ let+ dq = hname dh++ cons :: Constructors+ cons = do -- list monad+ GadtDecl _ cn _tyvarBinds _context (fromMaybe [] -> fields) _ty <- gadtDecls+ return (void cn , [void f | FieldDecl _ fNames _ <- fields, f <- fNames])++ infos = constructorsToInfos dq cons+ in+ Right (dataOrNewCon dataOrNew dq Nothing) : map Left infos++ DataFamDecl _ _ dh _ ->+ let tn = hname dh+ in [Right (SymDataFam { st_origName = tn, st_fixity = Nothing })]++ ClassDecl _ _ dh _ mds ->+ let+ ms = getBound impTbl d+ cq = hname dh+ cdecls = fromMaybe [] mds+ in+ Right (SymClass { st_origName = cq, st_fixity = Nothing }) :+ [ Right (SymTypeFam { st_origName = hname dh, st_fixity = Nothing }) | ClsTyFam _ dh _ _ <- cdecls ] +++ [ Right (SymDataFam { st_origName = hname dh, st_fixity = Nothing }) | ClsDataFam _ _ dh _ <- cdecls ] +++ [ Left (SymMethod { sv_origName = qname mn, sv_fixity = Nothing, sv_className = cq }) | mn <- ms ]++ FunBind _ ms ->+ let vn : _ = getBound impTbl ms+ in [ Left (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) ]++ PatBind _ p _ _ ->+ [ Left (SymValue { sv_origName = qname vn, sv_fixity = Nothing }) | vn <- getBound impTbl p ]++ ForImp _ _ _ _ fn _ ->+ [ Left (SymValue { sv_origName = qname fn, sv_fixity = Nothing }) ]++ _ -> []+ where+ ModuleName _ smdl = mdl+ qname = GName smdl . nameToString+ hname :: DeclHead l -> GName+ hname = qname . getDeclHeadName+ dataOrNewCon dataOrNew = case dataOrNew of DataType {} -> SymData; NewType {} -> SymNewType++ constructorsToInfos :: TypeName -> Constructors -> [SymValueInfo GName]+ constructorsToInfos ty cons = conInfos ++ selInfos+ where+ conInfos =+ [ SymConstructor { sv_origName = qname con, sv_fixity = Nothing, sv_typeName = ty }+ | (con, _) <- cons+ ]++ selectorsMap :: Map.Map SelectorName [ConName]+ selectorsMap =+ Map.unionsWith (++) . flip map cons $ \(c, fs) ->+ Map.unionsWith (++) . flip map fs $ \f ->+ Map.singleton f [c]++ selInfos =+ [ (SymSelector { sv_origName = qname f, sv_fixity = Nothing, sv_typeName = ty, sv_constructors = map qname fCons })+ | (f, fCons) <- Map.toList selectorsMap+ ]
+ src/haskell-names/Language/Haskell/Names/Open/Base.hs view
@@ -0,0 +1,152 @@+-- | This module provides a more flexible way to process Haskell code —+-- using an open-recursive traversal.+--+-- You can look at "Language.Haskell.Exts" source as an example+-- of how to use this module.+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MonoLocalBinds #-}++module Language.Haskell.Names.Open.Base+ ( Resolvable (..)+ , intro+ , mergeLocalScopes+ , alg+ , Scope (..)+ , setWcNames+ , gTable+ , exprV+ , exprT+ , rmap+ , wcNames+ , nameCtx+ , NameContext (..)+ , initialScope+ , binderV+ , Alg (..)+ , binderT+ , defaultRtraverse+ , lTable+ ) where++import Fay.Compiler.Prelude+import Language.Haskell.Names.GetBound+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable as Local+import Language.Haskell.Names.RecordWildcards++import Control.Monad.Identity+import Data.Generics.Traversable+import Data.Lens.Light+import GHC.Exts (Constraint)+import Language.Haskell.Exts++-- | Describes how we should treat names in the current context+data NameContext+ = BindingT+ | BindingV+ | ReferenceT+ | ReferenceV+ | Other++-- | Contains information about the node's enclosing scope. Can be+-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx', 'wcNames'.+data Scope = Scope+ { _gTable :: Global.Table+ , _lTable :: Local.Table+ , _nameCtx :: NameContext+ , _wcNames :: WcNames+ }++makeLens ''Scope++-- | Create an initial scope+initialScope :: Global.Table -> Scope+initialScope tbl = Scope tbl Local.empty Other []++-- | Merge local tables of two scopes. The other fields of the scopes are+-- assumed to be the same.+mergeLocalScopes :: Scope -> Scope -> Scope+mergeLocalScopes sc1 sc2 =+ modL lTable (<> sc2 ^. lTable) sc1++-- | The algebra for 'rtraverse'. It's newtype-wrapped because an implicit+-- parameter cannot be polymorphic.+newtype Alg w = Alg+ { runAlg :: forall d . Resolvable d => d -> Scope -> w d }++alg :: (?alg :: Alg w, Resolvable d) => d -> Scope -> w d+alg = runAlg ?alg++data ConstraintProxy (p :: * -> Constraint) = ConstraintProxy++defaultRtraverse+ :: (GTraversable Resolvable a, Applicative f, ?alg :: Alg f)+ => a -> Scope -> f a+defaultRtraverse a sc =+ let ?c = ConstraintProxy :: ConstraintProxy Resolvable+ in gtraverse @Resolvable (\a -> alg a sc) a++-- | A type that implements 'Resolvable' provides a way to perform+-- a shallow scope-aware traversal.++-- There is a generic implementation, 'defaultRtraverse', which is based on+-- 'GTraversable'. It can be used when there the scope of all the immediate+-- children is the same as the scope of the current node.+--+-- We use 'Typeable' here rather than a class-based approach.+-- Otherwise, hand-written instances would carry extremely long lists of+-- constraints, saying that the subterms satisfy the user-supplied class.+class Typeable a => Resolvable a where+ rtraverse+ :: (Applicative f, ?alg :: Alg f)+ => a -> Scope -> f a++instance (Typeable a, GTraversable Resolvable a) => Resolvable a where+ rtraverse = defaultRtraverse++-- | Analogous to 'gmap', but for 'Resolvable'+rmap+ :: Resolvable a+ => (forall b. Resolvable b => Scope -> b -> b)+ -> Scope -> a -> a+rmap f sc =+ let ?alg = Alg $ \a sc -> Identity (f sc a)+ in runIdentity . flip rtraverse sc++intro :: (SrcInfo l, GetBound a l) => a -> Scope -> Scope+intro node sc =+ modL lTable+ (\tbl -> foldl' (flip Local.addValue) tbl $+ getBound (sc ^. gTable) node)+ sc++setNameCtx :: NameContext -> Scope -> Scope+setNameCtx = setL nameCtx++setWcNames :: WcNames -> Scope -> Scope+setWcNames = setL wcNames++binderV :: Scope -> Scope+binderV = setNameCtx BindingV++binderT :: Scope -> Scope+binderT = setNameCtx BindingT++exprV :: Scope -> Scope+exprV = setNameCtx ReferenceV++exprT :: Scope -> Scope+exprT = setNameCtx ReferenceT
+ src/haskell-names/Language/Haskell/Names/Open/Derived.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-unused-matches #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+module Language.Haskell.Names.Open.Derived where++import Data.Generics.Traversable.TH+import Language.Haskell.Exts++deriveGTraversable ''ModuleName+deriveGTraversable ''SpecialCon+deriveGTraversable ''QName+deriveGTraversable ''Name+deriveGTraversable ''Boxed+deriveGTraversable ''IPName+deriveGTraversable ''QOp+deriveGTraversable ''Op+deriveGTraversable ''CName+deriveGTraversable ''Module+deriveGTraversable ''ModuleHead+deriveGTraversable ''ExportSpecList+deriveGTraversable ''ExportSpec+deriveGTraversable ''ImportDecl+deriveGTraversable ''ImportSpecList+deriveGTraversable ''ImportSpec+deriveGTraversable ''Assoc+deriveGTraversable ''Decl+deriveGTraversable ''Annotation+deriveGTraversable ''DataOrNew+deriveGTraversable ''DeclHead+deriveGTraversable ''InstHead+deriveGTraversable ''InstRule+deriveGTraversable ''Deriving+deriveGTraversable ''Binds+deriveGTraversable ''IPBind+deriveGTraversable ''Match+deriveGTraversable ''QualConDecl+deriveGTraversable ''ConDecl+deriveGTraversable ''FieldDecl+deriveGTraversable ''GadtDecl+deriveGTraversable ''ClassDecl+deriveGTraversable ''InstDecl+deriveGTraversable ''BangType+deriveGTraversable ''Rhs+deriveGTraversable ''GuardedRhs+deriveGTraversable ''Type+deriveGTraversable ''TyVarBind+deriveGTraversable ''FunDep+deriveGTraversable ''Context+deriveGTraversable ''Asst+deriveGTraversable ''Literal+deriveGTraversable ''Exp+deriveGTraversable ''XName+deriveGTraversable ''XAttr+deriveGTraversable ''Bracket+deriveGTraversable ''Splice+deriveGTraversable ''Safety+deriveGTraversable ''CallConv+deriveGTraversable ''ModulePragma+deriveGTraversable ''Tool+deriveGTraversable ''Activation+deriveGTraversable ''Rule+deriveGTraversable ''RuleVar+deriveGTraversable ''WarningText+deriveGTraversable ''Pat+deriveGTraversable ''PXAttr+deriveGTraversable ''RPatOp+deriveGTraversable ''RPat+deriveGTraversable ''PatField+deriveGTraversable ''Stmt+deriveGTraversable ''QualStmt+deriveGTraversable ''FieldUpdate+deriveGTraversable ''Alt+deriveGTraversable ''Promoted+deriveGTraversable ''BooleanFormula+deriveGTraversable ''TypeEqn+deriveGTraversable ''Overlap+deriveGTraversable ''Sign+deriveGTraversable ''Namespace+deriveGTraversable ''Role+deriveGTraversable ''PatternSynDirection+deriveGTraversable ''Unpackedness+deriveGTraversable ''ResultSig+deriveGTraversable ''InjectivityInfo+deriveGTraversable ''DerivStrategy+deriveGTraversable ''MaybePromotedName
+ src/haskell-names/Language/Haskell/Names/Open/Instances.hs view
@@ -0,0 +1,361 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- MonoLocalBinds extension prevents premature generalization, which+-- results in the "default" instance being picked.+{-# LANGUAGE MonoLocalBinds #-}+module Language.Haskell.Names.Open.Instances () where++import Fay.Compiler.Prelude+import Language.Haskell.Names.GetBound+import Language.Haskell.Names.Open.Base+import Language.Haskell.Names.Open.Derived ()+import Language.Haskell.Names.RecordWildcards+import Language.Haskell.Names.Types++import Data.Lens.Light+import qualified Data.Traversable as T+import Language.Haskell.Exts++c :: Applicative w => c -> w c+c = pure++(<|)+ :: (Applicative w, Resolvable b, ?alg :: Alg w)+ => w (b -> c) -> (b, Scope) -> w c+(<|) k (b, sc) = k <*> alg b sc+infixl 4 <|++(-:) :: Scope -> a -> (a, Scope)+sc -: b = (b, sc)+infix 5 -:++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Decl l) where+ rtraverse e sc =+ case e of+ -- N.B. We do not add pat to the local scope.+ --+ -- If this is a top-level binding, then we shouldn't do so, lest+ -- global values are marked as local.+ -- (see https://github.com/haskell-suite/haskell-names/issues/35)+ --+ -- If this is a local binding, then we have already introduced these+ -- variables when processing the enclosing Binds.+ PatBind l pat rhs mbWhere ->+ let+ scWithWhere = intro mbWhere sc+ in+ c PatBind+ <| sc -: l+ <| sc -: pat+ <| exprV scWithWhere -: rhs+ <| sc -: mbWhere+ -- FunBind consists of Matches, which we handle below anyway.+ TypeSig l names ty ->+ c TypeSig+ <| sc -: l+ <| exprV sc -: names+ <| sc -: ty+ _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Type l) where+ rtraverse e sc = defaultRtraverse e (exprT sc)++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (DeclHead l) where+ rtraverse e sc =+ case e of+ DHead l name ->+ c DHead+ <| sc -: l+ <| binderT sc -: name+ DHInfix l v1 name ->+ c DHInfix+ <| sc -: l+ <| sc -: v1+ <| binderT sc -: name+ _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (ConDecl l) where+ rtraverse e sc =+ case e of+ ConDecl l name tys ->+ c ConDecl+ <| sc -: l+ <| binderV sc -: name+ <| sc -: tys+ InfixConDecl l t1 name t2 ->+ c InfixConDecl+ <| sc -: l+ <| sc -: t1+ <| binderV sc -: name+ <| sc -: t2+ RecDecl l name fields ->+ c RecDecl+ <| sc -: l+ <| binderV sc -: name+ <| sc -: fields+++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (FieldDecl l) where+ rtraverse e sc =+ case e of+ FieldDecl l name tys ->+ c FieldDecl+ <| sc -: l+ <| binderV sc -: name+ <| sc -: tys++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Pat l) where+ rtraverse e sc =+ case e of+ PVar l name ->+ c PVar+ <| sc -: l+ <| binderV sc -: name+ PNPlusK l name i ->+ c PNPlusK+ <| sc -: l+ <| binderV sc -: name+ <| sc -: i+ PInfixApp l pat1 name pat2 ->+ c PInfixApp+ <| sc -: l+ <| sc -: pat1+ <| exprV sc -: name+ <| sc -: pat2+ PApp l qn pat ->+ c PApp+ <| sc -: l+ <| exprV sc -: qn+ <| sc -: pat+ PRec l qn pfs ->+ let+ scWc =+ setWcNames (patWcNames (sc ^. gTable) qn pfs) sc+ in+ c PRec+ <| sc -: l+ <| exprV sc -: qn+ <| scWc -: pfs+ PAsPat l n pat ->+ c PAsPat+ <| sc -: l+ <| binderV sc -: n+ <| sc -: pat+ PViewPat l exp pat ->+ c PViewPat+ <| sc -: l+ <| exprV sc -: exp+ <| sc -: pat+ _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (PatField l) where+ rtraverse e sc =+ case e of+ PFieldPat l qn pat ->+ c PFieldPat+ <| sc -: l+ <| exprV sc -: qn+ <| sc -: pat+ PFieldPun l qn ->+ c PFieldPun+ <| sc -: l+ <| exprV sc -: qn+ -- In future we might want to annotate PFieldWildcard with the names+ -- it introduces.+ PFieldWildcard {} -> defaultRtraverse e sc++-- | Chain a sequence of nodes where every node may introduce some+-- variables into scope for the subsequent nodes. Examples: patterns (see+-- note [Nested pattern scopes]), statements.+chain+ :: ( Resolvable (a l)+ , GetBound (a l) l+ , Applicative w+ , SrcInfo l+ , Data l+ , ?alg :: Alg w)+ => [a l] -> Scope -> (w [a l], Scope)+chain pats sc =+ case pats of+ [] -> (pure [], sc)+ p:ps ->+ let+ sc' = intro p sc+ p' = alg p sc+ (ps', sc'') = chain ps sc'+ in ((:) <$> p' <*> ps', sc'')++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Match l) where+ rtraverse e sc =+ case e of+ Match l name pats rhs mbWhere ->+ -- f x y z = ...+ -- where ...+ let+ (pats', scWithPats) = chain pats sc+ scWithWhere = intro mbWhere scWithPats+ in+ c Match+ <| sc -: l+ <| binderV sc -: name+ <*> pats' -- has been already traversed+ <| exprV scWithWhere -: rhs+ <| scWithPats -: mbWhere+ InfixMatch l pat1 name patsRest rhs mbWhere ->+ let+ equivalentMatch = Match l name (pat1:patsRest) rhs mbWhere+ back (Match l name (pat1:patsRest) rhs mbWhere) =+ InfixMatch l pat1 name patsRest rhs mbWhere+ back _ = error "InfixMatch"+ in back <$> rtraverse equivalentMatch sc++-- NB: there is an inefficiency here (and in similar places), because we+-- call intro on the same subtree several times. Maybe tackle it later.+instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Binds l) where+ rtraverse e sc =+ case e of+ BDecls l decls ->+ let scWithBinds = intro decls sc+ in+ c BDecls+ <| sc -: l+ <| scWithBinds -: decls+ _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Exp l) where+ rtraverse e sc =+ case e of+ Let l bnds body ->+ let scWithBinds = intro bnds sc+ in+ c Let+ <| sc -: l+ <| scWithBinds -: bnds+ <| scWithBinds -: body++ Lambda l pats body ->+ let (pats', scWithPats) = chain pats sc+ in+ c Lambda+ <| sc -: l+ <*> pats'+ <| scWithPats -: body++ ListComp l e stmts ->+ let (stmts', scWithStmts) = chain stmts sc+ in+ c ListComp+ <| sc -: l+ <| scWithStmts -: e+ <*> stmts'++ ParComp l e stmtss ->+ let+ (stmtss', scsWithStmts) =+ unzip $ map (\stmts -> chain stmts sc) stmtss+ scWithAllStmtss = foldl1' mergeLocalScopes scsWithStmts+ in+ c ParComp+ <| sc -: l+ <| scWithAllStmtss -: e+ <*> T.sequenceA stmtss'++ Proc l pat e ->+ let scWithPat = intro pat sc+ in+ c Proc+ <| sc -: l+ <| sc -: pat+ <| scWithPat -: e++ RecConstr l qn fields ->+ let+ scWc =+ setWcNames+ (expWcNames+ (sc ^. gTable)+ (sc ^. lTable)+ qn+ fields)+ sc+ in+ c RecConstr+ <| sc -: l+ <| sc -: qn+ <| scWc -: fields++ _ -> defaultRtraverse e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (Alt l) where+ rtraverse e sc =+ case e of+ Alt l pat guardedAlts mbWhere ->+ let+ scWithPat = intro pat sc+ scWithBinds = intro mbWhere scWithPat+ in+ c Alt+ <| sc -: l+ <| sc -: pat+ <| scWithBinds -: guardedAlts+ <| scWithBinds -: mbWhere++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (GuardedRhs l) where+ rtraverse e sc =+ case e of+ GuardedRhs l stmts exp ->+ let (stmts', scWithStmts) = chain stmts sc+ in+ c GuardedRhs+ <| sc -: l+ <*> stmts'+ <| scWithStmts -: exp++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable [Stmt l] where+ rtraverse e sc =+ fst $ chain e sc++instance {-# OVERLAPPING #-} (Resolvable l, SrcInfo l, Data l) => Resolvable (QualStmt l) where+ rtraverse e sc =+ case e of+ QualStmt {} -> defaultRtraverse e sc+ _ -> error "haskell-names: TransformListComp is not supported yet"++{-+Note [Nested pattern scopes]+~~~~~~~~~~~~~~~~~~~~~~++When we resolve a group of patterns, their scopes nest.++Most of the time, this is not important, but there are two exceptions:+1. ScopedTypeVariables++Example: f (x :: a) (y :: a) = ...++The first 'a' is a binder, the second — a reference.++2. View patterns++An expression inside a view pattern may reference the variables bound+earlier.++Example: f x (find (< x) -> Just y) = ...+-}++-- Some road-block Resolvable instances+instance {-# OVERLAPPING #-} Typeable a => Resolvable (Scoped a) where+ rtraverse = flip $ const pure+instance {-# OVERLAPPING #-} Resolvable SrcSpan where+ rtraverse = flip $ const pure+instance {-# OVERLAPPING #-} Resolvable SrcSpanInfo where+ rtraverse = flip $ const pure++
+ src/haskell-names/Language/Haskell/Names/RecordWildcards.hs view
@@ -0,0 +1,145 @@+-- Wildcards are tricky, they deserve a module of their own+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-}+module Language.Haskell.Names.RecordWildcards+ ( patWcNames+ , wcFieldName+ , WcNames+ , expWcNames+ , wcFieldOrigName+ ) where++import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import qualified Language.Haskell.Names.LocalSymbolTable as Local+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Control.Monad+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.Set as Set+import Language.Haskell.Exts++-- | Information about the names being introduced by a record wildcard+--+-- During resolving traversal, we always (lazily) construct this list when+-- we process PRec or RecConstr, even if it doesn't contain a wildcard.+--+-- Then, if the pattern or construction actually contains a wildcard, we use the computed value.+type WcNames = [WcField]++-- | Information about a field in the wildcard+data WcField = WcField+ { wcFieldName :: Name ()+ -- ^ the field's simple name+ , wcFieldOrigName :: OrigName+ -- ^ the field's original name+ , wcExistsGlobalValue :: Bool+ -- ^ whether there is a global value in scope with the same name as+ -- the field but different from the field selector+ }++getElidedFields+ :: Global.Table+ -> QName l+ -> [Name l] -- mentioned field names+ -> WcNames+getElidedFields gt con fields =+ let+ givenFieldNames :: Map.Map (Name ()) ()+ givenFieldNames =+ Map.fromList . map ((, ()) . void) $ fields++ -- FIXME must report error when the constructor cannot be+ -- resolved+ (mbConOrigName, mbTypeOrigName) =+ case Global.lookupValue con gt of+ Global.Result info@SymConstructor{} ->+ (Just $ sv_origName info, Just $ sv_typeName info)+ _ -> (Nothing, Nothing)++ allValueInfos :: Set.Set (SymValueInfo OrigName)+ allValueInfos = Set.unions $ Map.elems $ Global.values gt++ ourFieldInfos :: Set.Set (SymValueInfo OrigName)+ ourFieldInfos =+ case mbConOrigName of+ Nothing -> Set.empty+ Just conOrigName ->+ flip Set.filter allValueInfos $ \v ->+ case v of+ SymSelector { sv_constructors }+ | conOrigName `elem` sv_constructors -> True+ _ -> False++ existsGlobalValue :: Name () -> Bool+ existsGlobalValue name =+ case Global.lookupValue (UnQual () name) gt of+ Global.Result info+ | Just typeOrigName <- mbTypeOrigName+ , SymSelector {} <- info+ , sv_typeName info == typeOrigName+ -> False -- this is the field selector+ | otherwise -> True -- exists, but not this field's selector+ _ -> False -- doesn't exist or ambiguous++ ourFieldNames :: Map.Map (Name ()) WcField+ ourFieldNames =+ Map.fromList $+ map+ (+ (\orig ->+ let name = stringToName . gName . origGName $ orig in+ (name, ) $+ WcField+ { wcFieldName = name+ , wcFieldOrigName = orig+ , wcExistsGlobalValue = existsGlobalValue name+ }+ ) . sv_origName+ )+ $ Set.toList ourFieldInfos++ in Map.elems $ ourFieldNames `Map.difference` givenFieldNames++nameOfPatField :: PatField l -> Maybe (Name l)+nameOfPatField pf =+ case pf of+ PFieldPat _ qn _ -> Just $ qNameToName qn+ PFieldPun _ qn -> Just $ qNameToName qn+ PFieldWildcard {} -> Nothing++nameOfUpdField :: FieldUpdate l -> Maybe (Name l)+nameOfUpdField pf =+ case pf of+ FieldUpdate _ qn _ -> Just $ qNameToName qn+ FieldPun _ qn -> Just $ qNameToName qn+ FieldWildcard {} -> Nothing++patWcNames+ :: Global.Table+ -> QName l+ -> [PatField l]+ -> WcNames+patWcNames gt con patfs =+ getElidedFields gt con $+ mapMaybe nameOfPatField patfs++expWcNames+ :: Global.Table+ -> Local.Table+ -> QName l+ -> [FieldUpdate l]+ -> WcNames+expWcNames gt lt con patfs =+ filter isInScope $+ getElidedFields gt con $+ mapMaybe nameOfUpdField patfs+ where+ isInScope field+ | Right {} <- Local.lookupValue qn lt = True+ | otherwise = wcExistsGlobalValue field+ where+ qn = UnQual () $ wcFieldName field
+ src/haskell-names/Language/Haskell/Names/Recursive.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Language.Haskell.Names.Recursive+ ( computeInterfaces+ , getInterfaces+ , annotateModule+ ) where++import Fay.Compiler.Prelude++import Fay.Compiler.ModuleT+import Language.Haskell.Names.Annotated+import Language.Haskell.Names.Exports+import Language.Haskell.Names.Imports+import Language.Haskell.Names.ModuleSymbols+import Language.Haskell.Names.Open.Base+import Language.Haskell.Names.ScopeUtils+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Data.Data (Data)+import Data.Foldable+import Data.Graph (flattenSCC, stronglyConnComp)+import qualified Data.Set as Set+import Language.Haskell.Exts+++-- | Take a set of modules and return a list of sets, where each sets for+-- a strongly connected component in the import graph.+-- The boolean determines if imports using @SOURCE@ are taken into account.+groupModules :: forall l . [Module l] -> [[Module l]]+groupModules modules =+ map flattenSCC $ stronglyConnComp $ map mkNode modules+ where+ mkNode :: Module l -> (Module l, ModuleName (), [ModuleName ()])+ mkNode m =+ ( m+ , dropAnn $ getModuleName m+ , map (dropAnn . importModule) $ getImports m+ )++-- | Annotate a module with scoping information. This assumes that all+-- module dependencies have been resolved and cached — usually you need+-- to run 'computeInterfaces' first, unless you have one module in+-- isolation.+annotateModule+ :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Eq l)+ => Language -- ^ base language+ -> [Extension] -- ^ global extensions (e.g. specified on the command line)+ -> Module l -- ^ input module+ -> m (Module (Scoped l)) -- ^ output (annotated) module+annotateModule lang exts mod@(Module lm mh os is ds) = do+ let extSet = moduleExtensions lang exts mod+ (imp, impTbl) <- processImports extSet is+ let tbl = moduleTable impTbl mod+ (exp, _syms) <- processExports tbl mod++ let+ lm' = none lm+ os' = fmap noScope os+ is' = imp+ ds' = annotate (initialScope tbl) `map` ds++ mh' = flip fmap mh $ \(ModuleHead lh n mw _me) ->+ let+ lh' = none lh+ n' = noScope n+ mw' = fmap noScope mw+ me' = exp+ in ModuleHead lh' n' mw' me'++ return $ Module lm' mh' os' is' ds'++annotateModule _ _ _ = error "annotateModule: non-standard modules are not supported"++-- | Compute interfaces for a set of mutually recursive modules and write+-- the results to the cache. Return the set of import/export errors.+findFixPoint+ :: (Ord l, Data l, MonadModule m, ModuleInfo m ~ Symbols)+ => [(Module l, ExtensionSet)]+ -- ^ module and all extensions with which it is to be compiled.+ -- Use 'moduleExtensions' to build this list.+ -> m (Set.Set (Error l))+findFixPoint mods = go mods (map (const mempty) mods) where+ go mods syms = do+ forM_ (zip syms mods) $ \(s,(m, _)) -> insertInCache (getModuleName m) s+ (syms', errors) <- liftM unzip $ forM mods $ \(m, extSet) -> do+ (imp, impTbl) <- processImports extSet $ getImports m+ let tbl = moduleTable impTbl m+ (exp, syms) <- processExports tbl m+ return (syms, foldMap getErrors imp <> foldMap getErrors exp)+ if syms' == syms+ then return $ mconcat errors+ else go mods syms'++-- | 'computeInterfaces' takes a list of possibly recursive modules and+-- computes the interface of each module. The computed interfaces are+-- written into the @m@'s cache and are available to further computations+-- in this monad.+--+-- Returns the set of import/export errors. Note that the interfaces are+-- registered in the cache regardless of whether there are any errors, but+-- if there are errors, the interfaces may be incomplete.+computeInterfaces+ :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+ => Language -- ^ base language+ -> [Extension] -- ^ global extensions (e.g. specified on the command line)+ -> [Module l] -- ^ input modules+ -> m (Set.Set (Error l)) -- ^ errors in export or import lists+computeInterfaces lang exts =+ liftM fold . mapM findFixPoint . map supplyExtensions . groupModules+ where+ supplyExtensions = map $ \m -> (m, moduleExtensions lang exts m)++-- | Like 'computeInterfaces', but also returns a list of interfaces, one+-- per module and in the same order+getInterfaces+ :: (MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l, Ord l)+ => Language -- ^ base language+ -> [Extension] -- ^ global extensions (e.g. specified on the command line)+ -> [Module l] -- ^ input modules+ -> m ([Symbols], Set.Set (Error l)) -- ^ output modules, and errors in export or import lists+getInterfaces lang exts mods = do+ errs <- computeInterfaces lang exts mods+ ifaces <- forM mods $ \mod ->+ let modName = getModuleName mod in+ fromMaybe (error $ msg modName) `liftM` lookupInCache modName+ return (ifaces, errs)+ where+ msg modName = "getInterfaces: module " ++ modToString modName ++ " is not in the cache"
+ src/haskell-names/Language/Haskell/Names/ScopeUtils.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.ScopeUtils+ ( computeSymbolTable+ , noScope+ , none+ , resolveCNames+ , scopeError+ , sv_parent+ ) where++import Fay.Compiler.Prelude+import qualified Language.Haskell.Names.GlobalSymbolTable as Global+import Language.Haskell.Names.SyntaxUtils+import Language.Haskell.Names.Types++import Data.Lens.Light+import qualified Data.Set as Set+import Language.Haskell.Exts++scopeError :: Functor f => Error l -> f l -> f (Scoped l)+scopeError e f = Scoped (ScopeError e) <$> f++none :: l -> Scoped l+none = Scoped None++noScope :: (Annotated a) => a l -> a (Scoped l)+noScope = fmap none++sv_parent :: SymValueInfo n -> Maybe n+sv_parent (SymSelector { sv_typeName = n }) = Just n+sv_parent (SymConstructor { sv_typeName = n }) = Just n+sv_parent (SymMethod { sv_className = n }) = Just n+sv_parent _ = Nothing++computeSymbolTable+ :: Bool+ -- ^ If 'True' (\"qualified\"), then only the qualified names are+ -- inserted.+ --+ -- If 'False', then both qualified and unqualified names are insterted.+ -> ModuleName l+ -> Symbols+ -> Global.Table+computeSymbolTable qual (ModuleName _ mod) syms =+ Global.fromLists $+ if qual+ then renamed+ else renamed <> unqualified+ where+ vs = Set.toList $ syms^.valSyms+ ts = Set.toList $ syms^.tySyms+ renamed = renameSyms mod+ unqualified = renameSyms ""+ renameSyms mod = (map (rename mod) vs, map (rename mod) ts)+ rename :: HasOrigName i => ModuleNameS -> i OrigName -> (GName, i OrigName)+ rename m v = ((origGName . origName $ v) { gModule = m }, v)++resolveCName+ :: Symbols+ -> OrigName+ -> (CName l -> Error l) -- ^ error for "not found" condition+ -> CName l+ -> (CName (Scoped l), Symbols)+resolveCName syms parent notFound cn =+ let+ vs =+ [ info+ | info <- Set.toList $ syms^.valSyms+ , let name = gName . origGName $ sv_origName info+ , nameToString (unCName cn) == name+ , Just p <- return $ sv_parent info+ , p == parent+ ]+ in+ case vs of+ [] -> (scopeError (notFound cn) cn, mempty)+ [i] -> (Scoped (GlobalValue i) <$> cn, mkVal i)+ _ -> (scopeError (EInternal "resolveCName") cn, mempty)++resolveCNames+ :: Symbols+ -> OrigName+ -> (CName l -> Error l) -- ^ error for "not found" condition+ -> [CName l]+ -> ([CName (Scoped l)], Symbols)+resolveCNames syms orig notFound =+ second mconcat . unzip . map (resolveCName syms orig notFound)
+ src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs view
@@ -0,0 +1,136 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+module Language.Haskell.Names.SyntaxUtils+ ( dropAnn+ , getModuleName+ , getImports+ , getExportSpecList+ , getDeclHeadName+ , getModuleDecls+ , nameToString+ , stringToName+ , qNameToName+ , unCName+ , getErrors+ , moduleExtensions+ ) where++import Language.Haskell.Names.Types++import Data.Char+import Data.Either+import Data.Foldable+import Data.Maybe+import qualified Data.Set as Set+import Language.Haskell.Exts++dropAnn :: (Functor a) => a l -> a ()+dropAnn = fmap (const ())++getModuleName :: Module l -> ModuleName l+getModuleName (Module _ (Just (ModuleHead _ mn _ _)) _ _ _) = mn+getModuleName (XmlPage _ mn _ _ _ _ _) = mn+getModuleName (XmlHybrid _ (Just (ModuleHead _ mn _ _)) _ _ _ _ _ _ _) = mn+getModuleName m = main_mod (ann m)++getImports :: Module l -> [ImportDecl l]+getImports (Module _ _ _ is _) = is+getImports (XmlPage _ _ _ _ _ _ _) = []+getImports (XmlHybrid _ _ _ is _ _ _ _ _) = is++getModuleDecls :: Module l -> [Decl l]+getModuleDecls (Module _ _ _ _ ds) = ds+getModuleDecls (XmlPage _ _ _ _ _ _ _) = []+getModuleDecls (XmlHybrid _ _ _ _ ds _ _ _ _) = ds++getExportSpecList :: Module l -> Maybe (ExportSpecList l)+getExportSpecList m = me where ModuleHead _ _ _ me = getModuleHead m++getModuleHead :: Module l -> ModuleHead l+getModuleHead (Module _ (Just mh) _ _ _) = mh+getModuleHead (XmlHybrid _ (Just mh) _ _ _ _ _ _ _) = mh+getModuleHead m = ModuleHead l (main_mod l) Nothing (Just (ExportSpecList l [EVar l (UnQual l (Ident l "main"))]))+ where l = ann m++qNameToName :: QName l -> Name l+qNameToName (UnQual _ n) = n+qNameToName (Qual _ _ n) = n+qNameToName (Special l s) = Ident l (specialConToString s)++getDeclHeadName :: DeclHead l -> Name l+getDeclHeadName dh =+ case dh of+ DHead _ n -> n+ DHInfix _ _ n -> n+ DHParen _ dh' -> getDeclHeadName dh'+ DHApp _ dh' _ -> getDeclHeadName dh'++----------------------------------------------------++nameToString :: Name l -> String+nameToString (Ident _ s) = s+nameToString (Symbol _ s) = s++stringToName :: String -> Name ()+stringToName s@(c:_) | isSymbol c = Symbol () s+stringToName s = Ident () s++specialConToString :: SpecialCon l -> String+specialConToString (UnitCon _) = "()"+specialConToString (ListCon _) = "[]"+specialConToString (FunCon _) = "->"+specialConToString (TupleCon _ Boxed n) = replicate (n-1) ','+specialConToString (TupleCon _ Unboxed n) = '#':replicate (n-1) ','+specialConToString (Cons _) = ":"+specialConToString (UnboxedSingleCon _) = "#"+specialConToString (ExprHole _) = "_"++unCName :: CName l -> Name l+unCName (VarName _ n) = n+unCName (ConName _ n) = n++getErrors :: (Ord l, Foldable a) => a (Scoped l) -> Set.Set (Error l)+getErrors = foldl' f Set.empty+ where+ f errors (Scoped (ScopeError e) _) = Set.insert e errors+ f errors _ = errors++-- | Compute the extension set for the given module, based on the global+-- preferences (e.g. specified on the command line) and module's LANGUAGE+-- pragmas.+moduleExtensions+ :: Language -- ^ base language+ -> [Extension] -- ^ global extensions+ -> Module l+ -> ExtensionSet+moduleExtensions globalLang globalExts mod =+ let+ (mbModLang, modExts) = getModuleExtensions mod+ lang = fromMaybe globalLang mbModLang+ kexts = toExtensionList lang (globalExts ++ modExts)+ in Set.fromList kexts++getModuleExtensions :: Module l -> (Maybe Language, [Extension])+getModuleExtensions mod =+ let+ names =+ [ name+ | let+ pragmas =+ case mod of+ Module _ _ pragmas _ _ -> pragmas+ XmlPage _ _ pragmas _ _ _ _ -> pragmas+ XmlHybrid _ _ pragmas _ _ _ _ _ _ -> pragmas+ , LanguagePragma _ names <- pragmas+ , Ident _ name <- names+ ]++ classified :: [Either Language Extension]+ classified =+ flip map names $ \name ->+ case (parseExtension name, classifyLanguage name) of+ (e, UnknownLanguage {}) -> Right e+ (_, l) -> Left l++ (langs, exts) = partitionEithers classified+ in+ (if null langs then Nothing else Just $ last langs, exts)
+ src/haskell-names/Language/Haskell/Names/Types.hs view
@@ -0,0 +1,293 @@+{-# OPTIONS -fno-warn-name-shadowing #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StandaloneDeriving #-}+module Language.Haskell.Names.Types+ ( Error (..)+ , ExtensionSet+ , GName (..)+ , HasOrigName (..)+ , ModuleNameS+ , NameInfo (..)+ , NameS+ , OrigName (..)+ , Scoped (..)+ , SymTypeInfo (..)+ , SymValueInfo (..)+ , Symbols (..)+ , mkTy+ , mkVal+ , ppError+ , ppGName+ , ppOrigName+ , sLoc+ , tySyms+ , valSyms+ ) where++import {-# SOURCE #-} qualified Language.Haskell.Names.GlobalSymbolTable as Global+import Fay.Compiler.Prelude++import Data.Foldable as F+import Data.Lens.Light+import qualified Data.Set as Set+import Language.Haskell.Exts+import Text.Printf+import qualified Data.Semigroup as SG++type ExtensionSet = Set.Set KnownExtension++-- | Repesents the symbol's fixity+type SymFixity = (Assoc (), Int)++-- | Information about a value-level entitity+data SymValueInfo name+ = SymValue+ { sv_origName :: name+ , sv_fixity :: Maybe SymFixity+ }+ -- ^ value or function+ | SymMethod+ { sv_origName :: name+ , sv_fixity :: Maybe SymFixity+ , sv_className :: name+ }+ -- ^ class method+ | SymSelector+ { sv_origName :: name+ , sv_fixity :: Maybe SymFixity+ , sv_typeName :: name+ , sv_constructors :: [name]+ }+ -- ^ record field selector+ | SymConstructor+ { sv_origName :: name+ , sv_fixity :: Maybe SymFixity+ , sv_typeName :: name+ }+ -- ^ data constructor+ deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++-- | Information about a type-level entitity+data SymTypeInfo name+ = SymType+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ type synonym+ | SymData+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ data type+ | SymNewType+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ newtype+ | SymTypeFam+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ type family+ | SymDataFam+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ data family+ | SymClass+ { st_origName :: name+ , st_fixity :: Maybe SymFixity+ }+ -- ^ type class+ deriving (Eq, Ord, Show, Data, Typeable, Functor, Foldable, Traversable)++class HasOrigName i where+ origName :: i n -> n++instance HasOrigName SymValueInfo where+ origName = sv_origName++instance HasOrigName SymTypeInfo where+ origName = st_origName++-- | The set of symbols (entities) exported by a single module. Contains+-- the sets of value-level and type-level entities.+data Symbols = Symbols (Set.Set (SymValueInfo OrigName)) (Set.Set (SymTypeInfo OrigName))+ deriving (Eq, Ord, Show, Data, Typeable)++instance SG.Semigroup Symbols where+ (Symbols s1 t1) <> (Symbols s2 t2) =+ Symbols (s1 <> s2) (t1 <> t2)++instance Monoid Symbols where+ mempty = Symbols mempty mempty+ mappend = (<>)++valSyms :: Lens Symbols (Set.Set (SymValueInfo OrigName))+valSyms = lens (\(Symbols vs _) -> vs) (\vs (Symbols _ ts) -> Symbols vs ts)++tySyms :: Lens Symbols (Set.Set (SymTypeInfo OrigName))+tySyms = lens (\(Symbols _ ts) -> ts) (\ts (Symbols vs _) -> Symbols vs ts)++mkVal :: SymValueInfo OrigName -> Symbols+mkVal i = Symbols (Set.singleton i) mempty++mkTy :: SymTypeInfo OrigName -> Symbols+mkTy i = Symbols mempty (Set.singleton i)++-- | String representing an unqualified entity name+type NameS = String+-- | String representing a module name+type ModuleNameS = String++-- | Possibly qualified name. If the name is not qualified,+-- 'ModuleNameS' is the empty string.+data GName = GName+ { gModule :: ModuleNameS+ , gName :: NameS+ }+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Display a 'GName'+ppGName :: GName -> String+ppGName (GName mod name) = printf "%s.%s" mod name++-- # if !MIN_VERSION_Cabal(1,17,0)+-- deriving instance Typeable PackageIdentifier+-- deriving instance Data PackageIdentifier+-- deriving instance Typeable PackageName+-- deriving instance Data PackageName+-- deriving instance Data Version+-- # endif++-- | Qualified name, where 'ModuleNameS' points to the module where the+-- name was originally defined. The module part is never empty.+--+-- Also contains name and version of the package where it was defined. If+-- it's 'Nothing', then the entity is defined in the \"current\" package.+data OrigName = OrigName+ { origGName :: GName+ }+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Display an 'OrigName'+ppOrigName :: OrigName -> String+ppOrigName (OrigName gname) = ppGName gname++-- | A pair of the name information and original annotation. Used as an+-- annotation type for AST.+data Scoped l = Scoped (NameInfo l) l+ deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data NameInfo l+ = GlobalValue (SymValueInfo OrigName) -- ^ global value+ | GlobalType (SymTypeInfo OrigName) -- ^ global type+ | LocalValue SrcLoc -- ^ local value, and location where it is bound+ | TypeVar SrcLoc -- ^ type variable, and location where it is bound+ | ValueBinder -- ^ here the value name is bound+ | TypeBinder -- ^ here the type name is defined+ | Import Global.Table+ -- ^ @import@ declaration, and the table of symbols that it+ -- introduces+ | ImportPart Symbols+ -- ^ part of an @import@ declaration+ | Export Symbols+ -- ^ @export@ declaration, and the symbols it exports+ | RecPatWildcard [OrigName]+ -- ^ wildcard in a record pattern. The list contains resolved names+ -- of the fields that are brought in scope by this pattern.+ | RecExpWildcard [(OrigName, NameInfo l)]+ -- ^ wildcard in a record construction expression. The list contains+ -- resolved names of the fields and information about values+ -- assigned to those fields.+ | None+ -- ^ no annotation+ | ScopeError (Error l)+ -- ^ scope error+ deriving (Functor, Foldable, Traversable, Show, Typeable, Data, Eq, Ord)++data Error l+ = ENotInScope (QName l) -- FIXME annotate with namespace (types/values)+ -- ^ name is not in scope+ | EAmbiguous (QName l) [OrigName]+ -- ^ name is ambiguous+ | ETypeAsClass (QName l)+ -- ^ type is used where a type class is expected+ | EClassAsType (QName l)+ -- ^ type class is used where a type is expected+ | ENotExported+ (Maybe (Name l)) --+ (Name l) --+ (ModuleName l)+ -- ^ Attempt to explicitly import a name which is not exported (or,+ -- possibly, does not even exist). For example:+ --+ -- >import Prelude(Bool(Right))+ --+ -- The fields are:+ --+ -- 1. optional parent in the import list, e.g. @Bool@ in @Bool(Right)@+ --+ -- 2. the name which is not exported+ --+ -- 3. the module which does not export the name+ | EModNotFound (ModuleName l)+ -- ^ module not found+ | EInternal String+ -- ^ internal error+ deriving (Data, Typeable, Show, Functor, Foldable, Traversable, Eq, Ord)++-- | Display an error.+--+-- Note: can span multiple lines; the trailing newline is included.+ppError :: SrcInfo l => Error l -> String+ppError e =+ case e of+ ENotInScope qn -> printf "%s: not in scope: %s\n"+ (ppLoc qn)+ (prettyPrint qn)+ EAmbiguous qn names ->+ printf "%s: ambiguous name %s\nIt may refer to:\n"+ (ppLoc qn)+ (prettyPrint qn)+ +++ F.concat (map (printf " %s\n" . ppOrigName) names)+ ETypeAsClass qn ->+ printf "%s: type %s is used where a class is expected\n"+ (ppLoc qn)+ (prettyPrint qn)+ EClassAsType qn ->+ printf "%s: class %s is used where a type is expected\n"+ (ppLoc qn)+ (prettyPrint qn)+ ENotExported _mbParent name mod ->+ printf "%s: %s does not export %s\n"+ (ppLoc name)+ (prettyPrint mod)+ (prettyPrint name)+ -- FIXME: make use of mbParent+ EModNotFound mod ->+ printf "%s: module not found: %s\n"+ (ppLoc mod)+ (prettyPrint mod)+ EInternal s -> printf "Internal error: %s\n" s++ where+ ppLoc :: (Annotated a, SrcInfo l) => a l -> String+ ppLoc = prettyPrint . getPointLoc . ann++instance (SrcInfo l) => SrcInfo (Scoped l) where+ toSrcInfo l1 ss l2 = Scoped None $ toSrcInfo l1 ss l2+ fromSrcInfo = Scoped None . fromSrcInfo+ getPointLoc = getPointLoc . sLoc+ fileName = fileName . sLoc+ startLine = startLine . sLoc+ startColumn = startColumn . sLoc++sLoc :: Scoped l -> l+sLoc (Scoped _ l) = l
src/main/Main.hs view
@@ -3,45 +3,54 @@ module Main where import Fay-import Paths_fay (version)+import Paths_fay (version) +import Control.Applicative ((<|>), (<$>), (<*>))+import qualified Control.Exception as E import Control.Monad import Control.Monad.Reader-import Data.List.Split (wordsBy)+import Data.List.Split (wordsBy) import Data.Maybe-import Data.Version (showVersion)-import Options.Applicative-import Options.Applicative.Types-import qualified Control.Exception as E+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+ { optBasePath :: Maybe FilePath+ , optGClosure :: Bool , optFlattenApps :: Bool- , optHTMLWrapper :: Bool , optHTMLJSLibs :: [String]+ , optHTMLWrapper :: Bool , optInclude :: [String]- , optPackages :: [String]- , optWall :: Bool+ , optLibrary :: Bool , optNoGHC :: Bool- , optStdout :: Bool- , optVersion :: Bool- , optOutput :: Maybe String- , optPretty :: Bool- , optOptimize :: Bool- , optGClosure :: Bool- , optPackageConf :: Maybe String+ , 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- , optBasePath :: Maybe FilePath+ , optStdout :: Bool , optStrict :: [String] , optTypecheckOnly :: Bool- , optRuntimePath :: Maybe FilePath- , optSourceMap :: Bool+ , optVersion :: Bool+ , optWall :: Bool+ , optShowGhcCalls :: Bool+ , optTypeScript :: Bool , optFiles :: [String]- , optNoOptimizeNewtypes :: Bool } -- | Main entry point.@@ -53,7 +62,7 @@ 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@@ -70,11 +79,15 @@ , 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@@ -86,41 +99,46 @@ parser = info (helper <*> options) (fullDesc <> header helpTxt) outPutFile :: FayCompilerOptions -> String -> FilePath- outPutFile opts file = fromMaybe (toJsName file) $ optOutput opts+ outPutFile opts file = fromMaybe (if optTypeScript opts then toTsName file else toJsName file) $ optOutput opts -- | All Fay's command-line options. options :: Parser FayCompilerOptions options = FayCompilerOptions- <$> switch (long "library" <> help "Don't automatically call main in generated JavaScript")+ <$> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+ <*> switch (long "closure" <> help "Provide help with Google Closure") <*> switch (long "flatten-apps" <> help "flatten function applicaton")- <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript") <*> strsOption (long "html-js-lib" <> metavar "file1[, ..]" <> help "javascript files to add to <head> if using option html-wrapper")+ <*> switch (long "html-wrapper" <> help "Create an html file that loads the javascript") <*> strsOption (long "include" <> metavar "dir1[, ..]" <> help "additional directories for include")- <*> strsOption (long "package" <> metavar "package[, ..]"- <> help "packages to use for compilation")- <*> switch (long "Wall" <> help "Typecheck with -Wall")+ <*> switch (long "library" <> help "Don't automatically call main in generated JavaScript") <*> switch (long "no-ghc" <> help "Don't typecheck, specify when not working with files")- <*> switch (long "stdout" <> short 's' <> help "Output to stdout")- <*> switch (long "version" <> help "Output version number")- <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))- <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")- <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")- <*> switch (long "closure" <> help "Provide help with Google Closure")- <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+ <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types") <*> switch (long "no-rts" <> short 'r' <> help "Don't export the RTS") <*> switch (long "no-stdlib" <> help "Don't generate code for the Prelude/FFI")+ <*> switch (long "optimize" <> short 'O' <> help "Apply optimizations to generated code")+ <*> optional (strOption (long "output" <> short 'o' <> metavar "file" <> help "Output to specified file"))+ <*> strsOption (long "package" <> metavar "package[, ..]"+ <> help "packages to use for compilation")+ <*> optional (strOption (long "package-conf" <> help "Specify the Cabal package config file"))+ <*> switch (long "pretty-all" <> help "Pretty print, pretty operators and pretty thunks")+ <*> switch (long "pretty" <> short 'p' <> help "Pretty print the output")+ <*> switch (long "pretty-operators" <> help "Use pretty operators")+ <*> switch (long "pretty-thunks" <> help "Use pretty thunk names") <*> switch (long "print-runtime" <> help "Print the runtime JS source to stdout")+ <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")+ <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map") <*> switch (long "stdlib" <> help "Only output the stdlib")- <*> optional (strOption $ long "base-path" <> help "If fay can't find the sources of fay-base you can use this to provide the path. Use --base-path ~/example instead of --base-path=~/example to make sure ~ is expanded properly")+ <*> switch (long "stdout" <> short 's' <> help "Output to stdout") <*> strsOption (long "strict" <> metavar "modulename[, ..]" <> help "Generate strict and uncurried exports for the supplied modules. Simplifies calling Fay from JS") <*> switch (long "typecheck-only" <> help "Only invoke GHC for typechecking, don't produce any output")- <*> optional (strOption $ long "runtime-path" <> help "Custom path to the runtime so you don't have to reinstall fay when modifying it")- <*> switch (long "sourcemap" <> help "Produce a source map in <outfile>.map")+ <*> switch (long "version" <> help "Output version number")+ <*> switch (long "Wall" <> help "Typecheck with -Wall")+ <*> switch (long "show-ghc-calls" <> help "Print commands sent to ghc")+ <*> switch (long "ts" <> help "Output TypeScript instead of JavaScript") <*> many (argument (ReadM ask) (metavar "<hs-file>..."))- <*> switch (long "no-optimized-newtypes" <> help "Remove optimizations for newtypes, treating them as normal data types") where strsOption :: Mod OptionFields [String] -> Parser [String] strsOption m = option (ReadM . fmap (wordsBy (== ',')) $ ask) (m <> value [])@@ -135,10 +153,9 @@ -- | The basic help text. helpTxt :: String-helpTxt = concat- ["fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"- ," fay <hs-file>... processes each .hs file"- ]+helpTxt+ = "fay -- The fay compiler from (a proper subset of) Haskell to Javascript\n\n"+ ++ " fay <hs-file>... processes each .hs file" -- | Print the command version. runCommandVersion :: IO ()
src/tests/Test/CommandLine.hs view
@@ -39,4 +39,6 @@ whatAGreatFramework <- fmap (lookup "HASKELL_PACKAGE_SANDBOX") getEnvironment res <- compileFile (["--include=tests", "tests/RecordImport_Import.hs","--no-ghc"] ++ ["--package-conf=" ++ packageConf | Just packageConf <- [whatAGreatFramework] ])- assertBool (fromLeft res) (isRight res)+ case res of+ Left e -> assertFailure $ "Compilation failed: " ++ e+ Right _ -> assertBool "impossible" True
src/tests/Test/Compile.hs view
@@ -3,15 +3,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -module Test.Compile (tests) where+module Test.Compile (tests,runScriptFile) where import Fay import Fay.Compiler.Prelude-#if !MIN_VERSION_base(4,7,0)-import Test.Util (isRight)-#endif -import Language.Haskell.Exts.Annotated+import Language.Haskell.Exts import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.TH@@ -87,13 +84,45 @@ case_strictWrapper = do cfg <- defConf res <- compileFile cfg { configTypecheck = True, configFilePath = Just "tests/Compile/StrictWrapper.hs", configStrict = ["StrictWrapper"] } "tests/Compile/StrictWrapper.hs"+ let isTs = configTypeScript cfg+ suffix = if isTs then ".ts" else ".js" (\a b -> either a b res) (assertFailure . show) $ \js -> do- writeFile "tests/Compile/StrictWrapper.js" js- (err, out) <- either id id <$> readAllFromProcess "node" ["tests/Compile/StrictWrapper.js"] ""+ writeFile ("tests/Compile/StrictWrapper" ++ suffix) js+ (err, out) <- either id id <$> runScriptFile isTs ("tests/Compile/StrictWrapper" ++ suffix) when (err /= "") $ assertFailure err expected <- readFile "tests/Compile/StrictWrapper.res" assertEqual "strictWrapper node stdout" expected out +assertPretty :: Config -> String -> Assertion+assertPretty cfg flagName = do+ let isTs = configTypeScript cfg+ suffix = if isTs then ".ts" else ".js"+ res <- compileFile cfg $ "tests/Compile/" ++ flagName ++ ".hs"+ case res of+ Left l -> assertFailure $ "Should compile, but failed with: " ++ show l+ Right js -> do+ writeFile ("tests/Compile/" ++ flagName ++ suffix) js+ (err, out) <- either id id <$> runScriptFile isTs+ ("tests/Compile/" ++ flagName ++ suffix)+ when (err /= "") $ assertFailure err+ expected <- readFile $ "tests/Compile/" ++ flagName ++ ".res"+ assertEqual (flagName ++ " node stdout") expected out++case_pretty :: Assertion+case_pretty = do+ cfg <- defConf+ assertPretty cfg { configPrettyPrint = True } "pretty"++case_prettyThunks :: Assertion+case_prettyThunks = do+ cfg <- defConf+ assertPretty cfg { configPrettyThunks = True } "prettyThunks"++case_prettyOperators :: Assertion+case_prettyOperators = do+ cfg <- defConf+ assertPretty cfg { configPrettyOperators = True } "prettyOperators"+ case_charEnum :: Assertion case_charEnum = do cfg <- defConf@@ -107,3 +136,15 @@ defConf = do cfg <- defaultConfigWithSandbox return $ addConfigDirectoryIncludePaths ["tests/"] cfg { configTypecheck = False }++-- | Run a JS or TS file.+runScriptFile :: Bool -- ^ If a file-format is TypeScript, this is True.+ -> String -- ^ A name of script file+ -> IO (Either (String,String) (String,String))+runScriptFile True file = do+ tsc_ret <- readAllFromProcess "tsc" [file] ""+ case tsc_ret of+ Left _ -> return tsc_ret+ Right _ -> readAllFromProcess "node" [(reverse (drop 3 (reverse file))) ++ ".js" ] ""++runScriptFile False file = readAllFromProcess "node" [file] ""
src/tests/Test/Desugar.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ViewPatterns #-} module Test.Desugar ( tests , devTest@@ -9,13 +10,13 @@ import Fay.Compiler.Prelude import Fay.Compiler.Desugar-import Fay.Compiler.Parse (parseFay)-import Fay.Types.CompileError (CompileError (..))+import Fay.Compiler.Parse (parseFay)+import Fay.Types.CompileError (CompileError (..)) -import Language.Haskell.Exts.Annotated hiding (alt, binds, loc, name)+import Language.Haskell.Exts hiding (name) import Test.Tasty import Test.Tasty.HUnit-import Text.Groom+-- import Text.Groom tests :: TestTree tests = testGroup "desugar" $ map (\(T k a b) -> testCase k $ doDesugar k a b) testDeclarations@@ -91,12 +92,17 @@ parseAndDesugar :: String -> String -> IO (Module SrcLoc, Either CompileError (Module SrcLoc)) parseAndDesugar name s =- case parseFay "test" s :: ParseResult (Module SrcLoc) of+ case parseFay "test" s :: ParseResult (Module SrcSpanInfo) of ParseFailed a b -> error $ show (name, a, b)- ParseOk m -> do+ ParseOk (fmap srcSpanInfoToSrcLoc -> m) -> do d <- desugar' "gen" noLoc m- return (m,d)-+ 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@@ -106,8 +112,8 @@ 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+ (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@@ -141,7 +147,7 @@ when (unAnn desugaredExpected /= unAnn originalExpected ) $ putStrLn "desugaredExpected /= undesugared" g :: Show a => a -> IO ()-g = putStrLn . groom+g = print -- putStrLn . groom unAnn :: Functor f => f a -> f () unAnn = void
src/tests/Test/Util.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE NoImplicitPrelude #-} module Test.Util ( fayPath- , isRight- , fromLeft , getRecursiveContents ) where @@ -32,10 +30,6 @@ hush :: Either a b -> Maybe b hush = either (const Nothing) Just -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@@ -50,9 +44,3 @@ then getRecursiveContents path else return [path] return (concat paths)--#if !MIN_VERSION_base(4,7,0)-isRight :: Either a b -> Bool-isRight Right{} = True-isRight Left{} = False-#endif
src/tests/Tests.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ViewPatterns #-} -- | Generate the web site/documentation for the Fay project. --@@ -7,17 +8,21 @@ module Main where -import Fay import Fay.Compiler.Prelude++import Fay import qualified Test.CommandLine as Cmd import qualified Test.Compile as Compile import qualified Test.Convert as Convert import qualified Test.Desugar as Desugar import Test.Util +import Data.Set (Set)+import qualified Data.Set as S import System.Directory import System.Environment import System.FilePath+import System.Random import Test.Tasty import Test.Tasty.HUnit @@ -25,10 +30,14 @@ 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- (runtime,codegen) <- makeCompilerTests (packageConf <|> sandbox) basePath- withArgs args' $ defaultMain $ testGroup "Fay"+ (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@@ -42,18 +51,19 @@ 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 (TestTree,TestTree)-makeCompilerTests packageConf basePath = do- runtimeFiles <- runtimeTestFiles- codegenFiles <- codegenTestFiles+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 file- testFile packageConf basePath True file)- ,makeTestGroup "Codegen tests"- codegenFiles- (\file -> testCodegen packageConf basePath file))+ ( 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 ->@@ -67,12 +77,30 @@ 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/"] defaultConfig@@ -80,12 +108,13 @@ , 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)@@ -101,11 +130,9 @@ -- | 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 -> String -> IO ()-testCodegen packageConf basePath file = do- let root = (reverse . drop 1 . dropWhile (/='.') . reverse) file- out = toJsName file- resf = root <.> "res"+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@@ -117,14 +144,12 @@ , configPrettyPrint = True , configLibrary = True , configExportRuntime = False+ , configTypeScript = isTs } compileFromTo config file (Just out) actual <- readStripped out- expected <- readStripped resf+ expected <- readStripped $ resf ++ (if isTs then "_ts" else "") assertEqual file expected actual where readStripped = fmap (unlines . filter (not . null) . lines) . readFile --- | Run a JS file.-runJavaScriptFile :: String -> IO (Either (String,String) (String,String))-runJavaScriptFile file = readAllFromProcess "node" [file] ""
tests/Compile/StrictWrapper.hs view
@@ -1,4 +1,8 @@-module StrictWrapper (f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth) where+module StrictWrapper (+ f, g, h, r, clog, logInlineOnly, logSeparateOnly, logBoth,+ sumInt, sumIntWrapped, zipWithPlus, zipWithPlusWrapped,+ sumPair, sumPairWrapped, zipPairs, zipPairsWrapped+) where import FFI import Prelude@@ -29,7 +33,36 @@ 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@@ -41,3 +74,15 @@ ffi "Strict.StrictWrapper.logInlineOnly('inlineOnly')" :: Fay () ffi "Strict.StrictWrapper.logSeparateOnly('separateOnly')" :: Fay () ffi "Strict.StrictWrapper.logBoth('both')" :: Fay ()+ + -- lists+ (ffi "console.log(Strict.StrictWrapper.sumInt(%1))" :: [Int] -> Fay ()) [1, 2, 3]+ (ffi "console.log(Strict.StrictWrapper.sumIntWrapped(%1))" :: IntList -> Fay ()) (IntList [1, 2, 3])+ (ffi "console.log(Strict.StrictWrapper.zipWithPlus(%1, %2))" :: [Int] -> [Int] -> Fay ()) [1, 2, 3] [1, 2, 3]+ (ffi "console.log(Strict.StrictWrapper.zipWithPlusWrapped(%1, %2))" :: IntList -> IntList -> Fay ()) (IntList [1, 2, 3]) (IntList [1, 2, 3])+ + -- tuples+ (ffi "console.log(Strict.StrictWrapper.sumPair(%1))" :: (Int, Int) -> Fay ()) (1, 3)+ (ffi "console.log(Strict.StrictWrapper.sumPairWrapped(%1))" :: IntPair -> Fay ()) (IntPair (1, 3))+ (ffi "console.log(Strict.StrictWrapper.zipPairs(%1, %2))" :: (Int, Int) -> (Int, Int) -> Fay ()) (1, 3) (1, 3)+ (ffi "console.log(Strict.StrictWrapper.zipPairsWrapped(%1, %2))" :: IntPair -> IntPair -> Fay ()) (IntPair (1, 3)) (IntPair (1, 3))
tests/Compile/StrictWrapper.res view
@@ -6,3 +6,11 @@ inlineOnly separateOnly both+6+6+[ 2, 4, 6 ]+{ instance: 'IntList', list: [ 2, 4, 6 ] }+4+4+[ 2, 6 ]+{ instance: 'IntPair', pair: [ 2, 6 ] }
+ tests/Compile/pretty.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+ let n = 3::Int+ print . length' 0 . takeWhile (<=n) $ [0..]+ putStrLn $ if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+ forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/pretty.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
+ tests/Compile/prettyOperators.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+ let n = 3::Int+ print . length' 0 . takeWhile (<=n) $ [0..]+ putStrLn $ if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+ forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/prettyOperators.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
+ tests/Compile/prettyThunks.hs view
@@ -0,0 +1,9 @@+module Pretty where++import Prelude++main = do+ let n = 3::Int+ print . length' 0 . takeWhile (<=n) $ [0..]+ putStrLn $ if (n + 5) ^ 2 == 64 && n*8 == 26 then "T" else "F"+ forM [1..5] $ \k -> putStrLn $ if odd k then "odd" else "even"
+ tests/Compile/prettyThunks.res view
@@ -0,0 +1,7 @@+4+F+odd+even+odd+even+odd
tests/ExportQualified_Export.hs view
@@ -2,7 +2,7 @@ module ExportQualified_Export (main, X.X) where import Prelude-import "foo" X+import "base" X main :: Fay () main = return ()
tests/ImportType2I/A.hs view
tests/ImportType2I/B.hs view
+ tests/ListEq.hs view
@@ -0,0 +1,7 @@+module ListEq where++main :: Fay ()+main = do+ print $ [] == []+ print $ [1,2,3] == [1,2,3]+ print $ ["a"] == ["b"]
+ tests/ListEq.res view
@@ -0,0 +1,3 @@+true+true+false
tests/Nullable.hs view
@@ -40,4 +40,4 @@ r2 = ffi "{ instance : 'R', slot1 : null }" parseInt :: String -> Nullable Int-parseInt = ffi "(function () { var n = global.parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"+parseInt = ffi "(function () { var n = parseInt(%1, 10); if (isNaN(n)) return null; return n; })()"
− tests/String.hs
@@ -1,3 +0,0 @@-module String where--main = putStrLn "Hello, World!"
− tests/String.res
@@ -1,1 +0,0 @@-Hello, World!
+ tests/Strings.hs view
@@ -0,0 +1,3 @@+module Strings where++main = putStrLn "Hello, World!"
+ tests/Strings.res view
@@ -0,0 +1,1 @@+Hello, World!
+ tests/TextOrd.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RebindableSyntax #-}+module TextOrd where++import Prelude++import Data.Text++main :: Fay ()+main = do+ print ("abc" < ("c"::Text))+ print ("a" < ("bcd"::Text))+ print ("bcd" > ("a"::Text))+ print ("bcd" < ("a"::Text))
+ tests/TextOrd.res view
@@ -0,0 +1,4 @@+true+true+true+false
+ tests/VarPtr.hs view
@@ -0,0 +1,11 @@+module VarPtr where++import Data.Var++data Record = Record Int++main = do + v <- newVar $ Record 5+ subscribeAndRead v $ \y -> case y of+ Record a -> putStrLn . show $ a+ set v $ Record 10
+ tests/VarPtr.res view
@@ -0,0 +1,2 @@+5+10
+ tests/WhenUnlessRecursion.hs view
@@ -0,0 +1,22 @@+module WhenUnlessRecursion where++import FFI++getStackSize :: Fay Int+getStackSize = ffi "(Error[\"stackTraceLimit\"] = Infinity, new Error().stack.split('\\n').length)"++checkGrowth :: Maybe Int -> Int -> Fay ()+checkGrowth Nothing _ = return ()+checkGrowth (Just old) new = if new == old then return () else (error $ "Call stack growth: " ++ show old ++ " to " ++ show new)++main = do+ putStrLn "loopIf" >> loopIf Nothing 0+ putStrLn "loopWhen" >> loopWhen Nothing 0+ putStrLn "loopUnless" >> loopUnless Nothing 0+ where+ pred = (< 5)+ step = (+ 1)+ action f s n = getStackSize >>= \s' -> checkGrowth s s' >> f (Just s') (step n)+ loopIf s n = if (pred n) then (action loopIf s n) else return ()+ loopWhen s n = when (pred n) (action loopWhen s n)+ loopUnless s n = unless (not (pred n)) (action loopUnless s n)
+ tests/WhenUnlessRecursion.res view
@@ -0,0 +1,3 @@+loopIf+loopWhen+loopUnless
tests/doLet.hs view
@@ -7,6 +7,7 @@ fourth fifth sixth+ newtyp first = do let x = 123@@ -43,3 +44,11 @@ let y = 777 print y print x++newtype I = I Int+newtyp = do+ putStrLn "newtype"+ I i <- return (I 1)+ print i+ let I j = I 2+ print j
tests/doLet.res view
@@ -11,3 +11,6 @@ 10 777 123+newtype+1+2
+ tests/patternMatchLet.hs view
@@ -0,0 +1,10 @@+module PatternMatchLet where++first3 :: String -> Fay ()+first3 cs = do+ let (a:b:c:_) = cs+ putStrLn [a, b, c]++main :: Fay ()+main = first3 "abcd"+
+ tests/patternMatchLet.res view
@@ -0,0 +1,1 @@+abc
tests/serialization.hs view
@@ -11,8 +11,8 @@ printMaybeConcrete (Just (ConcreteRecord 42)) printMaybeAutomatic (Just (ConcreteRecord 42)) printMaybe (Just (ConcreteRecord 42))- printUnknown (error "do not want")- printUnknownField (Just (error "do not want"))+ printUnknown 42+ printUnknownField (Just 42) printAutomatic (Just (ConcreteRecord 42)) printParametricButConcreteType :: Parametric ConcreteRecord -> Fay ()
tests/serialization.res view
@@ -3,15 +3,14 @@ { instance: 'Parametric', slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Parametric',- slot1: { forced: false, value: [Function] } }+ slot1: { instance: 'ConcreteRecord', concreteField: 123 } } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } } { instance: 'Just',- slot1: { forced: false, value: [Function] } }-{ forced: false, value: [Function] }-{ instance: 'Just',- slot1: { forced: false, value: [Function] } }+ slot1: { instance: 'ConcreteRecord', concreteField: 42 } }+42+{ instance: 'Just', slot1: 42 } { instance: 'Just', slot1: { instance: 'ConcreteRecord', concreteField: 42 } }