elm-compiler 0.14 → 0.14.1
raw patch · 21 files changed
+638/−1051 lines, 21 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Elm.Compiler: runtimeDebugPath :: IO FilePath
Files
- LICENSE +1/−1
- elm-compiler.cabal +2/−4
- runtime/debug.js +0/−604
- src/AST/Annotation.hs +62/−24
- src/AST/PrettyPrint.hs +4/−0
- src/Elm/Compiler.hs +0/−12
- src/Generate/JavaScript.hs +30/−19
- src/Generate/JavaScript/Variable.hs +6/−4
- src/Parse/Declaration.hs +33/−23
- src/Parse/Expression.hs +71/−39
- src/Parse/Helpers.hs +4/−3
- src/Parse/Module.hs +56/−48
- src/Parse/Parse.hs +48/−33
- src/Parse/Pattern.hs +10/−5
- src/Transform/AddDefaultImports.hs +1/−0
- src/Type/ExtraChecks.hs +47/−24
- src/Type/Hint.hs +35/−0
- src/Type/Inference.hs +3/−3
- src/Type/Solve.hs +150/−132
- src/Type/State.hs +9/−32
- src/Type/Unify.hs +66/−41
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012-2014, Evan Czaplicki+Copyright (c) 2012-2015, Evan Czaplicki All rights reserved.
elm-compiler.cabal view
@@ -1,6 +1,6 @@ Name: elm-compiler-Version: 0.14+Version: 0.14.1 Synopsis: Values to help with elm-package, elm-make, and elm-lang.org.@@ -27,9 +27,6 @@ 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@@ -98,6 +95,7 @@ Type.Environment, Type.ExtraChecks, Type.Fragment,+ Type.Hint, Type.Inference, Type.PrettyPrint, Type.Solve,
− runtime/debug.js
@@ -1,604 +0,0 @@-(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
@@ -4,59 +4,97 @@ import qualified Text.PrettyPrint as P import AST.PrettyPrint -data Annotated annotation expr = A annotation expr++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)+ }+ deriving (Show) -type Located expr = Annotated Region expr -none e = A (None (pretty e)) e-noneNoDocs e = A (None P.empty) e+type Located expr =+ Annotated Region expr -at :: (Pretty expr) => Parsec.SourcePos -> Parsec.SourcePos -> expr- -> Annotated Region expr++none :: (Pretty expr) => expr -> Located expr+none e =+ A (None (pretty e)) e+++noneNoDocs :: a -> Located a+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)+ where+ position loc =+ Position (Parsec.sourceLine loc) (Parsec.sourceColumn loc) ++merge :: (Pretty expr) => Located a -> Located b -> expr -> Located expr 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+ 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 :: Located a -> Located b -> c -> Located c 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])+ 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+ (Span _ _ _, _) -> s1 + (_, Span _ _ _) -> s2++ (_, _) -> None P.empty++ sameAs :: Annotated a expr -> expr' -> Annotated a expr'-sameAs (A annotation _) expr = A annotation expr+sameAs (A annotation _) expr =+ A annotation expr ++getRegionDocs :: Region -> P.Doc getRegionDocs region = case region of Span _ _ doc -> doc None doc -> doc + instance Pretty Region where pretty span = case span of@@ -68,6 +106,6 @@ 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/PrettyPrint.hs view
@@ -38,5 +38,9 @@ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ") | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ") +instance Error Doc where+ noMsg = P.empty+ strMsg = P.text+ instance ErrorList Doc where listMsg str = [ P.text str ]
src/Elm/Compiler.hs view
@@ -3,7 +3,6 @@ module Elm.Compiler ( version , parseDependencies, compile- , runtimeDebugPath ) where import Control.Monad.Error (MonadError, throwError)@@ -16,11 +15,9 @@ 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@@ -70,12 +67,3 @@ |> List.intersperse "" |> unlines |> Left----- DATA FILES--{-| Path to the debugger runtime.--}-runtimeDebugPath :: IO FilePath-runtimeDebugPath =- Utils.getAsset "compiler" Paths.getDataFileName "runtime/debug.js"
src/Generate/JavaScript.hs view
@@ -71,36 +71,47 @@ hi' <- expression hi return $ _List "range" `call` [lo',hi'] - Access e x ->+ Access e field -> do e' <- expression e- return $ DotRef () e' (var x)+ return $ DotRef () e' (var (Var.varName field)) - Remove e x ->+ Remove e field -> do e' <- expression e- return $ _Utils "remove" `call` [string x, e']+ return $ _Utils "remove" `call` [ string (Var.varName field), e' ] - Insert e x v ->- do v' <- expression v+ Insert e field value ->+ do value' <- expression value e' <- expression e- return $ _Utils "insert" `call` [string x, v', e']+ return $ _Utils "insert" `call` [ string (Var.varName field), value', e' ] - Modify e fs ->+ Modify e fields -> 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']+ fields' <-+ forM fields $ \(field, value) ->+ do value' <- expression value+ return $ ArrayLit () [ string (Var.varName field), value' ] + return $ _Utils "replace" `call` [ArrayLit () fields', e']+ Record fields ->- do fields' <- forM fields $ \(f,e) -> do- (,) f <$> expression e- let fieldMap = List.foldl' combine Map.empty fields'+ do fields' <-+ forM fields $ \(field, e) ->+ (,) (Var.varName field) <$> 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+ combine record (field, value) =+ Map.insertWith (++) field [value] record++ 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
src/Generate/JavaScript/Variable.hs view
@@ -33,9 +33,11 @@ varName :: String -> String-varName x = map (swap '\'' '$') x'- where- x' = if Set.member x jsReserveds then '$' : x else x+varName name =+ let saferName =+ if Set.member name jsReserveds then '$' : name else name+ in+ map (swap '\'' '$') saferName value :: Module.Name -> String -> JS.Expression ()@@ -56,7 +58,7 @@ , "interface", "let", "package", "private", "protected", "public" , "static", "yield" -- reserved by the Elm runtime system- , "Elm", "ElmRuntime"+ , "Elm" , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9" , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9" ]
src/Parse/Declaration.hs view
@@ -21,29 +21,32 @@ typeDecl :: IParser D.SourceDecl typeDecl =- do reserved "type" <?> "type declaration"- forcedWS- isAlias <- optionMaybe (string "alias" >> forcedWS)+ do try (reserved "type") <?> "type declaration"+ forcedWS+ isAlias <- optionMaybe (string "alias" >> forcedWS) - name <- capVar- args <- spacePrefix lowVar- padded equals+ name <- capVar+ args <- spacePrefix lowVar+ padded equals - case isAlias of- Just _ ->- do tipe <- Type.expr <?> "a type"- return (D.TypeAlias name args tipe)+ 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+ 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 ]+ assoc <-+ choice+ [ try (reserved "infixl") >> return D.L+ , try (reserved "infixr") >> return D.R+ , try (reserved "infix") >> return D.N+ ] forcedWS n <- digit forcedWS@@ -52,10 +55,17 @@ 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 ]+ 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
@@ -139,62 +139,94 @@ -------- Normal Expressions -------- binaryExpr :: IParser Source.Expr-binaryExpr = Binop.binops appExpr lastExpr anyOp- where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])- <|> lambdaExpr+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)- ]+ifExpr =+ do try (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+ 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)+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)+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+letExpr =+ do try (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)+caseExpr =+ do try (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 =
src/Parse/Helpers.hs view
@@ -95,8 +95,10 @@ reserved :: String -> IParser String reserved word =- (try (string word >> notFollowedBy innerVarChar) >> return word)- <?> "reserved word '" ++ word ++ "'"+ expecting ("reserved word '" ++ word ++ "'") $+ do string word+ notFollowedBy innerVarChar+ return word -- INFIX OPERATORS@@ -114,7 +116,6 @@ guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ]) case op of "." -> notFollowedBy lower >> return op- "\8728" -> return "." _ -> return op
src/Parse/Module.hs view
@@ -8,49 +8,51 @@ 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)+ 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+ do optional freshLine+ (names, exports) <-+ option (["Main"], Var.openListing) (header `followedBy` freshLine)+ imports' <- imports+ return $ Module.HeaderAndImports names exports imports' + 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)+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')))+imports =+ many (import' `followedBy` freshLine) + import' :: IParser (Module.Name, Module.ImportMethod) import' =- do reserved "import"- whitespace- names <- dotSep1 capVar- (,) names <$> option (Module.As (intercalate "." names)) method+ do try (reserved "import")+ whitespace+ names <- dotSep1 capVar+ (,) names <$> option (Module.As (intercalate "." names)) method where method :: IParser Module.ImportMethod method = as' <|> importing'@@ -64,25 +66,31 @@ 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+ 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)+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)+ 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
@@ -14,51 +14,66 @@ 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+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+ 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+ 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+ 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)- ]+ 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 ]- ++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 ]+ Right result ->+ Right result++ Left err ->+ Left [ P.text $ "Parse error at " ++ show err ]
src/Parse/Pattern.hs view
@@ -25,12 +25,17 @@ 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+asPattern pattern =+ do var <- optionMaybe (try (whitespace >> reserved "as") >> whitespace >> lowVar)+ case var of+ Just v ->+ return (P.Alias v pattern)++ Nothing ->+ return pattern+ record :: IParser P.RawPattern record = P.Record <$> brackets (commaSep1 lowVar)
src/Transform/AddDefaultImports.hs view
@@ -22,6 +22,7 @@ defaultImports = Map.fromList [ ["Basics"] ==> ([], Var.openListing)+ , ["List"] ==> ([], Var.Listing [Var.Value "::"] False) , ["Maybe"] ==> ([], Var.Listing [maybe] False) , ["Result"] ==> ([], Var.Listing [result] False) , ["Signal"] ==> ([], Var.Listing [signal] False)
src/Type/ExtraChecks.hs view
@@ -20,37 +20,55 @@ import qualified AST.Type as ST import qualified AST.Variable as V import qualified Transform.Expression as Expr+import qualified Type.Hint as Hint import qualified Type.Type as TT import qualified Type.State as TS + throw :: [Doc] -> Either [Doc] a-throw err = Left [ P.vcat err ]+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'+ 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+ :: (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+ | otherwise -> throwError [ err ] where- acceptable = [ "Graphics.Element.Element"- , "Signal.Signal Graphics.Element.Element" ]+ acceptable =+ [ "Graphics.Element.Element"+ , "Signal.Signal Graphics.Element.Element"+ , "Html.Html"+ , "Signal.Signal Html.Html"+ ] 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 " " ] + err =+ P.vcat+ [ P.text "Type Error: 'main' must have one of the following types:"+ , P.text " "+ , P.text " Element, Html, Signal Element, Signal Html"+ , P.text " "+ , 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@@ -120,20 +138,25 @@ , 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'+ do vars <- liftIO $ infiniteVars [] variable+ case vars of+ [] ->+ return ()++ var : _ ->+ do desc <- liftIO $ UF.descriptor var+ case TT.structure desc of+ Nothing ->+ TS.addHint (P.text msg)++ Just _ ->+ do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })+ var' <- liftIO $ UF.fresh desc+ hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'+ TS.addHint hint where msg = "Infinite types are not allowed"
+ src/Type/Hint.hs view
@@ -0,0 +1,35 @@+module Type.Hint where++import Control.Applicative ( (<$>) )+import qualified Data.UnionFind.IO as UF+import Text.PrettyPrint as P++import qualified AST.Annotation as A+import AST.PrettyPrint (pretty)+import Type.Type (Descriptor, toSrcType)+++type Hint = Doc+++create+ :: A.Region+ -> Maybe String+ -> UF.Point Descriptor+ -> UF.Point Descriptor+ -> IO Hint+create region hint t1 t2 =+ 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+ ]
src/Type/Inference.hs view
@@ -29,9 +29,9 @@ state <- liftIO $ execStateT (Solve.solve constraint) TS.initialState - () <- case TS.sErrors state of- errors@(_:_) -> throwError errors- [] -> return ()+ () <- case TS.sHint state of+ hints@(_:_) -> throwError hints+ [] -> return () () <- Check.portTypes (program (body modul))
src/Type/Solve.hs view
@@ -9,6 +9,7 @@ import Type.Type import Type.Unify import qualified Type.ExtraChecks as Check+import qualified Type.Hint as Hint import qualified Type.State as TS import qualified AST.Annotation as A @@ -16,180 +17,197 @@ -- | 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+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)+ -- 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+ -- 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+ -- 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'+ 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 ()+ -- 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- 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)+ 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'+ 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)+ do let rank' = min groupRank (rank descriptor)+ liftIO $ UF.setDescriptor var (descriptor { mark = visitedMark, rank = rank' })+ return rank' - where- adjust = adjustRank youngMark visitedMark groupRank+ | 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+ 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 ()+ CTrue ->+ return () - CSaveEnv -> TS.saveLocalEnv+ CSaveEnv ->+ TS.saveLocalEnv - CEqual term1 term2 -> do- t1 <- TS.flatten term1- t2 <- TS.flatten term2- unify region t1 t2+ CEqual term1 term2 ->+ do t1 <- TS.flatten term1+ t2 <- TS.flatten term2+ unify region t1 t2 - CAnd cs -> mapM_ solve cs+ 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 [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)+ 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.")+ 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+ 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 [] [] constraint header ->+ do solve constraint+ Traversable.traverse TS.flatten header - Scheme rigidQuantifiers flexibleQuantifiers constraint header -> do- let quantifiers = rigidQuantifiers ++ flexibleQuantifiers- oldPool <- TS.getPool+ 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+ -- 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'+ allDistinct region rigidQuantifiers+ youngPool <- TS.getPool+ TS.switchToPool oldPool+ generalize youngPool+ mapM (isGeneric region) rigidQuantifiers+ return header' +addHint+ :: A.Region+ -> Maybe String+ -> UF.Point Descriptor+ -> UF.Point Descriptor+ -> StateT TS.SolverState IO ()+addHint region hint t1 t2 =+ do msg <- liftIO (Hint.create region hint t1 t2)+ TS.addHint msg++ -- 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."+allDistinct region vars =+ do seen <- TS.uniqueMark+ forM_ vars $ \var ->+ do desc <- liftIO $ UF.descriptor var+ case structure desc of+ Just _ ->+ let msg = "Cannot generalize something that is not a type variable."+ in+ addHint region (Just msg) var var - 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+ Nothing ->+ do when (mark desc == seen) $+ do let msg = "Duplicate variable during generalization."+ addHint region (Just msg) var var+ liftIO $ UF.setDescriptor var (desc { mark = seen }) + -- 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+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 addHint region (Just msg) var var
src/Type/State.hs view
@@ -7,11 +7,10 @@ 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 qualified Type.Hint as Hint import Type.Type + -- Pool -- Holds a bunch of variables -- The rank of each variable is less than or equal to the pool's "maxRank"@@ -40,7 +39,7 @@ , sSavedEnv :: Env , sPool :: Pool , sMark :: Int- , sErrors :: [P.Doc]+ , sHint :: [Hint.Hint] } @@ -51,7 +50,7 @@ , sSavedEnv = Map.empty , sPool = emptyPool , sMark = noMark + 1 -- The mark must never be equal to noMark!- , sErrors = []+ , sHint = [] } @@ -65,31 +64,9 @@ 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- ]+addHint :: Hint.Hint -> StateT SolverState IO ()+addHint hint =+ modify $ \state -> state { sHint = hint : sHint state } switchToPool :: (MonadState SolverState m) => Pool -> m ()@@ -109,8 +86,8 @@ saveLocalEnv :: StateT SolverState IO () saveLocalEnv =- do env <- sEnv <$> get- modify $ \state -> state { sSavedEnv = env }+ do currentEnv <- getEnv+ modify $ \state -> state { sSavedEnv = currentEnv } uniqueMark :: StateT SolverState IO Int
src/Type/Unify.hs view
@@ -1,37 +1,62 @@ module Type.Unify (unify) where import Control.Applicative ((<|>))-import Control.Monad.State+import Control.Monad.Error (ErrorT, throwError, runErrorT)+import Control.Monad.State as 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 Text.PrettyPrint (render)+ 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 qualified Type.Hint as Hint import Elm.Utils ((|>)) unify :: A.Region -> Variable -> Variable -> StateT TS.SolverState IO ()-unify region variable1 variable2 = do+unify region variable1 variable2 =+ do result <- runErrorT (unifyHelp region variable1 variable2)+ either TS.addHint return result+++-- ACTUALLY UNIFY STUFF++type Unify = ErrorT Hint.Hint (StateT TS.SolverState IO)+++typeError+ :: A.Region+ -> Maybe String+ -> UF.Point Descriptor+ -> UF.Point Descriptor+ -> Unify a+typeError region hint t1 t2 =+ do msg <- liftIO (Hint.create region hint t1 t2)+ throwError msg+++unifyHelp :: A.Region -> Variable -> Variable -> Unify ()+unifyHelp 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 :: A.Region -> Variable -> Variable -> Unify () actuallyUnify region variable1 variable2 = do desc1 <- liftIO $ UF.descriptor variable1 desc2 <- liftIO $ UF.descriptor variable2- let unify' = unify region+ let unifyHelp' = unifyHelp region (name', flex', rank', alias') = combinedDescriptors desc1 desc2 - merge1 :: StateT TS.SolverState IO ()+ merge1 :: Unify () merge1 = liftIO $ do if rank desc1 < rank desc2 then UF.union variable2 variable1 else UF.union variable1 variable2@@ -42,7 +67,7 @@ , alias = alias' } - merge2 :: StateT TS.SolverState IO ()+ merge2 :: Unify () merge2 = liftIO $ do if rank desc1 < rank desc2 then UF.union variable2 variable1 else UF.union variable1 variable2@@ -55,7 +80,7 @@ merge = if rank desc1 < rank desc2 then merge1 else merge2 - fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable+ fresh :: Maybe (Term1 Variable) -> Unify Variable fresh structure = do v <- liftIO . UF.fresh $ Descriptor { structure = structure@@ -66,11 +91,11 @@ , mark = noMark , alias = alias' }- TS.register v+ lift (TS.register v) flexAndUnify v = do liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }- unify' variable1 variable2+ unifyHelp' variable1 variable2 unifyNumber svar (Var.Canonical home name) = case home of@@ -79,17 +104,17 @@ _ -> let hint = "Looks like something besides an Int or Float is being used as a number." in- TS.addError region (Just hint) variable1 variable2+ typeError region (Just hint) variable1 variable2 comparableError maybe =- TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2+ typeError 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+ typeError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2 where msg = "Looks like you want something appendable, but the only Strings, Lists,\n\@@ -106,14 +131,14 @@ case struct of Other -> comparableError Nothing List v -> do flexAndUnify varSuper- unify' v =<< liftIO (variable $ Is Comparable)+ unifyHelp' 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+ zipWithM_ unifyHelp' vs cmpVars unifyAppendable varSuper varFlex = do struct <- liftIO $ collectApps varFlex@@ -122,7 +147,7 @@ _ -> appendableError Nothing rigidError var =- TS.addError region (Just hint) variable1 variable2+ typeError region (Just hint) variable1 variable2 where hint = "Could not unify rigid type variable '" ++ render (pretty Never var) ++ "'.\n" ++@@ -153,15 +178,15 @@ (Rigid, _, _, _) -> rigidError variable1 (_, Rigid, _, _) -> rigidError variable2- _ -> TS.addError region Nothing variable1 variable2+ _ -> typeError 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+ (Just (Var1 v), _) -> unifyHelp' v variable2+ (_, Just (Var1 v)) -> unifyHelp' v variable1 (Nothing, _) -> superUnify (_, Nothing) -> superUnify@@ -170,33 +195,33 @@ case (type1,type2) of (App1 term1 term2, App1 term1' term2') -> do merge- unify' term1 term1'- unify' term2 term2'+ unifyHelp' term1 term1'+ unifyHelp' term2 term2' (Fun1 term1 term2, Fun1 term1' term2') -> do merge- unify' term1 term1'- unify' term2 term2'+ unifyHelp' term1 term1'+ unifyHelp' 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 fields ext, EmptyRecord1) | Map.null fields -> unifyHelp' ext variable2+ (EmptyRecord1, Record1 fields ext) | Map.null fields -> unifyHelp' ext variable1 (Record1 _ _, Record1 _ _) -> recordUnify region fresh variable1 variable2 - _ -> TS.addError region Nothing variable1 variable2+ _ -> typeError region Nothing variable1 variable2 -- RECORD UNIFICATION recordUnify :: A.Region- -> (Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable)+ -> (Maybe (Term1 Variable) -> Unify Variable) -> Variable -> Variable- -> StateT TS.SolverState IO ()+ -> Unify () recordUnify region fresh variable1 variable2 = do (ExpandedRecord fields1 ext1) <- liftIO (gatherFields variable1) (ExpandedRecord fields2 ext2) <- liftIO (gatherFields variable2)@@ -212,57 +237,57 @@ let addFieldMismatchError missingFields = let msg = fieldMismatchError missingFields in- TS.addError region (Just msg) variable1 variable2+ typeError 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+ False -> typeError 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+ (True, True) -> unifyHelp region var1 var2 (False, True) -> do subRecord <- freshRecord uniqueFields1 var1- unify region subRecord var2+ unifyHelp 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, True) -> unifyHelp region var1 var2 (True, False) -> do subRecord <- freshRecord uniqueFields2 var2- unify region var1 subRecord+ unifyHelp region var1 subRecord (Extension var1, Extension var2) -> case (Map.null uniqueFields1, Map.null uniqueFields2) of (True, True) ->- unify region var1 var2+ unifyHelp region var1 var2 (True, False) -> do subRecord <- freshRecord uniqueFields2 var2- unify region var1 subRecord+ unifyHelp region var1 subRecord (False, True) -> do subRecord <- freshRecord uniqueFields1 var1- unify region subRecord var2+ unifyHelp region subRecord var2 (False, False) -> do record1' <- freshRecord uniqueFields1 =<< fresh Nothing record2' <- freshRecord uniqueFields2 =<< fresh Nothing- unify region record1' var2- unify region var1 record2'+ unifyHelp region record1' var2+ unifyHelp region var1 record2' unifyOverlappingFields :: A.Region -> Map.Map String [Variable] -> Map.Map String [Variable]- -> StateT TS.SolverState IO ()+ -> Unify () unifyOverlappingFields region fields1 fields2 =- Map.intersectionWith (zipWith (unify region)) fields1 fields2+ Map.intersectionWith (zipWith (unifyHelp region)) fields1 fields2 |> Map.elems |> concat |> sequence_