diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012-2014, Evan Czaplicki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Evan Czaplicki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,351 @@ + +## 0.14 + +#### Breaking Changes + + * Keyword `data` renamed to `type` + * Keyword `type` renamed to `type alias` + +## 0.13 + +#### Improvements: + + * Type aliases in port types + * Add Keyboard.alt and Keyboard.meta + * Add Debug.crash, Debug.watch, Debug.watchSummary, and Debug.trace + * Add List.indexedMap and List.filterMap + * Add Maybe.map + * Add Basics.negate + * Add (>>) to Basics as in F# + * Add --bundle-runtime flag which creates stand-alone Elm programs + * Error on ambiguious use of imported variables + * Replace dependency on Pandoc with cheapskate+kate + * Better architecture for compiler. Uses types to make compilation pipeline + safer, setting things up for giving programmatic access to the AST to + improve editor and IDE support. + +#### Breaking Changes: + + * Rename (.) to (<<) as in F# + * Rename Basics.id to Basics.identity + * Rename Basics.div to (//) + * Rename Basics.mod to (%) + * Remove Maybe.justs for (List.filterMap identity) + * Remove List.and for (List.foldl (&&) True) + * Remove List.or for (List.foldl (||) False) + * Unambiguous syntax for importing ADTs and type aliases + * sqrt and logBase both only work on Floats now + +## 0.12.3 + + * Minor changes to support webgl as a separate library + * Switch from HSV to HSL + * Programmatic access to colors with toHsl and toRgb + +## 0.12.1 + +#### Improvements: + + * New Array library (thanks entirely to @Xashili) + * Json.Value can flow through ports + * Improve speed and stack usage in List library (thanks to @maxsnew) + * Add Dict.filter and Dict.partition (thanks to @hdgarrood) + +#### Breaking Changes: + + * Revamp Json library, simpler with better names + * Revamp JavaScript.Experimental library to have slightly better names + * Remove JavaScript library which was made redundant by ports + +## 0.12 + +#### Breaking Changes: + + * Overhaul Graphics.Input library (inspired by Spiros Eliopoulos and Jeff Smitts) + * Overhaul Text library to accomodate new Graphics.Input.Field + library and make the API more consistent overall + * Overhaul Regex library (inspired by Attila Gazso) + * Change syntax for "import open List" to "import List (..)" + * Improved JSON format for types generated by elm-doc + * Remove problematic Mouse.isClicked signal + * Revise the semantics of keepWhen and dropWhen to only update when + the filtered signal changes (thanks Max New and Janis Voigtländer) + +#### Improvements: + + * Add Graphics.Input.Field for customizable text fields + * Add Trampoline library (thanks to @maxsnew and @timthelion) + * Add Debug library (inspired by @timthelion) + * Drastically improved performance on markdown parsing (thanks to @Dandandan) + * Add Date.fromTime function + * Use pointer-events to detect hovers on layered elements (thanks to @Xashili) + * Fix bugs in Bitwise library + * Fix bug when exporting Maybe values through ports + +## 0.11 + + * Ports, a new FFI that is more general and much nicer to use + * Basic compiler tests (thanks to Max New) + +## 0.10.1 + + * sort, sortBy, sortWith (thanks to Max Goldstein) + * elm-repl + * Bitwise library + * Regex library + * Improve Transform2D library (thanks to Michael Søndergaard) + +## 0.10 + + * Native strings + * Tango colors + * custom precedence and associativity for infix operators + * elm-doc released with new documentation format + * Realiasing in type errors + * Rename Matrix2D => Transform2D + * Add Random.floatList (thank you Max GoldStein) + * Fix remove function in Dict (thank you Max New) + * Start using language-ecmascript for JS generation + * Make compatable with cabal-1.18 (thank you Justin Leitgeb) + * All functions with 10+ arguments (thanks to Max New) + +## 0.9.1 + + * Allow custom precedence and associativity for user-defined infix ops + * Realias types before printing + * Switch to Tango color scheme, adding a bunch of nice colors + * add the greyscale function for easily producing greys + * Check the type of main + * Fix miscellaneous bugs in type checker + * Switch name of Matrix2D to Transform2D + +## 0.9 + +Build Improvements: + * Major speed improvements to type-checker + * Type-checker should catch _all_ type errors now + * Module-level compilation, only re-compile if necessary + * Import types and type aliases between modules + * Intermediate files are generated to avoid unneeded recompilation + and shorten compile time. These files go in ElmFiles/ by default + * Generated files are placed in ElmFiles/ by default, replicating + the directory structure of your source code. + +Error Messages: + * Cross-module type errors + * Errors for undefined values + * Pretty printing of expressions and types + +Syntax: + * Pattern matching on literals + * Pattern aliases with `as` (Andrew) + * Unary negation + * Triple-quoted multi-line strings + * Type annotations in let expressions (Andrew) + * Record Constructors + * Record type aliases can be closed on the zeroth column + * (,,) syntax in types + * Allow infix op definitions without args: (*) = add + * Unparenthesized if, let, case, lambda at end of binary expressions + +elm-server: + * Build multi-module projects + * Report all errors in browser + +Libraries: + * Detect hovering over any Element + * Set alpha of arbitrary forms in collages + * Switch Text.height to use px instead of em + +Bug Fixes: + * Many bug fixes for collage, especially when rendering Elements. + +Website: + * Hot-swapping + * Much faster page load with pre-compiled Elm files (Max New) + + + + +forgot to fill this in again... + + +## 0.7.2 + +* Add a WebSockets library. +* Add support for the mathematical looking operator for function composition (U+2218). + + +forgot to fill this in for a while... + + +## 0.5.0 + +* Add Dict, Set, and Automaton libraries! + +* Add (,,) notation for creating tuples. + +* Redo HTTP library, allowing any kind of request and more flexibility. + +* Remove the library prefixes `Data.`, `Graphics.`, and `Signal.` because + they were more confusing than helpful. + +* Better type error reporting for ambiguous uses of variables and for + variables in aliased modules. + +* Add `readInt` and `readFloat` functions. +* Add `complement` function to compute complementary colors. +* Ensure that `String` is treated as an alias of `[Char]`. + +* Fix bug in pattern parsing. `A B _ _` was parsed as `A (B _ _)`. +* Make pattern matching a bit more compact in generated code. +* Make generated JS more readable. + +* The Haskell API exports the absolute path to the Elm runtime + system (with the corresponding version number). This makes it easier + to run Elm programs with less setup. + + + +## 0.4.0 + +This version is all about graphics: nicer API with more features and major +efficiency improvements. I am really excited about this release! + +* Add native Markdown support. You can now embed markdown directly in .elm files + and it is used as an `Element`. Syntax is `[markdown| ... |]` where `...` is + formatted as described [here](http://daringfireball.net/projects/markdown/). + Content can span multiple lines too. + +* Drastically improve the `collage` interface. You can now move, rotate, and scale + the following forms: + - Elements (any Element you want can be turned into a Form with `toForm`) + - Images + - Shapes (shapes can be textured now too) + - Lines + This will make it way easier to make games in Elm. Games can now include text, + gifs, videos, and any other Element you can think of. + +* Add `--minify` flag, to minify JS code. + +* Significantly improve performance of pattern matching. + +* Compiler performs beta-reduction in some simple cases. + +* The rendering section of the Elm runtume-system (RTS) has been totally rewritten, + making screen refreshes use fewer cycles, less memory, and cause less garbage-collection. + + + +## 0.3.6 + +* Add JSON library. + +* Type-error messages improved. Gives better context for error, making them + easier to find. Better messages for runtime errors as well (errors that + the type checker cannot find yet). + +* Add Comparable super-type which allows the comparision of any values + of type {Int,Float,Char,String}. Now possible to make Set and Map libraries. + +* Parser now handles decimal numbers. + +* Added many new functions for manipulating numbers: + - truncate, round, floor, ceiling :: Float -> Int + - toFloat :: Int -> Float + - (^) :: Number -> Number -> Number + - e :: Float + +* Foreign import/export statements no longer have to preceed all other + variable and datatype definitions. They can be mixed in, making things + a bit more readable/natural. + +* Bug fixes: + - The `toText` function did not escape strings properly + - Correct `castJSTupleToTupleN` family of functions + - `foldr1` took the leftmost element as the base case instead of the rightmost + - Fix minor display issue in latest version of Chrome. + - Fix behavior of [ lo .. hi ] syntax (now [4..0] == [], not [0]). + + + +## 0.3.5 + +* Add JavaScript event interface. Allows Elm to import and export JS values + and events. This makes it possible to import and export Elements, so users + can use JS techniques and libraries if necessary. Conversion between JS + and Elm values happens with functions from here: + http://localhost:8000/docs/Foreign/JavaScript.elm + http://localhost:8000/docs/Foreign/JavaScript/Experimental.elm + +* Add new flags to help with JavaScript event interface. + +* Add three built-in event listeners (elm_title, elm_log, elm_redirect) that + make it possible to make some common/simple imperative actions without + having to worry about writing the JS yourself. For example: + foreign export jsevent "elm_title" + title :: Signal JSString + will update the page's title to the current value of the title signal. + Empty strings are ignored. "elm_redirect" and "elm_log" events work much + the same way, except that "elm_log" does not skip empty strings. + +* Add new Signal functions: + count :: Signal a -> Signal Int + keepIf :: (a -> Bool) -> a -> Signal a -> Signal a + dropIf :: (a -> Bool) -> a -> Signal a -> Signal a + keepWhen :: Signal Bool -> a -> Signal a -> Signal a + dropWhen :: Signal Bool -> a -> Signal a -> Signal a + dropRepeats :: Signal a -> Signal a + sampleOn :: Signal a -> Signal b -> Signal b + clicks :: Signal () + The keep and drop functions make it possible to filter events, which + was not possible in prior releases. More documentation: + http://elm-lang.org/docs/Signal/Signal.elm + +* Add examples of JS event interface and new signal functions: + https://github.com/evancz/Elm/tree/master/Examples/elm-js + +* Use more compressed format for strings. Should make strings 10-12 times + more space efficient than in previous releases. Anecdotal evidence: + Elm's home page is now 70% of its previous size. + +* Add new function to Data.List: + last :: [a] -> a + +* Fix parenthesization bug with binary operators. + + + +## 0.3.0 + +Major Changes (Read this part!) +------------------------------- + +* Add a basic module system. +* Elm's JavaScript runtime is now distributed with the elm package. + Previously it was available for download as an unversioned JavaScript + file (elm-mini.js). It is now installed with the elm compiler as + elm-runtime-0.3.0.js. Be sure to serve the Elm runtime system that matches + the version of the compiler used to generate JavaScript. When working + locally, the compiler will automatically use your local copy of this file. +* BREAKING CHANGE: rgb and rgba (in the color module) now take their red, + green, and blue components as integers between 0 and 255 inclusive. +* Improve error messages for parse errors and runtime errors. + + +New Functions and Other Additions +--------------------------------- + +* Add support for keyboard events: Keyboard.Raw +* Add buttons in Signal.Input: + button :: String -> (Element, Signal Bool) +* Add new basic element (an empty rectangle, good for adding spaces): + rectangle :: Int -> Int -> Element +* Add (an awkwardly named) way to display right justified text: rightedText +* Add two basic libraries: Data.Char and Data.Maybe +* Add some new colors: magenta, yellow, cyan, gray, grey +* Add functions to Data.List module: take, drop +* Add functions to Prelude (the default imports): + fst, snd, curry, uncurry, and a bunch of list functions +* Add --make, --separate-js, and --only-js flags to help compile + with the new module system. diff --git a/elm-compiler.cabal b/elm-compiler.cabal new file mode 100644 --- /dev/null +++ b/elm-compiler.cabal @@ -0,0 +1,234 @@ + +Name: elm-compiler +Version: 0.14 + +Synopsis: + Values to help with elm-package, elm-make, and elm-lang.org. + +Description: + Elm aims to make client-side web-development pleasant. It is a + statically/strongly typed, functional reactive language that compiles to + HTML, CSS, and JS. This package provides a couple helpful values that are + intended for use in packages such as elm-package and elm-make. + +Homepage: http://elm-lang.org + +License: BSD3 +License-file: LICENSE + +Author: Evan Czaplicki +Maintainer: info@elm-lang.org +Copyright: Copyright (c) 2011-2014 Evan Czaplicki + +Category: Compiler, Language + +Extra-source-files: changelog.md + +Cabal-version: >=1.9 +Build-type: Simple + +Data-files: + runtime/debug.js + +source-repository head + type: git + location: git://github.com/elm-lang/elm-compiler.git + +Library + ghc-options: + -threaded -O2 -W + + Hs-Source-Dirs: + src + + exposed-modules: + Elm.Compiler, + Elm.Compiler.Module, + Elm.Compiler.Type, + Elm.Docs, + Elm.Utils + + other-modules: + AST.Annotation, + AST.Declaration, + AST.Expression.General, + AST.Expression.Source, + AST.Expression.Valid, + AST.Expression.Canonical, + AST.Helpers, + AST.Literal, + AST.Module, + AST.Pattern, + AST.PrettyPrint, + AST.Type, + AST.Variable, + Compile, + Elm.Compiler.Type.Extract, + Elm.Compiler.Version, + Generate.JavaScript, + Generate.JavaScript.Helpers, + Generate.JavaScript.Ports, + Generate.JavaScript.Variable, + Generate.Cases, + Transform.AddDefaultImports, + Transform.Canonicalize, + Transform.Canonicalize.Environment, + Transform.Canonicalize.Setup, + Transform.Canonicalize.Type, + Transform.Canonicalize.Variable, + Transform.Check, + Transform.Expression, + Transform.Declaration, + Transform.Definition, + Transform.Interface, + Transform.SortDefinitions, + Transform.Substitute, + Parse.Binop, + Parse.Declaration, + Parse.Expression, + Parse.Helpers, + Parse.Literal, + Parse.Module, + Parse.Parse, + Parse.Pattern, + Parse.Type, + Type.Constrain.Expression, + Type.Constrain.Literal, + Type.Constrain.Pattern, + Type.Environment, + Type.ExtraChecks, + Type.Fragment, + Type.Inference, + Type.PrettyPrint, + Type.Solve, + Type.State, + Type.Type, + Type.Unify, + Paths_elm_compiler + + Build-depends: + aeson >= 0.7 && < 0.9, + aeson-pretty >= 0.7 && < 0.8, + base >=4.2 && <5, + binary >= 0.7.0.0 && < 0.8, + blaze-html >= 0.5 && < 0.8, + blaze-markup >= 0.5.1 && < 0.7, + bytestring >= 0.9 && < 0.11, + cmdargs >= 0.7 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.0 && < 2.0, + filepath >= 1 && < 2.0, + indents >= 0.3 && < 0.4, + language-ecmascript >=0.15 && < 0.17, + language-glsl >= 0.0.2 && < 0.2, + mtl >= 2 && < 3, + parsec >= 3.1.1 && < 3.5, + pretty >= 1.0 && < 2.0, + process, + text >= 1 && < 2, + transformers >= 0.2 && < 0.5, + union-find >= 0.2 && < 0.3, + unordered-containers >= 0.1 && < 0.3 + + +Executable elm-doc + ghc-options: + -threaded -O2 -W + + Hs-Source-Dirs: + src + + Main-is: + Docs.hs + + other-modules: + Elm.Compiler.Version, + AST.Annotation, + AST.Declaration, + AST.Expression.General, + AST.Helpers, + AST.Literal, + AST.Module, + AST.Pattern, + AST.PrettyPrint, + AST.Type, + AST.Variable, + Parse.Binop, + Parse.Declaration, + Parse.Expression, + Parse.Helpers, + Parse.Literal, + Parse.Module, + Parse.Pattern, + Parse.Type + + Build-depends: + aeson >= 0.7 && < 0.9, + aeson-pretty >= 0.7 && < 0.8, + base >=4.2 && <5, + binary >= 0.7.0.0 && < 0.8, + bytestring >= 0.9 && < 0.11, + cmdargs >= 0.7 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.0 && < 2.0, + filepath >= 1 && < 2.0, + indents >= 0.3 && < 0.4, + language-glsl >= 0.0.2 && < 0.2, + mtl >= 2 && < 3, + parsec >= 3.1.1 && < 3.5, + pretty >= 1.0 && < 2.0, + process, + text >= 1 && < 2, + transformers >= 0.2 && < 0.5, + union-find >= 0.2 && < 0.3 + + +Test-Suite compiler-tests + Type: + exitcode-stdio-1.0 + + Hs-Source-Dirs: + tests, src + + Main-is: + Test.hs + + other-modules: + Test.Compiler + Test.Property + Test.Property.Arbitrary + AST.Helpers + AST.Literal + AST.PrettyPrint + + build-depends: + test-framework > 0.8 && < 0.9, + test-framework-hunit >= 0.3 && < 0.4, + test-framework-quickcheck2 >= 0.3 && < 0.4, + HUnit >= 1.1 && < 2, + QuickCheck >= 2 && < 3, + aeson >= 0.7 && < 0.9, + aeson-pretty >= 0.7 && < 0.8, + base >=4.2 && <5, + binary >= 0.7.0.0 && < 0.8, + blaze-html >= 0.5 && < 0.8, + blaze-markup >= 0.5.1 && < 0.7, + bytestring >= 0.9 && < 0.11, + cmdargs >= 0.7 && < 0.11, + containers >= 0.3 && < 0.6, + directory >= 1.0 && < 2.0, + elm-compiler, + filemanip >= 0.3.5 && < 0.4, + filepath >= 1 && < 2.0, + indents >= 0.3 && < 0.4, + language-ecmascript >=0.15 && < 0.17, + language-glsl >= 0.0.2 && < 0.2, + mtl >= 2 && < 3, + parsec >= 3.1.1 && < 3.5, + pretty >= 1.0 && < 2.0, + process, + text >= 1 && < 2, + transformers >= 0.2 && < 0.5, + union-find >= 0.2 && < 0.3, + unordered-containers >= 0.1 && < 0.3 + diff --git a/runtime/debug.js b/runtime/debug.js new file mode 100644 --- /dev/null +++ b/runtime/debug.js @@ -0,0 +1,604 @@ +(function() { +'use strict'; + +if (typeof window != 'undefined' && !window.location.origin) { + window.location.origin = + window.location.protocol + "//" + + window.location.hostname + + (window.location.port ? (':' + window.location.port) : ''); +} + +Elm.fullscreenDebugHooks = function(elmModule, debuggerHistory /* =undefined */) { + var exposedDebugger = {}; + function debuggerAttach(elmModule, debuggerHistory) { + return { + make: function(runtime) { + var wrappedModule = debugModule(elmModule, runtime); + exposedDebugger = debuggerInit(wrappedModule, runtime, debuggerHistory); + return wrappedModule.debuggedModule; + } + } + } + var mainHandle = Elm.fullscreen(debuggerAttach(elmModule, debuggerHistory)); + mainHandle.debugger = exposedDebugger; + return mainHandle; +}; + +var EVENTS_PER_SAVE = 100; + +function debugModule(module, runtime) { + var programPaused = false; + var recordedEvents = []; + var asyncCallbacks = []; + var snapshots = []; + var watchTracker = Elm.Native.Debug.make(runtime).watchTracker; + var pauseTime = 0; + var eventsUntilSnapshot = EVENTS_PER_SAVE; + runtime.debuggerStatus = runtime.debuggerStatus || {}; + runtime.debuggerStatus.eventCounter = runtime.debuggerStatus.eventCounter || 0; + + // runtime is the prototype of wrappedRuntime + // so we can access all runtime properties too + var wrappedRuntime = Object.create(runtime); + wrappedRuntime.notify = notifyWrapper; + wrappedRuntime.setTimeout = setTimeoutWrapper; + + // make a copy of the wrappedRuntime + var assignedPropTracker = Object.create(wrappedRuntime); + var debuggedModule = module.make(assignedPropTracker); + + // make sure the signal graph is actually a signal & extract the visual model + if ( !('recv' in debuggedModule.main) ) { + debuggedModule.main = Elm.Signal.make(runtime).constant(debuggedModule.main); + } + + // The main module stores imported modules onto the runtime. + // To ensure only one instance of each module is created, + // we assign them back on the original runtime object. + Object.keys(assignedPropTracker).forEach(function(key) { + runtime[key] = assignedPropTracker[key]; + }); + + var signalGraphNodes = flattenSignalGraph(wrappedRuntime.inputs); + var tracePath = tracePathInit(runtime, debuggedModule.main); + + snapshots.push(snapshotSignalGraph(signalGraphNodes)); + + function notifyWrapper(id, v) { + var timestep = runtime.timer.now(); + + if (programPaused) { + // ignore async events generated while playing back + // or user events while program is paused + return false; + } + else { + recordEvent(id, v, timestep); + var changed = runtime.notify(id, v, timestep); + snapshotOnCheckpoint(); + if (parent.window) { + parent.window.postMessage("elmNotify", window.location.origin); + } + return changed; + } + }; + + function setTimeoutWrapper(func, delayMs) { + if (programPaused) { + // Don't push timers and such to the callback stack while we're paused. + // It causes too many callbacks to be fired during unpausing. + return 0; + } + var cbObj = { func:func, delayMs:delayMs, timerId:0, executed:false }; + var timerId = setTimeout(function() { + cbObj.executed = true; + func(); + }, delayMs); + cbObj.timerId = timerId; + asyncCallbacks.push(cbObj); + return timerId; + } + + function recordEvent(id, v, timestep) { + watchTracker.pushFrame(); + recordedEvents.push({ id:id, value:v, timestep:timestep }); + runtime.debuggerStatus.eventCounter += 1; + } + + function clearAsyncCallbacks() { + asyncCallbacks.forEach(function(timer) { + if (!timer.executed) { + clearTimeout(timer.timerId); + } + }); + } + + function clearRecordedEvents() { + recordedEvents = []; + runtime.debuggerStatus.eventCounter = 0; + } + + function getRecordedEventsLength() { + return recordedEvents.length; + } + + function getRecordedEventAt(i) { + return recordedEvents[i]; + } + + function copyRecordedEvents() { + return recordedEvents.slice(); + } + + function loadRecordedEvents(events) { + recordedEvents = events.slice(); + } + + function clearSnapshots() { + snapshots = [snapshotSignalGraph(signalGraphNodes)]; + } + + function getSnapshotAt(i) { + var snapshotEvent = Math.floor(i / EVENTS_PER_SAVE); + assert(snapshotEvent < snapshots.length && snapshotEvent >= 0, + "Out of bounds index: " + snapshotEvent); + return snapshots[snapshotEvent]; + } + + function snapshotOnCheckpoint() { + if (eventsUntilSnapshot === 1) { + snapshots.push(snapshotSignalGraph(signalGraphNodes)); + eventsUntilSnapshot = EVENTS_PER_SAVE; + } else { + eventsUntilSnapshot -= 1; + } + } + + function setPaused() { + programPaused = true; + clearAsyncCallbacks(); + pauseTime = Date.now(); + tracePath.stopRecording(); + preventInputEvents(); + } + + function setContinue(position) { + var pauseDelay = Date.now() - pauseTime; + runtime.timer.addDelay(pauseDelay); + programPaused = false; + + // we need to dump the events that are ahead of where we're continuing. + var lastSnapshotPosition = Math.floor(position / EVENTS_PER_SAVE); + eventsUntilSnapshot = EVENTS_PER_SAVE - (position % EVENTS_PER_SAVE); + snapshots = snapshots.slice(0, lastSnapshotPosition + 1); + + if (position < getRecordedEventsLength()) { + var lastEventTime = recordedEvents[position].timestep; + var scrubTime = runtime.timer.now() - lastEventTime; + runtime.timer.addDelay(scrubTime); + } + + recordedEvents = recordedEvents.slice(0, position); + tracePath.clearTracesAfter(position); + runtime.debuggerStatus.eventCounter = position; + executeCallbacks(asyncCallbacks); + permitInputEvents(); + + tracePath.startRecording(); + } + + function getPaused() { + return programPaused; + } + + function preventInputEvents(){ + var events = + [ "click", "mousemove", "mouseup", "mousedown", "mouseclick" + , "keydown", "keypress", "keyup", "touchstart", "touchend" + , "touchcancel", "touchleave", "touchmove", "pointermove" + , "pointerdown", "pointerup", "pointerover", "pointerout" + , "pointerenter", "pointerleave", "pointercancel" + ]; + + var ignore = function(e) { + var evt = e ? e : window.event; + if (evt.stopPropagation) { + evt.stopPropagation(); + } + if (evt.cancelBubble !== null) { + evt.cancelBubble = true; + } + if (evt.preventDefault) { + evt.preventDefault(); + } + return false; + }; + + var ignoringDiv = document.getElementById("elmEventIgnorer"); + if (!ignoringDiv) { + ignoringDiv = document.createElement("div"); + ignoringDiv.id = "elmEventIgnorer"; + ignoringDiv.style.position = "absolute"; + ignoringDiv.style.top = "0px"; + ignoringDiv.style.left = "0px"; + ignoringDiv.style.width = "100%"; + ignoringDiv.style.height = "100%"; + + for (var i = events.length; i-- ;) { + ignoringDiv.addEventListener(events[i], ignore, true); + } + runtime.node.appendChild(ignoringDiv); + } + } + + function permitInputEvents(){ + var ignoringDiv = document.getElementById("elmEventIgnorer"); + ignoringDiv.parentNode.removeChild(ignoringDiv); + } + + return { + debuggedModule: debuggedModule, + signalGraphNodes: signalGraphNodes, + initialSnapshot: snapshotSignalGraph(signalGraphNodes), + initialAsyncCallbacks: asyncCallbacks.slice(), + // API functions + clearAsyncCallbacks: clearAsyncCallbacks, + clearRecordedEvents: clearRecordedEvents, + getRecordedEventsLength: getRecordedEventsLength, + getRecordedEventAt: getRecordedEventAt, + copyRecordedEvents: copyRecordedEvents, + loadRecordedEvents: loadRecordedEvents, + clearSnapshots: clearSnapshots, + getSnapshotAt: getSnapshotAt, + snapshotOnCheckpoint: snapshotOnCheckpoint, + getPaused: getPaused, + setPaused: setPaused, + setContinue: setContinue, + tracePath: tracePath, + watchTracker: watchTracker + }; +} + +// The debuggerHistory variable is passed in on swap. It represents +// the a state of the debugger for it to assume during init. It contains +// the paused state of the debugger, the recorded events, and the current +// event being processed. +function debuggerInit(debugModule, runtime, debuggerHistory /* =undefined */) { + var currentEventIndex = 0; + + function resetProgram(position) { + var closestSnapshot = debugModule.getSnapshotAt(position); + debugModule.clearAsyncCallbacks(); + restoreSnapshot(debugModule.signalGraphNodes, closestSnapshot); + redrawGraphics(); + } + + function restartProgram() { + pauseProgram(); + resetProgram(0); + debugModule.watchTracker.clear(); + debugModule.tracePath.clearTraces(); + debugModule.setContinue(0); + debugModule.clearRecordedEvents(); + debugModule.clearSnapshots(); + executeCallbacks(debugModule.initialAsyncCallbacks); + } + + function pauseProgram() { + debugModule.setPaused(); + currentEventIndex = debugModule.getRecordedEventsLength(); + } + + function continueProgram() { + if (debugModule.getPaused()) + { + var closestSnapshotIndex = + Math.floor(currentEventIndex / EVENTS_PER_SAVE) * EVENTS_PER_SAVE; + resetProgram(currentEventIndex); + var continueIndex = currentEventIndex; + currentEventIndex = closestSnapshotIndex; + stepTo(continueIndex); + debugModule.setContinue(currentEventIndex); + } + } + + function stepTo(index) { + if (!debugModule.getPaused()) { + debugModule.setPaused(); + resetProgram(); + } + + if (index < 0 || index > getMaxSteps()) { + throw "Index out of bounds: " + index; + } + + if (index < currentEventIndex) { + var closestSnapshotIndex = Math.floor(index / EVENTS_PER_SAVE) * EVENTS_PER_SAVE; + resetProgram(index); + currentEventIndex = closestSnapshotIndex; + } + + while (currentEventIndex < index) { + var nextEvent = debugModule.getRecordedEventAt(currentEventIndex); + runtime.notify(nextEvent.id, nextEvent.value, nextEvent.timestep); + + currentEventIndex += 1; + } + } + + function getMaxSteps() { + return debugModule.getRecordedEventsLength(); + } + + function redrawGraphics() { + var main = debugModule.debuggedModule.main + for (var i = main.kids.length ; i-- ; ) { + main.kids[i].recv(runtime.timer.now(), true, main.id); + } + } + + function getSwapState() { + var continueIndex = currentEventIndex; + if (!debugModule.getPaused()) { + continueIndex = getMaxSteps(); + } + return { + paused: debugModule.getPaused(), + recordedEvents: debugModule.copyRecordedEvents(), + currentEventIndex: continueIndex + }; + } + + function dispose() { + var parentNode = runtime.node.parentNode; + parentNode.removeChild(debugModule.tracePath.canvas); + parentNode.removeChild(runtime.node); + } + + if (debuggerHistory) { + // The problem is that we want to previous paused state. But + // by the time JS reaches here, the old code has been swapped out + // and the new modules are being generated. So we can ask the + // debugging console what it thinks the pause state is and go + // from there. + var paused = debuggerHistory.paused; + debugModule.setPaused(); + debugModule.loadRecordedEvents(debuggerHistory.recordedEvents); + var index = getMaxSteps(); + runtime.debuggerStatus.eventCounter = 0; + debugModule.tracePath.clearTraces(); + + // draw new trace path + debugModule.tracePath.startRecording(); + while(currentEventIndex < index) { + var nextEvent = debugModule.getRecordedEventAt(currentEventIndex); + runtime.debuggerStatus.eventCounter += 1; + runtime.notify(nextEvent.id, nextEvent.value, nextEvent.timestep); + debugModule.snapshotOnCheckpoint(); + currentEventIndex += 1; + } + debugModule.tracePath.stopRecording(); + + stepTo(debuggerHistory.currentEventIndex); + if (!paused) { + debugModule.setContinue(debuggerHistory.currentEventIndex); + } + } + + runtime.node.parentNode.appendChild(debugModule.tracePath.canvas); + + var elmDebugger = { + restart: restartProgram, + pause: pauseProgram, + kontinue: continueProgram, + getMaxSteps: getMaxSteps, + stepTo: stepTo, + getPaused: debugModule.getPaused, + getSwapState: getSwapState, + dispose: dispose, + allNodes: debugModule.signalGraphNodes, + watchTracker: debugModule.watchTracker + }; + + return elmDebugger; +} + +function Point(x, y) { + this.x = x; + this.y = y; + + this.translate = function(x, y) { + return new Point(this.x + x, this.y + y); + } + + this.equals = function(p) { + return this.x == p.x && this.y == p.y; + } +} + +function tracePathInit(runtime, signalGraphMain) { + var List = Elm.List.make(runtime); + var Signal = Elm.Signal.make(runtime); + var tracePathNode = A2(Signal.map, graphicsUpdate, signalGraphMain); + var tracePathCanvas = createCanvas(); + var tracePositions = {}; + var recordingTraces = true; + + function findPositions(currentScene) { + var positions = {}; + function processElement(elem, offset) { + if (elem.element.ctor == "Custom" && elem.element.type == "Collage") + { + List.map(F2(processForm)(offset))(elem.element.model.forms); + } + } + + function processForm(offset, form) { + if (form.form.ctor == "FElement") + { + processElement(form.form._0, offset.translate(form.x, -form.y)); + } + if (form.form.ctor == "FGroup") + { + var newOffset = offset.translate(form.x, -form.y); + List.map(F2(processForm)(newOffset))(form.form._1); + } + if (form.debugTracePathId) + { + positions[form.debugTracePathId] = new Point(form.x + offset.x, -form.y + offset.y); + } + } + + processElement(currentScene, new Point(0, 0)); + return positions; + } + + function appendPositions(positions) { + for (var id in positions) { + var pos = positions[id]; + if (tracePositions.hasOwnProperty(id)) { + tracePositions[id].push(pos); + } + else { + tracePositions[id] = [pos]; + } + if (tracePositions[id].length < runtime.debuggerStatus.eventCounter) { + var padCount = runtime.debuggerStatus.eventCounter - tracePositions[id].length; + var lastTracePosition = tracePositions[id][tracePositions[id].length - 1]; + for (var i = padCount; i--;) { + tracePositions[id].push(lastTracePosition) + } + } + assert(tracePositions[id].length === runtime.debuggerStatus.eventCounter, + "We don't have a 1-1 mapping of trace positions to events"); + } + } + + function graphicsUpdate(currentScene) { + if (!recordingTraces) { + return; + } + + var ctx = tracePathCanvas.getContext('2d'); + ctx.clearRect(0, 0, tracePathCanvas.width, tracePathCanvas.height); + + ctx.save(); + ctx.translate(ctx.canvas.width/2, ctx.canvas.height/2); + appendPositions(findPositions(currentScene)); + for (var id in tracePositions) + { + ctx.beginPath(); + var points = tracePositions[id]; + for (var i=0; i < points.length; i++) + { + var p = points[i]; + if (i == 0) { + ctx.moveTo(p.x, p.y); + } + else { + ctx.lineTo(p.x, p.y); + } + } + ctx.lineWidth = 1; + ctx.strokeStyle = "rgba(50, 50, 50, 0.4)"; + ctx.stroke(); + } + + ctx.restore(); + } + + function clearTraces() { + tracePositions = {}; + } + + function stopRecording() { + recordingTraces = false; + } + + function startRecording() { + recordingTraces = true; + } + + function clearTracesAfter(position) { + var newTraces = {}; + for (var id in tracePositions) { + newTraces[id] = tracePositions[id].slice(0,position); + } + tracePositions = newTraces; + } + + return { + graphicsUpdate: graphicsUpdate, + canvas: tracePathCanvas, + clearTraces: clearTraces, + clearTracesAfter: clearTracesAfter, + stopRecording: stopRecording, + startRecording: startRecording + } +} + +function executeCallbacks(callbacks) { + callbacks.forEach(function(timer) { + if (!timer.executed) { + var func = timer.func; + timer.executed = true; + func(); + } + }); +} + +function createCanvas() { + var c = document.createElement('canvas'); + c.width = window.innerWidth; + c.height = window.innerHeight; + c.style.position = "absolute"; + c.style.top = "0"; + c.style.left = "0"; + c.style.pointerEvents = "none"; + return c; +} + +function assert(bool, msg) { + if (!bool) { + throw "Assertion error: " + msg; + } +} + +function snapshotSignalGraph(signalGraphNodes) { + var nodeValues = []; + + signalGraphNodes.forEach(function(node) { + nodeValues.push({ value: node.value, id: node.id }); + }); + + return nodeValues; +}; + +function restoreSnapshot(signalGraphNodes, snapshot) { + assert(signalGraphNodes.length == snapshot.length, + "saved program state has wrong length"); + for (var i=0; i < signalGraphNodes.length; i++) { + var node = signalGraphNodes[i]; + var state = snapshot[i]; + assert(node.id == state.id, "the nodes moved position"); + + node.value = state.value; + } +} + +function flattenSignalGraph(nodes) { + var nodesById = {}; + + function addAllToDict(node) { + nodesById[node.id] = node; + node.kids.forEach(addAllToDict); + } + nodes.forEach(addAllToDict); + + var allNodes = Object.keys(nodesById).sort().map(function(key) { + return nodesById[key]; + }); + return allNodes; +}; + +}()); diff --git a/src/AST/Annotation.hs b/src/AST/Annotation.hs new file mode 100644 --- /dev/null +++ b/src/AST/Annotation.hs @@ -0,0 +1,73 @@ +module AST.Annotation where + +import qualified Text.Parsec.Pos as Parsec +import qualified Text.PrettyPrint as P +import AST.PrettyPrint + +data Annotated annotation expr = A annotation expr + deriving (Show) + +data Region + = Span Position Position P.Doc + | None P.Doc + deriving (Show) + +data Position = Position + { line :: Int + , column :: Int + } deriving (Show) + +type Located expr = Annotated Region expr + +none e = A (None (pretty e)) e +noneNoDocs e = A (None P.empty) e + +at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr + -> Annotated Region expr +at start end e = + A (Span (position start) (position end) (pretty e)) e + where + position loc = Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc) + +merge (A s1 _) (A s2 _) e = + A (span (pretty e)) e + where + span = case (s1,s2) of + (Span start _ _, Span _ end _) -> Span start end + (Span start end _, _) -> Span start end + (_, Span start end _) -> Span start end + (_, _) -> None + +mergeOldDocs (A s1 _) (A s2 _) e = + A span e + where + span = case (s1,s2) of + (Span start _ d1, Span _ end d2) -> + Span start end (P.vcat [d1, P.text "\n", d2]) + + (Span _ _ _, _) -> s1 + (_, Span _ _ _) -> s2 + (_, _) -> None P.empty + +sameAs :: Annotated a expr -> expr' -> Annotated a expr' +sameAs (A annotation _) expr = A annotation expr + +getRegionDocs region = + case region of + Span _ _ doc -> doc + None doc -> doc + +instance Pretty Region where + pretty span = + case span of + None _ -> P.empty + Span start end _ -> + P.text $ + case line start == line end of + False -> "between lines " ++ show (line start) ++ " and " ++ show (line end) + True -> "on line " ++ show (line end) ++ ", column " ++ + show (column start) ++ " to " ++ show (column end) + +instance Pretty e => Pretty (Annotated a e) where + pretty (A _ e) = pretty e + diff --git a/src/AST/Declaration.hs b/src/AST/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/AST/Declaration.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -Wall #-} +module AST.Declaration where + +import Data.Binary +import qualified AST.Expression.Source as Source +import qualified AST.Expression.Valid as Valid +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Type as T +import qualified AST.Variable as Var +import AST.PrettyPrint +import Text.PrettyPrint as P + + + +data Declaration' port def var + = Definition def + | Datatype String [String] [(String, [T.Type var])] + | TypeAlias String [String] (T.Type var) + | Port port + | Fixity Assoc Int String + + +data Assoc = L | N | R + deriving (Eq) + + +data RawPort + = PPAnnotation String T.RawType + | PPDef String Source.Expr + + +data Port expr var + = Out String expr (T.Type var) + | In String (T.Type var) + + +type SourceDecl = Declaration' RawPort Source.Def Var.Raw +type ValidDecl = Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw +type CanonicalDecl = Declaration' (Port Canonical.Expr Var.Canonical) + Canonical.Def + Var.Canonical + + +portName :: Port expr var -> String +portName port = + case port of + Out name _ _ -> name + In name _ -> name + + +assocToString :: Assoc -> String +assocToString assoc = + case assoc of + L -> "left" + N -> "non" + R -> "right" + + +-- BINARY CONVERSION + +instance Binary Assoc where + get = + do n <- getWord8 + return $ case n of + 0 -> L + 1 -> N + 2 -> R + _ -> error "Error reading valid associativity from serialized string" + + put assoc = + putWord8 $ + case assoc of + L -> 0 + N -> 1 + R -> 2 + + +-- PRETTY STRINGS + +instance (Pretty port, Pretty def, Pretty var, Var.ToString var) => + Pretty (Declaration' port def var) where + pretty decl = + case decl of + Definition def -> pretty def + + Datatype tipe tvars ctors -> + P.hang + (P.text "type" <+> P.text tipe <+> P.hsep (map P.text tvars)) + 4 + (P.sep $ zipWith (<+>) seperators (map prettyCtor ctors)) + where + seperators = + map P.text ("=" : repeat "|") + + prettyCtor (name, tipes) = + P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes)) + + TypeAlias name tvars tipe -> + P.hang + (P.text "type" <+> P.text "alias" <+> name' <+> P.equals) + 4 + (pretty tipe) + where + name' = + P.text name <+> P.hsep (map P.text tvars) + + Port port -> pretty port + + Fixity assoc prec op -> + P.text "infix" <> assoc' <+> P.int prec <+> P.text op + where + assoc' = + case assoc of + L -> P.text "l" + N -> P.empty + R -> P.text "r" + + +instance Pretty RawPort where + pretty port = + case port of + PPAnnotation name tipe -> + prettyPort name ":" tipe + + PPDef name expr -> + prettyPort name "=" expr + + +instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where + pretty port = + case port of + In name tipe -> + prettyPort name ":" tipe + + Out name expr tipe -> + P.vcat + [ prettyPort name ":" tipe + , prettyPort name "=" expr + ] + + +prettyPort :: (Pretty a) => String -> String -> a -> Doc +prettyPort name op e = + P.text "port" <+> P.text name <+> P.text op <+> pretty e diff --git a/src/AST/Expression/Canonical.hs b/src/AST/Expression/Canonical.hs new file mode 100644 --- /dev/null +++ b/src/AST/Expression/Canonical.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wall #-} + +module AST.Expression.Canonical where + +import AST.PrettyPrint +import Text.PrettyPrint as P +import qualified AST.Expression.General as General +import AST.Type (CanonicalType) +import qualified AST.Annotation as Annotation +import qualified AST.Pattern as Pattern +import qualified AST.Variable as Var + + +{-| Canonicalized expressions. All variables are fully resolved to the module +they came from. +-} +type Expr = General.Expr Annotation.Region Def Var.Canonical +type Expr' = General.Expr' Annotation.Region Def Var.Canonical + +data Def = Definition Pattern.CanonicalPattern Expr (Maybe CanonicalType) + deriving (Show) + +instance Pretty Def where + pretty (Definition pattern expr maybeTipe) = + P.vcat [ annotation, definition ] + where + definition = pretty pattern <+> P.equals <+> pretty expr + annotation = case maybeTipe of + Nothing -> P.empty + Just tipe -> pretty pattern <+> P.colon <+> pretty tipe diff --git a/src/AST/Expression/General.hs b/src/AST/Expression/General.hs new file mode 100644 --- /dev/null +++ b/src/AST/Expression/General.hs @@ -0,0 +1,218 @@ +{-# OPTIONS_GHC -Wall #-} + +{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats. +The first is the fully general version and is labeled with a prime (Expr'). +The others are specialized versions of the AST that represent specific phases +of the compilation process. I expect there to be more phases as we begin to +enrich the AST with more information. +-} +module AST.Expression.General where + +import AST.PrettyPrint +import Text.PrettyPrint as P +import AST.Type (Type) + +import qualified AST.Annotation as Annotation +import qualified AST.Helpers as Help +import qualified AST.Literal as Literal +import qualified AST.Pattern as Pattern +import qualified AST.Variable as Var + +---- GENERAL AST ---- + +{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has +"type holes" that allow us to enrich the AST with additional information as we +move through the compilation process. The type holes are used to represent: + + ann: Annotations for arbitrary expressions. Allows you to add information + to the AST like position in source code or inferred types. + + def: Definition style. The source syntax separates type annotations and + definitions, but after parsing we check that they are well formed and + collapse them. + + var: Representation of variables. Starts as strings, but is later enriched + with information about what module a variable came from. + +-} +type Expr annotation definition variable = + Annotation.Annotated annotation (Expr' annotation definition variable) + +data Expr' ann def var + = Literal Literal.Literal + | Var var + | Range (Expr ann def var) (Expr ann def var) + | ExplicitList [Expr ann def var] + | Binop var (Expr ann def var) (Expr ann def var) + | Lambda (Pattern.Pattern var) (Expr ann def var) + | App (Expr ann def var) (Expr ann def var) + | MultiIf [(Expr ann def var,Expr ann def var)] + | Let [def] (Expr ann def var) + | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)] + | Data String [Expr ann def var] + | Access (Expr ann def var) String + | Remove (Expr ann def var) String + | Insert (Expr ann def var) String (Expr ann def var) + | Modify (Expr ann def var) [(String, Expr ann def var)] + | Record [(String, Expr ann def var)] + -- for type checking and code gen only + | PortIn String (Type var) + | PortOut String (Type var) (Expr ann def var) + | GLShader String String Literal.GLShaderTipe + deriving (Show) + + +---- UTILITIES ---- + +rawVar :: String -> Expr' ann def Var.Raw +rawVar x = Var (Var.Raw x) + +localVar :: String -> Expr' ann def Var.Canonical +localVar x = Var (Var.Canonical Var.Local x) + +tuple :: [Expr ann def var] -> Expr' ann def var +tuple es = Data ("_Tuple" ++ show (length es)) es + +delist :: Expr ann def var -> [Expr ann def var] +delist (Annotation.A _ (Data "::" [h,t])) = h : delist t +delist _ = [] + +saveEnvName :: String +saveEnvName = "_save_the_environment!!!" + +dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical +dummyLet defs = + Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName)) + +instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where + pretty expr = + case expr of + Literal lit -> + pretty lit + + Var x -> + pretty x + + Range e1 e2 -> + P.brackets (pretty e1 <> P.text ".." <> pretty e2) + + ExplicitList es -> + P.brackets (commaCat (map pretty es)) + + Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e + | Var.toString op == "-" -> + P.text "-" <> prettyParens e + + Binop op e1 e2 -> + P.hang (prettyParens e1) 2 (P.text op'' <+> prettyParens e2) + where + op' = Var.toString op + op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`" + + Lambda p e -> + P.text "\\" <> args <+> P.text "->" <+> pretty body + where + (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e) + args = P.sep (map Pattern.prettyParens ps) + + App _ _ -> + P.hang func 2 (P.sep args) + where + func:args = + map prettyParens (collectApps (Annotation.A undefined expr)) + + MultiIf branches -> + P.text "if" $$ nest 3 (vcat $ map iff branches) + where + iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e) + + Let defs e -> + P.sep + [ P.hang (P.text "let") 4 (P.vcat (map pretty defs)) + , P.text "in" <+> pretty e + ] + + Case e pats -> + P.hang pexpr 2 (P.vcat (map pretty' pats)) + where + pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ] + pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b + + Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl + Data "[]" [] -> P.text "[]" + Data name es + | Help.isTuple name -> P.parens (commaCat (map pretty es)) + | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es)) + + Access e x -> + prettyParens e <> P.text "." <> variable x + + Remove e x -> + P.braces (pretty e <+> P.text "-" <+> variable x) + + Insert (Annotation.A _ (Remove e y)) x v -> + P.braces $ + P.hsep + [ pretty e, P.text "-", variable y, P.text "|" + , variable x, P.equals, pretty v + ] + + Insert e x v -> + P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v) + + Modify e fs -> + P.braces $ + P.hang + (pretty e <+> P.text "|") + 4 + (commaSep $ map field fs) + where + field (k,v) = variable k <+> P.text "<-" <+> pretty v + + Record fs -> + P.sep + [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map field fs)) + , P.rbrace + ] + where + field (field, value) = + variable field <+> P.equals <+> pretty value + + GLShader _ _ _ -> P.text "[glsl| ... |]" + + PortIn name _ -> P.text $ "" + + PortOut _ _ signal -> pretty signal + + +collectApps :: Expr ann def var -> [Expr ann def var] +collectApps annExpr@(Annotation.A _ expr) = + case expr of + App a b -> collectApps a ++ [b] + _ -> [annExpr] + + +collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var) +collectLambdas lexpr@(Annotation.A _ expr) = + case expr of + Lambda pattern body -> + let (ps, body') = collectLambdas body + in (pattern : ps, body') + + _ -> ([], lexpr) + + +prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc +prettyParens (Annotation.A _ expr) = + parensIf needed (pretty expr) + where + needed = + case expr of + Binop _ _ _ -> True + Lambda _ _ -> True + App _ _ -> True + MultiIf _ -> True + Let _ _ -> True + Case _ _ -> True + Data name (_:_) -> not (name == "::" || Help.isTuple name) + _ -> False diff --git a/src/AST/Expression/Source.hs b/src/AST/Expression/Source.hs new file mode 100644 --- /dev/null +++ b/src/AST/Expression/Source.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wall #-} + +module AST.Expression.Source where + +import AST.PrettyPrint +import Text.PrettyPrint as P +import qualified AST.Expression.General as General +import AST.Type (RawType) +import qualified AST.Variable as Var +import qualified AST.Annotation as Annotation +import qualified AST.Pattern as Pattern + + +{-| Expressions created by the parser. These use a split representation of type +annotations and definitions, which is how they appear in source code and how +they are parsed. +-} +type Expr = General.Expr Annotation.Region Def Var.Raw +type Expr' = General.Expr' Annotation.Region Def Var.Raw + +data Def + = Definition Pattern.RawPattern Expr + | TypeAnnotation String RawType + deriving (Show) + +instance Pretty Def where + pretty def = + case def of + TypeAnnotation name tipe -> + variable name <+> P.colon <+> pretty tipe + Definition pattern expr -> + pretty pattern <+> P.equals <+> pretty expr diff --git a/src/AST/Expression/Valid.hs b/src/AST/Expression/Valid.hs new file mode 100644 --- /dev/null +++ b/src/AST/Expression/Valid.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -Wall #-} + +module AST.Expression.Valid where + +import AST.PrettyPrint +import Text.PrettyPrint as P +import qualified AST.Expression.General as General +import AST.Type (RawType) +import qualified AST.Variable as Var +import qualified AST.Annotation as Annotation +import qualified AST.Pattern as Pattern + + +{-| "Normal" expressions. When the compiler checks that type annotations and +ports are all paired with definitions in the appropriate order, it collapses +them into a Def that is easier to work with in later phases of compilation. +-} +type Expr = General.Expr Annotation.Region Def Var.Raw +type Expr' = General.Expr' Annotation.Region Def Var.Raw + +data Def = Definition Pattern.RawPattern Expr (Maybe RawType) + deriving (Show) + +instance Pretty Def where + pretty (Definition pattern expr maybeTipe) = + P.vcat [ annotation, definition ] + where + definition = pretty pattern <+> P.equals <+> pretty expr + annotation = case maybeTipe of + Nothing -> P.empty + Just tipe -> pretty pattern <+> P.colon <+> pretty tipe diff --git a/src/AST/Helpers.hs b/src/AST/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/AST/Helpers.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -Wall #-} +module AST.Helpers where + +import qualified Data.Char as Char + +splitDots :: String -> [String] +splitDots = go [] + where + go vars str = + case break (=='.') str of + (x,_:rest) | isOp x -> vars ++ [x ++ '.' : rest] + | otherwise -> go (vars ++ [x]) rest + (x,[]) -> vars ++ [x] + +brkt :: String -> String +brkt s = "{ " ++ s ++ " }" + +isTuple :: String -> Bool +isTuple name = + take 6 name == "_Tuple" && all Char.isDigit (drop 6 name) + +isOp :: String -> Bool +isOp = all isSymbol + +isSymbol :: Char -> Bool +isSymbol c = + Char.isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!" diff --git a/src/AST/Literal.hs b/src/AST/Literal.hs new file mode 100644 --- /dev/null +++ b/src/AST/Literal.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wall #-} +module AST.Literal where + +import AST.PrettyPrint +import Data.Map (Map) +import qualified Text.PrettyPrint as PP + +data Literal + = IntNum Int + | FloatNum Double + | Chr Char + | Str String + | Boolean Bool + deriving (Eq, Ord, Show) + + +instance Pretty Literal where + pretty literal = + case literal of + IntNum n -> PP.int n + FloatNum n -> PP.double n + Chr c -> PP.text . show $ c + Str s -> PP.text . show $ s + Boolean bool -> PP.text (show bool) + + +data GLTipe + = Int + | Float + | V2 + | V3 + | V4 + | M4 + | Texture + deriving (Show) + + +glTipeName :: GLTipe -> String +glTipeName glTipe = + case glTipe of + Int -> "Int" + Float -> "Float" + V2 -> "Math.Vector2.Vec2" + V3 -> "Math.Vector3.Vec3" + V4 -> "Math.Vector4.Vec4" + M4 -> "Math.Matrix4.Mat4" + Texture -> "WebGL.Texture" + + +data GLShaderTipe = GLShaderTipe + { attribute :: Map String GLTipe + , uniform :: Map String GLTipe + , varying :: Map String GLTipe + } + deriving (Show) diff --git a/src/AST/Module.hs b/src/AST/Module.hs new file mode 100644 --- /dev/null +++ b/src/AST/Module.hs @@ -0,0 +1,168 @@ +module AST.Module where + +import Data.Binary +import qualified Data.List as List +import qualified Data.Map as Map +import Control.Applicative ((<$>),(<*>)) + +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Declaration as Decl +import qualified AST.Type as Type +import qualified AST.Variable as Var +import AST.PrettyPrint +import qualified Elm.Compiler.Version as Compiler +import Text.PrettyPrint as P + + +-- HELPFUL TYPE ALIASES + +type Interfaces = Map.Map Name Interface + +type Types = Map.Map String Type.CanonicalType +type Aliases = Map.Map String ([String], Type.CanonicalType) +type ADTs = Map.Map String (AdtInfo String) + +type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] ) +type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical) + + +-- MODULES + +type SourceModule = + Module (Var.Listing Var.Value) [Decl.SourceDecl] + +type ValidModule = + Module (Var.Listing Var.Value) [Decl.ValidDecl] + +type CanonicalModule = + Module [Var.Value] CanonicalBody + + +data Module exports body = Module + { names :: Name + , path :: FilePath + , exports :: exports + , imports :: [(Name, ImportMethod)] + , body :: body + } + +data CanonicalBody = CanonicalBody + { program :: Canonical.Expr + , types :: Types + , fixities :: [(Decl.Assoc, Int, String)] + , aliases :: Aliases + , datatypes :: ADTs + , ports :: [String] + } + + +-- HEADERS + +{-| Basic info needed to identify modules and determine dependencies. -} +data HeaderAndImports = HeaderAndImports + { _names :: Name + , _exports :: Var.Listing Var.Value + , _imports :: [(Name, ImportMethod)] + } + +type Name = [String] -- must be non-empty + +nameToString :: Name -> String +nameToString = List.intercalate "." + +nameIsNative :: Name -> Bool +nameIsNative name = + case name of + "Native" : _ -> True + _ -> False + + + +-- INTERFACES + +{-| Key facts about a module, used when reading info from .elmi files. -} +data Interface = Interface + { iVersion :: String + , iExports :: [Var.Value] + , iTypes :: Types + , iImports :: [(Name, ImportMethod)] + , iAdts :: ADTs + , iAliases :: Aliases + , iFixities :: [(Decl.Assoc, Int, String)] + , iPorts :: [String] + } + +toInterface :: CanonicalModule -> Interface +toInterface modul = + let body' = body modul in + Interface + { iVersion = Compiler.version + , iExports = exports modul + , iTypes = types body' + , iImports = imports modul + , iAdts = datatypes body' + , iAliases = aliases body' + , iFixities = fixities body' + , iPorts = ports body' + } + +instance Binary Interface where + get = Interface <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get + put modul = do + put (iVersion modul) + put (iExports modul) + put (iTypes modul) + put (iImports modul) + put (iAdts modul) + put (iAliases modul) + put (iFixities modul) + put (iPorts modul) + + +-- IMPORT METHOD + +data ImportMethod + = As !String + | Open !(Var.Listing Var.Value) + +open :: ImportMethod +open = Open (Var.openListing) + +importing :: [Var.Value] -> ImportMethod +importing xs = Open (Var.Listing xs False) + +instance Binary ImportMethod where + put method = + case method of + As alias -> putWord8 0 >> put alias + Open listing -> putWord8 1 >> put listing + + get = do tag <- getWord8 + case tag of + 0 -> As <$> get + 1 -> Open <$> get + _ -> error "Error reading valid ImportMethod type from serialized string" + + +-- PRETTY PRINTING + +instance (Pretty exs, Pretty body) => Pretty (Module exs body) where + pretty (Module names _ exs ims body) = + P.vcat [modul, P.text "", prettyImports, P.text "", pretty body] + where + modul = P.text "module" <+> name <+> pretty exs <+> P.text "where" + name = P.text (List.intercalate "." names) + + prettyImports = + P.vcat $ map prettyMethod ims + + +prettyMethod :: (Name, ImportMethod) -> Doc +prettyMethod import' = + case import' of + ([name], As alias) + | name == alias -> P.empty + + (_, As alias) -> P.text "as" <+> P.text alias + + (_, Open listing) -> pretty listing diff --git a/src/AST/Pattern.hs b/src/AST/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/AST/Pattern.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -Wall #-} +module AST.Pattern where + +import qualified AST.Helpers as Help +import AST.PrettyPrint +import Text.PrettyPrint as PP +import qualified Data.Set as Set + +import qualified AST.Variable as Var +import AST.Literal as Literal + +data Pattern var + = Data var [Pattern var] + | Record [String] + | Alias String (Pattern var) + | Var String + | Anything + | Literal Literal.Literal + deriving (Eq, Ord, Show) + +type RawPattern = Pattern Var.Raw +type CanonicalPattern = Pattern Var.Canonical + +cons :: RawPattern -> RawPattern -> RawPattern +cons h t = Data (Var.Raw "::") [h,t] + +nil :: RawPattern +nil = Data (Var.Raw "[]") [] + +list :: [RawPattern] -> RawPattern +list = foldr cons nil + +tuple :: [RawPattern] -> RawPattern +tuple es = Data (Var.Raw ("_Tuple" ++ show (length es))) es + +boundVarList :: Pattern var -> [String] +boundVarList = Set.toList . boundVars + +boundVars :: Pattern var -> Set.Set String +boundVars pattern = + case pattern of + Var x -> Set.singleton x + Alias x p -> Set.insert x (boundVars p) + Data _ ps -> Set.unions (map boundVars ps) + Record fields -> Set.fromList fields + Anything -> Set.empty + Literal _ -> Set.empty + + +instance Var.ToString var => Pretty (Pattern var) where + pretty pattern = + case pattern of + Var x -> variable x + Literal lit -> pretty lit + Record fs -> PP.braces (commaCat $ map variable fs) + Alias x p -> prettyParens p <+> PP.text "as" <+> variable x + Anything -> PP.text "_" + Data name [hd,tl] | Var.toString name == "::" -> + parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl + where + isCons = case hd of + Data ctor _ -> Var.toString ctor == "::" + _ -> False + + Data name ps + | Help.isTuple name' -> PP.parens . commaCat $ map pretty ps + | otherwise -> hsep (PP.text name' : map prettyParens ps) + where + name' = Var.toString name + +prettyParens :: Var.ToString var => Pattern var -> Doc +prettyParens pattern = + parensIf needsThem (pretty pattern) + where + needsThem = + case pattern of + Data name (_:_) | not (Help.isTuple (Var.toString name)) -> True + Alias _ _ -> True + _ -> False diff --git a/src/AST/PrettyPrint.hs b/src/AST/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/AST/PrettyPrint.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} +module AST.PrettyPrint where + +import Control.Monad.Trans.Error +import Text.PrettyPrint as P +import qualified AST.Helpers as Help + +class Pretty a where + pretty :: a -> Doc + +instance Pretty Doc where + pretty doc = doc + +instance Pretty String where + pretty = P.text + +renderPretty :: (Pretty a) => a -> String +renderPretty e = render (pretty e) + +commaCat docs = cat (punctuate comma docs) +commaSep docs = sep (punctuate comma docs) + +parensIf :: Bool -> Doc -> Doc +parensIf bool doc = if bool then parens doc else doc + +variable :: String -> Doc +variable x = + if Help.isOp x then parens (text x) else text x + +eightyCharLines :: Int -> String -> String +eightyCharLines indent message = answer + where + (answer,_,_) = foldl step (spaces, indent-1, "") chunks + + chunks = map (\w -> (w, length w)) (words message) + spaces = replicate indent ' ' + step (sentence, slen, space) (word, wlen) + | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ") + | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ") + +instance ErrorList Doc where + listMsg str = [ P.text str ] diff --git a/src/AST/Type.hs b/src/AST/Type.hs new file mode 100644 --- /dev/null +++ b/src/AST/Type.hs @@ -0,0 +1,148 @@ +module AST.Type where + +import Control.Applicative ((<$>), (<*>)) +import Data.Binary +import qualified Data.Map as Map + +import qualified AST.Variable as Var +import AST.PrettyPrint +import qualified AST.Helpers as Help +import Text.PrettyPrint as P + +data Type var + = Lambda (Type var) (Type var) + | Var String + | Type var + | App (Type var) [Type var] + | Record [(String, Type var)] (Maybe (Type var)) + | Aliased Var.Canonical (Type var) + deriving (Eq,Show) + +type RawType = Type Var.Raw +type CanonicalType = Type Var.Canonical + +fieldMap :: [(String,a)] -> Map.Map String [a] +fieldMap fields = + foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields + +recordOf :: [(String, Type var)] -> Type var +recordOf fields = Record fields Nothing + +listOf :: RawType -> RawType +listOf t = App (Type (Var.Raw "List")) [t] + +tupleOf :: [RawType] -> RawType +tupleOf ts = App (Type t) ts + where + t = Var.Raw ("_Tuple" ++ show (length ts)) + +instance (Var.ToString var, Pretty var) => Pretty (Type var) where + pretty tipe = + case tipe of + Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ] + where + t:ts = map prettyLambda (collectLambdas tipe) + prettyLambda t = case t of + Lambda _ _ -> P.parens (pretty t) + _ -> pretty t + + Var x -> P.text x + + Type var -> + let v = Var.toString var in + P.text (if v == "_Tuple0" then "()" else v) + + App f args -> + case (f,args) of + (Type name, _) + | Help.isTuple (Var.toString name) -> + P.parens . P.sep . P.punctuate P.comma $ map pretty args + + _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args) + + Record _ _ -> + case flattenRecord tipe of + ([], Nothing) -> + P.text "{}" + + (fields, Nothing) -> + P.sep + [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields)) + , P.rbrace + ] + + (fields, Just x) -> + P.hang + (P.lbrace <+> P.text x <+> P.text "|") + 4 + (P.sep + [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields)) + , P.rbrace + ]) + where + prettyField (field, tipe) = + P.text field <+> P.text ":" <+> pretty tipe + + Aliased name t -> + let t' = pretty t in + if show t' `elem` ["Int", "Float", "String", "Char", "Bool"] + then t' + else pretty name + + +collectLambdas :: Type var -> [Type var] +collectLambdas tipe = + case tipe of + Lambda arg body -> arg : collectLambdas body + _ -> [tipe] + +prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc +prettyParens tipe = parensIf (needed tipe) (pretty tipe) + where + needed t = + case t of + Aliased _ t' -> needed t' + + Lambda _ _ -> True + + App (Type name) _ | Help.isTuple (Var.toString name) -> False + App t' [] -> needed t' + App _ _ -> True + + _ -> False + +flattenRecord :: Type var -> ( [(String, Type var)], Maybe String ) +flattenRecord tipe = + case tipe of + Var x -> ([], Just x) + + Record fields Nothing -> (fields, Nothing) + + Record fields (Just ext) -> + let (fields',ext') = flattenRecord ext + in (fields' ++ fields, ext') + + Aliased _ tipe' -> flattenRecord tipe' + + _ -> error "Trying to flatten ill-formed record." + +instance Binary var => Binary (Type var) where + put tipe = + case tipe of + Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2 + Var x -> putWord8 1 >> put x + Type name -> putWord8 2 >> put name + App t1 t2 -> putWord8 3 >> put t1 >> put t2 + Record fs ext -> putWord8 4 >> put fs >> put ext + Aliased var t -> putWord8 5 >> put var >> put t + + get = do + n <- getWord8 + case n of + 0 -> Lambda <$> get <*> get + 1 -> Var <$> get + 2 -> Type <$> get + 3 -> App <$> get <*> get + 4 -> Record <$> get <*> get + 5 -> Aliased <$> get <*> get + _ -> error "Error reading a valid type from serialized string" diff --git a/src/AST/Variable.hs b/src/AST/Variable.hs new file mode 100644 --- /dev/null +++ b/src/AST/Variable.hs @@ -0,0 +1,240 @@ +module AST.Variable where + +import Control.Applicative ((<$>), (<*>)) +import Data.Binary +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import Text.PrettyPrint as P +import qualified AST.Helpers as Help +import AST.PrettyPrint + + +-- VARIABLES + +newtype Raw = Raw String + deriving (Eq,Ord,Show) + + +data Home + = BuiltIn + | Module [String] + | Local + deriving (Eq,Ord,Show) + + +data Canonical = Canonical + { home :: !Home + , name :: !String + } + deriving (Eq,Ord,Show) + + +local :: String -> Canonical +local x = Canonical Local x + + +builtin :: String -> Canonical +builtin x = Canonical BuiltIn x + + +-- VARIABLE RECOGNIZERS + +is :: [String] -> String -> Canonical -> Bool +is home name var = + var == Canonical (Module home) name + + +isJson :: Canonical -> Bool +isJson = + is ["Json", "Encode"] "Value" + + +isMaybe :: Canonical -> Bool +isMaybe = + is ["Maybe"] "Maybe" + +isArray :: Canonical -> Bool +isArray = + is ["Array"] "Array" + + +isSignal :: Canonical -> Bool +isSignal = + is ["Signal"] "Signal" + + +isList :: Canonical -> Bool +isList v = + v == Canonical BuiltIn "List" + + +isTuple :: Canonical -> Bool +isTuple v = + case v of + Canonical BuiltIn name -> Help.isTuple name + _ -> False + + +isPrimitive :: Canonical -> Bool +isPrimitive v = + case v of + Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"] + _ -> False + + +isPrim :: String -> Canonical -> Bool +isPrim prim v = + case v of + Canonical BuiltIn name -> name == prim + _ -> False + + +isText :: Canonical -> Bool +isText = + is ["Text"] "Text" + + +-- VARIABLE TO STRING + +class ToString a where + toString :: a -> String + + +instance ToString Raw where + toString (Raw x) = x + + +instance ToString Canonical where + toString (Canonical home name) = + case home of + BuiltIn -> name + Module path -> List.intercalate "." (path ++ [name]) + Local -> name + + +-- LISTINGS + +-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..) +data Listing a = Listing + { _explicits :: [a] + , _open :: Bool + } deriving (Eq,Ord,Show) + + +openListing :: Listing a +openListing = + Listing [] True + + +-- | A value that can be imported or exported +data Value + = Value !String + | Alias !String + | Union !String !(Listing String) + deriving (Eq,Ord,Show) + + +-- CATEGORIZING VALUES + +getValues :: [Value] -> [String] +getValues values = + Maybe.mapMaybe getValue values + + +getValue :: Value -> Maybe String +getValue value = + case value of + Value name -> Just name + Alias _ -> Nothing + Union _ _ -> Nothing + + +getAliases :: [Value] -> [String] +getAliases values = + Maybe.mapMaybe getAlias values + + +getAlias :: Value -> Maybe String +getAlias value = + case value of + Value _-> Nothing + Alias name -> Just name + Union _ _ -> Nothing + + +getUnions :: [Value] -> [(String, Listing String)] +getUnions values = + Maybe.mapMaybe getUnion values + + +getUnion :: Value -> Maybe (String, Listing String) +getUnion value = + case value of + Value _ -> Nothing + Alias _ -> Nothing + Union name ctors -> Just (name, ctors) + + +-- PRETTY VARIABLES + +instance Pretty Raw where + pretty (Raw var) = variable var + + +instance Pretty Canonical where + pretty var = P.text (toString var) + + +instance Pretty a => Pretty (Listing a) where + pretty (Listing explicits open) = + P.parens (commaCat (map pretty explicits ++ dots)) + where + dots = [if open then P.text ".." else P.empty] + + +instance Pretty Value where + pretty portable = + case portable of + Value name -> P.text name + Alias name -> P.text name + Union name ctors -> + P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) }) + + +-- BINARY SERIALIZATION + +instance Binary Canonical where + put (Canonical home name) = + case home of + BuiltIn -> putWord8 0 >> put name + Module path -> putWord8 1 >> put path >> put name + Local -> putWord8 2 >> put name + + get = do tag <- getWord8 + case tag of + 0 -> Canonical BuiltIn <$> get + 1 -> Canonical . Module <$> get <*> get + 2 -> Canonical Local <$> get + _ -> error "Unexpected tag when deserializing canonical variable" + + +instance Binary Value where + put portable = + case portable of + Value name -> putWord8 0 >> put name + Alias name -> putWord8 1 >> put name + Union name ctors -> putWord8 2 >> put name >> put ctors + + get = do tag <- getWord8 + case tag of + 0 -> Value <$> get + 1 -> Alias <$> get + 2 -> Union <$> get <*> get + _ -> error "Error reading valid import/export information from serialized string" + + +instance (Binary a) => Binary (Listing a) where + put (Listing explicits open) = + put explicits >> put open + + get = Listing <$> get <*> get diff --git a/src/Compile.hs b/src/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Compile.hs @@ -0,0 +1,60 @@ +module Compile (compile) where + +import qualified Data.Map as Map +import Text.PrettyPrint (Doc) + +import qualified AST.Module as Module +import qualified Parse.Helpers as Parse +import qualified Parse.Parse as Parse +import qualified Transform.AddDefaultImports as DefaultImports +import qualified Transform.Check as Check +import qualified Type.Inference as TI +import qualified Transform.Canonicalize as Canonical +import Elm.Utils ((|>)) + + +compile + :: String + -> String + -> Module.Interfaces + -> String + -> Either [Doc] Module.CanonicalModule + +compile user projectName interfaces source = + do + -- Parse the source code + parsedModule <- + Parse.program (getOpTable interfaces) source + + -- determine if default imports should be added + -- only elm-lang/core is exempt + let needsDefaults = + not (user == "elm-lang" && projectName == "core") + + -- add default imports if necessary + let rawModule = + DefaultImports.add needsDefaults parsedModule + + -- validate module (e.g. all variables exist) + case Check.mistakes (Module.body rawModule) of + [] -> return () + ms -> Left ms + + -- Canonicalize all variables, pinning down where they came from. + canonicalModule <- Canonical.module' interfaces rawModule + + -- Run type inference on the program. + types <- TI.infer interfaces canonicalModule + + -- Add the real list of tyes + let body = (Module.body canonicalModule) { Module.types = types } + + return $ canonicalModule { Module.body = body } + + +getOpTable :: Module.Interfaces -> Parse.OpTable +getOpTable interfaces = + Map.elems interfaces + |> concatMap Module.iFixities + |> map (\(assoc,lvl,op) -> (op,(lvl,assoc))) + |> Map.fromList diff --git a/src/Docs.hs b/src/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Docs.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} +module Main where + +import System.Console.CmdArgs +import System.Directory +import System.FilePath +import System.Exit +import System.IO + +import Control.Applicative ((<$>)) +import Control.Arrow (second) +import qualified Data.Aeson.Encode.Pretty as Json +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set + +import qualified AST.Declaration as Decl +import qualified AST.Expression.Source as Source +import qualified AST.Variable as Var + +import Text.Parsec hiding (newline, spaces) +import qualified Parse.Declaration as Parse (typeDecl, infixDecl) +import qualified Parse.Expression as Parse (typeAnnotation) +import qualified Parse.Helpers as Parse +import qualified Parse.Module as Parse (header) +import qualified Elm.Compiler.Module as Module +import qualified Elm.Compiler.Type.Extract as Type +import qualified Elm.Docs as Docs + + +-- FLAGS + +data Flags = Flags + { input :: FilePath + , output :: Maybe FilePath + } + deriving (Data,Typeable,Show,Eq) + + +defaultFlags :: Flags +defaultFlags = Flags + { input = def &= args &= typ "FILE" + + , output = Nothing &= typFile + &= help "file name for generated JSON documentation" + + } &= help "Generate documentation for Elm" + &= summary "Generate documentation for Elm, (c) Evan Czaplicki" + + +-- GENERATE DOCUMENTATION + +main :: IO () +main = + do flags <- cmdArgs defaultFlags + source <- readFile (input flags) + case Parse.iParse documentation source of + Right docs -> + let json = Json.encodePretty' config docs in + case output flags of + Nothing -> BS.putStrLn json + Just docPath -> + do createDirectoryIfMissing True (dropFileName docPath) + BS.writeFile docPath json + + Left err -> + do hPutStrLn stderr (show err) + exitFailure + + +config :: Json.Config +config = + Json.Config + { Json.confIndent = 2 + , Json.confCompare = Json.keyOrder keys + } + where + keys = + [ "tag", "name", "comment", "aliases", "types" + , "values", "func", "args", "type", "cases" + ] + + +-- PARSE DOCUMENTATION + +documentation :: Parse.IParser Docs.Documentation +documentation = + do optional Parse.freshLine + (names, exports) <- Parse.header + + manyTill (string " " <|> Parse.newline "more whitespace") + (lookAhead (string "{-|") "module documentation comment") + + overview <- docComment + + decls <- allDeclarations + + let (aliases, unions, values) = categorizeDeclarations decls + + return $ + Docs.Documentation + (Module.Name names) + overview + (filterAliases exports aliases) + (filterUnions exports unions) + (filterValues exports values) + + +docComment :: Parse.IParser String +docComment = + do try (string "{-|") + contents <- Parse.closeComment + + let reversed = + dropWhile (`elem` " \n\r") . drop 2 $ reverse contents + + return $ dropWhile (==' ') (reverse reversed) + + +allDeclarations :: Parse.IParser [(String, Decl.SourceDecl)] +allDeclarations = + Parse.onFreshLines (:) [] declaration + + +declaration :: Parse.IParser (String, Decl.SourceDecl) +declaration = + uncommentable <|> commented <|> uncommented "" + where + uncommentable = + (,) "" <$> Parse.infixDecl + + commented = + do comment <- docComment + Parse.freshLine + uncommented comment + + uncommented comment = + (,) comment + <$> choice [ Parse.typeDecl, Decl.Definition <$> Parse.typeAnnotation ] + + +-- CATEGORIZE DECLARATIONS + +data CategoryInfo = CategoryInfo + { aliases :: [Docs.Alias] + , unions :: [Docs.Union] + , values :: Map.Map String Docs.Value + , infixes :: Map.Map String (String, Int) + } + + +emptyInfo :: CategoryInfo +emptyInfo = + CategoryInfo [] [] Map.empty Map.empty + + +categorizeDeclarations :: [(String, Decl.SourceDecl)] -> ([Docs.Alias], [Docs.Union], [Docs.Value]) +categorizeDeclarations decls = + (aliases, unions, Map.elems values) + where + (CategoryInfo aliases unions rawValues infixes) = + foldr collectInfo emptyInfo decls + + values = + Map.union + (Map.intersectionWith addInfixInfo rawValues infixes) + rawValues + + +addInfixInfo :: Docs.Value -> (String, Int) -> Docs.Value +addInfixInfo value infixInfo = + value { Docs.valueAssocPrec = Just infixInfo } + + +collectInfo :: (String, Decl.SourceDecl) -> CategoryInfo -> CategoryInfo +collectInfo (comment, decl) info = + case decl of + Decl.Definition def -> + case def of + Source.Definition _ _ -> error errorMessage + Source.TypeAnnotation name tipe -> + let value = Docs.Value name comment (Type.fromInternalType tipe) Nothing + in + info { values = Map.insert name value (values info) } + + Decl.Datatype name args cases -> + let cases' = map (second (map Type.fromInternalType)) cases + union = Docs.Union name comment args cases' + in + info { unions = union : unions info } + + Decl.TypeAlias name args tipe -> + let alias = Docs.Alias name comment args (Type.fromInternalType tipe) + in + info { aliases = alias : aliases info } + + Decl.Fixity assoc prec name -> + let infixInfo = (Decl.assocToString assoc, prec) + in + info { infixes = Map.insert name infixInfo (infixes info) } + + Decl.Port _ -> + error errorMessage + + +errorMessage :: String +errorMessage = + "there appears to be a bug in this tool.\n" ++ + "Please report it to " + + +-- FILTER OUT UNEXPORTED VALUES, ALIASES, and UNIONS + +filterValues :: Var.Listing Var.Value -> [Docs.Value] -> [Docs.Value] +filterValues (Var.Listing exports open) values = + case open of + True -> values + False -> + let names = + Set.fromList (Var.getValues exports) + in + filter (\value -> Set.member (Docs.valueName value) names) values + + +filterAliases :: Var.Listing Var.Value -> [Docs.Alias] -> [Docs.Alias] +filterAliases (Var.Listing exports open) aliases = + case open of + True -> aliases + False -> + let names = + Set.fromList (Var.getAliases exports) + in + filter (\value -> Set.member (Docs.aliasName value) names) aliases + + +filterUnions :: Var.Listing Var.Value -> [Docs.Union] -> [Docs.Union] +filterUnions (Var.Listing exports open) unions = + case open of + True -> unions + False -> + Maybe.mapMaybe (filterUnion exportedUnions) unions + where + exportedUnions = + Map.fromList (Var.getUnions exports) + + +filterUnion :: Map.Map String (Var.Listing String) -> Docs.Union -> Maybe Docs.Union +filterUnion exportedUnions union = + case Map.lookup (Docs.unionName union) exportedUnions of + Nothing -> + Nothing + + Just (Var.Listing tags unionOpen) + | unionOpen -> + Just union + | otherwise -> + let publicTags = + filter (\(tag, _) -> tag `elem` tags) (Docs.unionCases union) + in + Just (union { Docs.unionCases = publicTags }) + diff --git a/src/Elm/Compiler.hs b/src/Elm/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Compiler.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} +module Elm.Compiler + ( version + , parseDependencies, compile + , runtimeDebugPath + ) where + +import Control.Monad.Error (MonadError, throwError) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Text.PrettyPrint as P + +import qualified AST.Module as Module (HeaderAndImports(HeaderAndImports), toInterface) +import qualified Compile +import qualified Elm.Compiler.Module as PublicModule +import qualified Elm.Compiler.Version as Version +import Elm.Utils ((|>)) +import qualified Elm.Utils as Utils +import qualified Generate.JavaScript as JS +import qualified Parse.Helpers as Help +import qualified Parse.Module as Parse +import qualified Paths_elm_compiler as Paths + + +-- VERSION + +version :: String +version = + Version.version + + +-- DEPENDENCIES + +parseDependencies + :: (MonadError String m) + => String + -> m (PublicModule.Name, [PublicModule.Name]) +parseDependencies src = + case Help.iParse Parse.headerAndImports src of + Left msg -> + throwError (show msg) + + Right (Module.HeaderAndImports names _exports imports) -> + return + ( PublicModule.Name names + , map (PublicModule.Name . fst) imports + ) + + +-- COMPILATION + +{-| Compiles Elm source code to JavaScript. -} +compile + :: String + -> String + -> String + -> Map.Map PublicModule.Name PublicModule.Interface + -> Either String (PublicModule.Interface, String) +compile user packageName source interfaces = + let unwrappedInterfaces = + Map.mapKeysMonotonic (\(PublicModule.Name name) -> name) interfaces + in + case Compile.compile user packageName unwrappedInterfaces source of + Right modul -> + Right (Module.toInterface modul, JS.generate modul) + + Left docs -> + map P.render docs + |> List.intersperse "" + |> unlines + |> Left + + +-- DATA FILES + +{-| Path to the debugger runtime. +-} +runtimeDebugPath :: IO FilePath +runtimeDebugPath = + Utils.getAsset "compiler" Paths.getDataFileName "runtime/debug.js" diff --git a/src/Elm/Compiler/Module.hs b/src/Elm/Compiler/Module.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Compiler/Module.hs @@ -0,0 +1,112 @@ +module Elm.Compiler.Module + ( Interface, Name(Name) + , nameToPath + , nameToString, nameFromString + , hyphenate, dehyphenate + , defaultImports + , interfacePorts + , interfaceTypes + ) + where + +import Control.Monad (mzero) +import qualified Data.Aeson as Json +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Text as Text +import System.FilePath (()) + +import qualified AST.Module as Module +import qualified Transform.AddDefaultImports as Defaults +import qualified Elm.Compiler.Type as Type +import qualified Elm.Compiler.Type.Extract as Extract + + +-- EXPOSED TYPES + +type Interface = Module.Interface + + +newtype Name = Name [String] + deriving (Eq, Ord) + + +defaultImports :: [Name] +defaultImports = + map Name (Map.keys Defaults.defaultImports) + + +-- POKING AROUND INTERFACES + +interfacePorts :: Interface -> [String] +interfacePorts interface = + Module.iPorts interface + + +interfaceTypes :: Interface -> Map.Map String Type.Type +interfaceTypes interface = + Map.map Extract.fromInternalType (Module.iTypes interface) + + +-- STRING CONVERSIONS for NAMES + +nameToPath :: Name -> FilePath +nameToPath (Name names) = + List.foldl1 () names + + +nameToString :: Name -> String +nameToString (Name names) = + List.intercalate "." names + + +nameFromString :: String -> Maybe Name +nameFromString = + fromString '.' + + +hyphenate :: Name -> String +hyphenate (Name names) = + List.intercalate "-" names + + +dehyphenate :: String -> Maybe Name +dehyphenate = + fromString '-' + + +fromString :: Char -> String -> Maybe Name +fromString sep raw = + Name `fmap` mapM isLegit names + where + names = + filter (/= [sep]) (List.groupBy (\a b -> a /= sep && b /= sep) raw) + + isLegit name = + case name of + [] -> Nothing + char:rest -> + if Char.isUpper char && all legitChar rest + then Just name + else Nothing + + legitChar char = + Char.isAlphaNum char || char `elem` "_'" + + +-- JSON for NAME + +instance Json.ToJSON Name where + toJSON name = + Json.toJSON (nameToString name) + + +instance Json.FromJSON Name where + parseJSON (Json.String text) = + let rawName = Text.unpack text in + case nameFromString rawName of + Nothing -> fail (rawName ++ " is not a valid module name") + Just name -> return name + + parseJSON _ = mzero diff --git a/src/Elm/Compiler/Type.hs b/src/Elm/Compiler/Type.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Compiler/Type.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +module Elm.Compiler.Type + ( Type(..) + , toString + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Json +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Text as Text +import Text.PrettyPrint as P + +import qualified AST.Helpers as Help + + +data Type + = Lambda Type Type + | Var String + | Type String + | App Type [Type] + | Record [(String, Type)] (Maybe Type) + + +-- TO STRING + +data Context = None | ADT | Function + + +toString :: Type -> String +toString tipe = + P.render (toDoc None tipe) + + +toDoc :: Context -> Type -> P.Doc +toDoc context tipe = + case tipe of + Lambda _ _ -> + let t:ts = + map (toDoc Function) (collectLambdas tipe) + + lambda = + P.sep [ t, P.sep (map (P.text "->" <+>) ts) ] + in + case context of + None -> lambda + _ -> P.parens lambda + + Var name -> + P.text name + + Type name -> + P.text (if name == "_Tuple0" then "()" else name) + + App (Type name) args + | Help.isTuple name -> + P.sep + [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args)) + , P.rparen + ] + + | otherwise -> + let adt = P.hang (P.text name) 2 (P.sep $ map (toDoc ADT) args) + in + case (context, args) of + (ADT, _ : _) -> P.parens adt + _ -> adt + + Record _ _ -> + case flattenRecord tipe of + ([], Nothing) -> + P.text "{}" + + (fields, Nothing) -> + P.sep + [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields)) + , P.rbrace + ] + + (fields, Just x) -> + P.hang + (P.lbrace <+> P.text x <+> P.text "|") + 4 + (P.sep + [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields)) + , P.rbrace + ]) + where + prettyField (field, tipe) = + P.text field <+> P.text ":" <+> toDoc None tipe + + +collectLambdas :: Type -> [Type] +collectLambdas tipe = + case tipe of + Lambda arg body -> arg : collectLambdas body + _ -> [tipe] + + +flattenRecord :: Type -> ( [(String, Type)], Maybe String ) +flattenRecord tipe = + case tipe of + Var x -> ([], Just x) + + Record fields Nothing -> (fields, Nothing) + + Record fields (Just ext) -> + let (fields',ext') = flattenRecord ext + in + (fields' ++ fields, ext') + + _ -> error "Trying to flatten ill-formed record." + + +-- JSON for TYPE + +instance Json.ToJSON Type where + toJSON tipe = + Json.object (getFields tipe) + where + getFields tipe = + case tipe of + Lambda t1 t2 -> + [ "tag" .= ("lambda" :: Text.Text) + , "in" .= Json.toJSON t1 + , "out" .= Json.toJSON t2 + ] + + Var x -> + [ "tag" .= ("var" :: Text.Text) + , "name" .= Json.toJSON x + ] + + Type name -> + [ "tag" .= ("type" :: Text.Text) + , "name" .= Json.toJSON name + ] + + App t ts -> + [ "tag" .= ("app" :: Text.Text) + , "func" .= Json.toJSON t + , "args" .= Json.toJSON ts + ] + + Record fields ext -> + [ "tag" .= ("record" :: Text.Text) + , "fields" .= Json.toJSON (map (Json.toJSON . second Json.toJSON) fields) + , "extension" .= Json.toJSON ext + ] + + +instance Json.FromJSON Type where + parseJSON (Json.Object obj) = + do tag <- obj .: "tag" + case (tag :: String) of + "lambda" -> + Lambda <$> obj .: "in" <*> obj .: "out" + + "var" -> + Var <$> obj .: "name" + + "type" -> + Type <$> obj .: "name" + + "app" -> + App <$> obj .: "func" <*> obj .: "args" + + "record" -> + Record <$> obj .: "fields" <*> obj .: "extension" + + _ -> + fail $ "Error when decoding type with tag: " ++ tag + + + parseJSON value = + fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value) diff --git a/src/Elm/Compiler/Type/Extract.hs b/src/Elm/Compiler/Type/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Compiler/Type/Extract.hs @@ -0,0 +1,30 @@ +module Elm.Compiler.Type.Extract where + +import Control.Arrow (second) +import qualified AST.Type as Type +import qualified AST.Variable as Var +import qualified Elm.Compiler.Type as T + + +-- INTERNAL TYPE to PUBLIC TYPE + +fromInternalType :: Var.ToString a => Type.Type a -> T.Type +fromInternalType astType = + case astType of + Type.Lambda t1 t2 -> + T.Lambda (fromInternalType t1) (fromInternalType t2) + + Type.Var x -> + T.Var x + + Type.Type var -> + T.Type (Var.toString var) + + Type.App t ts -> + T.App (fromInternalType t) (map fromInternalType ts) + + Type.Record fields ext -> + T.Record (map (second fromInternalType) fields) (fmap fromInternalType ext) + + Type.Aliased _ t -> + fromInternalType t diff --git a/src/Elm/Compiler/Version.hs b/src/Elm/Compiler/Version.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Compiler/Version.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wall #-} +module Elm.Compiler.Version (version) where + +import qualified Data.Version as Version +import qualified Paths_elm_compiler as This + + +version :: String +version = + Version.showVersion This.version diff --git a/src/Elm/Docs.hs b/src/Elm/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Docs.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} +module Elm.Docs where + +import Control.Applicative ((<$>),(<*>)) +import Control.Monad +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as Json +import qualified Data.ByteString.Lazy.Char8 as BS + +import qualified Elm.Compiler.Module as Module +import qualified Elm.Compiler.Type as Type + + +data Documentation = Documentation + { moduleName :: Module.Name + , comment :: String + , aliases :: [Alias] + , types :: [Union] + , values :: [Value] + } + + +data Alias = Alias + { aliasName :: String + , aliasComment :: String + , aliasArgs :: [String] + , aliasType :: Type.Type + } + + +data Union = Union + { unionName :: String + , unionComment :: String + , unionArgs :: [String] + , unionCases :: [(String, [Type.Type])] + } + + +data Value = Value + { valueName :: String + , valueComment :: String + , valueType :: Type.Type + , valueAssocPrec :: Maybe (String,Int) + } + + +-- JSON for DOCUMENTATION + +instance Json.ToJSON Documentation where + toJSON (Documentation name comment aliases types values) = + Json.object + [ "name" .= name + , "comment" .= comment + , "aliases" .= aliases + , "types" .= types + , "values" .= values + ] + +instance Json.FromJSON Documentation where + parseJSON (Json.Object obj) = + Documentation + <$> obj .: "name" + <*> obj .: "comment" + <*> obj .: "aliases" + <*> obj .: "types" + <*> obj .: "values" + + parseJSON value = + fail $ "Cannot decode Documentation from: " ++ BS.unpack (Json.encode value) + + +-- JSON for ALIAS + +instance Json.ToJSON Alias where + toJSON (Alias name comment args tipe) = + Json.object + [ "name" .= name + , "comment" .= comment + , "args" .= args + , "type" .= tipe + ] + +instance Json.FromJSON Alias where + parseJSON (Json.Object obj) = + Alias + <$> obj .: "name" + <*> obj .: "comment" + <*> obj .: "args" + <*> obj .: "type" + + parseJSON value = + fail $ "Cannot decode Alias from: " ++ BS.unpack (Json.encode value) + + +-- JSON for UNION + +instance Json.ToJSON Union where + toJSON (Union name comment args cases) = + Json.object + [ "name" .= name + , "comment" .= comment + , "args" .= args + , "cases" .= cases + ] + +instance Json.FromJSON Union where + parseJSON (Json.Object obj) = + Union + <$> obj .: "name" + <*> obj .: "comment" + <*> obj .: "args" + <*> obj .: "cases" + + parseJSON value = + fail $ "Cannot decode Union from: " ++ BS.unpack (Json.encode value) + + +-- JSON for VALUE + +instance Json.ToJSON Value where + toJSON (Value name comment tipe assocPrec) = + Json.object (fields ++ possibleFields) + where + fields = + [ "name" .= name + , "comment" .= comment + , "type" .= tipe + ] + + possibleFields = + case assocPrec of + Nothing -> [] + Just (assoc, prec) -> + [ "associativity" .= assoc + , "precedence" .= prec + ] + + +instance Json.FromJSON Value where + parseJSON (Json.Object obj) = + Value + <$> obj .: "name" + <*> obj .: "comment" + <*> obj .: "type" + <*> (liftM2 (,) <$> obj .:? "associativity" <*> obj .:? "precedence") + + parseJSON value = + fail $ "Cannot decode Value from: " ++ BS.unpack (Json.encode value) + diff --git a/src/Elm/Utils.hs b/src/Elm/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Utils.hs @@ -0,0 +1,121 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE FlexibleContexts #-} +module Elm.Utils ((|>), (<|), getAsset, run, unwrappedRun, CommandError(..)) where + +import Control.Monad.Error (MonadError, MonadIO, liftIO, throwError) +import System.Directory (doesFileExist) +import System.Environment (getEnv) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) +import System.FilePath (()) +import System.IO.Error (tryIOError) +import System.Process (readProcessWithExitCode) + +import qualified Elm.Compiler.Version as Version + + +{-| Forward function application `x |> f == f x`. This function is useful +for avoiding parenthesis and writing code in a more natural way. +-} +(|>) :: a -> (a -> b) -> b +x |> f = f x + + +{-| Backward function application `f <| x == f x`. This function is useful for +avoiding parenthesis. +-} +(<|) :: (a -> b) -> a -> b +f <| x = f x + + +infixr 0 <| +infixl 0 |> + + +-- RUN EXECUTABLES + +data CommandError + = MissingExe String + | CommandFailed String String + + +{-| Run a command, throw an error if the command is not found or if something +goes wrong. +-} +run :: (MonadError String m, MonadIO m) => String -> [String] -> m String +run command args = + do result <- liftIO (unwrappedRun command args) + case result of + Right out -> return out + Left err -> + throwError (context (message err)) + where + context msg = + "failure when running:" ++ concatMap (' ':) (command:args) ++ "\n" ++ msg + + message err = + case err of + CommandFailed stderr stdout -> + stdout ++ stderr + MissingExe msg -> + msg + + +unwrappedRun :: String -> [String] -> IO (Either CommandError String) +unwrappedRun command args = + do (exitCode, stdout, stderr) <- readProcessWithExitCode command args "" + return $ + case exitCode of + ExitSuccess -> Right stdout + ExitFailure code + | code == 127 -> Left (missingExe command) -- UNIX + | code == 9009 -> Left (missingExe command) -- Windows + | otherwise -> Left (CommandFailed stdout stderr) + + +missingExe :: String -> CommandError +missingExe command = + MissingExe $ + "Could not find command '" ++ command ++ "'. Do you have it installed?\n\ + \ Can it be run from anywhere? Is it on your PATH?" + + + +-- GET STATIC ASSETS + +{-| Get the absolute path to a data file. If you install with cabal it will look +-} +getAsset :: String -> (FilePath -> IO FilePath) -> FilePath -> IO FilePath +getAsset project getDataFileName name = + do path <- getDataFileName name + exists <- doesFileExist path + if exists + then return path + else do + environment <- tryIOError (getEnv "ELM_HOME") + case environment of + Right env -> + return (env project name) + + Left _ -> + fail (errorNotFound name) + + +errorNotFound :: FilePath -> String +errorNotFound name = + unlines + [ "Unable to find the ELM_HOME environment variable when searching" + , "for the " ++ name ++ " file." + , "" + , "If you installed Elm Platform with the Mac or Windows installer, it looks like" + , "ELM_HOME was not set automatically. Look up how to set environment variables" + , "on your platform and set ELM_HOME to the directory that contains Elm's static" + , "files:" + , "" + , " * On Mac it is /usr/local/share/elm" + , " * On Windows it is one of the following:" + , " C:/Program Files/Elm Platform/" ++ Version.version ++ "/share" + , " C:/Program Files (x86)/Elm Platform/" ++ Version.version ++ "/share" + , "" + , "If it seems like a more complex issue, please report it here:" + , " " + ] diff --git a/src/Generate/Cases.hs b/src/Generate/Cases.hs new file mode 100644 --- /dev/null +++ b/src/Generate/Cases.hs @@ -0,0 +1,210 @@ +module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where + +import Control.Applicative ((<$>)) +import Control.Arrow (first) +import Control.Monad.State (State) +import qualified Control.Monad.State as State +import Data.List (groupBy,sortBy) +import Data.Maybe (fromMaybe) + +import qualified AST.Annotation as A +import qualified AST.Expression.General as Expr +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Literal as Literal +import qualified AST.Pattern as P +import qualified AST.Variable as Var +import Transform.Substitute (subst) + +toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match) +toMatch patterns = do + v <- newVar + (,) v <$> match [v] (map (first (:[])) patterns) Fail + + +newVar :: State Int String +newVar = + do n <- State.get + State.modify (+1) + return $ "_v" ++ show n + + +data Match + = Match String [Clause] Match + | Break + | Fail + | Other Canonical.Expr + | Seq [Match] + deriving Show + + +data Clause = + Clause (Either Var.Canonical Literal.Literal) [String] Match + deriving Show + + +type Case = + ([P.CanonicalPattern], Canonical.Expr) + + +matchSubst :: [(String,String)] -> Match -> Match +matchSubst pairs match = + case match of + Break -> Break + + Fail -> Fail + + Seq ms -> + Seq (map (matchSubst pairs) ms) + + Other (A.A a e) -> + Other . A.A a $ foldr ($) e $ map (\(x,y) -> subst x (Expr.localVar y)) pairs + + Match n cs m -> + Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m) + where + varSubst v = fromMaybe v (lookup v pairs) + clauseSubst (Clause c vs m) = + Clause c (map varSubst vs) (matchSubst pairs m) + + +isCon :: ([P.Pattern var], expr) -> Bool +isCon ([] , _) = noMatch "isCon" +isCon (p:_, _) = + case p of + P.Data _ _ -> True + P.Literal _ -> True + _ -> False + + +isVar :: ([P.Pattern var], expr) -> Bool +isVar p = not (isCon p) + + +match :: [String] -> [Case] -> Match -> State Int Match +match variables cases match = + case (variables, cases, match) of + ([], [], _) -> + return match + + ([], [([], expr)], Fail) -> + return $ Other expr + + ([], [([], expr)], Break) -> + return $ Other expr + + ([], _, _) -> + return $ Seq (map (Other . snd) cases ++ [match]) + + (var:_, _, _) + | all isVar cases' -> matchVar variables cases' match + | all isCon cases' -> matchCon variables cases' match + | otherwise -> matchMix variables cases' match + where + cases' = map (dealias var) cases + + +dealias :: String -> Case -> Case +dealias _ ([], _) = noMatch "dealias" +dealias v c@(p:ps, A.A a e) = + case p of + P.Alias x pattern -> (pattern:ps, A.A a $ subst x (Expr.localVar v) e) + _ -> c + + +matchVar :: [String] -> [Case] -> Match -> State Int Match +matchVar [] _ _ = noMatch "matchVar" +matchVar (v:vs) cs def = + match vs (map subVar cs) def + where + subVar ([], _) = noMatch "matchVar.subVar" + subVar (p:ps, (A.A a expr)) = + (ps, A.A a $ subOnePattern p expr) + where + subOnePattern pattern expr = + case pattern of + P.Anything -> expr + + P.Var x -> + subst x (Expr.localVar v) expr + + P.Record fs -> + foldr (\x -> subst x (Expr.Access (A.A a (Expr.localVar v)) x)) expr fs + + _ -> noMatch "matchVar.subVar" + + +matchCon :: [String] -> [Case] -> Match -> State Int Match +matchCon variables cases match = + case variables of + [] -> noMatch "matchCon" + + var : _vars -> + flip (Match var) match <$> mapM toClause caseGroups + where + caseGroups :: [[Case]] + caseGroups = + groupBy eq (sortBy cmp cases) + + eq :: Case -> Case -> Bool + eq (patterns1, _) (patterns2, _) = + case (patterns1, patterns2) of + (pattern1:_, pattern2:_) -> + case (pattern1, pattern2) of + (P.Data name1 _, P.Data name2 _) -> name1 == name2 + (_, _) -> pattern1 == pattern2 + (_, _) -> noMatch "matchCon.eq" + + cmp :: Case -> Case -> Ordering + cmp (patterns1, _) (patterns2, _) = + case (patterns1, patterns2) of + (pattern1:_, pattern2:_) -> + case (pattern1, pattern2) of + (P.Data name1 _, P.Data name2 _) -> compare name1 name2 + (_, _) -> compare pattern1 pattern2 + (_, _) -> noMatch "matchCon.cmp" + + toClause :: [Case] -> State Int Clause + toClause cases = + case head cases of + (P.Data name _ : _, _) -> + matchClause (Left name) variables cases Break + + (P.Literal lit : _, _) -> + matchClause (Right lit) variables cases Break + + _ -> noMatch "matchCon" + + +matchClause :: Either Var.Canonical Literal.Literal -> [String] -> [Case] -> Match + -> State Int Clause +matchClause _ [] _ _ = noMatch "matchClause" +matchClause c (_:vs) cs mtch = + do vs' <- getVars + Clause c vs' <$> match (vs' ++ vs) (map flatten cs) mtch + where + flatten ([], _) = noMatch "matchClause.flatten" + flatten (p:ps, e) = + case p of + P.Data _ ps' -> (ps' ++ ps, e) + P.Literal _ -> (ps, e) + _ -> noMatch "matchClause.flatten" + + getVars :: State Int [String] + getVars = + case head cs of + (P.Data _ ps : _, _) -> State.forM ps (const newVar) + (P.Literal _ : _, _) -> return [] + _ -> noMatch "matchClause.getVars" + + +matchMix :: [String] -> [Case] -> Match -> State Int Match +matchMix vs cs def = + State.foldM (flip $ match vs) def (reverse css) + where + css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs + + +noMatch :: String -> a +noMatch name = + error $ "unexpected pattern in '" ++ name ++ + "' function. Report a compiler issue to ." diff --git a/src/Generate/JavaScript.hs b/src/Generate/JavaScript.hs new file mode 100644 --- /dev/null +++ b/src/Generate/JavaScript.hs @@ -0,0 +1,454 @@ +module Generate.JavaScript (generate) where + +import Control.Applicative ((<$>),(<*>)) +import Control.Arrow (first,(***)) +import Control.Monad.State +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Language.ECMAScript3.PrettyPrint +import Language.ECMAScript3.Syntax + +import Generate.JavaScript.Helpers as Help +import qualified Generate.Cases as Case +import qualified Generate.JavaScript.Ports as Port +import qualified Generate.JavaScript.Variable as Var + +import AST.Annotation +import AST.Module +import AST.Expression.General +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Module as Module +import qualified AST.Helpers as Help +import AST.Literal +import qualified AST.Pattern as P +import qualified AST.Variable as Var + + +internalImports :: Module.Name -> [VarDecl ()] +internalImports name = + [ varDecl "_N" (obj ["Elm","Native"]) + , include "_U" "Utils" + , include "_L" "List" + , include "_P" "Ports" + , varDecl Help.localModuleName (string (Module.nameToString name)) + ] + where + include :: String -> String -> VarDecl () + include alias modul = + varDecl alias (Help.make ["_N", modul]) + + +_Utils :: String -> Expression () +_Utils x = + obj ["_U", x] + + +_List :: String -> Expression () +_List x = + obj ["_L", x] + + +literal :: Literal -> Expression () +literal lit = + case lit of + Chr c -> _Utils "chr" <| string [c] + Str s -> string s + IntNum n -> IntLit () n + FloatNum n -> NumLit () n + Boolean b -> BoolLit () b + + +expression :: Canonical.Expr -> State Int (Expression ()) +expression (A region expr) = + case expr of + Var var -> return $ Var.canonical var + + Literal lit -> return $ literal lit + + Range lo hi -> + do lo' <- expression lo + hi' <- expression hi + return $ _List "range" `call` [lo',hi'] + + Access e x -> + do e' <- expression e + return $ DotRef () e' (var x) + + Remove e x -> + do e' <- expression e + return $ _Utils "remove" `call` [string x, e'] + + Insert e x v -> + do v' <- expression v + e' <- expression e + return $ _Utils "insert" `call` [string x, v', e'] + + Modify e fs -> + do e' <- expression e + fs' <- forM fs $ \(f,v) -> do + v' <- expression v + return $ ArrayLit () [string f, v'] + return $ _Utils "replace" `call` [ArrayLit () fs', e'] + + Record fields -> + do fields' <- forM fields $ \(f,e) -> do + (,) f <$> expression e + let fieldMap = List.foldl' combine Map.empty fields' + return $ ObjectLit () $ (prop "_", hidden fieldMap) : visible fieldMap + where + combine r (k,v) = Map.insertWith (++) k [v] r + hidden fs = ObjectLit () . map (prop *** ArrayLit ()) . + Map.toList . Map.filter (not . null) $ Map.map tail fs + visible fs = map (first prop) . Map.toList $ Map.map head fs + + Binop op e1 e2 -> binop region op e1 e2 + + Lambda p e@(A ann _) -> + do (args, body) <- foldM depattern ([], innerBody) (reverse patterns) + body' <- expression body + return $ case length args < 2 || length args > 9 of + True -> foldr (==>) body' (map (:[]) args) + False -> ref ("F" ++ show (length args)) <| (args ==> body') + where + depattern (args, body) pattern = + case pattern of + P.Var x -> return (args ++ [ Var.varName x ], body) + _ -> do arg <- Case.newVar + return ( args ++ [arg] + , A ann (Case (A ann (localVar arg)) [(pattern, body)])) + + (patterns, innerBody) = collect [p] e + + collect patterns lexpr@(A _ expr) = + case expr of + Lambda p e -> collect (p:patterns) e + _ -> (patterns, lexpr) + + App e1 e2 -> + do func' <- expression func + args' <- mapM expression args + return $ case args' of + [arg] -> func' <| arg + _ | length args' <= 9 -> ref aN `call` (func':args') + | otherwise -> foldl1 (<|) (func':args') + where + aN = "A" ++ show (length args) + (func, args) = getArgs e1 [e2] + getArgs func args = + case func of + (A _ (App f arg)) -> getArgs f (arg : args) + _ -> (func, args) + + Let defs e -> + do let (defs',e') = flattenLets defs e + stmts <- concat <$> mapM definition defs' + exp <- expression e' + return $ function [] (stmts ++ [ ret exp ]) `call` [] + + MultiIf branches -> + do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e + return $ case last branches of + (A _ (Var (Var.Canonical (Var.Module ["Basics"]) "otherwise")), _) -> + safeIfs branches' + (A _ (Literal (Boolean True)), _) -> safeIfs branches' + _ -> ifs branches' (throw "badIf" region) + where + safeIfs branches = ifs (init branches) (snd (last branches)) + ifs branches finally = foldr iff finally branches + iff (if', then') else' = CondExpr () if' then' else' + + Case e cases -> + do (tempVar,initialMatch) <- Case.toMatch cases + (revisedMatch, stmt) <- + case e of + A _ (Var (Var.Canonical Var.Local x)) -> + return (Case.matchSubst [(tempVar, Var.varName x)] initialMatch, []) + _ -> + do e' <- expression e + return (initialMatch, [VarDeclStmt () [varDecl tempVar e']]) + match' <- match region revisedMatch + return (function [] (stmt ++ match') `call` []) + + ExplicitList es -> + do es' <- mapM expression es + return $ _List "fromArray" <| ArrayLit () es' + + Data name es -> + do es' <- mapM expression es + return $ ObjectLit () (ctor : fields es') + where + ctor = (prop "ctor", string name) + fields = zipWith (\n e -> (prop ("_" ++ show n), e)) [0..] + + GLShader _uid src _tipe -> + return $ ObjectLit () [(PropString () "src", literal (Str src))] + + PortIn name tipe -> + return $ obj ["_P","portIn"] `call` + [ string name, Port.incoming tipe ] + + PortOut name tipe value -> + do value' <- expression value + return $ obj ["_P","portOut"] `call` + [ string name, Port.outgoing tipe, value' ] + + +definition :: Canonical.Def -> State Int [Statement ()] +definition (Canonical.Definition pattern expr@(A region _) _) = do + expr' <- expression expr + let assign x = varDecl x expr' + case pattern of + P.Var x + | Help.isOp x -> + let op = LBracket () (ref "_op") (string x) in + return [ ExprStmt () $ AssignExpr () OpAssign op expr' ] + | otherwise -> + return [ VarDeclStmt () [ assign (Var.varName x) ] ] + + P.Record fields -> + let setField f = varDecl f (obj ["$",f]) in + return [ VarDeclStmt () (assign "$" : map setField fields) ] + + P.Data (Var.Canonical _ name) patterns | vars /= Nothing -> + return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ] + where + vars = getVars patterns + getVars patterns = + case patterns of + P.Var x : rest -> (Var.varName x :) `fmap` getVars rest + [] -> Just [] + _ -> Nothing + + decl x n = varDecl x (obj ["$","_" ++ show n]) + setup vars + | Help.isTuple name = assign "$" : vars + | otherwise = assign "_raw" : safeAssign : vars + + safeAssign = varDecl "$" (CondExpr () if' (ref "_raw") exception) + if' = InfixExpr () OpStrictEq (obj ["_raw","ctor"]) (string name) + exception = Help.throw "badCase" region + + _ -> + do defs' <- concat <$> mapM toDef vars + return (VarDeclStmt () [assign "_"] : defs') + where + vars = P.boundVarList pattern + mkVar = A region . localVar + toDef y = + let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)] + in + definition $ Canonical.Definition (P.Var y) expr Nothing + + +match :: Region -> Case.Match -> State Int [Statement ()] +match region mtch = + case mtch of + Case.Match name clauses mtch' -> + do (isChars, clauses') <- unzip <$> mapM (clause region name) clauses + mtch'' <- match region mtch' + return (SwitchStmt () (format isChars (access name)) clauses' : mtch'') + where + isLiteral p = case p of + Case.Clause (Right _) _ _ -> True + _ -> False + + access name + | any isLiteral clauses = obj [name] + | otherwise = obj (Help.splitDots name ++ ["ctor"]) + + format isChars e + | or isChars = InfixExpr () OpAdd e (string "") + | otherwise = e + + Case.Fail -> + return [ ExprStmt () (Help.throw "badCase" region) ] + + Case.Break -> return [BreakStmt () Nothing] + + Case.Other e -> + do e' <- expression e + return [ ret e' ] + + Case.Seq ms -> concat <$> mapM (match region) (dropEnd [] ms) + where + dropEnd acc [] = acc + dropEnd acc (m:ms) = + case m of + Case.Other _ -> acc ++ [m] + _ -> dropEnd (acc ++ [m]) ms + + +clause :: Region -> String -> Case.Clause -> State Int (Bool, CaseClause ()) +clause region variable (Case.Clause value vars mtch) = + (,) isChar . CaseClause () pattern <$> match region (Case.matchSubst (zip vars vars') mtch) + where + vars' = map (\n -> variable ++ "._" ++ show n) [0..] + (isChar, pattern) = + case value of + Right (Chr c) -> (True, string [c]) + _ -> + (,) False $ + case value of + Right (Boolean b) -> BoolLit () b + Right lit -> literal lit + Left (Var.Canonical _ name) -> + string name + + +flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr) +flattenLets defs lexpr@(A _ expr) = + case expr of + Let ds body -> flattenLets (defs ++ ds) body + _ -> (defs, lexpr) + + +generate :: CanonicalModule -> String +generate modul = + show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++ + [ assign ("Elm" : names ++ ["make"]) (function [localRuntime] programStmts) ] + where + names :: [String] + names = Module.names modul + + thisModule :: Expression () + thisModule = obj (localRuntime : names ++ ["values"]) + + programStmts :: [Statement ()] + programStmts = + concat + [ [ ExprStmt () (string "use strict") ] + , setup localRuntime (names ++ ["values"]) + , [ IfSingleStmt () thisModule (ret thisModule) ] + , [ VarDeclStmt () localVars ] + , body + , [ jsExports ] + , [ ret thisModule ] + ] + + localVars :: [VarDecl ()] + localVars = varDecl "_op" (ObjectLit () []) : + internalImports (Module.names modul) ++ + explicitImports + where + explicitImports :: [VarDecl ()] + explicitImports = + map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul + + jsImport :: Module.Name -> VarDecl () + jsImport name = + varDecl (Var.moduleName name) $ + obj ("Elm" : name ++ ["make"]) <| ref localRuntime + + body :: [Statement ()] + body = concat $ evalState defs 0 + where + defs = mapM definition . fst . flattenLets [] $ Module.program (Module.body modul) + + setup namespace path = map create paths + where + create name = assign name (InfixExpr () OpLOr (obj name) (ObjectLit () [])) + paths = drop 2 . init . List.inits $ namespace : path + + jsExports = assign (localRuntime : names ++ ["values"]) (ObjectLit () exs) + where + exs = map entry $ "_op" : concatMap extract (exports modul) + entry x = (prop x, ref x) + extract value = + case value of + Var.Alias _ -> [] + + Var.Value x + | Help.isOp x -> [] + | otherwise -> [Var.varName x] + + Var.Union _ (Var.Listing ctors _) -> + map Var.varName ctors + + assign path expr = + case path of + [x] -> VarDeclStmt () [ varDecl x expr ] + _ -> + ExprStmt () $ + AssignExpr () OpAssign (LDot () (obj (init path)) (last path)) expr + + +binop + :: Region + -> Var.Canonical + -> Canonical.Expr + -> Canonical.Expr + -> State Int (Expression ()) +binop region func@(Var.Canonical home op) e1 e2 = + case (home, op) of + (Var.Module ["Basics"], ">>") -> + do es <- mapM expression (collectLeftAssoc [e2] e1) + return $ ["$"] ==> List.foldl' (\e f -> f <| e) (ref "$") es + + (Var.Module ["Basics"], "<<") -> + do es <- mapM expression (e1 : collectRightAssoc [] e2) + return $ ["$"] ==> foldr (<|) (ref "$") es + + (Var.Module ["Basics"], "<|") -> + do e2' <- expression e2 + es <- mapM expression (collectRightAssoc [] e1) + return $ foldr (<|) e2' es + + (Var.BuiltIn, "::") -> + expression (A region (Data "::" [e1,e2])) + + (Var.Module ["Basics"], _) -> + do e1' <- expression e1 + e2' <- expression e2 + case Map.lookup op basicOps of + Just f -> + return (f e1' e2') + + Nothing -> + return (ref "A2" `call` [ Var.canonical func, e1', e2' ]) + + _ -> + do e1' <- expression e1 + e2' <- expression e2 + return (ref "A2" `call` [ Var.canonical func, e1', e2' ]) + + where + collectRightAssoc es e = + case e of + A _ (Binop (Var.Canonical (Var.Module ["Basics"]) "<<") e1 e2) -> + collectRightAssoc (es ++ [e1]) e2 + _ -> es ++ [e] + + collectLeftAssoc es e = + case e of + A _ (Binop (Var.Canonical (Var.Module ["Basics"]) ">>") e1 e2) -> + collectLeftAssoc (e2 : es) e1 + _ -> e : es + + basicOps = + Map.fromList (infixOps ++ specialOps) + + infixOps = + let infixOp str op = (str, InfixExpr () op) in + [ infixOp "+" OpAdd + , infixOp "-" OpSub + , infixOp "*" OpMul + , infixOp "/" OpDiv + , infixOp "&&" OpLAnd + , infixOp "||" OpLOr + ] + + specialOps = + [ (,) "^" $ \a b -> obj ["Math","pow"] `call` [a,b] + , (,) "|>" $ flip (<|) + , (,) "==" $ \a b -> _Utils "eq" `call` [a,b] + , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (_Utils "eq" `call` [a,b]) + , (,) "<" $ cmp OpLT 0 + , (,) ">" $ cmp OpGT 0 + , (,) "<=" $ cmp OpLT 1 + , (,) ">=" $ cmp OpGT (-1) + , (,) "//" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0) + ] + + cmp op n a b = + InfixExpr () op (_Utils "cmp" `call` [a,b]) (IntLit () n) diff --git a/src/Generate/JavaScript/Helpers.hs b/src/Generate/JavaScript/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Generate/JavaScript/Helpers.hs @@ -0,0 +1,118 @@ +module Generate.JavaScript.Helpers where + +import AST.Annotation (Region) +import qualified AST.PrettyPrint as PP +import Language.ECMAScript3.Syntax + + +localRuntime :: String +localRuntime = + "_elm" + + +varDecl :: String -> Expression () -> VarDecl () +varDecl x expr = + VarDecl () (var x) (Just expr) + + +make :: [String] -> Expression () +make moduleName = + obj (moduleName ++ ["make"]) <| ref localRuntime + + +useLazy :: [String] -> String -> Expression () +useLazy moduleName functionName = + DotRef () (make moduleName) (var functionName) + + +-- Creating Variables + +var :: String -> Id () +var name = + Id () name + + +ref :: String -> Expression () +ref name = + VarRef () (var name) + + +prop :: String -> Prop () +prop name = + PropId () (var name) + + +string = StringLit () + + +obj :: [String] -> Expression () +obj vars = + case vars of + x:xs -> foldl (DotRef ()) (ref x) (map var xs) + [] -> error "dotSep must be called on a non-empty list of variables" + + +-- Specific Utilities + +localModuleName :: String +localModuleName = + "$moduleName" + + +throw :: String -> Region -> Expression () +throw kind region = + let args = + [ ref localModuleName + , string (PP.renderPretty region) + ] + in + obj ["_U",kind] `call` args + + +-- Function Calls + +(<|) :: Expression () -> Expression () -> Expression () +(<|) f x = + CallExpr () f [x] + + +ret :: Expression () -> Statement () +ret e = + ReturnStmt () (Just e) + + +(==>) :: [String] -> Expression () -> Expression () +(==>) args e = + FuncExpr () Nothing (map var args) [ ret e ] + + +function :: [String] -> [Statement ()] -> Expression () +function args stmts = + FuncExpr () Nothing (map var args) stmts + + +call :: Expression () -> [Expression ()] -> Expression () +call = + CallExpr () + + +-- Checks + +equal :: Expression () -> Expression () -> Expression () +equal a b = + InfixExpr () OpStrictEq a b + + +instanceof :: String -> Expression () -> Expression () +instanceof tipe x = + InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe)) + + +typeof :: String -> Expression () -> Expression () +typeof tipe x = + equal (PrefixExpr () PrefixTypeof x) (string tipe) + + +member :: String -> Expression () -> Expression () +member field x = + InfixExpr () OpIn (string field) x diff --git a/src/Generate/JavaScript/Ports.hs b/src/Generate/JavaScript/Ports.hs new file mode 100644 --- /dev/null +++ b/src/Generate/JavaScript/Ports.hs @@ -0,0 +1,217 @@ +module Generate.JavaScript.Ports (incoming, outgoing) where + +import qualified Data.List as List +import Generate.JavaScript.Helpers +import AST.Type as T +import qualified AST.Variable as Var +import Language.ECMAScript3.Syntax + + +data JSType + = JSNumber + | JSBoolean + | JSString + | JSArray + | JSObject [String] + + +typeToString :: JSType -> String +typeToString tipe = + case tipe of + JSNumber -> "a number" + JSBoolean -> "a boolean (true or false)" + JSString -> "a string" + JSArray -> "an array" + JSObject fields -> + "an object with fields '" ++ List.intercalate "', '" fields ++ "'" + + +_Array :: String -> Expression () +_Array functionName = + useLazy ["Elm","Native","Array"] functionName + + +_List :: String -> Expression () +_List functionName = + useLazy ["Elm","Native","List"] functionName + + +_Maybe :: String -> Expression () +_Maybe functionName = + useLazy ["Elm","Maybe"] functionName + + +check :: Expression () -> JSType -> Expression () -> Expression () +check x jsType continue = + CondExpr () (jsFold OpLOr checks x) continue throw + where + jsFold op checks value = + foldl1 (InfixExpr () op) (map ($ value) checks) + + throw = + obj ["_U","badPort"] `call` [ string (typeToString jsType), x ] + + checks = + case jsType of + JSNumber -> [typeof "number"] + JSBoolean -> [typeof "boolean"] + JSString -> [typeof "string", instanceof "String"] + JSArray -> [instanceof "Array"] + JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)] + + +incoming :: CanonicalType -> Expression () +incoming tipe = + case tipe of + Aliased _ t -> incoming t + + App (Type v) [t] + | Var.isSignal v -> obj ["_P","incomingSignal"] <| incoming t + + _ -> ["v"] ==> inc tipe (ref "v") + + +inc :: CanonicalType -> Expression () -> Expression () +inc tipe x = + case tipe of + Lambda _ _ -> error "functions should not be allowed through input ports" + Var _ -> error "type variables should not be allowed through input ports" + Aliased _ t -> + inc t x + + Type (Var.Canonical Var.BuiltIn name) + | name == "Int" -> from JSNumber + | name == "Float" -> from JSNumber + | name == "Bool" -> from JSBoolean + | name == "String" -> from JSString + where + from checks = check x checks x + + Type name + | Var.isJson name -> + x + + | Var.isTuple name -> + incomingTuple [] x + + | otherwise -> + error "bad type got to incoming port generation code" + + App f args -> + case f : args of + Type name : [t] + | Var.isMaybe name -> + CondExpr () + (equal x (NullLit ())) + (_Maybe "Nothing") + (_Maybe "Just" <| inc t x) + + | Var.isList name -> + check x JSArray (_List "fromArray" <| array) + + | Var.isArray name -> + check x JSArray (_Array "fromJSArray" <| array) + where + array = DotRef () x (var "map") <| incoming t + + Type name : ts + | Var.isTuple name -> incomingTuple ts x + + _ -> error "bad ADT got to incoming port generation code" + + Record _ (Just _) -> + error "bad record got to incoming port generation code" + + Record fields Nothing -> + check x (JSObject (map fst fields)) object + where + object = ObjectLit () $ (prop "_", ObjectLit () []) : keys + keys = map convert fields + convert (f,t) = (prop f, inc t (DotRef () x (var f))) + + +incomingTuple :: [CanonicalType] -> Expression () -> Expression () +incomingTuple types x = + check x JSArray (ObjectLit () fields) + where + fields = (prop "ctor", ctor) : zipWith convert [0..] types + + ctor = string ("_Tuple" ++ show (length types)) + + convert n t = + ( prop ('_':show n) + , inc t (BracketRef () x (IntLit () n)) + ) + + +outgoing :: CanonicalType -> Expression () +outgoing tipe = + case tipe of + Aliased _ t -> outgoing t + + App (Type v) [t] + | Var.isSignal v -> obj ["_P","outgoingSignal"] <| outgoing t + + _ -> ["v"] ==> out tipe (ref "v") + + +out :: CanonicalType -> Expression () -> Expression () +out tipe x = + case tipe of + Aliased _ t -> out t x + + Lambda _ _ + | numArgs > 1 && numArgs < 10 -> + func (ref ('A':show numArgs) `call` (x:values)) + | otherwise -> func (foldl (<|) x values) + where + ts = T.collectLambdas tipe + numArgs = length ts - 1 + args = map (\n -> '_' : show n) [0..] + values = zipWith inc (init ts) (map ref args) + func body = + function (take numArgs args) + [ VarDeclStmt () [VarDecl () (var "_r") (Just body)] + , ret (out (last ts) (ref "_r")) + ] + + Var _ -> error "type variables should not be allowed through input ports" + + Type (Var.Canonical Var.BuiltIn name) + | name `elem` ["Int","Float","Bool","String"] -> x + + Type name + | Var.isJson name -> x + | Var.isTuple name -> ArrayLit () [] + | otherwise -> error "bad type got to outgoing port generation code" + + App f args -> + case f : args of + Type name : [t] + | Var.isMaybe name -> + CondExpr () + (equal (DotRef () x (var "ctor")) (string "Nothing")) + (NullLit ()) + (out t (DotRef () x (var "_0"))) + + | Var.isArray name -> + DotRef () (_Array "toJSArray" <| x) (var "map") <| outgoing t + + | Var.isList name -> + DotRef () (_List "toArray" <| x) (var "map") <| outgoing t + + Type name : ts + | Var.isTuple name -> + let convert n t = out t $ DotRef () x $ var ('_':show n) + in ArrayLit () $ zipWith convert [0..] ts + + _ -> error "bad ADT got to outgoing port generation code" + + Record _ (Just _) -> + error "bad record got to outgoing port generation code" + + Record fields Nothing -> + ObjectLit () keys + where + keys = map convert fields + convert (f,t) = (PropId () (var f), out t (DotRef () x (var f))) diff --git a/src/Generate/JavaScript/Variable.hs b/src/Generate/JavaScript/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Generate/JavaScript/Variable.hs @@ -0,0 +1,62 @@ +module Generate.JavaScript.Variable where + +import qualified AST.Helpers as Help +import qualified AST.Module as Module +import qualified AST.Variable as Var +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Generate.JavaScript.Helpers as JS +import qualified Language.ECMAScript3.Syntax as JS + + +swap :: Char -> Char -> Char -> Char +swap from to c = + if c == from then to else c + + +canonical :: Var.Canonical -> JS.Expression () +canonical (Var.Canonical home name) = + case Help.isOp name of + True -> JS.BracketRef () (JS.obj (home' ++ ["_op"])) (JS.string name) + False -> JS.obj (home' ++ [ varName name ]) + where + home' = + case home of + Var.Local -> [] + Var.BuiltIn -> [] + Var.Module path -> [ moduleName path ] + + +moduleName :: Module.Name -> String +moduleName name = + '$' : List.intercalate "$" name + + +varName :: String -> String +varName x = map (swap '\'' '$') x' + where + x' = if Set.member x jsReserveds then '$' : x else x + + +value :: Module.Name -> String -> JS.Expression () +value home name = + canonical (Var.Canonical (Var.Module home) name) + + +jsReserveds :: Set.Set String +jsReserveds = Set.fromList + [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval" + , "arguments", "int", "byte", "char", "goto", "long", "final", "float" + , "short", "double", "native", "throws", "boolean", "abstract", "volatile" + , "transient", "synchronized", "function", "break", "case", "catch" + , "continue", "debugger", "default", "delete", "do", "else", "finally" + , "for", "function", "if", "in", "instanceof", "new", "return", "switch" + , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class" + , "const", "enum", "export", "extends", "import", "super", "implements" + , "interface", "let", "package", "private", "protected", "public" + , "static", "yield" + -- reserved by the Elm runtime system + , "Elm", "ElmRuntime" + , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9" + , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9" + ] diff --git a/src/Parse/Binop.hs b/src/Parse/Binop.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Binop.hs @@ -0,0 +1,85 @@ +module Parse.Binop (binops, OpTable) where + +import Control.Applicative ((<$>)) +import qualified Data.List as List +import qualified Data.Map as Map +import Text.Parsec ((<|>), choice, getState, try) + +import AST.Annotation (merge) +import AST.Declaration (Assoc(L, N, R)) +import AST.Expression.General (Expr'(Binop)) +import qualified AST.Expression.Source as Source +import qualified AST.Variable as Var +import Parse.Helpers (IParser, OpTable, commitIf, failure, whitespace) + +opLevel :: OpTable -> String -> Int +opLevel table op = fst $ Map.findWithDefault (9,L) op table + +opAssoc :: OpTable -> String -> Assoc +opAssoc table op = snd $ Map.findWithDefault (9,L) op table + +hasLevel :: OpTable -> Int -> (String, Source.Expr) -> Bool +hasLevel table n (op,_) = opLevel table op == n + +binops :: IParser Source.Expr + -> IParser Source.Expr + -> IParser String + -> IParser Source.Expr +binops term last anyOp = + do e <- term + table <- getState + split table 0 e =<< nextOps + where + nextOps = choice [ commitIf (whitespace >> anyOp) $ do + whitespace ; op <- anyOp ; whitespace + expr <- Left <$> try term <|> Right <$> last + case expr of + Left t -> (:) (op,t) <$> nextOps + Right e -> return [(op,e)] + , return [] ] + +split :: OpTable + -> Int + -> Source.Expr + -> [(String, Source.Expr)] + -> IParser Source.Expr +split _ _ e [] = return e +split table n e eops = do + assoc <- getAssoc table n eops + es <- sequence (splitLevel table n e eops) + let ops = map fst (filter (hasLevel table n) eops) + case assoc of R -> joinR es ops + _ -> joinL es ops + +splitLevel :: OpTable -> Int -> Source.Expr -> [(String, Source.Expr)] + -> [IParser Source.Expr] +splitLevel table n e eops = + case break (hasLevel table n) eops of + (lops, (_op,e'):rops) -> + split table (n+1) e lops : splitLevel table n e' rops + (lops, []) -> [ split table (n+1) e lops ] + +joinL :: [Source.Expr] -> [String] -> IParser Source.Expr +joinL [e] [] = return e +joinL (a:b:es) (op:ops) = joinL (merge a b (Binop (Var.Raw op) a b) : es) ops +joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug." + +joinR :: [Source.Expr] -> [String] -> IParser Source.Expr +joinR [e] [] = return e +joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops + return (merge a e (Binop (Var.Raw op) a e)) +joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug." + +getAssoc :: OpTable -> Int -> [(String,Source.Expr)] -> IParser Assoc +getAssoc table n eops + | all (==L) assocs = return L + | all (==R) assocs = return R + | all (==N) assocs = case assocs of [_] -> return N + _ -> failure (msg "precedence") + | otherwise = failure (msg "associativity") + where levelOps = filter (hasLevel table n) eops + assocs = map (opAssoc table . fst) levelOps + msg problem = + concat [ "Conflicting " ++ problem ++ " for binary operators (" + , List.intercalate ", " (map fst eops), "). " + , "Consider adding parentheses to disambiguate." ] diff --git a/src/Parse/Declaration.hs b/src/Parse/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Declaration.hs @@ -0,0 +1,61 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +module Parse.Declaration where + +import Control.Applicative ((<$>)) +import Text.Parsec ((<|>), (), choice, digit, optionMaybe, string, try) + +import qualified AST.Declaration as D +import qualified Parse.Expression as Expr +import Parse.Helpers +import qualified Parse.Type as Type + + +declaration :: IParser D.SourceDecl +declaration = + typeDecl <|> infixDecl <|> port <|> definition + + +definition :: IParser D.SourceDecl +definition = D.Definition <$> Expr.def + + +typeDecl :: IParser D.SourceDecl +typeDecl = + do reserved "type" "type declaration" + forcedWS + isAlias <- optionMaybe (string "alias" >> forcedWS) + + name <- capVar + args <- spacePrefix lowVar + padded equals + + case isAlias of + Just _ -> + do tipe <- Type.expr "a type" + return (D.TypeAlias name args tipe) + + Nothing -> + do tcs <- pipeSep1 Type.constructor "a constructor for a union type" + return $ D.Datatype name args tcs + + +infixDecl :: IParser D.SourceDecl +infixDecl = do + assoc <- choice [ reserved "infixl" >> return D.L + , reserved "infix" >> return D.N + , reserved "infixr" >> return D.R ] + forcedWS + n <- digit + forcedWS + D.Fixity assoc (read [n]) <$> anyOp + + +port :: IParser D.SourceDecl +port = + do try (reserved "port") + whitespace + name <- lowVar + whitespace + let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr } + D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr + , port' equals D.PPDef Expr.expr ] diff --git a/src/Parse/Expression.hs b/src/Parse/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Expression.hs @@ -0,0 +1,239 @@ +module Parse.Expression (def,term,typeAnnotation,expr) where + +import Control.Applicative ((<$>), (<*>)) +import qualified Data.List as List +import Text.Parsec hiding (newline, spaces) +import Text.Parsec.Indent (block, withPos) + +import qualified Parse.Binop as Binop +import Parse.Helpers +import qualified Parse.Helpers as Help +import qualified Parse.Literal as Literal +import qualified Parse.Pattern as Pattern +import qualified Parse.Type as Type + +import qualified AST.Annotation as Annotation +import qualified AST.Expression.General as E +import qualified AST.Expression.Source as Source +import qualified AST.Literal as L +import qualified AST.Pattern as P +import qualified AST.Variable as Var + + +-------- Basic Terms -------- + +varTerm :: IParser Source.Expr' +varTerm = toVar <$> var "variable" + +toVar :: String -> Source.Expr' +toVar v = + case v of + "True" -> E.Literal (L.Boolean True) + "False" -> E.Literal (L.Boolean False) + _ -> E.rawVar v + +accessor :: IParser Source.Expr' +accessor = do + (start, lbl, end) <- located (try (string "." >> rLabel)) + let loc e = Annotation.at start end e + return (E.Lambda (P.Var "_") (loc $ E.Access (loc $ E.rawVar "_") lbl)) + +negative :: IParser Source.Expr' +negative = do + (start, nTerm, end) <- + located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term) + let loc e = Annotation.at start end e + return (E.Binop (Var.Raw "-") (loc $ E.Literal (L.IntNum 0)) nTerm) + + +-------- Complex Terms -------- + +listTerm :: IParser Source.Expr' +listTerm = shader' <|> braces (try range <|> E.ExplicitList <$> commaSep expr) + where + range = do + lo <- expr + padded (string "..") + E.Range lo <$> expr + + shader' = do + pos <- getPosition + let uid = show (sourceLine pos) ++ ":" ++ show (sourceColumn pos) + (rawSrc, tipe) <- Help.shader + return $ E.GLShader uid (filter (/='\r') rawSrc) tipe + + +parensTerm :: IParser Source.Expr +parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened) + where + opFn = do + (start, op, end) <- located anyOp + let loc = Annotation.at start end + return . loc . E.Lambda (P.Var "x") . loc . E.Lambda (P.Var "y") . loc $ + E.Binop (Var.Raw op) (loc (E.rawVar "x")) (loc (E.rawVar "y")) + + tupleFn = do + let comma = char ',' "comma ','" + (start, commas, end) <- located (comma >> many (whitespace >> comma)) + let vars = map (('v':) . show) [ 0 .. length commas + 1 ] + loc = Annotation.at start end + return $ foldr (\x e -> loc $ E.Lambda x e) + (loc . E.tuple $ map (loc . E.rawVar) vars) (map P.Var vars) + + parened = do + (start, es, end) <- located (commaSep expr) + return $ case es of + [e] -> e + _ -> Annotation.at start end (E.tuple es) + +recordTerm :: IParser Source.Expr +recordTerm = brackets $ choice [ misc, addLocation record ] + where + field = do + label <- rLabel + patterns <- spacePrefix Pattern.term + padded equals + body <- expr + return (label, makeFunction patterns body) + + record = E.Record <$> commaSep field + + change = do + lbl <- rLabel + padded (string "<-") + (,) lbl <$> expr + + remove r = addLocation (string "-" >> whitespace >> E.Remove r <$> rLabel) + + insert r = addLocation $ do + string "|" >> whitespace + E.Insert r <$> rLabel <*> (padded equals >> expr) + + modify r = + addLocation (string "|" >> whitespace >> E.Modify r <$> commaSep1 change) + + misc = try $ do + record <- addLocation (E.rawVar <$> rLabel) + opt <- padded (optionMaybe (remove record)) + case opt of + Just e -> try (insert e) <|> return e + Nothing -> try (insert record) <|> try (modify record) + + +term :: IParser Source.Expr +term = addLocation (choice [ E.Literal <$> Literal.literal, listTerm, accessor, negative ]) + <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm) + "basic term (4, x, 'c', etc.)" + +-------- Applications -------- + +appExpr :: IParser Source.Expr +appExpr = do + t <- term + ts <- constrainedSpacePrefix term $ \str -> + if null str then notFollowedBy (char '-') else return () + return $ case ts of + [] -> t + _ -> List.foldl' (\f x -> Annotation.merge f x $ E.App f x) t ts + +-------- Normal Expressions -------- + +binaryExpr :: IParser Source.Expr +binaryExpr = Binop.binops appExpr lastExpr anyOp + where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ]) + <|> lambdaExpr + +ifExpr :: IParser Source.Expr' +ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf) + where + normal = do + bool <- expr + padded (reserved "then") + thenBranch <- expr + whitespace "an 'else' branch" ; reserved "else" "an 'else' branch" ; whitespace + elseBranch <- expr + return $ E.MultiIf + [ (bool, thenBranch) + , (Annotation.sameAs elseBranch (E.Literal . L.Boolean $ True), elseBranch) + ] + + multiIf = E.MultiIf <$> spaceSep1 iff + where iff = do string "|" ; whitespace + b <- expr ; padded arrow + (,) b <$> expr + +lambdaExpr :: IParser Source.Expr +lambdaExpr = do char '\\' <|> char '\x03BB' "anonymous function" + whitespace + args <- spaceSep1 Pattern.term + padded arrow + body <- expr + return (makeFunction args body) + +defSet :: IParser [Source.Def] +defSet = block (do d <- def ; whitespace ; return d) + +letExpr :: IParser Source.Expr' +letExpr = do + reserved "let" ; whitespace + defs <- defSet + padded (reserved "in") + E.Let defs <$> expr + +caseExpr :: IParser Source.Expr' +caseExpr = do + reserved "case"; e <- padded expr; reserved "of"; whitespace + E.Case e <$> (with <|> without) + where case_ = do p <- Pattern.expr + padded arrow + (,) p <$> expr + with = brackets (semiSep1 (case_ "cases { x -> ... }")) + without = block (do c <- case_ ; whitespace ; return c) + +expr :: IParser Source.Expr +expr = addLocation (choice [ ifExpr, letExpr, caseExpr ]) + <|> lambdaExpr + <|> binaryExpr + "an expression" + +defStart :: IParser [P.RawPattern] +defStart = + choice [ do p1 <- try Pattern.term + infics p1 <|> func p1 + , func =<< (P.Var <$> parens symOp) + , (:[]) <$> Pattern.expr + ] "the definition of a variable (x = ...)" + where + func pattern = + case pattern of + P.Var _ -> (pattern:) <$> spacePrefix Pattern.term + _ -> do try (lookAhead (whitespace >> string "=")) + return [pattern] + + infics p1 = do + o:p <- try (whitespace >> anyOp) + p2 <- (whitespace >> Pattern.term) + return $ if o == '`' then [ P.Var $ takeWhile (/='`') p, p1, p2 ] + else [ P.Var (o:p), p1, p2 ] + +makeFunction :: [P.RawPattern] -> Source.Expr -> Source.Expr +makeFunction args body@(Annotation.A ann _) = + foldr (\arg body' -> Annotation.A ann $ E.Lambda arg body') body args + +definition :: IParser Source.Def +definition = withPos $ do + (name:args) <- defStart + padded equals + body <- expr + return . Source.Definition name $ makeFunction args body + +typeAnnotation :: IParser Source.Def +typeAnnotation = Source.TypeAnnotation <$> try start <*> Type.expr + where + start = do + v <- lowVar <|> parens symOp + padded hasType + return v + +def :: IParser Source.Def +def = typeAnnotation <|> definition diff --git a/src/Parse/Helpers.hs b/src/Parse/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Helpers.hs @@ -0,0 +1,577 @@ +module Parse.Helpers where + +import Prelude hiding (until) +import Control.Applicative ((<$>),(<*>)) +import Control.Monad (guard, join) +import Control.Monad.State (State) +import Data.Char (isUpper) +import qualified Data.Map as Map +import qualified Language.GLSL.Parser as GLP +import qualified Language.GLSL.Syntax as GLS +import Text.Parsec hiding (newline,spaces,State) +import Text.Parsec.Indent (indented, runIndent) +import qualified Text.Parsec.Token as T + +import qualified AST.Annotation as Annotation +import qualified AST.Declaration as Decl +import qualified AST.Expression.General as E +import qualified AST.Expression.Source as Source +import qualified AST.Helpers as Help +import qualified AST.Literal as L +import qualified AST.PrettyPrint as P +import qualified AST.Variable as Variable +import Elm.Utils ((|>)) + +reserveds :: [String] +reserveds = + [ "if", "then", "else" + , "case", "of" + , "let", "in" + , "type" + , "module", "where" + , "import", "as", "hiding", "open" + , "export", "foreign" + , "deriving", "port" + ] + + +expecting = flip () + + +type OpTable = Map.Map String (Int, Decl.Assoc) +type SourceM = State SourcePos +type IParser a = ParsecT String OpTable SourceM a + + +iParse :: IParser a -> String -> Either ParseError a +iParse parser source = + iParseWithTable "" Map.empty parser source + + +iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseError a +iParseWithTable sourceName table aParser input = + runIndent sourceName $ runParserT aParser table sourceName input + + +-- VARIABLES + +var :: IParser String +var = + makeVar (letter <|> char '_' "variable") + + +lowVar :: IParser String +lowVar = + makeVar (lower "lower case variable") + + +capVar :: IParser String +capVar = + makeVar (upper "upper case variable") + + +qualifiedVar :: IParser String +qualifiedVar = + do vars <- many ((++) <$> capVar <*> string ".") + (++) (concat vars) <$> lowVar + + +rLabel :: IParser String +rLabel = lowVar + + +innerVarChar :: IParser Char +innerVarChar = + alphaNum <|> char '_' <|> char '\'' "" + + +makeVar :: IParser Char -> IParser String +makeVar p = + do v <- (:) <$> p <*> many innerVarChar + if v `elem` reserveds + then fail $ "unexpected keyword '" ++ v ++ "', variables cannot be keywords" + else return v + + +reserved :: String -> IParser String +reserved word = + (try (string word >> notFollowedBy innerVarChar) >> return word) + "reserved word '" ++ word ++ "'" + + +-- INFIX OPERATORS + +anyOp :: IParser String +anyOp = + betwixt '`' '`' qualifiedVar + <|> symOp + "infix operator" + + +symOp :: IParser String +symOp = + do op <- many1 (satisfy Help.isSymbol) + guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ]) + case op of + "." -> notFollowedBy lower >> return op + "\8728" -> return "." + _ -> return op + + +-- COMMON SYMBOLS + +equals :: IParser String +equals = string "=" + +arrow :: IParser String +arrow = string "->" <|> string "\8594" "arrow (->)" + +hasType :: IParser String +hasType = string ":" "':' (a type annotation)'" + + +commitIf check p = + commit <|> try p + where + commit = + try (lookAhead check) >> p + + +-- SEPARATORS + +spaceySepBy1 :: IParser b -> IParser a -> IParser [a] +spaceySepBy1 sep p = + do a <- p + (a:) <$> many (commitIf (whitespace >> sep) (padded sep >> p)) + + +commaSep1 :: IParser a -> IParser [a] +commaSep1 = + spaceySepBy1 (char ',' "comma ','") + + +commaSep :: IParser a -> IParser [a] +commaSep = + option [] . commaSep1 + + +semiSep1 :: IParser a -> IParser [a] +semiSep1 = + spaceySepBy1 (char ';' "semicolon ';'") + + +pipeSep1 :: IParser a -> IParser [a] +pipeSep1 = + spaceySepBy1 (char '|' "type divider '|'") + + +consSep1 :: IParser a -> IParser [a] +consSep1 = + spaceySepBy1 (string "::" "cons operator '::'") + + +dotSep1 :: IParser a -> IParser [a] +dotSep1 p = + (:) <$> p <*> many (try (char '.') >> p) + + +spaceSep1 :: IParser a -> IParser [a] +spaceSep1 p = + (:) <$> p <*> spacePrefix p + + +spacePrefix p = + constrainedSpacePrefix p (\_ -> return ()) + + +constrainedSpacePrefix p constraint = + many $ choice + [ try (spacing >> lookAhead (oneOf "[({")) >> p + , try (spacing >> p) + ] + where + spacing = do + n <- whitespace + constraint n + indented + + +-- SURROUNDED BY + +followedBy a b = + do x <- a + b + return x + + +betwixt a b c = + do char a + out <- c + char b "closing '" ++ [b] ++ "'" + return out + + +surround a z name p = do + char a + v <- padded p + char z unwords ["closing", name, show z] + return v + + +braces :: IParser a -> IParser a +braces = + surround '[' ']' "brace" + + +parens :: IParser a -> IParser a +parens = + surround '(' ')' "paren" + + +brackets :: IParser a -> IParser a +brackets = + surround '{' '}' "bracket" + + +-- HELPERS FOR EXPRESSIONS + +addLocation :: (P.Pretty a) => IParser a -> IParser (Annotation.Located a) +addLocation expr = + do (start, e, end) <- located expr + return (Annotation.at start end e) + + +located :: IParser a -> IParser (SourcePos, a, SourcePos) +located p = + do start <- getPosition + e <- p + end <- getPosition + return (start, e, end) + + +accessible :: IParser Source.Expr -> IParser Source.Expr +accessible expr = + do start <- getPosition + ce@(Annotation.A _ e) <- expr + let rest f = do + let dot = char '.' >> notFollowedBy (char '.') + access <- optionMaybe (try dot "field access (e.g. List.map)") + case access of + Nothing -> return ce + Just _ -> accessible $ do + v <- var "field access (e.g. List.map)" + end <- getPosition + return (Annotation.at start end (f v)) + case e of + E.Var (Variable.Raw (c:cs)) + | isUpper c -> rest (\v -> E.rawVar (c:cs ++ '.':v)) + | otherwise -> rest (E.Access ce) + _ -> rest (E.Access ce) + + +-- WHITESPACE + +padded :: IParser a -> IParser a +padded p = + do whitespace + out <- p + whitespace + return out + + +spaces :: IParser String +spaces = + let space = string " " <|> multiComment "whitespace" + in + concat <$> many1 space + + +forcedWS :: IParser String +forcedWS = + choice + [ (++) <$> spaces <*> (concat <$> many nl_space) + , concat <$> many1 nl_space + ] + where + nl_space = + try ((++) <$> (concat <$> many1 newline) <*> spaces) + + +-- Just eats whitespace until the next meaningful character. +dumbWhitespace :: IParser String +dumbWhitespace = + concat <$> many (spaces <|> newline) + + +whitespace :: IParser String +whitespace = + option "" forcedWS + + +freshLine :: IParser [[String]] +freshLine = + try (many1 newline >> many space_nl) <|> try (many1 space_nl) "" + where + space_nl = try $ spaces >> many1 newline + + +newline :: IParser String +newline = + simpleNewline <|> lineComment "a newline" + + +simpleNewline :: IParser String +simpleNewline = + try (string "\r\n") <|> string "\n" + + +lineComment :: IParser String +lineComment = + do try (string "--") + comment <- anyUntil $ simpleNewline <|> (eof >> return "\n") + return ("--" ++ comment) + + +multiComment :: IParser String +multiComment = + (++) <$> try (string "{-") <*> closeComment + + +closeComment :: IParser String +closeComment = + anyUntil $ + choice $ + [ try (string "-}") "close comment" + , concat <$> sequence [ try (string "{-"), closeComment, closeComment ] + ] + + +-- ODD COMBINATORS + +failure msg = do + inp <- getInput + setInput ('x':inp) + anyToken + fail msg + + +until :: IParser a -> IParser b -> IParser b +until p end = + go + where + go = end <|> (p >> go) + + +anyUntil :: IParser String -> IParser String +anyUntil end = + go + where + go = + end <|> (:) <$> anyChar <*> go + + +ignoreUntil :: IParser a -> IParser (Maybe a) +ignoreUntil end = + go + where + ignore p = + const () <$> p + + filler = + choice + [ try (ignore chr) <|> ignore str + , ignore multiComment + , ignore anyChar + ] + + go = + choice + [ Just <$> end + , filler `until` choice [ const Nothing <$> eof, newline >> go ] + ] + + +onFreshLines :: (a -> b -> b) -> b -> IParser a -> IParser b +onFreshLines insert init thing = + go init + where + go values = + do optionValue <- ignoreUntil thing + case optionValue of + Nothing -> return values + Just v -> go (insert v values) + + +withSource :: IParser a -> IParser (String, a) +withSource p = + do start <- getParserState + result <- p + endPos <- getPosition + setParserState start + raw <- anyUntilPos endPos + return (raw, result) + + +anyUntilPos :: SourcePos -> IParser String +anyUntilPos pos = + go + where + go = do currentPos <- getPosition + case currentPos == pos of + True -> return [] + False -> (:) <$> anyChar <*> go + + +-- BASIC LANGUAGE LITERALS + +shader :: IParser (String, L.GLShaderTipe) +shader = + do try (string "[glsl|") + rawSrc <- closeShader id + case glSource rawSrc of + Left err -> parserFail . show $ err + Right tipe -> return (rawSrc, tipe) + where + closeShader builder = + choice + [ do try (string "|]") + return (builder "") + , do c <- anyChar + closeShader (builder . (c:)) + ] + + +glSource :: String -> Either ParseError L.GLShaderTipe +glSource src = + case GLP.parse src of + Left e -> Left e + Right (GLS.TranslationUnit decls) -> + map extractGLinputs decls + |> join + |> foldr addGLinput emptyDecls + |> Right + where + emptyDecls = L.GLShaderTipe Map.empty Map.empty Map.empty + + addGLinput (qual,tipe,name) glDecls = + case qual of + GLS.Attribute -> + glDecls { L.attribute = Map.insert name tipe $ L.attribute glDecls } + + GLS.Uniform -> + glDecls { L.uniform = Map.insert name tipe $ L.uniform glDecls } + + GLS.Varying -> + glDecls { L.varying = Map.insert name tipe $ L.varying glDecls } + + _ -> error "Should never happen due to below filter" + + extractGLinputs decl = + case decl of + GLS.Declaration + (GLS.InitDeclaration + (GLS.TypeDeclarator + (GLS.FullType + (Just (GLS.TypeQualSto qual)) + (GLS.TypeSpec _prec (GLS.TypeSpecNoPrecision tipe _mexpr1)))) + [GLS.InitDecl name _mexpr2 _mexpr3] + ) -> + case elem qual [GLS.Attribute, GLS.Varying, GLS.Uniform] of + False -> [] + True -> + case tipe of + GLS.Int -> return (qual, L.Int,name) + GLS.Float -> return (qual, L.Float,name) + GLS.Vec2 -> return (qual, L.V2,name) + GLS.Vec3 -> return (qual, L.V3,name) + GLS.Vec4 -> return (qual, L.V4,name) + GLS.Mat4 -> return (qual, L.M4,name) + GLS.Sampler2D -> return (qual, L.Texture,name) + _ -> [] + _ -> [] + + +str :: IParser String +str = expecting "String" $ do + s <- choice [ multiStr, singleStr ] + processAs T.stringLiteral . sandwich '\"' $ concat s + where + rawString quote insides = + quote >> manyTill insides quote + + multiStr = rawString (try (string "\"\"\"")) multilineStringChar + singleStr = rawString (char '"') stringChar + + stringChar :: IParser String + stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ] + + multilineStringChar :: IParser String + multilineStringChar = + do noEnd + choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ] + where + noEnd = notFollowedBy (string "\"\"\"") + expandQuote c = if c == '\"' then "\\\"" else [c] + + newlineChar :: IParser String + newlineChar = + choice [ char '\n' >> return "\\n" + , char '\r' >> return "\\r" ] + + +sandwich :: Char -> String -> String +sandwich delim s = + delim : s ++ [delim] + + +escaped :: Char -> IParser String +escaped delim = + try $ do + char '\\' + c <- char '\\' <|> char delim + return ['\\', c] + + +chr :: IParser Char +chr = + betwixt '\'' '\'' character "character" + where + nonQuote = satisfy (/='\'') + + character = + do c <- choice + [ escaped '\'' + , (:) <$> char '\\' <*> many1 nonQuote + , (:[]) <$> nonQuote + ] + + processAs T.charLiteral $ sandwich '\'' c + + +processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a +processAs processor s = + calloutParser s (processor lexer) + where + calloutParser :: String -> IParser a -> IParser a + calloutParser inp p = + either (fail . show) return (iParse p inp) + + lexer :: T.GenTokenParser String u SourceM + lexer = T.makeTokenParser elmDef + + -- I don't know how many of these are necessary for charLiteral/stringLiteral + elmDef :: T.GenLanguageDef String u SourceM + elmDef = + T.LanguageDef + { T.commentStart = "{-" + , T.commentEnd = "-}" + , T.commentLine = "--" + , T.nestedComments = True + , T.identStart = undefined + , T.identLetter = undefined + , T.opStart = undefined + , T.opLetter = undefined + , T.reservedNames = reserveds + , T.reservedOpNames = [":", "->", "<-", "|"] + , T.caseSensitive = True + } diff --git a/src/Parse/Literal.hs b/src/Parse/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Literal.hs @@ -0,0 +1,72 @@ +module Parse.Literal (literal) where + +import Prelude hiding (exponent) +import Control.Applicative ((<$>)) +import Text.Parsec ((<|>), (), digit, hexDigit, lookAhead, many1, option, string, try) +import Parse.Helpers (IParser, chr, str) +import qualified AST.Literal as L + + +literal :: IParser L.Literal +literal = + num <|> (L.Str <$> str) <|> (L.Chr <$> chr) "literal" + + +num :: IParser L.Literal +num = + toLiteral <$> (rawNumber "number") + + +toLiteral :: String -> L.Literal +toLiteral n + | 'x' `elem` n = L.IntNum (read n) + | any (`elem` ".eE") n = L.FloatNum (read n) + | otherwise = L.IntNum (read n) + + +rawNumber :: IParser String +rawNumber = + concat <$> sequence + [ option "" minus + , base16 <|> base10 + ] + + +base16 :: IParser String +base16 = + do try (string "0x") + digits <- many1 hexDigit + return ("0x" ++ digits) + + +base10 :: IParser String +base10 = + concat <$> sequence + [ many1 digit + , option "" decimals + , option "" exponent + ] + + +minus :: IParser String +minus = + try $ do + string "-" + lookAhead digit + return "-" + + +decimals :: IParser String +decimals = + do try $ lookAhead (string "." >> digit) + string "." + n <- many1 digit + return ('.' : n) + + +exponent :: IParser String +exponent = + do string "e" <|> string "E" + op <- option "" (string "+" <|> string "-") + n <- many1 digit + return ('e' : op ++ n) diff --git a/src/Parse/Module.hs b/src/Parse/Module.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Module.hs @@ -0,0 +1,88 @@ +module Parse.Module (header, headerAndImports, getModuleName) where + +import Control.Applicative ((<$>), (<*>)) +import Data.List (intercalate) +import Text.Parsec hiding (newline, spaces) + +import Parse.Helpers +import qualified AST.Module as Module +import qualified AST.Variable as Var + +getModuleName :: String -> Maybe String +getModuleName source = + case iParse getModuleName source of + Right name -> Just name + Left _ -> Nothing + where + getModuleName = do + optional freshLine + (names, _) <- header + return (intercalate "." names) + +headerAndImports :: IParser Module.HeaderAndImports +headerAndImports = + do optional freshLine + (names, exports) <- + option (["Main"], Var.openListing) (header `followedBy` freshLine) + imports' <- commitToImports <|> return [] + return $ Module.HeaderAndImports names exports imports' + where + commitToImports = + do try (lookAhead $ reserved "import") + imports `followedBy` freshLine + +header :: IParser ([String], Var.Listing Var.Value) +header = do + try (reserved "module") + whitespace + names <- dotSep1 capVar "name of module" + whitespace + exports <- option Var.openListing (listing value) + whitespace "reserved word 'where'" + reserved "where" + return (names, exports) + +imports :: IParser [(Module.Name, Module.ImportMethod)] +imports = option [] ((:) <$> import' <*> many (try (freshLine >> import'))) + +import' :: IParser (Module.Name, Module.ImportMethod) +import' = + do reserved "import" + whitespace + names <- dotSep1 capVar + (,) names <$> option (Module.As (intercalate "." names)) method + where + method :: IParser Module.ImportMethod + method = as' <|> importing' + + as' :: IParser Module.ImportMethod + as' = do + try (whitespace >> reserved "as") + whitespace + Module.As <$> capVar "alias for module" + + importing' :: IParser Module.ImportMethod + importing' = Module.Open <$> listing value + +listing :: IParser a -> IParser (Var.Listing a) +listing item = + do try (whitespace >> char '(') + whitespace + listing <- choice [ const Var.openListing <$> string ".." + , Var.Listing <$> commaSep1 item <*> return False + ] "listing of values (x,y,z)" + whitespace + char ')' + return listing + +value :: IParser Var.Value +value = val <|> tipe + where + val = Var.Value <$> (lowVar <|> parens symOp) + + tipe = do + name <- capVar + maybeCtors <- optionMaybe (listing capVar) + case maybeCtors of + Nothing -> return (Var.Alias name) + Just ctors -> return (Var.Union name ctors) diff --git a/src/Parse/Parse.hs b/src/Parse/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Parse.hs @@ -0,0 +1,64 @@ +module Parse.Parse (program) where + +import Control.Applicative ((<$>)) +import qualified Data.List as List +import qualified Data.Map as Map +import Text.Parsec hiding (newline, spaces) +import qualified Text.PrettyPrint as P + +import qualified AST.Declaration as D +import qualified AST.Module as M +import Parse.Helpers +import Parse.Declaration (infixDecl) +import qualified Parse.Module as Module +import qualified Parse.Declaration as Decl +import Transform.Declaration (combineAnnotations) + +freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do + freshLine + Decl.declaration "another datatype or variable definition" + +decls = do d <- Decl.declaration "at least one datatype or variable definition" + (d:) <$> many freshDef + +program :: OpTable -> String -> Either [P.Doc] M.ValidModule +program table src = + do (M.Module names filePath exs ims sourceDecls) <- + setupParserWithTable table programParser src + + decls <- + either (\err -> Left [P.text err]) Right (combineAnnotations sourceDecls) + return $ M.Module names filePath exs ims decls + +programParser :: IParser M.SourceModule +programParser = + do (M.HeaderAndImports names exports imports) <- Module.headerAndImports + declarations <- decls + optional freshLine ; optional spaces ; eof + return $ M.Module names "" exports imports declarations + +setupParserWithTable :: OpTable -> IParser a -> String -> Either [P.Doc] a +setupParserWithTable table p source = + do localTable <- setupParser parseFixities source + case Map.intersection table localTable of + overlap | not (Map.null overlap) -> Left [ msg overlap ] + | otherwise -> + flip setupParser source $ do + putState (Map.union table localTable) + p + where + msg overlap = + P.vcat [ P.text "Parse error:" + , P.text $ "Overlapping definitions for infix operators: " ++ + List.intercalate " " (Map.keys overlap) + ] + +parseFixities = do + decls <- onFreshLines (:) [] infixDecl + return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ] + +setupParser :: IParser a -> String -> Either [P.Doc] a +setupParser p source = + case iParse p source of + Right result -> Right result + Left err -> Left [ P.text $ "Parse error at " ++ show err ] diff --git a/src/Parse/Pattern.hs b/src/Parse/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Pattern.hs @@ -0,0 +1,63 @@ +module Parse.Pattern (term, expr) where + +import Control.Applicative ((<$>)) +import Data.Char (isUpper) +import qualified Data.List as List +import Text.Parsec ((<|>), (), char, choice, optionMaybe, try) + +import Parse.Helpers +import qualified Parse.Literal as Literal +import qualified AST.Literal as L +import qualified AST.Pattern as P +import qualified AST.Variable as Var + +basic :: IParser P.RawPattern +basic = choice + [ char '_' >> return P.Anything + , stringToPattern <$> var + , P.Literal <$> Literal.literal + ] + where + stringToPattern v = + case v of + "True" -> P.Literal (L.Boolean True) + "False" -> P.Literal (L.Boolean False) + c:_ | isUpper c -> P.Data (Var.Raw v) [] + _ -> P.Var v + +asPattern :: P.RawPattern -> IParser P.RawPattern +asPattern pattern = do + var <- optionMaybe (try (whitespace >> reserved "as" >> whitespace >> lowVar)) + return $ case var of + Just v -> P.Alias v pattern + Nothing -> pattern + +record :: IParser P.RawPattern +record = P.Record <$> brackets (commaSep1 lowVar) + +tuple :: IParser P.RawPattern +tuple = do + ps <- parens (commaSep expr) + return $ case ps of + [p] -> p + _ -> P.tuple ps + +list :: IParser P.RawPattern +list = P.list <$> braces (commaSep expr) + +term :: IParser P.RawPattern +term = + (choice [ record, tuple, list, basic ]) "pattern" + +patternConstructor :: IParser P.RawPattern +patternConstructor = do + v <- List.intercalate "." <$> dotSep1 capVar + case v of + "True" -> return $ P.Literal (L.Boolean True) + "False" -> return $ P.Literal (L.Boolean False) + _ -> P.Data (Var.Raw v) <$> spacePrefix term + +expr :: IParser P.RawPattern +expr = do + patterns <- consSep1 (patternConstructor <|> term) + asPattern (foldr1 P.cons patterns) "pattern" diff --git a/src/Parse/Type.hs b/src/Parse/Type.hs new file mode 100644 --- /dev/null +++ b/src/Parse/Type.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +module Parse.Type where + +import Control.Applicative ((<$>),(<*>),(<*)) +import Data.List (intercalate) +import Text.Parsec ((<|>), (), char, many, optionMaybe, string, try) + +import qualified AST.Type as T +import qualified AST.Variable as Var +import Parse.Helpers + + +tvar :: IParser T.RawType +tvar = + T.Var <$> lowVar "type variable" + + +tuple :: IParser T.RawType +tuple = + do ts <- parens (commaSep expr) + case ts of + [t] -> return t + _ -> return (T.tupleOf ts) + + +record :: IParser T.RawType +record = + do char '{' + whitespace + rcrd <- extended <|> normal + dumbWhitespace + char '}' + return rcrd + where + normal = flip T.Record Nothing <$> commaSep field + + -- extended record types require at least one field + extended = do + ext <- try (lowVar <* (whitespace >> string "|")) + whitespace + flip T.Record (Just (T.Var ext)) <$> commaSep1 field + + field = do + lbl <- rLabel + whitespace >> hasType >> whitespace + (,) lbl <$> expr + + +capTypeVar :: IParser String +capTypeVar = + intercalate "." <$> dotSep1 capVar + + +constructor0 :: IParser T.RawType +constructor0 = + do name <- capTypeVar + return (T.Type (Var.Raw name)) + + +term :: IParser T.RawType +term = + tuple <|> record <|> tvar <|> constructor0 + + +app :: IParser T.RawType +app = + do f <- constructor0 <|> try tupleCtor "type constructor" + args <- spacePrefix term + case args of + [] -> return f + _ -> return (T.App f args) + where + tupleCtor = do + n <- length <$> parens (many (char ',')) + let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1) + return (T.Type (Var.Raw ctor)) + + +expr :: IParser T.RawType +expr = + do t1 <- app <|> term + arr <- optionMaybe $ try (whitespace >> arrow) + case arr of + Just _ -> T.Lambda t1 <$> (whitespace >> expr) + Nothing -> return t1 + + +constructor :: IParser (String, [T.RawType]) +constructor = + (,) <$> (capTypeVar "another type constructor") + <*> spacePrefix term diff --git a/src/Transform/AddDefaultImports.hs b/src/Transform/AddDefaultImports.hs new file mode 100644 --- /dev/null +++ b/src/Transform/AddDefaultImports.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +module Transform.AddDefaultImports (add, defaultImports) where + +import Prelude hiding (maybe) +import qualified Data.Map as Map + +import qualified AST.Module as Module +import qualified AST.Variable as Var + + +type ImportDict = + Map.Map Module.Name ([String], Var.Listing Var.Value) + + +-- DESCRIPTION OF DEFAULT IMPORTS + +(==>) :: a -> b -> (a,b) +(==>) = (,) + + +defaultImports :: ImportDict +defaultImports = + Map.fromList + [ ["Basics"] ==> ([], Var.openListing) + , ["Maybe"] ==> ([], Var.Listing [maybe] False) + , ["Result"] ==> ([], Var.Listing [result] False) + , ["Signal"] ==> ([], Var.Listing [signal] False) + ] + + +maybe :: Var.Value +maybe = + Var.Union "Maybe" Var.openListing + + +result :: Var.Value +result = + Var.Union "Result" Var.openListing + + +signal :: Var.Value +signal = + Var.Union "Signal" (Var.Listing [] False) + + +-- ADDING DEFAULT IMPORTS TO A MODULE + +add :: Bool -> Module.Module exs body -> Module.Module exs body +add needsDefaults (Module.Module moduleName path exports imports decls) = + Module.Module moduleName path exports ammendedImports decls + where + ammendedImports = + importDictToList $ + foldr addImport (if needsDefaults then defaultImports else Map.empty) imports + + +importDictToList :: ImportDict -> [(Module.Name, Module.ImportMethod)] +importDictToList dict = + concatMap toImports (Map.toList dict) + where + toImports (name, (qualifiers, listing@(Var.Listing explicits open))) = + map (\qualifier -> (name, Module.As qualifier)) qualifiers + ++ + if open || not (null explicits) + then [(name, Module.Open listing)] + else [] + + +addImport :: (Module.Name, Module.ImportMethod) -> ImportDict -> ImportDict +addImport (name, method) importDict = + Map.alter mergeMethods name importDict + where + mergeMethods :: Maybe ([String], Var.Listing Var.Value) + -> Maybe ([String], Var.Listing Var.Value) + mergeMethods entry = + let (qualifiers, listing) = + case entry of + Nothing -> ([], Var.Listing [] False) + Just v -> v + in + case method of + Module.As qualifier -> + Just (qualifier : qualifiers, listing) + + Module.Open newListing -> + Just (qualifiers, newListing) diff --git a/src/Transform/Canonicalize.hs b/src/Transform/Canonicalize.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize.hs @@ -0,0 +1,305 @@ +module Transform.Canonicalize (module') where + +import Control.Applicative ((<$>),(<*>)) +import Control.Monad.Error (runErrorT, throwError) +import Control.Monad.State (runState) +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Traversable as T + +import AST.Expression.General (Expr'(..), dummyLet) +import qualified AST.Expression.Valid as Valid +import qualified AST.Expression.Canonical as Canonical + +import AST.Module (CanonicalBody(..)) +import qualified AST.Module as Module +import qualified AST.Type as Type +import qualified AST.Variable as Var +import qualified AST.Annotation as A +import qualified AST.Declaration as D +import AST.PrettyPrint (pretty, commaSep) +import qualified AST.Pattern as P +import Text.PrettyPrint as P + +import Transform.Canonicalize.Environment as Env +import qualified Transform.Canonicalize.Setup as Setup +import qualified Transform.Canonicalize.Type as Canonicalize +import qualified Transform.Canonicalize.Variable as Canonicalize +import qualified Transform.SortDefinitions as Transform +import qualified Transform.Declaration as Transform + + +module' :: Module.Interfaces -> Module.ValidModule -> Either [Doc] Module.CanonicalModule +module' interfaces modul = + filterImports <$> modul' + where + (modul', usedModules) = + runState (runErrorT (moduleHelp interfaces modul)) Set.empty + + filterImports m = + let used (name,_) = Set.member name usedModules + in m { Module.imports = filter used (Module.imports m) } + + +moduleHelp :: Module.Interfaces -> Module.ValidModule + -> Canonicalizer [Doc] Module.CanonicalModule +moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) = + do env <- Setup.environment interfaces modul + canonicalDecls <- mapM (declaration env) decls + exports' <- resolveExports locals exports + return $ modul + { Module.exports = exports' + , Module.body = body canonicalDecls + } + where + locals :: [Var.Value] + locals = concatMap declToValue decls + + body :: [D.CanonicalDecl] -> Module.CanonicalBody + body decls = + Module.CanonicalBody + { program = + let expr = Transform.toExpr (Module.names modul) decls + in Transform.sortDefs (dummyLet expr) + , types = Map.empty + , datatypes = + Map.fromList [ (name,(vars,ctors)) | D.Datatype name vars ctors <- decls ] + , fixities = + [ (assoc,level,op) | D.Fixity assoc level op <- decls ] + , aliases = + Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ] + , ports = + [ D.portName port | D.Port port <- decls ] + } + + +resolveExports :: [Var.Value] -> Var.Listing Var.Value -> Canonicalizer [Doc] [Var.Value] +resolveExports fullList (Var.Listing partialList open) = + if open + then return fullList + else do + valueExports <- getValueExports + aliasExports <- concat `fmap` mapM getAliasExport aliases + adtExports <- mapM getAdtExport adts + return $ valueExports ++ aliasExports ++ adtExports + where + (allValues, allAliases, allAdts) = splitValues fullList + + (values, aliases, adts) = splitValues partialList + + getValueExports = + case Set.toList (Set.difference values' allValues') of + [] -> return (map Var.Value values) + xs -> notFound xs + where + allValues' = Set.fromList allValues + values' = Set.fromList values + + getAliasExport alias + | alias `elem` allAliases = + let recordConstructor = + if alias `elem` allValues then [Var.Value alias] else [] + in + return $ Var.Alias alias : recordConstructor + + | otherwise = + case List.find (\(name, _ctors) -> name == alias) allAdts of + Nothing -> notFound [alias] + Just (name, _ctor) -> + return [Var.Union name (Var.Listing [] False)] + + getAdtExport (name, Var.Listing ctors open) = + case lookup name allAdts of + Nothing -> notFound [name] + Just (Var.Listing allCtors _) + | open -> return $ Var.Union name (Var.Listing allCtors False) + | otherwise -> + case filter (`notElem` allCtors) ctors of + [] -> return $ Var.Union name (Var.Listing ctors False) + unfoundCtors -> notFound unfoundCtors + + notFound xs = + throwError [ P.text "Export Error: trying to export non-existent values:" <+> + commaSep (map pretty xs) + ] + + +{-| Split a list of values into categories so we can work with them +independently. +-} +splitValues :: [Var.Value] -> ([String], [String], [(String, Var.Listing String)]) +splitValues mixedValues = + case mixedValues of + [] -> ([], [], []) + x:xs -> + let (values, aliases, adts) = splitValues xs in + case x of + Var.Value name -> + (name : values, aliases, adts) + + Var.Alias name -> + (values, name : aliases, adts) + + Var.Union name listing -> + (values, aliases, (name, listing) : adts) + + + +declToValue :: D.ValidDecl -> [Var.Value] +declToValue decl = + case decl of + D.Definition (Valid.Definition pattern _ _) -> + map Var.Value (P.boundVarList pattern) + + D.Datatype name _tvs ctors -> + [ Var.Union name (Var.Listing (map fst ctors) False) ] + + D.TypeAlias name _ tipe -> + case tipe of + Type.Record _ _ -> + [ Var.Alias name, Var.Value name ] + _ -> [ Var.Alias name ] + + _ -> [] + + +declaration :: Environment -> D.ValidDecl -> Canonicalizer [Doc] D.CanonicalDecl +declaration env decl = + let canonicalize kind context pattern env v = + let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon + throw err = P.vcat [ ctx, P.text err ] + in + Env.onError throw (kind env v) + in + case decl of + D.Definition (Valid.Definition p e t) -> + do p' <- canonicalize pattern "definition" p env p + e' <- expression env e + t' <- T.traverse (canonicalize Canonicalize.tipe "definition" p env) t + return $ D.Definition (Canonical.Definition p' e' t') + + D.Datatype name tvars ctors -> + D.Datatype name tvars <$> mapM canonicalize' ctors + where + canonicalize' (ctor,args) = + (,) ctor <$> mapM (canonicalize Canonicalize.tipe "datatype" name env) args + + D.TypeAlias name tvars expanded -> + do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded + return (D.TypeAlias name tvars expanded') + + D.Port port -> + do Env.uses ["Native","Ports"] + Env.uses ["Native","Json"] + D.Port <$> + case port of + D.In name t -> + do t' <- canonicalize Canonicalize.tipe "port" name env t + return (D.In name t') + D.Out name e t -> + do e' <- expression env e + t' <- canonicalize Canonicalize.tipe "port" name env t + return (D.Out name e' t') + + D.Fixity assoc prec op -> + return $ D.Fixity assoc prec op + + +expression :: Environment -> Valid.Expr -> Canonicalizer [Doc] Canonical.Expr +expression env (A.A ann expr) = + let go = expression env + tipe' environ = format . Canonicalize.tipe environ + throw err = + P.vcat + [ P.text "Error" <+> pretty ann <> P.colon + , P.text err + ] + format = Env.onError throw + in + A.A ann <$> + case expr of + Literal lit -> + return (Literal lit) + + Range e1 e2 -> + Range <$> go e1 <*> go e2 + + Access e x -> + Access <$> go e <*> return x + + Remove e x -> + flip Remove x <$> go e + + Insert e x v -> + flip Insert x <$> go e <*> go v + + Modify e fs -> + Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fs + + Record fs -> + Record <$> mapM (\(k,v) -> (,) k <$> go v) fs + + Binop (Var.Raw op) e1 e2 -> + do op' <- format (Canonicalize.variable env op) + Binop op' <$> go e1 <*> go e2 + + Lambda p e -> + let env' = update p env in + Lambda <$> format (pattern env' p) <*> expression env' e + + App e1 e2 -> + App <$> go e1 <*> go e2 + + MultiIf ps -> + MultiIf <$> mapM go' ps + where + go' (b,e) = (,) <$> go b <*> go e + + Let defs e -> + Let <$> mapM rename' defs <*> expression env' e + where + env' = foldr update env $ map (\(Valid.Definition p _ _) -> p) defs + rename' (Valid.Definition p body mtipe) = + Canonical.Definition + <$> format (pattern env' p) + <*> expression env' body + <*> T.traverse (tipe' env') mtipe + + Var (Var.Raw x) -> + Var <$> format (Canonicalize.variable env x) + + Data name es -> + Data name <$> mapM go es + + ExplicitList es -> + ExplicitList <$> mapM go es + + Case e cases -> + Case <$> go e <*> mapM branch cases + where + branch (p,b) = + (,) <$> format (pattern env p) + <*> expression (update p env) b + + PortIn name st -> + PortIn name <$> tipe' env st + + PortOut name st signal -> + PortOut name <$> tipe' env st <*> go signal + + GLShader uid src tipe -> + return (GLShader uid src tipe) + + +pattern :: Environment -> P.RawPattern -> Canonicalizer String P.CanonicalPattern +pattern env ptrn = + case ptrn of + P.Var x -> return $ P.Var x + P.Literal lit -> return $ P.Literal lit + P.Record fs -> return $ P.Record fs + P.Anything -> return P.Anything + P.Alias x p -> P.Alias x <$> pattern env p + P.Data (Var.Raw name) ps -> + P.Data <$> Canonicalize.pvar env name + <*> mapM (pattern env) ps diff --git a/src/Transform/Canonicalize/Environment.hs b/src/Transform/Canonicalize/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize/Environment.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Canonicalize.Environment where + +import Control.Arrow (second) +import qualified Control.Monad.Error as Error +import qualified Control.Monad.State as State +import qualified Data.Map as Map +import qualified Data.Set as Set + +import AST.Expression.General (saveEnvName) +import qualified AST.Module as Module +import qualified AST.Pattern as P +import qualified AST.Type as Type +import qualified AST.Variable as Var + +import Text.PrettyPrint (Doc) + + +type Dict a = Map.Map String [a] + +dict :: [(String,a)] -> Dict a +dict pairs = + Map.fromList $ map (second (:[])) pairs + +insert :: String -> a -> Dict a -> Dict a +insert key value = + Map.insertWith (++) key [value] + + +type Canonicalizer err a = + Error.ErrorT err (State.State (Set.Set Module.Name)) a + +uses :: (Error.Error e) => Module.Name -> Canonicalizer e () +uses home = + Error.lift (State.modify (Set.insert home)) + +using :: Var.Canonical -> Canonicalizer String Var.Canonical +using var@(Var.Canonical home _) = + do case home of + Var.BuiltIn -> return () + Var.Module path -> uses path + Var.Local -> return () + return var + +onError :: (String -> Doc) -> Canonicalizer String a -> Canonicalizer [Doc] a +onError handler canonicalizer = + do usedModules <- Error.lift State.get + let (result, usedModules') = + State.runState (Error.runErrorT canonicalizer) usedModules + Error.lift (State.put usedModules') + case result of + Left err -> Error.throwError [handler err] + Right x -> return x + + +data Environment = Env + { _home :: Module.Name + , _values :: Dict Var.Canonical + , _adts :: Dict Var.Canonical + , _aliases :: Dict (Var.Canonical, [String], Type.CanonicalType) + , _patterns :: Dict Var.Canonical + } + +builtIns :: Module.Name -> Environment +builtIns home = + Env { _home = home + , _values = builtIn (tuples ++ [saveEnvName]) + , _adts = builtIn (tuples ++ ["List","Int","Float","Char","Bool","String"]) + , _aliases = dict [] + , _patterns = builtIn (tuples ++ ["::","[]"]) + } + where + builtIn xs = dict $ map (\x -> (x, Var.Canonical Var.BuiltIn x)) xs + tuples = map (\n -> "_Tuple" ++ show (n :: Int)) [0..9] + +update :: P.Pattern var -> Environment -> Environment +update ptrn env = + env { _values = foldr put (_values env) (P.boundVarList ptrn) } + where + put x = Map.insert x [Var.local x] + +merge :: Environment -> Environment -> Environment +merge (Env n1 v1 t1 a1 p1) (Env n2 v2 t2 a2 p2) + | n1 /= n2 = error "trying to merge incompatable environments" + | otherwise = + Env { _home = n1 + , _values = Map.unionWith (++) v1 v2 + , _adts = Map.unionWith (++) t1 t2 + , _aliases = Map.unionWith (++) a1 a2 + , _patterns = Map.unionWith (++) p1 p2 + } diff --git a/src/Transform/Canonicalize/Setup.hs b/src/Transform/Canonicalize/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize/Setup.hs @@ -0,0 +1,269 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Canonicalize.Setup + ( environment + , typeAliasErrorSegue + , typeAliasErrorExplanation + ) where + +import Control.Arrow (first) +import Control.Monad (foldM) +import Control.Monad.Error (throwError) +import qualified Data.Graph as Graph +import qualified Data.List as List +import qualified Data.Map as Map + +import qualified AST.Expression.Valid as Valid + +import AST.Module (Interface(iAdts, iTypes, iAliases)) +import qualified AST.Module as Module +import qualified AST.Type as Type +import qualified AST.Variable as Var +import qualified AST.Declaration as D +import AST.PrettyPrint (pretty, eightyCharLines) +import qualified AST.Pattern as P +import Text.PrettyPrint as P + +import Transform.Canonicalize.Environment as Env +import qualified Transform.Canonicalize.Type as Canonicalize +import qualified Transform.Interface as Interface + + +environment :: Module.Interfaces -> Module.ValidModule -> Canonicalizer [Doc] Environment +environment interfaces modul@(Module.Module _ _ _ imports decls) = + do () <- allImportsAvailable + let moduleName = Module.names modul + nonLocalEnv <- foldM (addImports moduleName interfaces) (builtIns moduleName) imports + let (aliases, env) = List.foldl' (addDecl moduleName) ([], nonLocalEnv) decls + addTypeAliases moduleName aliases env + where + allImportsAvailable :: Canonicalizer [Doc] () + allImportsAvailable = + case filter (not . found) modules of + [] -> return () + missings -> throwError [ P.text (missingModuleError missings) ] + where + modules = map fst imports + + found m = Map.member m interfaces || Module.nameIsNative m + + missingModuleError missings = + concat [ "The following imports were not found:\n " + , List.intercalate ", " (map Module.nameToString missings) + ] + + +addImports :: Module.Name -> Module.Interfaces -> Environment -> (Module.Name, Module.ImportMethod) + -> Canonicalizer [Doc] Environment +addImports moduleName interfaces environ (name, method) + | Module.nameIsNative name = return environ + | otherwise = + case method of + Module.As name' -> + return (updateEnviron (name' ++ ".")) + + Module.Open (Var.Listing vs open) + | open -> return (updateEnviron "") + | otherwise -> foldM (addValue name interface) environ vs + where + interface = Interface.filterExports ((Map.!) interfaces name) + + updateEnviron prefix = + let dict' = dict . map (first (prefix++)) in + merge environ $ + Env { _home = moduleName + , _values = dict' $ map pair (Map.keys (iTypes interface)) ++ ctors + , _adts = dict' $ map pair (Map.keys (iAdts interface)) + , _aliases = dict' $ map alias (Map.toList (iAliases interface)) + , _patterns = dict' $ ctors + } + + canonical :: String -> Var.Canonical + canonical = Var.Canonical (Var.Module name) + + pair :: String -> (String, Var.Canonical) + pair key = (key, canonical key) + + alias (x,(tvars,tipe)) = (x, (canonical x, tvars, tipe)) + + ctors = concatMap (map (pair . fst) . snd . snd) (Map.toList (iAdts interface)) + +addValue :: Module.Name -> Module.Interface -> Environment -> Var.Value + -> Canonicalizer [Doc] Environment +addValue moduleName interface env value = + let name = Module.nameToString moduleName + insert' x = insert x (Var.Canonical (Var.Module moduleName) x) + msg x = "Import Error: Could not import value '" ++ name ++ "." ++ x ++ + "'.\n It is not exported by module " ++ name ++ "." + notFound x = throwError [ P.text (msg x) ] + in + case value of + Var.Value x + | Map.notMember x (iTypes interface) -> notFound x + | otherwise -> + return $ env { _values = insert' x (_values env) } + + Var.Alias x -> + case Map.lookup x (iAliases interface) of + Just (tvars, t) -> + return $ env + { _aliases = insert x v (_aliases env) + , _values = updatedValues + } + where + v = (Var.Canonical (Var.Module moduleName) x, tvars, t) + updatedValues = + if Map.member x (iTypes interface) + then insert' x (_values env) + else _values env + + Nothing -> + case Map.lookup x (iAdts interface) of + Nothing -> notFound x + Just (_,_) -> + return $ env { _adts = insert' x (_adts env) } + + Var.Union x (Var.Listing xs open) -> + case Map.lookup x (iAdts interface) of + Nothing -> notFound x + Just (_tvars, ctors) -> + do ctors' <- filterNames (map fst ctors) + return $ env { _adts = insert' x (_adts env) + , _values = foldr insert' (_values env) ctors' + , _patterns = foldr insert' (_patterns env) ctors' + } + where + filterNames names + | open = return names + | otherwise = + case filter (`notElem` names) xs of + [] -> return names + c:_ -> notFound c + +type Node = ((String, [String], Type.RawType), String, [String]) + +node :: String -> [String] -> Type.RawType -> Node +node name tvars alias = ((name, tvars, alias), name, edges alias) + where + edges tipe = + case tipe of + Type.Lambda t1 t2 -> edges t1 ++ edges t2 + Type.Var _ -> [] + Type.Type (Var.Raw x) -> [x] + Type.App t ts -> edges t ++ concatMap edges ts + Type.Record fs ext -> maybe [] edges ext ++ concatMap (edges . snd) fs + Type.Aliased _ t -> edges t + + +addTypeAliases + :: Module.Name + -> [Node] + -> Environment + -> Canonicalizer [Doc] Environment +addTypeAliases moduleName nodes environ = + foldM (addTypeAlias moduleName) environ (Graph.stronglyConnComp nodes) + + +addTypeAlias + :: Module.Name + -> Environment + -> Graph.SCC (String, [String], Type.RawType) + -> Canonicalizer [Doc] Environment +addTypeAlias moduleName env scc = + case Graph.flattenSCC scc of + [(name, tvars, alias)] -> + do alias' <- Env.onError throw (Canonicalize.tipe env alias) + let value = (Var.Canonical (Var.Module moduleName) name, tvars, alias') + return $ env { _aliases = insert name value (_aliases env) } + where + throw err = + let msg = "Problem with type alias '" ++ name ++ "':" + in P.vcat [ P.text msg, P.text err ] + + aliases -> + throwError + [ P.vcat + [ P.text (eightyCharLines 0 mutuallyRecursiveMessage) + , indented (map typeAlias aliases) + , P.text (eightyCharLines 0 typeAliasErrorSegue) + , indented (map datatype aliases) + , P.text (eightyCharLines 0 typeAliasErrorExplanation) + ] + ] + + +typeAlias + :: (String, [String], Type.Type var) + -> D.Declaration' port def var +typeAlias (n,ts,t) = + D.TypeAlias n ts t + + +datatype + :: (String, [String], Type.Type var) + -> D.Declaration' port def var +datatype (n,ts,t) = + D.Datatype n ts [(n,[t])] + + +indented :: [D.ValidDecl] -> Doc +indented decls = P.vcat (map prty decls) <> P.text "\n" + where + prty decl = P.text "\n " <> pretty decl + + +mutuallyRecursiveMessage :: String +mutuallyRecursiveMessage = + "The following type aliases are mutually recursive, forming an \ + \infinite type. When you expand them, they just keep getting bigger:" + + +typeAliasErrorSegue :: String +typeAliasErrorSegue = + "Try this instead:" + + +typeAliasErrorExplanation :: String +typeAliasErrorExplanation = + "It looks very similar, but the 'type' keyword creates a brand new type, \ + \not just an alias for an existing one. This lets us avoid infinitely \ + \expanding it during type inference." + + +-- When canonicalizing, all _values should be Local, but all _adts and _patterns +-- should be fully namespaced. With _adts, they may appear in types that can +-- escape the module. +addDecl :: Module.Name -> ([Node], Environment) -> D.ValidDecl -> ([Node], Environment) +addDecl moduleName info@(nodes,env) decl = + let namespacedVar = Var.Canonical (Var.Module moduleName) + addLocal x e = insert x (Var.local x) e + addNamespaced x e = insert x (namespacedVar x) e + in + case decl of + D.Definition (Valid.Definition pattern _ _) -> + (,) nodes $ env + { _values = foldr addLocal (_values env) (P.boundVarList pattern) } + + D.Datatype name _ ctors -> + (,) nodes $ env + { _values = addCtors addLocal (_values env) + , _adts = addNamespaced name (_adts env) + , _patterns = addCtors addNamespaced (_patterns env) + } + where + addCtors how e = foldr how e (map fst ctors) + + D.TypeAlias name tvars alias -> + (,) (node name tvars alias : nodes) $ env + { _values = case alias of + Type.Record _ _ -> addLocal name (_values env) + _ -> _values env + } + + D.Port port -> + let portName = case port of + D.Out name _ _ -> name + D.In name _ -> name + in + (,) nodes $ env { _values = addLocal portName (_values env) } + + D.Fixity _ _ _ -> info diff --git a/src/Transform/Canonicalize/Type.hs b/src/Transform/Canonicalize/Type.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize/Type.hs @@ -0,0 +1,96 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Canonicalize.Type (tipe) where + +import Control.Arrow (second) +import Control.Applicative ((<$>),(<*>)) +import Control.Monad.Error +import qualified Data.Map as Map +import Data.Traversable (traverse) + +import qualified AST.Type as T +import qualified AST.Variable as Var + +import Transform.Canonicalize.Environment +import qualified Transform.Canonicalize.Variable as Canonicalize + + +tipe + :: Environment + -> T.RawType + -> Canonicalizer String T.CanonicalType +tipe env typ = + let go = tipe env in + case typ of + T.Var x -> + return (T.Var x) + + T.Type _ -> + canonicalizeApp env typ [] + + T.App t ts -> + canonicalizeApp env t ts + + T.Lambda a b -> + T.Lambda <$> go a <*> go b + + T.Aliased name t -> + T.Aliased name <$> go t + + T.Record fields ext -> + let go' (f,t) = (,) f <$> go t + in + T.Record <$> mapM go' fields <*> traverse go ext + + +canonicalizeApp + :: Environment + -> T.RawType + -> [T.RawType] + -> Canonicalizer String T.CanonicalType +canonicalizeApp env f args = + case f of + T.Type (Var.Raw rawName) -> + do answer <- Canonicalize.tvar env rawName + case answer of + Right alias -> + canonicalizeAlias env alias args + + Left name -> + case args of + [] -> return (T.Type name) + _ -> + T.App (T.Type name) <$> mapM (tipe env) args + + _ -> + T.App <$> tipe env f <*> mapM (tipe env) args + + +canonicalizeAlias + :: Environment + -> (Var.Canonical, [String], T.CanonicalType) + -> [T.RawType] + -> Canonicalizer String T.CanonicalType +canonicalizeAlias env (name, tvars, dealiasedTipe) tipes = + do when (tipesLen /= tvarsLen) (throwError msg) + tipes' <- mapM (tipe env) tipes + let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe + return $ T.Aliased name tipe' + where + tipesLen = length tipes + tvarsLen = length tvars + + msg :: String + msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++ + " type argument" ++ (if tvarsLen == 1 then "" else "s") ++ + " but was given " ++ show tipesLen + + replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType + replace typeTable t = + let go = replace typeTable in + case t of + T.Lambda a b -> T.Lambda (go a) (go b) + T.Var x -> Map.findWithDefault t x typeTable + T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext) + T.Aliased original t' -> T.Aliased original (go t') + T.Type _ -> t + T.App f args -> T.App (go f) (map go args) diff --git a/src/Transform/Canonicalize/Variable.hs b/src/Transform/Canonicalize/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Canonicalize/Variable.hs @@ -0,0 +1,95 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Canonicalize.Variable where + +import Control.Monad.Error +import qualified Data.List as List +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) + +import AST.Helpers as Help +import qualified AST.Module as Module +import qualified AST.Type as Type +import qualified AST.Variable as Var +import Transform.Canonicalize.Environment as Env + +variable :: Environment -> String -> Canonicalizer String Var.Canonical +variable env var = + case modul of + Just name + | Module.nameIsNative name -> + Env.using (Var.Canonical (Var.Module name) varName) + + _ -> + case Map.lookup var (_values env) of + Just [v] -> Env.using v + Just vs -> preferLocals env "variable" vs var + Nothing -> notFound "variable" (Map.keys (_values env)) var + where + (modul, varName) = + case Help.splitDots var of + [x] -> (Nothing, x) + xs -> (Just (init xs), last xs) + +tvar :: Environment -> String + -> Canonicalizer String (Either Var.Canonical (Var.Canonical, [String], Type.CanonicalType)) +tvar env var = + case adts ++ aliases of + [] -> notFound "type" (Map.keys (_adts env) ++ Map.keys (_aliases env)) var + [v] -> found extract v + vs -> preferLocals' env extract "type" vs var + where + adts = map Left . fromMaybe [] $ Map.lookup var (_adts env) + aliases = map Right . fromMaybe [] $ Map.lookup var (_aliases env) + + extract value = + case value of + Left v -> v + Right (v,_,_) -> v + +pvar :: Environment -> String -> Canonicalizer String Var.Canonical +pvar env var = + case Map.lookup var (_patterns env) of + Just [v] -> Env.using v + Just vs -> preferLocals env "pattern" vs var + Nothing -> notFound "pattern" (Map.keys (_patterns env)) var + +found :: (a -> Var.Canonical) -> a -> Canonicalizer String a +found extract v = do + _ <- Env.using (extract v) + return v + +notFound :: String -> [String] -> String -> Canonicalizer String a +notFound kind possibilities var = + throwError $ "Could not find " ++ kind ++ " '" ++ var ++ "'." ++ msg + where + matches = filter (List.isInfixOf var) possibilities + msg = if null matches then "" else + "\nClose matches include: " ++ List.intercalate ", " matches + +preferLocals :: Environment -> String -> [Var.Canonical] -> String + -> Canonicalizer String Var.Canonical +preferLocals env = preferLocals' env id + +preferLocals' :: Environment -> (a -> Var.Canonical) -> String -> [a] -> String + -> Canonicalizer String a +preferLocals' env extract kind possibilities var = + case filter (isLocal . extract) possibilities of + [] -> ambiguous possibilities + [v] -> found extract v + locals -> ambiguous locals + where + isLocal :: Var.Canonical -> Bool + isLocal (Var.Canonical home _) = + case home of + Var.Local -> True + Var.BuiltIn -> False + Var.Module name -> + name == Env._home env + + ambiguous possibleVars = + throwError msg + where + vars = map (Var.toString . extract) possibleVars + msg = "Ambiguous usage of " ++ kind ++ " '" ++ var ++ "'.\n" ++ + " Disambiguate between: " ++ List.intercalate ", " vars + diff --git a/src/Transform/Check.hs b/src/Transform/Check.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Check.hs @@ -0,0 +1,177 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Check (mistakes) where + +import qualified Control.Arrow as Arrow +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set + +import qualified AST.Expression.Valid as Valid +import qualified AST.Declaration as D +import qualified AST.Pattern as Pattern +import qualified AST.Type as T +import qualified AST.Variable as Var +import qualified Transform.Expression as Expr +import qualified Transform.Canonicalize.Setup as Setup + +import AST.PrettyPrint +import Elm.Utils ((|>)) +import Text.PrettyPrint as P + + +mistakes :: [D.ValidDecl] -> [Doc] +mistakes decls = + concat + [ infiniteTypeAliases decls + , illFormedTypes decls + , map P.text (duplicateTypeDeclarations decls) + , map P.text (duplicateValues decls) + ] + + +dups :: Ord a => [a] -> [a] +dups names = + List.sort names + |> List.group + |> filter ((>1) . length) + |> map head + + +duplicateValues :: [D.ValidDecl] -> [String] +duplicateValues decls = + map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++ + case mapM exprDups (portExprs ++ defExprs) of + Left name -> [msg name] + Right _ -> [] + + where + msg x = + "Name Collision: There can only be one definition of '" ++ x ++ "'." + + (defPatterns, defExprs) = + unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ] + + (portNames, portExprs) = + Arrow.second concat $ unzip $ + flip map [ port | D.Port port <- decls ] $ \port -> + case port of + D.Out name expr _ -> (name, [expr]) + D.In name _ -> (name, []) + + exprDups :: Valid.Expr -> Either String Valid.Expr + exprDups expr = Expr.crawlLet defsDups expr + + defsDups :: [Valid.Def] -> Either String [Valid.Def] + defsDups defs = + let varsIn (Valid.Definition pattern _ _) = Pattern.boundVarList pattern in + case dups $ concatMap varsIn defs of + [] -> Right defs + name:_ -> Left name + + +duplicateTypeDeclarations :: [D.ValidDecl] -> [String] +duplicateTypeDeclarations decls = + map dupTypeError (dups (typeNames ++ aliasNames)) + ++ map dupCtorError (dups (ctorNames ++ aliasNames)) + where + typeNames = + [ name | D.Datatype name _ _ <- decls ] + + aliasNames = + [ name | D.TypeAlias name _ _ <- decls ] + + ctorNames = + concat [ map fst patterns | D.Datatype _ _ patterns <- decls ] + + +dupTypeError :: String -> String +dupTypeError name = + "Name Collision: There can only be one type named '" ++ name ++ "'" + + +dupCtorError :: String -> String +dupCtorError name = + "Name Collision: There can only be one constructor named '" ++ name ++ "'.\n" + ++ " Constructors are created for record type aliases and for union types, so\n" + ++ " something should be renamed or moved to a different module." + + +illFormedTypes :: [D.ValidDecl] -> [Doc] +illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts)) + where + aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe) <- decls ] + adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ] + + freeVars tipe = + case tipe of + T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2) + T.Var x -> Set.singleton x + T.Type _ -> Set.empty + T.App t ts -> Set.unions (map freeVars (t:ts)) + T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields) + where ext' = maybe Set.empty freeVars ext + T.Aliased _ t -> freeVars t + + undeclared tvars tipes = Set.difference used declared + where + used = Set.unions (map freeVars tipes) + declared = Set.fromList tvars + + isIllFormed (decl, tvars, tipes) = + let unbound = undeclared tvars tipes in + if Set.null unbound then Nothing + else Just (decl, Set.toList unbound) + + report (decl, tvars) = + P.vcat [ P.text $ "Error: type variable" ++ listing ++ " unbound in:" + , P.text "\n" + , nest 4 (pretty decl) ] + where + listing = + case tvars of + [tvar] -> " " ++ quote tvar ++ " is" + _ -> "s" ++ addCommas (map ((++) " ") (addAnd (map quote tvars))) ++ " are" + + addCommas xs + | length xs < 3 = concat xs + | otherwise = List.intercalate "," xs + + addAnd xs + | length xs < 2 = xs + | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs + + quote tvar = "'" ++ tvar ++ "'" + + +infiniteTypeAliases :: [D.ValidDecl] -> [Doc] +infiniteTypeAliases decls = + [ report name tvars tipe | D.TypeAlias name tvars tipe <- decls + , infiniteType name tipe ] + where + infiniteType :: String -> T.Type Var.Raw -> Bool + infiniteType name tipe = + let infinite = infiniteType name in + case tipe of + T.Lambda a b -> infinite a || infinite b + T.Var _ -> False + T.Type (Var.Raw name') -> name == name' + T.App t ts -> any infinite (t:ts) + T.Record fields _ -> any (infinite . snd) fields + T.Aliased _ t -> infinite t + + indented :: D.ValidDecl -> Doc + indented decl = P.text "\n " <> pretty decl <> P.text "\n" + + report name args tipe = + P.vcat + [ P.text $ eightyCharLines 0 msg1 + , indented $ D.TypeAlias name args tipe + , P.text $ eightyCharLines 0 Setup.typeAliasErrorSegue + , indented $ D.Datatype name args [(name,[tipe])] + , P.text $ eightyCharLines 0 Setup.typeAliasErrorExplanation ++ "\n" + ] + where + msg1 = + "Type alias '" ++ name ++ "' is an infinite type. " ++ + "Notice that it appears in its own definition, so when \ + \you expand it, it just keeps getting bigger:" diff --git a/src/Transform/Declaration.hs b/src/Transform/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Declaration.hs @@ -0,0 +1,129 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Declaration (combineAnnotations, toExpr) where + +import Control.Applicative ((<$>)) + +import qualified AST.Annotation as A +import qualified AST.Declaration as D +import qualified AST.Expression.General as E +import qualified AST.Expression.Source as Source +import qualified AST.Expression.Valid as Valid +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Module as Module +import qualified AST.Pattern as P +import qualified AST.Type as T +import qualified AST.Variable as Var + +import qualified Transform.Expression as Expr +import qualified Transform.Definition as Def + + +combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl] +combineAnnotations = go + where + msg x = "Syntax Error: The type annotation for '" ++ x ++ + "' must be directly above its definition." + + exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations + + go decls = + case decls of + -- simple cases, pass them through with no changes + [] -> return [] + + D.Datatype name tvars ctors : rest -> + (:) (D.Datatype name tvars ctors) <$> go rest + + D.TypeAlias name tvars alias : rest -> + (:) (D.TypeAlias name tvars alias) <$> go rest + + D.Fixity assoc prec op : rest -> + (:) (D.Fixity assoc prec op) <$> go rest + + -- combine definitions + D.Definition def : defRest -> + case def of + Source.Definition pat expr -> + do expr' <- exprCombineAnnotations expr + let def' = Valid.Definition pat expr' Nothing + (:) (D.Definition def') <$> go defRest + + Source.TypeAnnotation name tipe -> + case defRest of + D.Definition (Source.Definition pat@(P.Var name') expr) : rest + | name == name' -> + do expr' <- exprCombineAnnotations expr + let def' = Valid.Definition pat expr' (Just tipe) + (:) (D.Definition def') <$> go rest + + _ -> Left (msg name) + + -- combine ports + D.Port port : portRest -> + case port of + D.PPDef name _ -> Left (msg name) + D.PPAnnotation name tipe -> + case portRest of + D.Port (D.PPDef name' expr) : rest | name == name' -> + do expr' <- exprCombineAnnotations expr + (:) (D.Port (D.Out name expr' tipe)) <$> go rest + + _ -> (:) (D.Port (D.In name tipe)) <$> go portRest + + +toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def] +toExpr moduleName = concatMap (toDefs moduleName) + +toDefs :: Module.Name -> D.CanonicalDecl -> [Canonical.Def] +toDefs moduleName decl = + let typeVar = Var.Canonical (Var.Module moduleName) in + case decl of + D.Definition def -> [def] + + D.Datatype name tvars constructors -> concatMap toDefs' constructors + where + toDefs' (ctor, tipes) = + let vars = take (length tipes) arguments + tbody = T.App (T.Type (typeVar name)) (map T.Var tvars) + body = A.none . E.Data ctor $ map (A.none . E.localVar) vars + in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ] + + D.TypeAlias name _ tipe@(T.Record fields ext) -> + [ definition name (buildFunction record vars) (foldr T.Lambda result args) ] + where + result = T.Aliased (typeVar name) tipe + + args = map snd fields ++ maybe [] (:[]) ext + + var = A.none . E.localVar + vars = take (length args) arguments + + efields = zip (map fst fields) (map var vars) + record = case ext of + Nothing -> A.none $ E.Record efields + Just _ -> foldl (\r (f,v) -> A.none $ E.Insert r f v) (var $ last vars) efields + + -- Type aliases must be added to an extended equality dictionary, + -- but they do not require any basic constraints. + D.TypeAlias _ _ _ -> [] + + D.Port port -> + case port of + D.Out name expr@(A.A s _) tipe -> + [ definition name (A.A s $ E.PortOut name tipe expr) tipe ] + D.In name tipe -> + [ definition name (A.none $ E.PortIn name tipe) tipe ] + + -- no constraints are needed for fixity declarations + D.Fixity _ _ _ -> [] + + +arguments :: [String] +arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..] + +buildFunction :: Canonical.Expr -> [String] -> Canonical.Expr +buildFunction body@(A.A s _) vars = + foldr (\p e -> A.A s (E.Lambda p e)) body (map P.Var vars) + +definition :: String -> Canonical.Expr -> T.CanonicalType -> Canonical.Def +definition name expr tipe = Canonical.Definition (P.Var name) expr (Just tipe) diff --git a/src/Transform/Definition.hs b/src/Transform/Definition.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Definition.hs @@ -0,0 +1,35 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Definition where + +import Control.Applicative ((<$>)) +import qualified AST.Pattern as P +import qualified AST.Expression.Source as Source +import qualified AST.Expression.Valid as Valid +import qualified Transform.Expression as Expr + +combineAnnotations :: [Source.Def] -> Either String [Valid.Def] +combineAnnotations = go + where + msg x = "Syntax Error: The type annotation for '" ++ x ++ + "' must be directly above its definition." + + exprCombineAnnotations = Expr.crawlLet combineAnnotations + + go defs = + case defs of + Source.TypeAnnotation name tipe : rest -> + case rest of + Source.Definition pat@(P.Var name') expr : rest' + | name == name' -> + do expr' <- exprCombineAnnotations expr + let def = Valid.Definition pat expr' (Just tipe) + (:) def <$> go rest' + + _ -> Left (msg name) + + Source.Definition pat expr : rest -> + do expr' <- exprCombineAnnotations expr + let def = Valid.Definition pat expr' Nothing + (:) def <$> go rest + + [] -> return [] diff --git a/src/Transform/Expression.hs b/src/Transform/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Expression.hs @@ -0,0 +1,100 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Expression (crawlLet, checkPorts) where + +import Control.Applicative ((<$>),(<*>)) +import AST.Annotation ( Annotated(A) ) +import AST.Expression.General +import qualified AST.Expression.Canonical as Canonical +import AST.Type (Type, CanonicalType) + +crawlLet + :: ([def] -> Either a [def']) + -> Expr ann def var + -> Either a (Expr ann def' var) +crawlLet = + crawl (\_ _ -> return ()) (\_ _ -> return ()) + + +checkPorts + :: (String -> CanonicalType -> Either a ()) + -> (String -> CanonicalType -> Either a ()) + -> Canonical.Expr + -> Either a Canonical.Expr +checkPorts inCheck outCheck expr = + crawl inCheck outCheck (mapM checkDef) expr + where + checkDef def@(Canonical.Definition _ body _) = + do _ <- checkPorts inCheck outCheck body + return def + + +crawl + :: (String -> Type var -> Either a ()) + -> (String -> Type var -> Either a ()) + -> ([def] -> Either a [def']) + -> Expr ann def var + -> Either a (Expr ann def' var) +crawl portInCheck portOutCheck defsTransform = + go + where + go (A srcSpan expr) = + A srcSpan <$> + case expr of + Var x -> + return (Var x) + + Lambda p e -> + Lambda p <$> go e + + Binop op e1 e2 -> + Binop op <$> go e1 <*> go e2 + + Case e cases -> + Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases + + Data name es -> + Data name <$> mapM go es + + Literal lit -> + return (Literal lit) + + Range e1 e2 -> + Range <$> go e1 <*> go e2 + + ExplicitList es -> + ExplicitList <$> mapM go es + + App e1 e2 -> + App <$> go e1 <*> go e2 + + MultiIf branches -> + MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches + + Access e lbl -> + Access <$> go e <*> return lbl + + Remove e lbl -> + Remove <$> go e <*> return lbl + + Insert e lbl v -> + Insert <$> go e <*> return lbl <*> go v + + Modify e fields -> + Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields + + Record fields -> + Record <$> mapM (\(k,v) -> (,) k <$> go v) fields + + Let defs body -> + Let <$> defsTransform defs <*> go body + + GLShader uid src gltipe -> + return $ GLShader uid src gltipe + + PortIn name st -> + do portInCheck name st + return $ PortIn name st + + PortOut name st signal -> + do portOutCheck name st + PortOut name st <$> go signal diff --git a/src/Transform/Interface.hs b/src/Transform/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Interface.hs @@ -0,0 +1,60 @@ +module Transform.Interface (filterExports) where + +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified AST.Module as Module +import qualified AST.Variable as Var + + +filterExports :: Module.Interface -> Module.Interface +filterExports interface = + interface + { Module.iTypes = + Map.fromList $ + Maybe.mapMaybe + (get (Module.iTypes interface)) + (Var.getValues exports ++ ctors) + + , Module.iAliases = + Map.fromList $ + Maybe.mapMaybe + (get (Module.iAliases interface)) + (Var.getAliases exports) + + , Module.iAdts = + Map.fromList + (Maybe.mapMaybe (trimUnions interface) unions) + } + where + exports :: [Var.Value] + exports = + Module.iExports interface + + unions :: [(String, Var.Listing String)] + unions = + Var.getUnions exports + + ctors :: [String] + ctors = + concatMap (\(_, Var.Listing ctorList _) -> ctorList) unions + + +get :: Map.Map String a -> String -> Maybe (String, a) +get dict key = + case Map.lookup key dict of + Nothing -> Nothing + Just value -> Just (key, value) + + +trimUnions + :: Module.Interface + -> (String, Var.Listing String) + -> Maybe (String, Module.AdtInfo String) +trimUnions interface (name, Var.Listing exportedCtors _) = + case Map.lookup name (Module.iAdts interface) of + Nothing -> Nothing + Just (tvars, ctors) -> + let isExported (ctor, _) = + ctor `elem` exportedCtors + in + Just (name, (tvars, filter isExported ctors)) diff --git a/src/Transform/SortDefinitions.hs b/src/Transform/SortDefinitions.hs new file mode 100644 --- /dev/null +++ b/src/Transform/SortDefinitions.hs @@ -0,0 +1,170 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.SortDefinitions (sortDefs) where + +import Control.Monad.State +import Control.Applicative ((<$>),(<*>)) +import qualified Data.Graph as Graph +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set + +import AST.Annotation +import AST.Expression.General (Expr'(..)) +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Pattern as P +import qualified AST.Variable as V + +ctors :: P.CanonicalPattern -> [String] +ctors pattern = + case pattern of + P.Var _ -> [] + P.Alias _ p -> ctors p + P.Record _ -> [] + P.Anything -> [] + P.Literal _ -> [] + P.Data (V.Canonical home name) ps -> + case home of + V.Local -> name : rest + V.BuiltIn -> rest + V.Module _ -> rest + where + rest = concatMap ctors ps + +free :: String -> State (Set.Set String) () +free x = modify (Set.insert x) + +freeIfLocal :: V.Canonical -> State (Set.Set String) () +freeIfLocal (V.Canonical home name) = + do case home of + V.Local -> free name + V.BuiltIn -> return () + V.Module _ -> return () + +bound :: Set.Set String -> State (Set.Set String) () +bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars) + +sortDefs :: Canonical.Expr -> Canonical.Expr +sortDefs expr = evalState (reorder expr) Set.empty + +reorder :: Canonical.Expr -> State (Set.Set String) Canonical.Expr +reorder (A ann expr) = + A ann <$> + case expr of + -- Be careful adding and restricting freeVars + Var var -> freeIfLocal var >> return expr + + Lambda p e -> + uncurry Lambda <$> bindingReorder (p,e) + + Binop op e1 e2 -> + do freeIfLocal op + Binop op <$> reorder e1 <*> reorder e2 + + Case e cases -> + Case <$> reorder e <*> mapM bindingReorder cases + + Data name es -> + do free name + Data name <$> mapM reorder es + + -- Just pipe the reorder though + Literal _ -> return expr + + Range e1 e2 -> + Range <$> reorder e1 <*> reorder e2 + + ExplicitList es -> + ExplicitList <$> mapM reorder es + + App e1 e2 -> + App <$> reorder e1 <*> reorder e2 + + MultiIf branches -> + MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches + + Access e lbl -> + Access <$> reorder e <*> return lbl + + Remove e lbl -> + Remove <$> reorder e <*> return lbl + + Insert e lbl v -> + Insert <$> reorder e <*> return lbl <*> reorder v + + Modify e fields -> + Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields + + Record fields -> + Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields + + GLShader _ _ _ -> return expr + + PortOut name st signal -> PortOut name st <$> reorder signal + + PortIn name st -> return $ PortIn name st + + -- Actually do some reordering + Let defs body -> + do body' <- reorder body + + -- Sort defs into strongly connected components.This + -- allows the programmer to write definitions in whatever + -- order they please, we can still define things in order + -- and generalize polymorphic functions when appropriate. + sccs <- Graph.stronglyConnComp <$> buildDefDict defs + let defss = map Graph.flattenSCC sccs + + -- remove let-bound variables from the context + forM_ defs $ \(Canonical.Definition pattern _ _) -> do + bound (P.boundVars pattern) + mapM free (ctors pattern) + + let A _ let' = foldr (\ds bod -> A ann (Let ds bod)) body' defss + + return let' + +bindingReorder :: (P.CanonicalPattern, Canonical.Expr) + -> State (Set.Set String) (P.CanonicalPattern, Canonical.Expr) +bindingReorder (pattern,expr) = + do expr' <- reorder expr + bound (P.boundVars pattern) + mapM_ free (ctors pattern) + return (pattern, expr') + + +reorderAndGetDependencies :: Canonical.Def -> State (Set.Set String) (Canonical.Def, [String]) +reorderAndGetDependencies (Canonical.Definition pattern expr mType) = + do globalFrees <- get + -- work in a fresh environment + put Set.empty + expr' <- reorder expr + localFrees <- get + -- merge with global frees + modify (Set.union globalFrees) + return (Canonical.Definition pattern expr' mType, Set.toList localFrees) + + +-- This also reorders the all of the sub-expressions in the Def list. +buildDefDict :: [Canonical.Def] -> State (Set.Set String) [(Canonical.Def, Int, [Int])] +buildDefDict defs = + do pdefsDeps <- mapM reorderAndGetDependencies defs + return $ realDeps (addKey pdefsDeps) + + where + addKey :: [(Canonical.Def, [String])] -> [(Canonical.Def, Int, [String])] + addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..] + + variableToKey :: (Canonical.Def, Int, [String]) -> [(String, Int)] + variableToKey (Canonical.Definition pattern _ _, key, _) = + [ (var, key) | var <- Set.toList (P.boundVars pattern) ] + + variableToKeyMap :: [(Canonical.Def, Int, [String])] -> Map.Map String Int + variableToKeyMap pdefsDeps = + Map.fromList (concatMap variableToKey pdefsDeps) + + realDeps :: [(Canonical.Def, Int, [String])] -> [(Canonical.Def, Int, [Int])] + realDeps pdefsDeps = map convert pdefsDeps + where + varDict = variableToKeyMap pdefsDeps + convert (pdef, key, deps) = + (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps) diff --git a/src/Transform/Substitute.hs b/src/Transform/Substitute.hs new file mode 100644 --- /dev/null +++ b/src/Transform/Substitute.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -Wall #-} +module Transform.Substitute (subst) where + +import Control.Arrow (second, (***)) +import qualified Data.Set as Set + +import AST.Annotation +import AST.Expression.General (Expr'(..)) +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Pattern as Pattern +import qualified AST.Variable as V + + +subst :: String -> Canonical.Expr' -> Canonical.Expr' -> Canonical.Expr' +subst old new expression = + let f (A a e) = A a (subst old new e) in + case expression of + Range e1 e2 -> + Range (f e1) (f e2) + + ExplicitList exprs -> + ExplicitList (map f exprs) + + Binop op e1 e2 -> + Binop op (f e1) (f e2) + + Lambda pattern body + | Set.member old (Pattern.boundVars pattern) -> expression + | otherwise -> Lambda pattern (f body) + + App e1 e2 -> + App (f e1) (f e2) + + MultiIf branches -> + MultiIf (map (f *** f) branches) + + Let defs body + | anyShadow -> expression + | otherwise -> Let (map substDef defs) (f body) + where + substDef (Canonical.Definition p e t) = + Canonical.Definition p (f e) t + + anyShadow = + any (Set.member old . Pattern.boundVars) + [ pattern | Canonical.Definition pattern _ _ <- defs ] + + Var (V.Canonical home x) -> + case home of + V.Module _ -> expression + V.BuiltIn -> expression + V.Local -> if x == old then new else expression + + Case e cases -> + Case (f e) (map substCase cases) + where + substCase (pattern, expr) = + if Set.member old (Pattern.boundVars pattern) + then (pattern, expr) + else (pattern, f expr) + + Data tag values -> + Data tag (map f values) + + Access record field -> + Access (f record) field + + Remove record field -> + Remove (f record) field + + Insert record field value -> + Insert (f record) field (f value) + + Modify record fields -> + Modify (f record) (map (second f) fields) + + Record fields -> + Record (map (second f) fields) + + Literal _ -> expression + + GLShader _ _ _ -> expression + + PortIn name st -> + PortIn name st + + PortOut name st signal -> + PortOut name st (f signal) diff --git a/src/Type/Constrain/Expression.hs b/src/Type/Constrain/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Type/Constrain/Expression.hs @@ -0,0 +1,231 @@ +module Type.Constrain.Expression where + +import Control.Applicative ((<$>)) +import qualified Control.Monad as Monad +import Control.Monad.Error +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Text.PrettyPrint as PP + +import AST.Literal as Lit +import AST.Annotation as Ann +import AST.Expression.General +import qualified AST.Expression.Canonical as Canonical +import qualified AST.Pattern as P +import qualified AST.Type as ST +import qualified AST.Variable as V +import Type.Type hiding (Descriptor(..)) +import Type.Fragment +import qualified Type.Environment as Env +import qualified Type.Constrain.Literal as Literal +import qualified Type.Constrain.Pattern as Pattern + + +constrain + :: Env.Environment + -> Canonical.Expr + -> Type + -> ErrorT [PP.Doc] IO TypeConstraint +constrain env (A region expr) tipe = + let list t = Env.get env Env.types "List" <| t + and = A region . CAnd + true = A region CTrue + t1 === t2 = A region (CEqual t1 t2) + x liftIO $ Literal.constrain env region lit tipe + + GLShader _uid _src gltipe -> + exists $ \attr -> + exists $ \unif -> + let + shaderTipe a u v = Env.get env Env.types "WebGL.Shader" <| a <| u <| v + glTipe = Env.get env Env.types . Lit.glTipeName + makeRec accessor baseRec = + let decls = accessor gltipe + in if Map.size decls == 0 + then baseRec + else record (Map.map (\t -> [glTipe t]) decls) baseRec + attribute = makeRec Lit.attribute attr + uniform = makeRec Lit.uniform unif + varying = makeRec Lit.varying (termN EmptyRecord1) + in return . A region $ CEqual tipe (shaderTipe attribute uniform varying) + + Var var + | name == saveEnvName -> return (A region CSaveEnv) + | otherwise -> return (name + existsNumber $ \n -> do + clo <- constrain env lo n + chi <- constrain env hi n + return $ and [clo, chi, list n === tipe] + + ExplicitList exprs -> + exists $ \x -> do + cs <- mapM (\e -> constrain env e x) exprs + return . and $ list x === tipe : cs + + Binop op e1 e2 -> + exists $ \t1 -> + exists $ \t2 -> do + c1 <- constrain env e1 t1 + c2 <- constrain env e2 t2 + return $ and [ c1, c2, V.toString op t2 ==> tipe) ] + + Lambda p e -> + exists $ \t1 -> + exists $ \t2 -> do + fragment <- try region $ Pattern.constrain env p t1 + c2 <- constrain env e t2 + let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)] + (typeConstraint fragment /\ c2 )) + return $ c /\ tipe === (t1 ==> t2) + + App e1 e2 -> + exists $ \t -> do + c1 <- constrain env e1 (t ==> tipe) + c2 <- constrain env e2 t + return $ c1 /\ c2 + + MultiIf branches -> and <$> mapM constrain' branches + where + bool = Env.get env Env.types "Bool" + constrain' (b,e) = do + cb <- constrain env b bool + ce <- constrain env e tipe + return (cb /\ ce) + + Case exp branches -> + exists $ \t -> do + ce <- constrain env exp t + let branch (p,e) = do + fragment <- try region $ Pattern.constrain env p t + clet [toScheme fragment] <$> constrain env e tipe + and . (:) ce <$> mapM branch branches + + Data name exprs -> + do vars <- forM exprs $ \_ -> liftIO (variable Flexible) + let pairs = zip exprs (map varN vars) + (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs) + return $ ex vars (cs /\ name t, c /\ c') + + Access e label -> + exists $ \t -> + constrain env e (record (Map.singleton label [tipe]) t) + + Remove e label -> + exists $ \t -> + constrain env e (record (Map.singleton label [t]) tipe) + + Insert e label value -> + exists $ \tVal -> + exists $ \tRec -> do + cVal <- constrain env value tVal + cRec <- constrain env e tRec + let c = tipe === record (Map.singleton label [tVal]) tRec + return (and [cVal, cRec, c]) + + Modify e fields -> + exists $ \t -> do + oldVars <- forM fields $ \_ -> liftIO (variable Flexible) + let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars)) + cOld <- ex oldVars <$> constrain env e (record oldFields t) + + newVars <- forM fields $ \_ -> liftIO (variable Flexible) + let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars)) + let cNew = tipe === record newFields t + + cs <- zipWithM (constrain env) (map snd fields) (map varN newVars) + + return $ cOld /\ ex newVars (and (cNew : cs)) + + Record fields -> + do vars <- forM fields $ \_ -> liftIO (variable Flexible) + cs <- zipWithM (constrain env) (map snd fields) (map varN vars) + let fields' = ST.fieldMap (zip (map fst fields) (map varN vars)) + recordType = record fields' (termN EmptyRecord1) + return . ex vars . and $ tipe === recordType : cs + + Let defs body -> + do c <- constrain env body tipe + (schemes, rqs, fqs, header, c2, c1) <- + Monad.foldM (constrainDef env) + ([], [], [], Map.empty, true, true) + (concatMap expandPattern defs) + return $ clet schemes + (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ] + (c1 /\ c)) + + PortIn _ _ -> return true + + PortOut _ _ signal -> + constrain env signal tipe + + +constrainDef env info (Canonical.Definition pattern expr maybeTipe) = + let qs = [] -- should come from the def, but I'm not sure what would live there... + (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info + in + do rigidVars <- forM qs (\_ -> liftIO $ variable Rigid) -- Some mistake may be happening here. + -- Currently, qs is always []. + case (pattern, maybeTipe) of + (P.Var name, Just tipe) -> do + flexiVars <- forM qs (\_ -> liftIO $ variable Flexible) + let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars + env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts } + (vars, typ) <- Env.instantiateType env tipe Map.empty + let scheme = Scheme { rigidQuantifiers = [], + flexibleQuantifiers = flexiVars ++ vars, + constraint = Ann.noneNoDocs CTrue, + header = Map.singleton name typ } + c <- constrain env' expr typ + return ( scheme : schemes + , rigidQuantifiers + , flexibleQuantifiers + , headers + , c2 + , fl rigidVars c /\ c1 ) + + (P.Var name, Nothing) -> do + v <- liftIO $ variable Flexible + let tipe = varN v + inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars + env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts } + c <- constrain env' expr tipe + return ( schemes + , rigidVars ++ rigidQuantifiers + , v : flexibleQuantifiers + , Map.insert name tipe headers + , c /\ c2 + , c1 ) + + _ -> error ("problem in constrainDef with " ++ show pattern) + + +expandPattern :: Canonical.Def -> [Canonical.Def] +expandPattern def@(Canonical.Definition pattern lexpr@(A r _) maybeType) = + case pattern of + P.Var _ -> [def] + _ -> Canonical.Definition (P.Var x) lexpr maybeType : map toDef vars + where + vars = P.boundVarList pattern + x = "$" ++ concat vars + mkVar = A r . localVar + toDef y = Canonical.Definition (P.Var y) (A r $ Case (mkVar x) [(pattern, mkVar y)]) Nothing + + +try :: Region -> ErrorT (Region -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a +try region computation = + do result <- liftIO $ runErrorT computation + case result of + Left err -> throwError [err region] + Right value -> return value diff --git a/src/Type/Constrain/Literal.hs b/src/Type/Constrain/Literal.hs new file mode 100644 --- /dev/null +++ b/src/Type/Constrain/Literal.hs @@ -0,0 +1,21 @@ +module Type.Constrain.Literal where + +import AST.Annotation +import AST.Literal +import Type.Type +import Type.Environment as Env + +constrain :: Environment -> Region -> Literal -> Type -> IO TypeConstraint +constrain env region literal tipe = + do tipe' <- litType + return . A region $ CEqual tipe tipe' + where + prim name = return (Env.get env Env.types name) + + litType = + case literal of + IntNum _ -> varN `fmap` variable (Is Number) + FloatNum _ -> prim "Float" + Chr _ -> prim "Char" + Str _ -> prim "String" + Boolean _ -> prim "Bool" diff --git a/src/Type/Constrain/Pattern.hs b/src/Type/Constrain/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Type/Constrain/Pattern.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} +module Type.Constrain.Pattern where + +import Control.Arrow (second) +import Control.Applicative ((<$>)) +import qualified Control.Monad as Monad +import Control.Monad.Error +import qualified Data.Map as Map +import qualified Text.PrettyPrint as PP + +import qualified AST.Annotation as A +import qualified AST.Pattern as P +import qualified AST.Variable as V +import AST.PrettyPrint (pretty) +import Type.Type +import Type.Fragment +import Type.Environment as Env +import qualified Type.Constrain.Literal as Literal + + +constrain :: Environment -> P.CanonicalPattern -> Type + -> ErrorT (A.Region -> PP.Doc) IO Fragment +constrain env pattern tipe = + let region = A.None (pretty pattern) + t1 === t2 = A.A region (CEqual t1 t2) + in + case pattern of + P.Anything -> return emptyFragment + + P.Literal lit -> do + c <- liftIO $ Literal.constrain env region lit tipe + return $ emptyFragment { typeConstraint = c } + + P.Var name -> do + v <- liftIO $ variable Flexible + return $ Fragment { + typeEnv = Map.singleton name (varN v), + vars = [v], + typeConstraint = varN v === tipe + } + + P.Alias name p -> do + v <- liftIO $ variable Flexible + fragment <- constrain env p tipe + return $ fragment + { typeEnv = Map.insert name (varN v) (typeEnv fragment) + , vars = v : vars fragment + , typeConstraint = varN v === tipe /\ typeConstraint fragment + } + + P.Data name patterns -> do + (kind, cvars, args, result) <- liftIO $ freshDataScheme env (V.toString name) + let msg = concat [ "Constructor '", V.toString name, "' expects ", show kind + , " argument", if kind == 1 then "" else "s" + , " but was given ", show (length patterns), "." ] + err span = PP.vcat [ PP.text $ "Type error " ++ show span + , PP.text msg ] + case length patterns == kind of + False -> throwError err + True -> do + fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args) + return $ fragment { + typeConstraint = typeConstraint fragment /\ tipe === result, + vars = cvars ++ vars fragment + } + + P.Record fields -> do + pairs <- liftIO $ mapM (\name -> (,) name <$> variable Flexible) fields + let tenv = Map.fromList (map (second varN) pairs) + c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t) + return $ Fragment { + typeEnv = tenv, + vars = map snd pairs, + typeConstraint = c + } + +instance Error (A.Region -> PP.Doc) where + noMsg _ = PP.empty + strMsg str span = + PP.vcat [ PP.text $ "Type error " ++ show span + , PP.text str ] diff --git a/src/Type/Environment.hs b/src/Type/Environment.hs new file mode 100644 --- /dev/null +++ b/src/Type/Environment.hs @@ -0,0 +1,167 @@ +module Type.Environment where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (try, SomeException) +import Control.Monad +import Control.Monad.Error (ErrorT, throwError, liftIO) +import qualified Control.Monad.State as State +import qualified Data.Traversable as Traverse +import qualified Data.Map as Map +import Data.List (isPrefixOf) +import qualified Text.PrettyPrint as PP + +import qualified AST.Type as T +import qualified AST.Variable as V +import AST.Module (CanonicalAdt, AdtInfo) +import Type.Type + +type TypeDict = Map.Map String Type +type VarDict = Map.Map String Variable + +data Environment = Environment + { constructor :: Map.Map String (IO (Int, [Variable], [Type], Type)) + , types :: TypeDict + , value :: TypeDict + } + +initialEnvironment :: [CanonicalAdt] -> IO Environment +initialEnvironment datatypes = do + types <- makeTypes datatypes + let env = Environment + { constructor = Map.empty + , value = Map.empty + , types = types + } + return $ env { constructor = makeConstructors env datatypes } + +makeTypes :: [CanonicalAdt] -> IO TypeDict +makeTypes datatypes = + do adts <- mapM makeImported datatypes + bs <- mapM makeBuiltin builtins + return (Map.fromList (adts ++ bs)) + where + makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type) + makeImported (var, _) = do + tvar <- namedVar Constant var + return (V.toString var, varN tvar) + + makeBuiltin :: (String, Int) -> IO (String, Type) + makeBuiltin (name, _) = do + name' <- namedVar Constant (V.builtin name) + return (name, varN name') + + builtins :: [(String, Int)] + builtins = concat [ map tuple [0..9] + , kind 1 ["List"] + , kind 0 ["Int","Float","Char","String","Bool"] + ] + where + tuple n = ("_Tuple" ++ show n, n) + kind n names = map (\name -> (name, n)) names + + + +makeConstructors :: Environment + -> [CanonicalAdt] + -> Map.Map String (IO (Int, [Variable], [Type], Type)) +makeConstructors env datatypes = Map.fromList builtins + where + list t = (types env Map.! "List") <| t + + inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type) + inst numTVars tipe = do + vars <- forM [1..numTVars] $ \_ -> variable Flexible + let (args, result) = tipe (map (varN) vars) + return (length args, vars, args, result) + + tupleCtor n = + let name = "_Tuple" ++ show n + in (name, inst n $ \vs -> (vs, foldl (<|) (types env Map.! name) vs)) + + builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ] + builtins = [ ("[]", inst 1 $ \ [t] -> ([], list t)) + , ("::", inst 1 $ \ [t] -> ([t, list t], list t)) + ] ++ map tupleCtor [0..9] + ++ concatMap (ctorToType env) datatypes + + +ctorToType :: Environment + -> (V.Canonical, AdtInfo V.Canonical) + -> [(String, IO (Int, [Variable], [Type], Type))] +ctorToType env (name, (tvars, ctors)) = + zip (map (V.toString . fst) ctors) (map inst ctors) + where + inst :: (V.Canonical, [T.CanonicalType]) -> IO (Int, [Variable], [Type], Type) + inst ctor = do + ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty + return (length args, Map.elems dict, args, tipe) + + + go :: (V.Canonical, [T.CanonicalType]) -> State.StateT VarDict IO ([Type], Type) + go (_, args) = do + types <- mapM (instantiator env) args + returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars)) + return (types, returnType) + + +get :: Environment -> (Environment -> Map.Map String a) -> String -> a +get env subDict key = Map.findWithDefault (error msg) key (subDict env) + where + msg = "Could not find type constructor '" ++ key ++ "' while checking types." + + +freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type) +freshDataScheme env name = get env constructor name + +instantiateType :: Environment -> T.CanonicalType -> VarDict -> ErrorT [PP.Doc] IO ([Variable], Type) +instantiateType env sourceType dict = + do result <- liftIO $ try (State.runStateT (instantiator env sourceType) dict) + case result :: Either SomeException (Type, VarDict) of + Left someError -> throwError [ PP.text $ show someError ] + Right (tipe, dict') -> return (Map.elems dict', tipe) + +instantiator :: Environment -> T.CanonicalType -> State.StateT VarDict IO Type +instantiator env sourceType = go sourceType + where + go :: T.CanonicalType -> State.StateT VarDict IO Type + go sourceType = + case sourceType of + T.Lambda t1 t2 -> (==>) <$> go t1 <*> go t2 + + T.Var x -> do + dict <- State.get + case Map.lookup x dict of + Just v -> return (varN v) + Nothing -> + do v <- State.liftIO $ namedVar flex (V.local x) + State.put (Map.insert x v dict) + return (varN v) + where + flex | "number" `isPrefixOf` x = Is Number + | "comparable" `isPrefixOf` x = Is Comparable + | "appendable" `isPrefixOf` x = Is Appendable + | otherwise = Flexible + + T.Aliased name t -> do + t' <- go t + case t' of + VarN _ v -> return (VarN (Just name) v) + TermN _ term -> return (TermN (Just name) term) + + T.Type name -> + case Map.lookup (V.toString name) (types env) of + Just t -> return t + Nothing -> error $ "Could not find type constructor '" ++ + V.toString name ++ "' while checking types." + + T.App t ts -> do + t' <- go t + ts' <- mapM go ts + return $ foldl (<|) t' ts' + + T.Record fields ext -> do + fields' <- Traverse.traverse (mapM go) (T.fieldMap fields) + ext' <- case ext of + Nothing -> return $ termN EmptyRecord1 + Just x -> go x + return $ termN (Record1 fields' ext') diff --git a/src/Type/ExtraChecks.hs b/src/Type/ExtraChecks.hs new file mode 100644 --- /dev/null +++ b/src/Type/ExtraChecks.hs @@ -0,0 +1,155 @@ +{-# OPTIONS_GHC -Wall #-} + +{-| This module contains checks to be run *after* type inference has completed +successfully. At that point we still need to do occurs checks and ensure that +`main` has an acceptable type. +-} +module Type.ExtraChecks (mainType, occurs, portTypes) where + +import Control.Applicative ((<$>),(<*>)) +import Control.Monad.Error +import Control.Monad.State +import qualified Data.Map as Map +import qualified Data.Traversable as Traverse +import qualified Data.UnionFind.IO as UF +import Text.PrettyPrint as P + +import qualified AST.Annotation as A +import qualified AST.Expression.Canonical as Canonical +import qualified AST.PrettyPrint as PP +import qualified AST.Type as ST +import qualified AST.Variable as V +import qualified Transform.Expression as Expr +import qualified Type.Type as TT +import qualified Type.State as TS + +throw :: [Doc] -> Either [Doc] a +throw err = Left [ P.vcat err ] + +mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType) +mainType environment = + do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment + mainCheck environment' + where + mainCheck :: (Monad m) => Map.Map String ST.CanonicalType + -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType) + mainCheck env = + case Map.lookup "main" env of + Nothing -> return env + Just typeOfMain + | tipe `elem` acceptable -> return env + | otherwise -> throwError err + where + acceptable = [ "Graphics.Element.Element" + , "Signal.Signal Graphics.Element.Element" ] + + tipe = PP.renderPretty typeOfMain + err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)." + , P.text "Instead 'main' has type:\n" + , P.nest 4 (PP.pretty typeOfMain) + , P.text " " ] + +data Direction = In | Out + +portTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m () +portTypes expr = + case Expr.checkPorts (check In) (check Out) expr of + Left err -> throwError err + Right _ -> return () + where + check = isValid True False False + isValid isTopLevel seenFunc seenSignal direction name tipe = + case tipe of + ST.Aliased _ t -> valid t + + ST.Type v -> + case any ($ v) [ V.isJson, V.isPrimitive, V.isTuple ] of + True -> return () + False -> err "an unsupported type" + + ST.App t [] -> valid t + + ST.App (ST.Type v) [t] + | V.isSignal v -> handleSignal t + | V.isMaybe v -> valid t + | V.isArray v -> valid t + | V.isList v -> valid t + + ST.App (ST.Type v) ts + | V.isTuple v -> mapM_ valid ts + + ST.App _ _ -> err "an unsupported type" + + ST.Var _ -> err "free type variables" + + ST.Lambda _ _ -> + case direction of + In -> err "functions" + Out | seenFunc -> err "higher-order functions" + | seenSignal -> err "signals that contain functions" + | otherwise -> + forM_ (ST.collectLambdas tipe) + (isValid' True seenSignal direction name) + + ST.Record _ (Just _) -> err "extended records with free type variables" + + ST.Record fields Nothing -> + mapM_ (\(k,v) -> (,) k <$> valid v) fields + + where + isValid' = isValid False + valid = isValid' seenFunc seenSignal direction name + + handleSignal t + | seenFunc = err "functions that involve signals" + | seenSignal = err "signals-of-signals" + | isTopLevel = isValid' seenFunc True direction name t + | otherwise = err "a signal within a data stucture" + + dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg } + txt = P.text . concat + + err kind = + throw $ + [ txt [ "Type Error: the value ", dir "coming in" "sent out" + , " through port '", name, "' is invalid." ] + , txt [ "It contains ", kind, ":\n" ] + , P.nest 4 (PP.pretty tipe) <> P.text "\n" + , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ] + , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ] + , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ] + ] + +occurs :: (String, TT.Variable) -> StateT TS.SolverState IO () +occurs (name, variable) = + do vars <- liftIO $ infiniteVars [] variable + case vars of + [] -> return () + var:_ -> do + desc <- liftIO $ UF.descriptor var + case TT.structure desc of + Nothing -> + modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s } + Just _ -> + do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing }) + var' <- liftIO $ UF.fresh desc + TS.addError (A.None (P.text name)) (Just msg) var var' + where + msg = "Infinite types are not allowed" + + infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable] + infiniteVars seen var = + let go = infiniteVars (var:seen) in + if var `elem` seen + then return [var] + else do + desc <- UF.descriptor var + case TT.structure desc of + Nothing -> return [] + Just struct -> + case struct of + TT.App1 a b -> (++) <$> go a <*> go b + TT.Fun1 a b -> (++) <$> go a <*> go b + TT.Var1 a -> go a + TT.EmptyRecord1 -> return [] + TT.Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields)) diff --git a/src/Type/Fragment.hs b/src/Type/Fragment.hs new file mode 100644 --- /dev/null +++ b/src/Type/Fragment.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_GHC -Wall #-} +module Type.Fragment where + +import qualified Data.List as List +import qualified Data.Map as Map + +import Type.Type +import AST.Annotation (noneNoDocs) + +data Fragment = Fragment + { typeEnv :: Map.Map String Type + , vars :: [Variable] + , typeConstraint :: TypeConstraint + } + + +emptyFragment :: Fragment +emptyFragment = + Fragment Map.empty [] (noneNoDocs CTrue) + + +joinFragment :: Fragment -> Fragment -> Fragment +joinFragment f1 f2 = + Fragment + { typeEnv = + Map.union (typeEnv f1) (typeEnv f2) + + , vars = + vars f1 ++ vars f2 + + , typeConstraint = + typeConstraint f1 /\ typeConstraint f2 + } + + +joinFragments :: [Fragment] -> Fragment +joinFragments = + List.foldl' (flip joinFragment) emptyFragment + + +toScheme :: Fragment -> Scheme Type Variable +toScheme fragment = + Scheme [] (vars fragment) (typeConstraint fragment) (typeEnv fragment) diff --git a/src/Type/Inference.hs b/src/Type/Inference.hs new file mode 100644 --- /dev/null +++ b/src/Type/Inference.hs @@ -0,0 +1,98 @@ +module Type.Inference where + +import qualified Data.Map as Map + +import qualified Type.Type as T +import qualified Type.Environment as Env +import qualified Type.Constrain.Expression as TcExpr +import qualified Type.Solve as Solve + +import qualified AST.Annotation as A +import AST.Module as Module +import AST.Type (CanonicalType) +import qualified AST.Variable as Var +import Text.PrettyPrint +import qualified Type.State as TS +import qualified Type.ExtraChecks as Check +import Control.Arrow (first, second) +import Control.Monad.State (execStateT, forM) +import Control.Monad.Error (ErrorT, runErrorT, liftIO, throwError) + +import System.IO.Unsafe -- Possible to switch over to the ST monad instead of + -- the IO monad. I don't think that'd be worthwhile. + + +infer :: Interfaces -> CanonicalModule -> Either [Doc] (Map.Map String CanonicalType) +infer interfaces modul = + unsafePerformIO $ runErrorT $ + do (header, constraint) <- genConstraints interfaces modul + + state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState + + () <- case TS.sErrors state of + errors@(_:_) -> throwError errors + [] -> return () + + () <- Check.portTypes (program (body modul)) + + let header' = Map.delete "::" header + types = Map.difference (TS.sSavedEnv state) header' + + Check.mainType types + + +genConstraints + :: Interfaces + -> CanonicalModule + -> ErrorT [Doc] IO (Env.TypeDict, T.TypeConstraint) +genConstraints interfaces modul = + do env <- liftIO $ Env.initialEnvironment (canonicalizeAdts interfaces modul) + + ctors <- forM (Map.keys (Env.constructor env)) $ \name -> do + (_, vars, args, result) <- liftIO $ Env.freshDataScheme env name + return (name, (vars, foldr (T.==>) result args)) + + importedVars <- mapM (canonicalizeValues env) (Map.toList interfaces) + + let allTypes = concat (ctors : importedVars) + vars = concatMap (fst . snd) allTypes + header = Map.map snd (Map.fromList allTypes) + environ = A.noneNoDocs . T.CLet [ T.Scheme vars [] (A.noneNoDocs T.CTrue) header ] + + fvar <- liftIO $ T.variable T.Flexible + c <- TcExpr.constrain env (program (body modul)) (T.varN fvar) + return (header, environ c) + + +canonicalizeValues + :: Env.Environment + -> (Module.Name, Interface) + -> ErrorT [Doc] IO [(String, ([T.Variable], T.Type))] +canonicalizeValues env (moduleName, iface) = + forM (Map.toList (iTypes iface)) $ \(name,tipe) -> + do tipe' <- Env.instantiateType env tipe Map.empty + return (Module.nameToString moduleName ++ "." ++ name, tipe') + + +canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt] +canonicalizeAdts interfaces modul = + localAdts ++ importedAdts + where + localAdts :: [CanonicalAdt] + localAdts = format (Module.names modul, datatypes (body modul)) + + importedAdts :: [CanonicalAdt] + importedAdts = concatMap (format . second iAdts) (Map.toList interfaces) + + format :: (Module.Name, Module.ADTs) -> [CanonicalAdt] + format (home, adts) = + map canonical (Map.toList adts) + where + canonical :: (String, AdtInfo String) -> CanonicalAdt + canonical (name, (tvars, ctors)) = + ( toVar name + , (tvars, map (first toVar) ctors) + ) + + toVar :: String -> Var.Canonical + toVar = Var.Canonical (Var.Module home) diff --git a/src/Type/PrettyPrint.hs b/src/Type/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Type/PrettyPrint.hs @@ -0,0 +1,20 @@ +module Type.PrettyPrint where + +import Text.PrettyPrint + + +data ParensWhen = Fn | App | Never + + +class PrettyType a where + pretty :: ParensWhen -> a -> Doc + + +commaSep :: [Doc] -> Doc +commaSep docs = + sep (punctuate comma docs) + + +parensIf :: Bool -> Doc -> Doc +parensIf bool doc = + if bool then parens doc else doc diff --git a/src/Type/Solve.hs b/src/Type/Solve.hs new file mode 100644 --- /dev/null +++ b/src/Type/Solve.hs @@ -0,0 +1,195 @@ +module Type.Solve (solve) where + +import Control.Monad +import Control.Monad.State +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Traversable as Traversable +import qualified Data.UnionFind.IO as UF +import Type.Type +import Type.Unify +import qualified Type.ExtraChecks as Check +import qualified Type.State as TS +import qualified AST.Annotation as A + + +-- | Every variable has rank less than or equal to the maxRank of the pool. +-- This sorts variables into the young and old pools accordingly. +generalize :: TS.Pool -> StateT TS.SolverState IO () +generalize youngPool = do + youngMark <- TS.uniqueMark + let youngRank = TS.maxRank youngPool + insert dict var = do + descriptor <- liftIO $ UF.descriptor var + liftIO $ UF.modifyDescriptor var (\desc -> desc { mark = youngMark }) + return $ Map.insertWith (++) (rank descriptor) [var] dict + + -- Sort the youngPool variables by rank. + rankDict <- foldM insert Map.empty (TS.inhabitants youngPool) + + -- get the ranks right for each entry. + -- start at low ranks so that we only have to pass + -- over the information once. + visitedMark <- TS.uniqueMark + forM (Map.toList rankDict) $ \(poolRank, vars) -> + mapM (adjustRank youngMark visitedMark poolRank) vars + + -- For variables that have rank lowerer than youngRank, register them in + -- the old pool if they are not redundant. + let registerIfNotRedundant var = do + isRedundant <- liftIO $ UF.redundant var + if isRedundant then return var else TS.register var + + let rankDict' = Map.delete youngRank rankDict + Traversable.traverse (mapM registerIfNotRedundant) rankDict' + + -- For variables with rank youngRank + -- If rank < youngRank: register in oldPool + -- otherwise generalize + let registerIfLowerRank var = do + isRedundant <- liftIO $ UF.redundant var + case isRedundant of + True -> return () + False -> do + desc <- liftIO $ UF.descriptor var + case rank desc < youngRank of + True -> TS.register var >> return () + False -> do + let flex' = case flex desc of { Flexible -> Rigid ; other -> other } + liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' }) + + mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict) + + +-- adjust the ranks of variables such that ranks never increase as you +-- move deeper into a variable. +adjustRank :: Int -> Int -> Int -> Variable -> StateT TS.SolverState IO Int +adjustRank youngMark visitedMark groupRank var = + do descriptor <- liftIO $ UF.descriptor var + case () of + () | mark descriptor == youngMark -> + do -- Set the variable as marked first because it may be cyclic. + liftIO $ UF.modifyDescriptor var $ \desc -> + desc { mark = visitedMark } + rank' <- maybe (return groupRank) adjustTerm (structure descriptor) + liftIO $ UF.modifyDescriptor var $ \desc -> + desc { rank = rank' } + return rank' + + | mark descriptor /= visitedMark -> + do let rank' = min groupRank (rank descriptor) + liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' }) + return rank' + + | otherwise -> return (rank descriptor) + + where + adjust = adjustRank youngMark visitedMark groupRank + + adjustTerm term = + case term of + App1 a b -> max `liftM` adjust a `ap` adjust b + Fun1 a b -> max `liftM` adjust a `ap` adjust b + Var1 x -> adjust x + EmptyRecord1 -> return outermostRank + Record1 fields extension -> + do ranks <- mapM adjust (concat (Map.elems fields)) + rnk <- adjust extension + return . maximum $ rnk : ranks + + +solve :: TypeConstraint -> StateT TS.SolverState IO () +solve (A.A region constraint) = + case constraint of + CTrue -> return () + + CSaveEnv -> TS.saveLocalEnv + + CEqual term1 term2 -> do + t1 <- TS.flatten term1 + t2 <- TS.flatten term2 + unify region t1 t2 + + CAnd cs -> mapM_ solve cs + + CLet [Scheme [] fqs constraint' _] (A.A _ CTrue) -> do + oldEnv <- TS.getEnv + mapM TS.introduce fqs + solve constraint' + TS.modifyEnv (\_ -> oldEnv) + + CLet schemes constraint' -> do + oldEnv <- TS.getEnv + headers <- Map.unions `fmap` mapM (solveScheme region) schemes + TS.modifyEnv $ \env -> Map.union headers env + solve constraint' + mapM Check.occurs $ Map.toList headers + TS.modifyEnv (\_ -> oldEnv) + + CInstance name term -> do + env <- TS.getEnv + freshCopy <- + case Map.lookup name env of + Just tipe -> TS.makeInstance tipe + Nothing + | List.isPrefixOf "Native." name -> liftIO (variable Flexible) + | otherwise -> + error ("Could not find '" ++ name ++ "' when solving type constraints.") + + t <- TS.flatten term + unify region freshCopy t + +solveScheme :: A.Region -> TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable) +solveScheme region scheme = + case scheme of + Scheme [] [] constraint header -> do + solve constraint + Traversable.traverse TS.flatten header + + Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do + let quantifiers = rigidQuantifiers ++ flexibleQuantifiers + oldPool <- TS.getPool + + -- fill in a new pool when working on this scheme's constraints + freshPool <- TS.nextRankPool + TS.switchToPool freshPool + mapM TS.introduce quantifiers + header' <- Traversable.traverse TS.flatten header + solve constraint + + allDistinct region rigidQuantifiers + youngPool <- TS.getPool + TS.switchToPool oldPool + generalize youngPool + mapM (isGeneric region) rigidQuantifiers + return header' + + +-- Checks that all of the given variables belong to distinct equivalence classes. +-- Also checks that their structure is Nothing, so they represent a variable, not +-- a more complex term. +allDistinct :: A.Region -> [Variable] -> StateT TS.SolverState IO () +allDistinct region vars = do + seen <- TS.uniqueMark + let check var = do + desc <- liftIO $ UF.descriptor var + case structure desc of + Just _ -> TS.addError region (Just msg) var var + where msg = "Cannot generalize something that is not a type variable." + + Nothing -> do + if mark desc == seen + then let msg = "Duplicate variable during generalization." + in TS.addError region (Just msg) var var + else return () + liftIO $ UF.setDescriptor var (desc { mark = seen }) + mapM_ check vars + +-- Check that a variable has rank == noRank, meaning that it can be generalized. +isGeneric :: A.Region -> Variable -> StateT TS.SolverState IO () +isGeneric region var = do + desc <- liftIO $ UF.descriptor var + if rank desc == noRank + then return () + else let msg = "Unable to generalize a type variable. It is not unranked." + in TS.addError region (Just msg) var var diff --git a/src/Type/State.hs b/src/Type/State.hs new file mode 100644 --- /dev/null +++ b/src/Type/State.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE FlexibleContexts #-} +module Type.State where + +import Control.Applicative ( (<$>), (<*>), Applicative, (<|>) ) +import Control.Monad.State +import qualified Data.Map as Map +import qualified Data.Traversable as Traversable +import qualified Data.UnionFind.IO as UF + +import qualified AST.Annotation as A +import AST.PrettyPrint +import Text.PrettyPrint as P +import Type.Type + +-- Pool +-- Holds a bunch of variables +-- The rank of each variable is less than or equal to the pool's "maxRank" +-- The young pool exists to make it possible to identify these vars in constant time. + +data Pool = Pool + { maxRank :: Int + , inhabitants :: [Variable] + } + + +emptyPool :: Pool +emptyPool = + Pool + { maxRank = outermostRank + , inhabitants = [] + } + + +type Env = Map.Map String Variable + + +-- Keeps track of the environment, type variable pool, and a list of errors +data SolverState = SS + { sEnv :: Env + , sSavedEnv :: Env + , sPool :: Pool + , sMark :: Int + , sErrors :: [P.Doc] + } + + +initialState :: SolverState +initialState = + SS + { sEnv = Map.empty + , sSavedEnv = Map.empty + , sPool = emptyPool + , sMark = noMark + 1 -- The mark must never be equal to noMark! + , sErrors = [] + } + + +modifyEnv :: (MonadState SolverState m) => (Env -> Env) -> m () +modifyEnv f = + modify $ \state -> state { sEnv = f (sEnv state) } + + +modifyPool :: (MonadState SolverState m) => (Pool -> Pool) -> m () +modifyPool f = + modify $ \state -> state { sPool = f (sPool state) } + + +addError + :: A.Region + -> Maybe String + -> UF.Point Descriptor + -> UF.Point Descriptor + -> StateT SolverState IO () +addError region hint t1 t2 = + do err <- liftIO makeError + modify $ \state -> state { sErrors = err : sErrors state } + where + makeError = do + t1' <- pretty <$> toSrcType t1 + t2' <- pretty <$> toSrcType t2 + return . foldr ($+$) P.empty $ + [ P.text "Type mismatch between the following types" <+> pretty region <> P.text ":" + , P.text "" + , P.nest 8 t1' + , P.text "" + , P.nest 8 t2' + , P.text "" + , maybe P.empty (P.nest 4 . P.text) hint + , P.text " It is related to the following expression:" + , P.text "" + , P.nest 8 $ A.getRegionDocs region + ] + + +switchToPool :: (MonadState SolverState m) => Pool -> m () +switchToPool pool = + modifyPool (\_ -> pool) + + +getPool :: StateT SolverState IO Pool +getPool = + gets sPool + + +getEnv :: StateT SolverState IO Env +getEnv = + gets sEnv + + +saveLocalEnv :: StateT SolverState IO () +saveLocalEnv = + do env <- sEnv <$> get + modify $ \state -> state { sSavedEnv = env } + + +uniqueMark :: StateT SolverState IO Int +uniqueMark = + do state <- get + let mark = sMark state + put $ state { sMark = mark + 1 } + return mark + + +nextRankPool :: StateT SolverState IO Pool +nextRankPool = + do pool <- getPool + return $ Pool { maxRank = maxRank pool + 1, inhabitants = [] } + + +register :: Variable -> StateT SolverState IO Variable +register variable = + do modifyPool $ \pool -> pool { inhabitants = variable : inhabitants pool } + return variable + + +introduce :: Variable -> StateT SolverState IO Variable +introduce variable = + do pool <- getPool + liftIO $ UF.modifyDescriptor variable (\desc -> desc { rank = maxRank pool }) + register variable + + +flatten :: Type -> StateT SolverState IO Variable +flatten term = + case term of + VarN maybeAlias v -> + do liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = maybeAlias <|> alias desc } + return v + + TermN maybeAlias t -> + do flatStructure <- traverseTerm flatten t + pool <- getPool + var <- liftIO . UF.fresh $ Descriptor + { structure = Just flatStructure + , rank = maxRank pool + , flex = Flexible + , name = Nothing + , copy = Nothing + , mark = noMark + , alias = maybeAlias + } + register var + + +makeInstance :: Variable -> StateT SolverState IO Variable +makeInstance var = + do alreadyCopied <- uniqueMark + freshVar <- makeCopy alreadyCopied var + restore alreadyCopied var + return freshVar + + +makeCopy :: Int -> Variable -> StateT SolverState IO Variable +makeCopy alreadyCopied variable = do + desc <- liftIO $ UF.descriptor variable + case () of + () | mark desc == alreadyCopied -> + case copy desc of + Just v -> return v + Nothing -> error $ "Error copying type variable. This should be impossible." ++ + " Please report an error to the github repo!" + + | rank desc /= noRank || flex desc == Constant -> + return variable + + | otherwise -> do + pool <- getPool + newVar <- liftIO $ UF.fresh $ Descriptor + { structure = Nothing + , rank = maxRank pool + , mark = noMark + , flex = case flex desc of + Is s -> Is s + _ -> Flexible + , copy = Nothing + , name = case flex desc of + Rigid -> Nothing + _ -> name desc + , alias = Nothing + } + register newVar + + -- Link the original variable to the new variable. This lets us + -- avoid making multiple copies of the variable we are instantiating. + -- + -- Need to do this before recursively copying the structure of + -- the variable to avoid looping on cyclic terms. + liftIO $ UF.modifyDescriptor variable $ \desc -> + desc { mark = alreadyCopied, copy = Just newVar } + + -- Now we recursively copy the structure of the variable. + -- We have already marked the variable as copied, so we + -- will not repeat this work or crawl this variable again. + case structure desc of + Nothing -> return newVar + Just term -> do + newTerm <- traverseTerm (makeCopy alreadyCopied) term + liftIO $ UF.modifyDescriptor newVar $ \desc -> + desc { structure = Just newTerm } + return newVar + + +restore :: Int -> Variable -> StateT SolverState IO Variable +restore alreadyCopied variable = + do desc <- liftIO $ UF.descriptor variable + case mark desc /= alreadyCopied of + True -> return variable + False -> + do restoredStructure <- + Traversable.traverse (traverseTerm (restore alreadyCopied)) (structure desc) + liftIO $ UF.modifyDescriptor variable $ \desc -> + desc { mark = noMark, rank = noRank, structure = restoredStructure } + return variable + + +traverseTerm :: (Monad f, Applicative f) => (a -> f b) -> Term1 a -> f (Term1 b) +traverseTerm f term = + case term of + App1 a b -> App1 <$> f a <*> f b + Fun1 a b -> Fun1 <$> f a <*> f b + Var1 x -> Var1 <$> f x + EmptyRecord1 -> return EmptyRecord1 + Record1 fields ext -> + Record1 <$> Traversable.traverse (mapM f) fields <*> f ext + diff --git a/src/Type/Type.hs b/src/Type/Type.hs new file mode 100644 --- /dev/null +++ b/src/Type/Type.hs @@ -0,0 +1,513 @@ +module Type.Type where + +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.UnionFind.IO as UF +import Type.PrettyPrint +import Text.PrettyPrint as P +import System.IO.Unsafe +import Control.Applicative ((<$>),(<*>)) +import Control.Monad.State (StateT, get, put, execStateT, runStateT) +import Control.Monad.Error (ErrorT, Error, liftIO) +import Data.Traversable (traverse) +import AST.Annotation +import qualified AST.PrettyPrint as PP +import qualified AST.Type as T +import qualified AST.Variable as Var + + +data Term1 a + = App1 a a + | Fun1 a a + | Var1 a + | EmptyRecord1 + | Record1 (Map.Map String [a]) a + + +data TermN a + = VarN (Maybe Var.Canonical) a + | TermN (Maybe Var.Canonical) (Term1 (TermN a)) + + +varN :: a -> TermN a +varN = VarN Nothing + + +termN :: (Term1 (TermN a)) -> TermN a +termN = TermN Nothing + + +record :: Map.Map String [TermN a] -> TermN a -> TermN a +record fs rec = termN (Record1 fs rec) + + +type Type = TermN Variable + + +type Variable = UF.Point Descriptor + + +type SchemeName = String + + +type TypeName = Var.Canonical + + +type Constraint a b = Located (BasicConstraint a b) + + +data BasicConstraint a b + = CTrue + | CSaveEnv + | CEqual a a + | CAnd [Constraint a b] + | CLet [Scheme a b] (Constraint a b) + | CInstance SchemeName a + + +data Scheme a b = Scheme + { rigidQuantifiers :: [b] + , flexibleQuantifiers :: [b] + , constraint :: Constraint a b + , header :: Map.Map String a + } + + +type TypeConstraint = Constraint Type Variable + +type TypeScheme = Scheme Type Variable + + +monoscheme :: Map.Map String a -> Scheme a b +monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers + + +infixl 8 /\ + +(/\) :: Constraint a b -> Constraint a b -> Constraint a b +a@(A _ c1) /\ b@(A _ c2) = + case (c1, c2) of + (CTrue, _) -> b + (_, CTrue) -> a + _ -> mergeOldDocs a b (CAnd [a,b]) + + +infixr 9 ==> + +(==>) :: Type -> Type -> Type +a ==> b = termN (Fun1 a b) + + +(<|) :: TermN a -> TermN a -> TermN a +f <| a = termN (App1 f a) + + +data Descriptor = Descriptor + { structure :: Maybe (Term1 Variable) + , rank :: Int + , flex :: Flex + , name :: Maybe TypeName + , copy :: Maybe Variable + , mark :: Int + , alias :: Maybe Var.Canonical + } + + +noRank :: Int +noRank = -1 + + +outermostRank :: Int +outermostRank = 0 + + +noMark :: Int +noMark = 0 + + +initialMark :: Int +initialMark = 1 + + +data Flex + = Rigid + | Flexible + | Constant + | Is SuperType + deriving (Eq) + + +data SuperType + = Number + | Comparable + | Appendable + deriving (Eq) + + +namedVar :: Flex -> Var.Canonical -> IO Variable +namedVar flex name = UF.fresh $ Descriptor + { structure = Nothing + , rank = noRank + , flex = flex + , name = Just name + , copy = Nothing + , mark = noMark + , alias = Nothing + } + + +variable :: Flex -> IO Variable +variable flex = UF.fresh $ Descriptor + { structure = Nothing + , rank = noRank + , flex = flex + , name = Nothing + , copy = Nothing + , mark = noMark + , alias = Nothing + } + + +-- ex qs constraint == exists qs. constraint +ex :: [Variable] -> TypeConstraint -> TypeConstraint +ex fqs constraint@(A ann _) = + A ann $ CLet [Scheme [] fqs constraint Map.empty] (A ann CTrue) + + +-- fl qs constraint == forall qs. constraint +fl :: [Variable] -> TypeConstraint -> TypeConstraint +fl rqs constraint@(A ann _) = + A ann $ CLet [Scheme rqs [] constraint Map.empty] (A ann CTrue) + + +exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint +exists f = + do v <- liftIO $ variable Flexible + ex [v] <$> f (varN v) + + +existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint +existsNumber f = + do v <- liftIO $ variable (Is Number) + ex [v] <$> f (varN v) + + +-- TYPES TO PRETTY STRINGS + +instance PrettyType a => PrettyType (UF.Point a) where + pretty when point = + unsafePerformIO $ fmap (pretty when) (UF.descriptor point) + + +instance PrettyType t => PrettyType (Annotated a t) where + pretty when (A _ e) = + pretty when e + + +instance PrettyType a => PrettyType (Term1 a) where + pretty when term = + let prty = pretty Never in + case term of + App1 f x -> + parensIf needed (px <+> pretty App x) + where + px = prty f + needed = case when of + App -> True + _ -> False + + Fun1 arg body -> + parensIf needed (pretty Fn arg <+> P.text "->" <+> prty body) + where + needed = case when of + Never -> False + _ -> True + + Var1 x -> prty x + + EmptyRecord1 -> P.braces P.empty + + Record1 fields ext -> + P.braces (extend <+> commaSep prettyFields) + where + prettyExt = prty ext + extend | P.render prettyExt == "{}" = P.empty + | otherwise = prettyExt <+> P.text "|" + mkPretty f t = P.text f <+> P.text ":" <+> prty t + prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields) + + +instance PrettyType a => PrettyType (TermN a) where + pretty when term = + case term of + VarN alias x -> either alias (pretty when x) + TermN alias t1 -> either alias (pretty when t1) + where + either maybeAlias doc = + case maybeAlias of + Just alias -> PP.pretty alias + Nothing -> doc + + +instance PrettyType Descriptor where + pretty when desc = do + case (alias desc, structure desc, name desc) of + (Just name, _, _) -> PP.pretty name + (_, Just term, _) -> pretty when term + (_, _, Just name) + | Var.isTuple name -> + P.parens . P.text $ replicate (read (drop 6 (Var.toString name)) - 1) ',' + | otherwise -> + P.text (Var.toString name) + + _ -> P.text "?" + + +instance (PrettyType a, PrettyType b) => PrettyType (BasicConstraint a b) where + pretty _ constraint = + let prty = pretty Never in + case constraint of + CTrue -> P.text "True" + CSaveEnv -> P.text "SaveTheEnvironment!!!" + CEqual a b -> prty a <+> P.text "=" <+> prty b + CAnd [] -> P.text "True" + + CAnd cs -> + P.parens . P.sep $ P.punctuate (P.text " and") (map (pretty Never) cs) + + CLet [Scheme [] fqs constraint header] (A _ CTrue) | Map.null header -> + P.sep [ binder, pretty Never c ] + where + mergeExists vs (A _ c) = + case c of + CLet [Scheme [] fqs' c' _] (A _ CTrue) -> mergeExists (vs ++ fqs') c' + _ -> (vs, c) + + (fqs', c) = mergeExists fqs constraint + + binder = if null fqs' then P.empty else + P.text "\x2203" <+> P.hsep (map (pretty Never) fqs') <> P.text "." + + CLet schemes constraint -> + P.fsep [ P.hang (P.text "let") 4 (P.brackets . commaSep $ map (pretty Never) schemes) + , P.text "in", pretty Never constraint ] + + CInstance name tipe -> + P.text name <+> P.text "<" <+> prty tipe + + +instance (PrettyType a, PrettyType b) => PrettyType (Scheme a b) where + pretty _ (Scheme rqs fqs (A _ constraint) headers) = + P.sep [ forall, cs, headers' ] + where + prty = pretty Never + + forall = if null rqs && null fqs then P.empty else + P.text "\x2200" <+> frees <+> rigids + + frees = P.hsep $ map prty fqs + rigids = if null rqs then P.empty else P.braces . P.hsep $ map prty rqs + + cs = case constraint of + CTrue -> P.empty + CAnd [] -> P.empty + _ -> P.brackets (pretty Never constraint) + + headers' = if Map.size headers > 0 then dict else P.empty + dict = P.parens . commaSep . map prettyPair $ Map.toList headers + prettyPair (n,t) = P.text n <+> P.text ":" <+> pretty Never t + + +extraPretty :: (PrettyType t, Crawl t) => t -> IO Doc +extraPretty t = pretty Never <$> addNames t + + +-- ADDING NAMES TO TYPES + +addNames :: (Crawl t) => t -> IO t +addNames value = do + (rawVars, _, _, _) <- execStateT (crawl getNames value) ([], 0, 0, 0) + let vars = map head . List.group $ List.sort rawVars + suffix s = map (++s) (map (:[]) ['a'..'z']) + allVars = concatMap suffix $ ["","'","_"] ++ map show [ (0 :: Int) .. ] + okayVars = filter (`notElem` vars) allVars + runStateT (crawl rename value) (okayVars, 0, 0, 0) + return value + where + getNames desc state@(vars, a, b, c) = + let name' = name desc in + case name' of + Just (Var.Canonical _ var) -> (name', (var:vars, a, b, c)) + _ -> (name', state) + + rename desc state@(vars, a, b, c) = + case name desc of + Just var -> (Just var, state) + Nothing -> + case flex desc of + Is Number -> (local $ "number" ++ replicate a '\'', (vars, a+1, b, c)) + Is Comparable -> (local $ "comparable" ++ replicate b '\'', (vars, a, b+1, c)) + Is Appendable -> (local $ "appendable" ++ replicate c '\'', (vars, a, b, c+1)) + _ -> (local $ head vars, (tail vars, a, b, c)) + where + local v = Just (Var.local v) + + +-- CRAWLING OVER TYPES + +type CrawlState = ([String], Int, Int, Int) + + +-- Code for traversing all the type data-structures and giving +-- names to the variables embedded deep in there. +class Crawl t where + crawl :: (Descriptor -> CrawlState -> (Maybe TypeName, CrawlState)) + -> t + -> StateT CrawlState IO t + + +instance Crawl e => Crawl (Annotated a e) where + crawl nextState (A ann e) = A ann <$> crawl nextState e + + +instance (Crawl t, Crawl v) => Crawl (BasicConstraint t v) where + crawl nextState constraint = + let rnm = crawl nextState in + case constraint of + CTrue -> return CTrue + CSaveEnv -> return CSaveEnv + CEqual a b -> CEqual <$> rnm a <*> rnm b + CAnd cs -> CAnd <$> crawl nextState cs + CLet schemes c -> CLet <$> crawl nextState schemes <*> crawl nextState c + CInstance name tipe -> CInstance name <$> rnm tipe + + +instance Crawl a => Crawl [a] where + crawl nextState list = mapM (crawl nextState) list + + +instance (Crawl t, Crawl v) => Crawl (Scheme t v) where + crawl nextState (Scheme rqs fqs c headers) = + let rnm = crawl nextState + in + Scheme + <$> rnm rqs + <*> rnm fqs + <*> crawl nextState c + <*> return headers + + +instance Crawl t => Crawl (TermN t) where + crawl nextState tipe = + case tipe of + VarN a x -> + VarN a <$> crawl nextState x + + TermN a term -> + TermN a <$> crawl nextState term + + +instance Crawl t => Crawl (Term1 t) where + crawl nextState term = + let rnm = crawl nextState in + case term of + App1 a b -> App1 <$> rnm a <*> rnm b + Fun1 a b -> Fun1 <$> rnm a <*> rnm b + Var1 a -> Var1 <$> rnm a + EmptyRecord1 -> return EmptyRecord1 + Record1 fields ext -> + Record1 <$> traverse (mapM rnm) fields <*> rnm ext + + +instance Crawl a => Crawl (UF.Point a) where + crawl nextState point = + do desc <- liftIO $ UF.descriptor point + desc' <- crawl nextState desc + liftIO $ UF.setDescriptor point desc' + return point + + +instance Crawl Descriptor where + crawl nextState desc = + do state <- get + let (name', state') = nextState desc state + structure' <- traverse (crawl nextState) (structure desc) + put state' + return $ desc { name = name', structure = structure' } + + +toSrcType :: Variable -> IO T.CanonicalType +toSrcType var = + go =<< addNames var + where + go v = + do desc <- UF.descriptor v + srcType <- maybe (backupSrcType desc) termToSrcType (structure desc) + return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc) + + backupSrcType desc = + case name desc of + Just v@(Var.Canonical _ x@(c:_)) + | Char.isLower c -> return (T.Var x) + | otherwise -> return $ T.Type v + + _ -> error $ concat + [ "Problem converting the following type " + , "from a type-checker type to a source-syntax type:" + , P.render (pretty Never var) ] + + termToSrcType term = + case term of + App1 a b -> do + a' <- go a + b' <- go b + case a' of + T.App f args -> return $ T.App f (args ++ [b']) + _ -> return $ T.App a' [b'] + + Fun1 a b -> T.Lambda <$> go a <*> go b + + Var1 a -> go a + + EmptyRecord1 -> return $ T.Record [] Nothing + + Record1 tfields extension -> do + fields' <- traverse (mapM go) tfields + let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ] + ext' <- dealias <$> go extension + return $ case ext' of + T.Record fs ext -> T.Record (fs ++ fields) ext + T.Var _ -> T.Record fields (Just ext') + _ -> error "Used toSrcType on a type that is not well-formed" + + dealias :: T.CanonicalType -> T.CanonicalType + dealias t = + case t of + T.Aliased _ t' -> t' + _ -> t + + +data AppStructure = List Variable | Tuple [Variable] | Other + + +collectApps :: Variable -> IO AppStructure +collectApps var = go [] var + where + go vars var = do + desc <- UF.descriptor var + case (structure desc, vars) of + (Nothing, [v]) -> + case name desc of + Just n | Var.isList n -> return (List v) + _ -> return Other + + (Nothing, vs) -> + case name desc of + Just n | Var.isTuple n -> return (Tuple vs) + _ -> return Other + + (Just term, _) -> + case term of + App1 a b -> go (vars ++ [b]) a + _ -> return Other diff --git a/src/Type/Unify.hs b/src/Type/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Type/Unify.hs @@ -0,0 +1,348 @@ +module Type.Unify (unify) where + +import Control.Applicative ((<|>)) +import Control.Monad.State +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Data.Maybe as Maybe +import qualified Data.UnionFind.IO as UF +import qualified AST.Annotation as A +import qualified AST.Variable as Var +import qualified Type.State as TS +import Type.Type +import Type.PrettyPrint +import Text.PrettyPrint (render) +import Elm.Utils ((|>)) + + +unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO () +unify region variable1 variable2 = do + equivalent <- liftIO $ UF.equivalent variable1 variable2 + if equivalent + then return () + else actuallyUnify region variable1 variable2 + + +actuallyUnify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO () +actuallyUnify region variable1 variable2 = do + desc1 <- liftIO $ UF.descriptor variable1 + desc2 <- liftIO $ UF.descriptor variable2 + let unify' = unify region + + (name', flex', rank', alias') = combinedDescriptors desc1 desc2 + + merge1 :: StateT TS.SolverState IO () + merge1 = liftIO $ do + if rank desc1 < rank desc2 then UF.union variable2 variable1 + else UF.union variable1 variable2 + UF.modifyDescriptor variable1 $ \desc -> + desc { structure = structure desc1 + , flex = flex' + , name = name' + , alias = alias' + } + + merge2 :: StateT TS.SolverState IO () + merge2 = liftIO $ do + if rank desc1 < rank desc2 then UF.union variable2 variable1 + else UF.union variable1 variable2 + UF.modifyDescriptor variable2 $ \desc -> + desc { structure = structure desc2 + , flex = flex' + , name = name' + , alias = alias' + } + + merge = if rank desc1 < rank desc2 then merge1 else merge2 + + fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable + fresh structure = do + v <- liftIO . UF.fresh $ Descriptor + { structure = structure + , rank = rank' + , flex = flex' + , name = name' + , copy = Nothing + , mark = noMark + , alias = alias' + } + TS.register v + + flexAndUnify v = do + liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible } + unify' variable1 variable2 + + unifyNumber svar (Var.Canonical home name) = + case home of + Var.BuiltIn | name `elem` ["Int","Float"] -> flexAndUnify svar + Var.Local | List.isPrefixOf "number" name -> flexAndUnify svar + _ -> + let hint = "Looks like something besides an Int or Float is being used as a number." + in + TS.addError region (Just hint) variable1 variable2 + + comparableError maybe = + TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2 + where + msg = + "Looks like you want something comparable, but the only valid comparable\n\ + \types are Int, Float, Char, String, lists, or tuples." + + appendableError maybe = + TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2 + where + msg = + "Looks like you want something appendable, but the only Strings, Lists,\n\ + \and Text can be appended with the (++) operator." + + unifyComparable v (Var.Canonical home name) = + case home of + Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v + Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v + _ -> comparableError Nothing + + unifyComparableStructure varSuper varFlex = + do struct <- liftIO $ collectApps varFlex + case struct of + Other -> comparableError Nothing + List v -> do flexAndUnify varSuper + unify' v =<< liftIO (variable $ Is Comparable) + Tuple vs + | length vs > 6 -> + comparableError $ Just "Cannot compare a tuple with more than 6 elements." + | otherwise -> + do flexAndUnify varSuper + cmpVars <- liftIO $ forM [1..length vs] $ \_ -> variable (Is Comparable) + zipWithM_ unify' vs cmpVars + + unifyAppendable varSuper varFlex = + do struct <- liftIO $ collectApps varFlex + case struct of + List _ -> flexAndUnify varSuper + _ -> appendableError Nothing + + rigidError var = + TS.addError region (Just hint) variable1 variable2 + where + hint = + "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++ + "The problem probably relates to the type variable being shared between a\n\ + \top-level type annotation and a related let-bound type annotation." + + superUnify = + case (flex desc1, flex desc2, name desc1, name desc2) of + (Is super1, Is super2, _, _) + | super1 == super2 -> merge + (Is Number, Is Comparable, _, _) -> merge1 + (Is Comparable, Is Number, _, _) -> merge2 + + (Is Number, _, _, Just name) -> unifyNumber variable1 name + (_, Is Number, Just name, _) -> unifyNumber variable2 name + + (Is Comparable, _, _, Just name) -> unifyComparable variable1 name + (_, Is Comparable, Just name, _) -> unifyComparable variable2 name + (Is Comparable, _, _, _) -> unifyComparableStructure variable1 variable2 + (_, Is Comparable, _, _) -> unifyComparableStructure variable2 variable1 + + (Is Appendable, _, _, Just name) + | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable1 + (_, Is Appendable, Just name, _) + | Var.isText name || Var.isPrim "String" name -> flexAndUnify variable2 + (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2 + (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1 + + (Rigid, _, _, _) -> rigidError variable1 + (_, Rigid, _, _) -> rigidError variable2 + _ -> TS.addError region Nothing variable1 variable2 + + case (structure desc1, structure desc2) of + (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge + (Nothing, _) | flex desc1 == Flexible -> merge2 + (_, Nothing) | flex desc2 == Flexible -> merge1 + + (Just (Var1 v), _) -> unify' v variable2 + (_, Just (Var1 v)) -> unify' v variable1 + + (Nothing, _) -> superUnify + (_, Nothing) -> superUnify + + (Just type1, Just type2) -> + case (type1,type2) of + (App1 term1 term2, App1 term1' term2') -> + do merge + unify' term1 term1' + unify' term2 term2' + (Fun1 term1 term2, Fun1 term1' term2') -> + do merge + unify' term1 term1' + unify' term2 term2' + + (EmptyRecord1, EmptyRecord1) -> + return () + + (Record1 fields ext, EmptyRecord1) | Map.null fields -> unify' ext variable2 + (EmptyRecord1, Record1 fields ext) | Map.null fields -> unify' ext variable1 + + (Record1 _ _, Record1 _ _) -> + recordUnify region fresh variable1 variable2 + + _ -> TS.addError region Nothing variable1 variable2 + + +-- RECORD UNIFICATION + +recordUnify + :: A.Region + -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable) + -> Variable + -> Variable + -> StateT TS.SolverState IO () +recordUnify region fresh variable1 variable2 = + do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1) + (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2) + + unifyOverlappingFields region fields1 fields2 + + let freshRecord fields ext = + fresh (Just (Record1 fields ext)) + + let uniqueFields1 = diffFields fields1 fields2 + let uniqueFields2 = diffFields fields2 fields1 + + let addFieldMismatchError missingFields = + let msg = fieldMismatchError missingFields + in + TS.addError region (Just msg) variable1 variable2 + + case (ext1, ext2) of + (Empty _, Empty _) -> + case Map.null uniqueFields1 && Map.null uniqueFields2 of + True -> return () + False -> TS.addError region Nothing variable1 variable2 + + (Empty var1, Extension var2) -> + case (Map.null uniqueFields1, Map.null uniqueFields2) of + (_, False) -> addFieldMismatchError uniqueFields2 + (True, True) -> unify region var1 var2 + (False, True) -> + do subRecord <- freshRecord uniqueFields1 var1 + unify region subRecord var2 + + (Extension var1, Empty var2) -> + case (Map.null uniqueFields1, Map.null uniqueFields2) of + (False, _) -> addFieldMismatchError uniqueFields1 + (True, True) -> unify region var1 var2 + (True, False) -> + do subRecord <- freshRecord uniqueFields2 var2 + unify region var1 subRecord + + (Extension var1, Extension var2) -> + case (Map.null uniqueFields1, Map.null uniqueFields2) of + (True, True) -> + unify region var1 var2 + + (True, False) -> + do subRecord <- freshRecord uniqueFields2 var2 + unify region var1 subRecord + + (False, True) -> + do subRecord <- freshRecord uniqueFields1 var1 + unify region subRecord var2 + + (False, False) -> + do record1' <- freshRecord uniqueFields1 =<< fresh Nothing + record2' <- freshRecord uniqueFields2 =<< fresh Nothing + unify region record1' var2 + unify region var1 record2' + + +unifyOverlappingFields + :: A.Region + -> Map.Map String [Variable] + -> Map.Map String [Variable] + -> StateT TS.SolverState IO () +unifyOverlappingFields region fields1 fields2 = + Map.intersectionWith (zipWith (unify region)) fields1 fields2 + |> Map.elems + |> concat + |> sequence_ + + +diffFields :: Map.Map String [a] -> Map.Map String [a] -> Map.Map String [a] +diffFields fields1 fields2 = + let eat (_:xs) (_:ys) = eat xs ys + eat xs _ = xs + in + Map.union (Map.intersectionWith eat fields1 fields2) fields1 + |> Map.filter (not . null) + + +data ExpandedRecord = ExpandedRecord + { _fields :: Map.Map String [Variable] + , _extension :: Extension + } + +data Extension = Empty Variable | Extension Variable + + +gatherFields :: Variable -> IO ExpandedRecord +gatherFields var = + do desc <- UF.descriptor var + case structure desc of + (Just (Record1 fields ext)) -> + do (ExpandedRecord deeperFields rootExt) <- gatherFields ext + return (ExpandedRecord (Map.unionWith (++) fields deeperFields) rootExt) + + (Just EmptyRecord1) -> + return (ExpandedRecord Map.empty (Empty var)) + + _ -> + return (ExpandedRecord Map.empty (Extension var)) + + +-- assumes that one of the dicts has stuff in it +fieldMismatchError :: Map.Map String a -> String +fieldMismatchError missingFields = + case Map.keys missingFields of + [] -> "" + [key] -> + "Looks like a record is missing the field '" ++ key ++ "'.\n " ++ + "Maybe there is a misspelling in a record access or record update?" + keys -> + "Looks like one record is missing fields " + ++ List.intercalate ", " (init keys) ++ ", and " ++ last keys + + +combinedDescriptors :: Descriptor -> Descriptor + -> (Maybe Var.Canonical, Flex, Int, Maybe Var.Canonical) +combinedDescriptors desc1 desc2 = + (name', flex', rank', alias') + where + rank' :: Int + rank' = min (rank desc1) (rank desc2) + + alias' :: Maybe Var.Canonical + alias' = alias desc1 <|> alias desc2 + + name' :: Maybe Var.Canonical + name' = case (name desc1, name desc2) of + (Just name1, Just name2) -> + case (flex desc1, flex desc2) of + (_, Flexible) -> Just name1 + (Flexible, _) -> Just name2 + (Is Number, Is _) -> Just name1 + (Is _, Is Number) -> Just name2 + (Is _, Is _) -> Just name1 + (_, _) -> Nothing + (Just name1, _) -> Just name1 + (_, Just name2) -> Just name2 + _ -> Nothing + + flex' :: Flex + flex' = case (flex desc1, flex desc2) of + (f, Flexible) -> f + (Flexible, f) -> f + (Is Number, Is _) -> Is Number + (Is _, Is Number) -> Is Number + (Is super, Is _) -> Is super + (_, _) -> Flexible diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,14 @@ +module Main where + +import Test.Framework + +import Test.Compiler +import Test.Property + + +main :: IO () +main = + defaultMain + [ compilerTests + , propertyTests + ] diff --git a/tests/Test/Compiler.hs b/tests/Test/Compiler.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Compiler.hs @@ -0,0 +1,73 @@ +{-# OPTIONS_GHC -W #-} +module Test.Compiler (compilerTests) where + +import qualified Data.Map as Map +import Data.Traversable (traverse) + +import System.FilePath (()) +import System.FilePath.Find (find, (==?), extension) + +import Test.Framework +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion, assertFailure, assertBool) + +import qualified Elm.Compiler as Compiler +import qualified Elm.Compiler.Module as Module + + +compilerTests :: Test +compilerTests = + buildTest $ do + goods <- testIf isSuccess =<< getElms "good" + bads <- testIf isFailure =<< getElms "bad" + return $ + testGroup "Compile Tests" + [ testGroup "Good Tests" goods + , testGroup "Bad Tests" bads + ] + + +-- GATHER ELM FILES + +getElms :: FilePath -> IO [FilePath] +getElms filePath = + find + (return True) + (extension ==? ".elm") + (testsDir filePath) + + +testsDir :: FilePath +testsDir = + "tests" "compiler" "test-files" + + +-- RUN COMPILER + +testIf + :: (Either String (Module.Interface, String) -> Assertion) + -> [FilePath] + -> IO [Test] +testIf handleResult filePaths = + traverse setupTest filePaths + where + setupTest filePath = + do source <- readFile filePath + let result = Compiler.compile "elm-lang" "core" source Map.empty + return (testCase filePath (handleResult result)) + + +-- CHECK RESULTS + +isSuccess :: Either String a -> Assertion +isSuccess result = + case result of + Right _ -> assertBool "" True + Left msg -> assertFailure msg + + +isFailure :: Either a b -> Assertion +isFailure result = + case result of + Left _ -> assertFailure "Compilation succeeded but should have failed" + Right _ -> assertBool "" True diff --git a/tests/Test/Property.hs b/tests/Test/Property.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Property.hs @@ -0,0 +1,68 @@ +module Test.Property where + +import Control.Applicative ((<*)) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit (assert) +import Test.QuickCheck +import Text.Parsec.Combinator (eof) +import Text.PrettyPrint as P + +import AST.Literal as Lit +import qualified AST.Pattern as P +import qualified AST.Variable as V +import AST.PrettyPrint (Pretty, pretty) +import Parse.Helpers (IParser, iParse) +import Parse.Literal (literal) +import qualified Parse.Pattern as Pat (expr) +import qualified Parse.Type as Type (expr) +import Test.Property.Arbitrary + + +propertyTests :: Test +propertyTests = + testGroup "Parse/Print Agreement Tests" + [ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat) + , testProperty "Literal test" $ prop_parse_print literal + , testProperty "Pattern test" $ prop_parse_print Pat.expr + , testProperty "Type test" $ prop_parse_print Type.expr + ] + + where + -- This test was autogenerated from the Pattern test and should be + -- left in all its ugly glory. + longPat = P.Data (V.Raw "I") + [ P.Literal (Lit.Chr '+') + , P.Record + [ "q7yclkcm7k_ikstrczv_" + , "wQRv6gKsvvkjw4b5F" + ,"c9'eFfhk9FTvsMnwF_D" + ,"yqxhEkHvRFwZ" + ,"o" + ,"nbUlCn3y3NnkVoxhW" + ,"iJ0MNy3KZ_lrs" + ,"ug" + ,"sHHsX" + ,"mRKs9d" + ,"o2KiCX5'ZRzHJfRi8" ] + , P.Var "su'BrrbPUK6I33Eq" + ] + + +prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool +prop_parse_print parser value = + either (const False) (== value) (parse_print parser value) + + +parse_print :: (Pretty a) => IParser a -> a -> Either String a +parse_print parser value = + let doc = + pretty value + + string = + P.renderStyle P.style { mode = P.LeftMode } doc + in + case iParse (parser <* eof) string of + Left msg -> Left (show msg) + Right x -> Right x diff --git a/tests/Test/Property/Arbitrary.hs b/tests/Test/Property/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Property/Arbitrary.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -W -fno-warn-orphans #-} +module Test.Property.Arbitrary where + +import Control.Applicative ((<$>), (<*>), pure) +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +import qualified Data.Set as Set +import qualified Parse.Helpers (reserveds) + +import qualified AST.Literal as L +import qualified AST.Pattern as P +import qualified AST.Type as T +import qualified AST.Variable as V + +instance Arbitrary V.Raw where + arbitrary = V.Raw <$> capVar + shrink (V.Raw v) = V.Raw <$> shrink v + +instance Arbitrary L.Literal where + arbitrary = + oneof + [ L.IntNum <$> arbitrary + , L.FloatNum <$> (arbitrary `suchThat` noE) + , L.Chr <$> arbitrary + -- This is too permissive + , L.Str <$> arbitrary + -- Booleans aren't actually source syntax + -- , Boolean <$> arbitrary + ] + + shrink lit = + case lit of + L.IntNum n -> L.IntNum <$> shrink n + L.FloatNum f -> L.FloatNum <$> (filter noE . shrink $ f) + L.Chr c -> L.Chr <$> shrink c + L.Str s -> L.Str <$> shrink s + L.Boolean b -> L.Boolean <$> shrink b + +noE :: Double -> Bool +noE = notElem 'e' . show + +genVector :: Int -> (Int -> Gen a) -> Gen [a] +genVector n generator = do + len <- choose (0,n) + let m = n `div` (len + 1) + vectorOf len $ generator m + +instance Arbitrary v => Arbitrary (P.Pattern v) where + arbitrary = sized pat + where + pat :: (Arbitrary v) => Int -> Gen (P.Pattern v) + pat n = + oneof + [ pure P.Anything + , P.Var <$> lowVar + , P.Record <$> (listOf1 lowVar) + , P.Literal <$> arbitrary + , P.Alias <$> lowVar <*> pat (n-1) + , P.Data <$> arbitrary <*> genVector n pat + ] + + shrink pat = + case pat of + P.Anything -> [] + P.Var v -> P.Var <$> shrinkWHead v + P.Literal l -> P.Literal <$> shrink l + P.Alias s p -> p : (P.Alias <$> shrinkWHead s <*> shrink p) + P.Data s ps -> ps ++ (P.Data <$> shrink s <*> shrink ps) + P.Record fs -> + P.Record <$> filter (all notNull) (filter notNull (shrink fs)) + where + notNull = not . null + +shrinkWHead :: Arbitrary a => [a] -> [[a]] +shrinkWHead [] = error "Should be nonempty" +shrinkWHead (x:xs) = (x:) <$> shrink xs + +instance Arbitrary v => Arbitrary (T.Type v) where + arbitrary = sized tipe + where + tipe :: Arbitrary v => Int -> Gen (T.Type v) + tipe n = + let depthTipe = tipe =<< choose (0,n) + field = (,) <$> lowVar <*> depthTipe + fields = genVector n (\m -> (,) <$> lowVar <*> tipe m) + fields1 = (:) <$> field <*> fields + depthTipes = (:) <$> depthTipe <*> genVector n tipe + in + oneof + [ T.Lambda <$> depthTipe <*> depthTipe + , T.Var <$> lowVar + , T.Type <$> arbitrary + , T.App <$> (T.Type <$> arbitrary) <*> depthTipes + , T.Record <$> fields <*> pure Nothing + , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar) + ] + + shrink tipe = + case tipe of + T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t) + T.Var _ -> [] + T.Aliased v t -> t : (T.Aliased v <$> shrink t) + T.Type v -> T.Type <$> shrink v + T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts) + T.Record fs t -> map snd fs ++ record + where + record = + case t of + Nothing -> T.Record <$> shrinkList shrinkField fs <*> pure Nothing + Just _ -> + do fields <- filter (not . null) $ shrinkList shrinkField fs + return $ T.Record fields t + + shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t + +lowVar :: Gen String +lowVar = notReserved $ (:) <$> lower <*> listOf varLetter + where + lower = elements ['a'..'z'] + +capVar :: Gen String +capVar = notReserved $ (:) <$> upper <*> listOf varLetter + where + upper = elements ['A'..'Z'] + +varLetter :: Gen Char +varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_'] + +notReserved :: Gen String -> Gen String +notReserved = flip exceptFor Parse.Helpers.reserveds + +exceptFor :: (Ord a) => Gen a -> [a] -> Gen a +exceptFor g xs = g `suchThat` notAnX + where + notAnX = flip Set.notMember xset + xset = Set.fromList xs