packages feed

elm-compiler (empty) → 0.14

raw patch · 70 files changed

+10021/−0 lines, 70 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed

Dependencies added: HUnit, QuickCheck, aeson, aeson-pretty, base, binary, blaze-html, blaze-markup, bytestring, cmdargs, containers, directory, elm-compiler, filemanip, filepath, indents, language-ecmascript, language-glsl, mtl, parsec, pretty, process, test-framework, test-framework-hunit, test-framework-quickcheck2, text, transformers, union-find, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -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.
+ elm-compiler.cabal view
@@ -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+
+ runtime/debug.js view
@@ -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;+};++}());
+ src/AST/Annotation.hs view
@@ -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+
+ src/AST/Declaration.hs view
@@ -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
+ src/AST/Expression/Canonical.hs view
@@ -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
+ src/AST/Expression/General.hs view
@@ -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 $ "<port:" ++ name ++ ">"++      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
+ src/AST/Expression/Source.hs view
@@ -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
+ src/AST/Expression/Valid.hs view
@@ -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
+ src/AST/Helpers.hs view
@@ -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 "+-/*=.$<>:&|^?%#@~!"
+ src/AST/Literal.hs view
@@ -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)
+ src/AST/Module.hs view
@@ -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
+ src/AST/Pattern.hs view
@@ -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
+ src/AST/PrettyPrint.hs view
@@ -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 ]
+ src/AST/Type.hs view
@@ -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"
+ src/AST/Variable.hs view
@@ -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
+ src/Compile.hs view
@@ -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
+ src/Docs.hs view
@@ -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 <https://github.com/elm-lang/Elm/issues>"+++-- 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 })+
+ src/Elm/Compiler.hs view
@@ -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"
+ src/Elm/Compiler/Module.hs view
@@ -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
+ src/Elm/Compiler/Type.hs view
@@ -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)
+ src/Elm/Compiler/Type/Extract.hs view
@@ -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
+ src/Elm/Compiler/Version.hs view
@@ -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
+ src/Elm/Docs.hs view
@@ -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)+
+ src/Elm/Utils.hs view
@@ -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:"+    , "    <https://github.com/elm-lang/elm-platform/issues>"+    ]
+ src/Generate/Cases.hs view
@@ -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 <https://github.com/elm-lang/Elm>."
+ src/Generate/JavaScript.hs view
@@ -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)
+ src/Generate/JavaScript/Helpers.hs view
@@ -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
+ src/Generate/JavaScript/Ports.hs view
@@ -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)))
+ src/Generate/JavaScript/Variable.hs view
@@ -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"+    ]
+ src/Parse/Binop.hs view
@@ -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." ]
+ src/Parse/Declaration.hs view
@@ -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 ]
+ src/Parse/Expression.hs view
@@ -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
+ src/Parse/Helpers.hs view
@@ -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+        }
+ src/Parse/Literal.hs view
@@ -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)
+ src/Parse/Module.hs view
@@ -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)
+ src/Parse/Parse.hs view
@@ -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 ]
+ src/Parse/Pattern.hs view
@@ -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"
+ src/Parse/Type.hs view
@@ -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
+ src/Transform/AddDefaultImports.hs view
@@ -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)
+ src/Transform/Canonicalize.hs view
@@ -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
+ src/Transform/Canonicalize/Environment.hs view
@@ -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+            }
+ src/Transform/Canonicalize/Setup.hs view
@@ -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
+ src/Transform/Canonicalize/Type.hs view
@@ -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)
+ src/Transform/Canonicalize/Variable.hs view
@@ -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+
+ src/Transform/Check.hs view
@@ -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:"
+ src/Transform/Declaration.hs view
@@ -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)
+ src/Transform/Definition.hs view
@@ -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 []
+ src/Transform/Expression.hs view
@@ -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
+ src/Transform/Interface.hs view
@@ -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))
+ src/Transform/SortDefinitions.hs view
@@ -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)
+ src/Transform/Substitute.hs view
@@ -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)
+ src/Type/Constrain/Expression.hs view
@@ -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 <? t = A region (CInstance x t)+        clet schemes c = A region (CLet schemes c)+    in+    case expr of+      Literal lit -> 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 <? tipe)+          where+            name = V.toString var++      Range lo hi ->+          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 <? (t1 ==> 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 <? ctipe)+          where+            step (t,c) (e,x) = do+                c' <- constrain env e x+                return (x ==> 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
+ src/Type/Constrain/Literal.hs view
@@ -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"
+ src/Type/Constrain/Pattern.hs view
@@ -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 ]
+ src/Type/Environment.hs view
@@ -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')
+ src/Type/ExtraChecks.hs view
@@ -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))
+ src/Type/Fragment.hs view
@@ -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)
+ src/Type/Inference.hs view
@@ -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)
+ src/Type/PrettyPrint.hs view
@@ -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
+ src/Type/Solve.hs view
@@ -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
+ src/Type/State.hs view
@@ -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+
+ src/Type/Type.hs view
@@ -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
+ src/Type/Unify.hs view
@@ -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
+ tests/Test.hs view
@@ -0,0 +1,14 @@+module Main where++import Test.Framework++import Test.Compiler+import Test.Property+++main :: IO () +main =+  defaultMain+    [ compilerTests+    , propertyTests+    ]
+ tests/Test/Compiler.hs view
@@ -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
+ tests/Test/Property.hs view
@@ -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
+ tests/Test/Property/Arbitrary.hs view
@@ -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