yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'dev'

Browse source 
Conflicts:
	Elm.cabal
	Examples/elm-js/GameSkeleton/GameSkeleton.elm
	Examples/elm-js/Pong/Pong.elm
	core-js/Signal/Input.js
This commit is contained in:
evancz 2013-05-22 00:26:23 +02:00
commit af75972665
197 changed files with 6764 additions and 13408 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

62
elm/Elm.cabal → Elm.cabal
View file

@ -1,6 +1,5 @@
Name: Elm
Version: 0.7.2
Version: 0.8
Synopsis: The Elm language module.
Description: Elm aims to make client-side web-development more pleasant.
It is a statically/strongly typed, functional reactive
@ -19,10 +18,11 @@ Copyright: Copyright: (c) 2011-2012 Evan Czaplicki
Category: Compiler, Language
Build-type: Simple
Build-type: Custom
Extra-source-files: changelog.txt
Data-files: elm-runtime-0.7.2.js
Data-dir: dist/data
Data-files: elm-runtime.js docs.json
Cabal-version: >=1.8
source-repository head
@ -32,7 +32,7 @@ source-repository head
Library
exposed-modules: Language.Elm,
Language.Elm.Quasi
Hs-Source-Dirs: src, src/Gen
Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform
other-modules: Ast,
Context,
CompileToJS,
@ -41,6 +41,8 @@ Library
ExtractNoscript,
GenerateHtml,
Guid,
Libraries,
LoadLibraries,
Optimize,
Initialize,
Rename,
@ -65,10 +67,10 @@ Library
containers >= 0.3,
transformers >= 0.2,
mtl >= 2,
deepseq,
parsec >= 3.1.1,
blaze-html == 0.5.* || == 0.6.*,
blaze-markup == 0.5.1.*,
deepseq,
text,
template-haskell,
shakespeare >= 1,
@ -76,11 +78,16 @@ Library
bytestring,
hjsmin,
indents,
filepath
filepath,
template-haskell,
json,
directory
Executable elm
Main-is: Compiler.hs
Hs-Source-Dirs: src, src/Gen
Hs-Source-Dirs: compiler, compiler/Gen, compiler/Model, compiler/Transform
extensions: CPP
cpp-options: -DELM_COMPILEDATADIR="dist/data"
other-modules: Ast,
Context,
CompileToJS,
@ -89,6 +96,8 @@ Executable elm
ExtractNoscript,
GenerateHtml,
Guid,
Libraries,
LoadLibraries,
Optimize,
Initialize,
Rename,
@ -113,15 +122,16 @@ Executable elm
containers >= 0.3,
transformers >= 0.2,
mtl >= 2,
deepseq,
parsec >= 3.1.1,
blaze-html == 0.5.* || == 0.6.*,
blaze-markup == 0.5.1.*,
deepseq,
cmdargs,
pandoc >= 1.10,
bytestring,
hjsmin,
indents,
<<<<<<< .mine
filepath
@ -154,3 +164,37 @@ test-suite Main
hs-source-dirs: src, tests
main-is: Main.hs
=======
filepath,
template-haskell,
json,
directory
Executable elm-doc
Main-is: Docs.hs
Hs-Source-Dirs: compiler, compiler/Model, compiler/Transform
other-modules: Ast,
Context,
Parse.Library,
Parse.Modules,
Rename
Build-depends: base >=4.2 && <5,
containers >= 0.3,
transformers >= 0.2,
mtl >= 2,
parsec >= 3.1.1,
pandoc >= 1.10,
cmdargs,
indents
>>>>>>> .theirs

71
Examples/elm-happstack/Main.hs
View file

@ -1,71 +0,0 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
import Control.Monad (msum)
import Happstack.Server
import Language.Elm
import Language.Elm.Quasi
elmRuntime="elm-runtime.js"
elmRTPath='/':elmRuntime
-- elmResponse is a "nice to have" helper function for compiling
-- Elm code when using Elm with Happstack. At some point this might
-- be moved to an elm-happstack package.
elmResponse :: ElmSource a
=> String -- ^ Page title
-> a -- ^ elm source
-> Response
elmResponse title = toResponse . toHtml elmRTPath title
-- embedding variables (in this case URLs)
rootHandler :: ServerPart Response
rootHandler = ok $ elmResponse "Welcome!" $ elmIndex
where
mouse = "/mouse" -- all three of these variables are used in elm_source/index.elm
clock = "/clock"
shapes = "/shapes"
elmIndex = $(elmFile "elm_source/index.elm")
-- loading elm source from file
mouseHandler :: ServerPart Response
mouseHandler = ok $ elmResponse "Mouse position demo"
$(elmFile "elm_source/mouse.elm")
clockHandler :: ServerPart Response
clockHandler = ok $ elmResponse "A clock" $(elmFile "elm_source/clock.elm")
-- embedding elm code inside Haskell using the QuasiQuoter:
shapesPage = [elm|
square = rect 200 200 (150,150)
circle = oval 140 140 (150,150)
pentagon = ngon 5 60 (150,150)
main = collage 300 300
[ outlined black square
, filled green pentagon
, customOutline [8,4] blue circle
]
|]
shapesHandler :: ServerPart Response
shapesHandler = ok $ elmResponse "Simple shapes" $ shapesPage
-- routing
elmExample :: String -> ServerPart Response
elmExample elmLoc = do
msum [ nullDir >> rootHandler
, dir elmRuntime $ nullDir >>
serveFile (guessContentTypeM mimeTypes) elmLoc
, dir "mouse" $ nullDir >>
mouseHandler
, dir "clock" $ nullDir >>
clockHandler
, dir "shapes" $ nullDir >>
shapesHandler
]
main :: IO ()
main = do
elmLoc <- Language.Elm.runtimeLocation
simpleHTTP nullConf {port = 3000} $ elmExample elmLoc

13
Examples/elm-happstack/elm_source/clock.elm
View file

@ -1,13 +0,0 @@
import Time (every)
hand clr len time =
let t = pi * time / 30 - pi / 2 in
solid clr $ line [(200,200), (200 + len * cos t, 200 + len * sin t)]
clock t = collage 400 400 [ filled (rgb 96 176 224) $ ngon 12 110 (200, 200)
, hand red 100 t
, hand black 100 (t/60)
, hand black 60 (t/720) ]
main = lift clock (every 1)

44
Examples/elm-happstack/elm_source/index.elm
View file

@ -1,44 +0,0 @@
title w = size w 60 . text . header . toText $ "Elm-Happstack"
lightGrey = rgb 240 241 244
mediumGrey = rgb 216 221 225
heading outer inner =
color mediumGrey . size outer 61 .
color lightGrey . size outer 60 .
size inner 60 $ title inner
skeleton body outer =
let inner = if outer < 820 then outer - 20 else 800 in
flow down [ heading outer inner
, body outer inner
]
----------------------
section = text . bold . Text.height (5/4) . toText
-- splicing of values works but literal substitution of strings
-- for this reason, we need to have quotes.
mouseLink = "#{mouse}"
clockLink = "#{clock}"
shapesLink = "#{shapes}"
info w = List.map (\f -> f ()) . List.intersperse (\x -> plainText "&nbsp;") . List.map ((\e x -> e) . width w) $
[ section "Written in Elm, served with Happstack"
, text $ toText "This page is written in " ++ Text.link "http://elm-lang.org/" (toText "Elm") ++
toText " and served using the " ++
Text.link "http://happstack.com/" (toText "Happstack Web Framework") ++
toText ". Since you are looking at this page it is safe to assume that you already have the example code. "
, text $ toText "URLs are rendered using simple QuasiQuoter variable interpolation."
, section "More examples:"
, text $ toText "- " ++ Text.link mouseLink (toText "A simple mouse input example")
, text $ toText "- " ++ Text.link clockLink (toText "An animated analog clock")
, text $ toText "- " ++ Text.link shapesLink (toText "Some simple rendered shapes")
]
-- The following line does not parse, replaced it something slightly different
-- body outer inner = width outer . flow down $ (:) (plainText "&nbsp;") $ info inner
body outer inner = width outer . flow down $ info inner
main = lift (skeleton body) Window.width

15
Examples/elm-happstack/elm_source/mouse.elm
View file

@ -1,15 +0,0 @@
-- Move your mouse around above the canvas!
import Mouse (position)
import Window (dimensions)
myBlue = rgb 0 85 170
myGreen = rgba 28 267 85 (1/2)
scene (x,y) (w,h) =
collage w h [ rotate (toFloat (x+y) / 1000) $ filled myBlue $ ngon 4 100 (200,200)
, filled myGreen $ ngon 5 30 (x,y)
]
main = lift2 scene Mouse.position Window.dimensions

82
Examples/elm-js/GameSkeleton/GameSkeleton.elm
View file

@ -1,82 +0,0 @@
module GameSkeleton where
{-- Part 1: Model the user input ----------------------------------------------
What information do you need to represent all relevant user input?
Task: Redefine `UserInput` to include all of the information you need.
Redefine `userInput` to be a signal that correctly models the user
input as described by `UserInput`.
------------------------------------------------------------------------------}
data UserInput = UserInput
userInput = constant UserInput
data Input = Input Float UserInput
{-- Part 2: Model the game ----------------------------------------------------
What information do you need to represent the entire game?
Tasks: Redefine `GameState` to represent your particular game.
Redefine `defaultGame` to represent your initial game state.
For example, if you want to represent many objects that just have a position,
your GameState might just be a list of coordinates and your default game might
be an empty list (no objects at the start):
data GameState = GameState [(Float,Float)]
defaultGame = GameState []
------------------------------------------------------------------------------}
data GameState = GameState
defaultGame = GameState
{-- Part 3: Update the game ---------------------------------------------------
How does the game step from one state to another based on user input?
Task: redefine `stepGame` to use the UserInput and GameState
you defined in parts 1 and 2. Maybe use some helper functions
to break up the work, stepping smaller parts of the game.
------------------------------------------------------------------------------}
stepGame (Input delta (UserInput)) (GameState) = GameState
{-- Part 4: Display the game --------------------------------------------------
How should the GameState be displayed to the user?
Task: redefine `display` to use the GameState you defined in part 2.
------------------------------------------------------------------------------}
display (w,h) gameState = asText gameState
{-- That's all folks! ---------------------------------------------------------
The following code puts it all together and show it on screen.
------------------------------------------------------------------------------}
delta = fps 60
input = sampleOn delta (lift2 Input delta userInput)
gameState = foldp stepGame defaultGame input
main = lift2 display Window.dimensions gameState

17
Examples/elm-js/Logging/Log.elm
View file

@ -1,17 +0,0 @@
module Log where
import Foreign.JavaScript
import Signal.Input
foreign export jsevent "logMessage"
messages :: Signal JSString
(field, message) = textField ""
(butn , pressed) = button " Log "
messages =
lift castStringToJSString $ keepWhen pressed "" message
main = field `beside` butn

3
Examples/elm-js/Logging/LogHelp.js
View file

@ -1,3 +0,0 @@
document.addEventListener('logMessage', function(e) {
console.log(e.value);
});

16
Examples/elm-js/Logging/README.md
View file

@ -1,16 +0,0 @@
To compile this example yourself use:
elm --import-js="LogHelp.js" Log.elm
This compiles the Elm file and includes the necessary JavaScript code.
It produces a self-contained HTML file.
You can see the logged messages in the developer console of your browser.
The keyboard shortcut is F12 in many browsers.
Note: Not all browsers like reading the elm-runtime-x.y.z.js file from
an absolute path, so you may have to specify a relative path with
the --runtime flag (e.g. --runtime="../../../elm/elm-runtime-0.3.5.js").

14
Examples/elm-js/Maps/Map.elm
View file

@ -1,14 +0,0 @@
module Map where
import JavaScript.Experimental
foreign import jsevent "provideMap"
(castElementToJSElement $ spacer 640 360)
jsMaps :: Signal JSElement
center (w,h) elem = container w h middle elem
maps = lift (castJSElementToElement 640 360) jsMaps
main = lift2 center Window.dimensions maps

25
Examples/elm-js/Maps/MapHelp.js
View file

@ -1,25 +0,0 @@
document.body.onload = function() {
var lib = document.createElement('script');
lib.addEventListener('load', function() {
var div = document.createElement('div');
div.id = "demoMap";
div.style.width = "640px";
div.style.height = "360px";
var e = document.createEvent('Event');
e.initEvent('provideMap', true, true);
e.value = div;
document.dispatchEvent(e);
setTimeout(function() {
var map = new OpenLayers.Map("demoMap");
map.addLayer(new OpenLayers.Layer.OSM());
map.zoomToMaxExtent();
}, 0);
});
lib.src = "http://www.openlayers.org/api/OpenLayers.js";
document.head.appendChild(lib);
}

15
Examples/elm-js/Maps/README.md
View file

@ -1,15 +0,0 @@
To compile this example yourself use:
elm --import-js="MapHelp.js" Map.elm
This compiles the Elm file and includes the necessary JavaScript code.
It produces a self-contained HTML file.
Note: Not all browsers like reading the elm-runtime-x.y.z.js file from
an absolute path, so you may have to specify a relative path with
the --runtime flag (e.g. --runtime="../../../elm/elm-runtime-0.3.5.js").
Warning: I am not sure how stable the OpenLayers API is. This is for
example only!

263
Examples/elm-js/Pong/Pong.elm
View file

@ -1,263 +0,0 @@
{----- Overview ------------------------------------------------------
This game displays some of the strengths of Functional Reactive
Programming (FRP). By the end of this file we will have written an
entire GUI/game without any imperative code! No global mutable state,
no flipping pixels, no destructive updates. In fact, Elm disallows all
of these things at the language level. So good design and safe coding
practices are a requirement, not just self-inforced suggestions.
This code neatly divides Pong into three major parts: modeling the
game, updating the game, and viewing the game. It may be helpful to
think of it as a functional variation on the Model-View-Controller
paradigm.
The code for Pong is structured as follows:
1. MODEL:
First we need to define Pong. We do this by modelling Pong with
simple data structures. We need two categories of model:
- Inputs to the game. For Pong, this is keyboard input from
users and clock-ticks from the frame rate manager.
- A model of the game itself: paddles, ball, score, etc.
Without a model of the game we would have nothing to update
or display!
These models are the basis for the next two sections, holding
all of the information about Pong that we will need.
2. UPDATE:
When new inputs come in, we need to update the current state
of the game. Without updates, this version of Pong would be very
very boring! This section defines a number of 'step functions'
that step the game forward based on our inputs. By separating
this from the model and display code, we can change how the game
works (how it steps forward) without changing anything else: the
underlying model and the display code need not be touched.
3. VIEW:
Finally, we need a display function that defines the user's view
of the game. This code is separate from the game logic, so like
the update logic, it can be modified without affecting any other
part of the program. We can also define many different views
of the same underlying model. In Pong there's not much need for
this, but as your model becomes more complex this may be very
useful!
If you would like to make a game or larger application in Elm, use
this structure! Maybe even use this file as a starting point for
playing around with your own ideas.
Let's get started!
-----------------------------------------------------------------------}
module Pong where
import JavaScript
-- Set the frames per second (FPS) to 60, calculate the deltas (the
-- difference between the two latest times, the amount of time since
-- the last frame), and convert the time into a number of seconds.
delta = lift inSeconds (fps 60)
------------------------------------------------------------------------
------ Modelling User Input ------
------------------------------------------------------------------------
-- During gameplay, all keyboard input is about the position of the
-- two paddles. So the keyboard input can be reduced to two directions,
-- each represented by an integer in {-1,0,1}. Furthermore, the SPACE
-- key is used to start the game between rounds, so we also need a
-- boolean value to represent whether it is pressed.
data KeyInput = KeyInput Bool Int Int
defaultKeyInput = KeyInput False 0 0
keyInput = lift3 KeyInput Keyboard.space
(lift .y Keyboard.wasd)
(lift .y Keyboard.arrows)
------------------------------------------------------------------------
------ Combining all inputs ------
------------------------------------------------------------------------
-- The inputs to this game include a timestep (which we extracted from
-- JavaScript) and the keyboard input from the users.
data Input = Input Float KeyInput
-- Combine both kinds of inputs and filter out keyboard events. We only
-- want the game to refresh on clock-ticks, not key presses too.
input = sampleOn delta (lift2 Input delta keyInput)
------------------------------------------------------------------------
------ Modelling Pong / a State Machine ------
------------------------------------------------------------------------
-- Pong has two obvious components: the ball and two paddles.
data Paddle = Paddle Float -- y-position
data Ball = Ball (Float,Float) (Float,Float) -- position and velocity
-- But we also want to keep track of the current score and whether
-- the ball is currently in play. This will allow us to have rounds
-- of play rather than just having the ball move around continuously.
data Score = Score Int Int
data State = Play | BetweenRounds
-- Together, this information makes up the state of the game. We model
-- Pong by using the inputs (defined above) to update the state of the
-- game!
data GameState = GameState State Score Ball Paddle Paddle
-- I have chosen to parameterize the size of the board, so it can
-- be changed with minimal effort.
gameWidth = 600
gameHeight = 400
halfWidth = gameWidth / 2
halfHeight = gameHeight / 2
-- Before we can update anything, we must first define the default
-- configuration of the game. In our case we want to start between
-- rounds with a score of zero to zero.
defaultGame = GameState BetweenRounds
(Score 0 0)
(Ball (halfWidth, halfHeight) (150,150))
(Paddle halfHeight)
(Paddle halfHeight)
------------------------------------------------------------------------
------ Stepping from State to State ------
------------------------------------------------------------------------
-- Now to step the game from one state to another. We can break this up
-- into smaller components.
-- First, we define a step function for updating the position of
-- paddles. It depends on our timestep and a desired direction (given
-- by keyboard input).
stepPaddle delta dir (Paddle y) =
Paddle $ clamp 20 (gameHeight-20) (y - toFloat dir * 200 * delta)
-- We must also step the ball forward. This is more complicated due to
-- the many kinds of collisions that can happen. All together, this
-- function figures out the new velocity of the ball based on
-- collisions with the top and bottom borders and collisions with the
-- paddles. This new velocity is used to calculate a new position.
-- This function also determines whether a point has been scored and
-- who receives the point. Thus, its output is a new Ball and points
-- to be added to each player.
makePositive n = if n > 0 then n else 0-n
makeNegative n = if n > 0 then 0-n else n
within epsilon n x = x > n - epsilon && x < n + epsilon
stepVelocity velocity lowerCollision upperCollision =
if lowerCollision then makePositive velocity else
if upperCollision then makeNegative velocity else velocity
stepBall delta (Ball (x,y) (vx,vy)) (Paddle y1) (Paddle y2) =
let hitPaddle1 = within 20 y1 y && within 8 25 x
hitPaddle2 = within 20 y2 y && within 8 (gameWidth - 25) x
vx' = stepVelocity vx hitPaddle1 hitPaddle2
vy' = stepVelocity vy (y < 7) (y > gameHeight - 7)
scored = x > gameWidth || x < 0
x' = if scored then halfWidth else x + vx' * delta
y' = if scored then halfHeight else y + vy' * delta
in ( Ball (x',y') (vx',vy')
, if x > gameWidth then 1 else 0
, if x < 0 then 1 else 0 )
-- Finally, we define a step function for the entire game. This steps from state to
-- state based on the inputs to the game.
stepGame (Input delta (KeyInput space dir1 dir2))
(GameState state (Score s1 s2) ball paddle1 paddle2) =
let (ball',s1',s2') = if state == Play then stepBall delta ball paddle1 paddle2
else (ball, 0, 0)
state' = case state of
Play -> if s1' /= s2' then BetweenRounds else state
BetweenRounds -> if space then Play else state
in GameState state'
(Score (s1+s1') (s2+s2'))
ball'
(stepPaddle delta dir1 paddle1)
(stepPaddle delta dir2 paddle2)
-- Now we put it all together. We have a signal of inputs that changes whenever there
-- is a clock tick. This input signal carries the all the information we need about
-- the keyboard. We also have a step function that steps from one game-state to the
-- next based on some inputs.
-- The `gameState` signal steps forward every time a new input comes in. It starts
-- as the default game and progresses based on user behavior.
gameState = foldp stepGame defaultGame input
------------------------------------------------------------------------
------ Displaying the Game ------
------------------------------------------------------------------------
-- These functions take a GameState and turn it into something a user
-- can see and understand. It is totally independent of how the game
-- updates, it only needs to know the current game state. This allows us
-- to change how the game looks without changing any of the logic of the
-- game.
-- This function displays the current score and directions.
scoreBoard w inPlay p1 p2 =
let code = text . monospace . toText
stack top bottom = flow down [ code " ", code top, code bottom ]
msg = width w . centeredText . monospace $ toText "Press SPACE to begin"
board = flow right [ stack "W" "S", spacer 20 1
, text . Text.height 4 . toText $ show p1 ++ " " ++ show p2
, spacer 20 1, stack "&uarr;" "&darr;" ]
score = container w (heightOf board) midTop board
in if inPlay then score else score `above` msg
-- This function displays the entire GameState.
display (w,h) (GameState state (Score p1 p2) (Ball pos _) (Paddle y1) (Paddle y2)) =
layers
[ let pongGreen = rgb 60 100 60 in
container w h middle $ collage gameWidth gameHeight
[ filled pongGreen (rect gameWidth gameHeight (halfWidth,halfHeight))
, filled white (oval 15 15 pos) -- ball
, filled white (rect 10 40 ( 20, y1)) -- first paddle
, filled white (rect 10 40 (gameWidth - 20, y2)) -- second paddle
]
, scoreBoard w (state == Play) p1 p2
]
-- We can now define a view of the game (a signal of Elements) that changes
-- as the GameState changes. This is what the users will see.
main = lift2 display Window.dimensions gameState

11
Examples/elm-js/Pong/README.md
View file

@ -1,11 +0,0 @@
To compile this example yourself use:
elm Pong.elm
It produces a self-contained HTML file called Pong.html.
As of version 0.6 of the compiler, no external code is necessary
to make this work, so the code is slightly cleaner and simpler than
the "Pong in Elm" walkthrough.

12
Examples/elm-js/Redirect/README.md
View file

@ -1,12 +0,0 @@
To compile this example yourself use:
elm --import-js="RedirectHelp.js" Redirect.elm
This compiles the Elm file and includes the necessary JavaScript code.
It produces a self-contained HTML file.
Note: Not all browsers like reading the elm-runtime-x.y.z.js file from
an absolute path, so you may have to specify a relative path with
the --runtime flag (e.g. --runtime="../../../elm/elm-runtime-0.3.5.js").

17
Examples/elm-js/Redirect/Redirect.elm
View file

@ -1,17 +0,0 @@
module Redirect where
import Foreign.JavaScript
import Signal.Input
foreign export jsevent "redirect"
redirectTo :: Signal JSString
(butn, pressed) = button " Redirect to elm-lang.org "
redirectTo =
lift castStringToJSString $
keepWhen pressed "" (constant "http://elm-lang.org/")
main = butn

3
Examples/elm-js/Redirect/RedirectHelp.js
View file

@ -1,3 +0,0 @@
document.addEventListener('redirect', function(e) {
if (e.value.length > 0) { window.location = e.value; }
});

14
Examples/elm-js/Title/ChangeTitle.elm
View file

@ -1,14 +0,0 @@
module ChangeTitle where
import Foreign.JavaScript
import Signal.Input
foreign export jsevent "changeTitle"
title :: Signal JSString
(field, title) = let (f,t) = textField "" in
(f, lift castStringToJSString t)
main = plainText "Change this page's title to: " `beside` field

3
Examples/elm-js/Title/ChangeTitleHelp.js
View file

@ -1,3 +0,0 @@
document.addEventListener('changeTitle', function(e) {
document.title = e.value;
});

7
Examples/elm-js/Title/README.md
View file

@ -1,7 +0,0 @@
To compile this example yourself use:
elm --import-js="ChangeTitleHelp.js" ChangeTitle.elm
This compiles the Elm file and includes the necessary JavaScript code.
It produces a self-contained HTML file.

81
Examples/elm-yesod/Main.hs
View file

@ -1,81 +0,0 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings, TypeFamilies, MultiParamTypeClasses #-}
import Language.Elm
import Language.Elm.Quasi
import Language.Elm.Yesod
import Yesod
import Text.Hamlet
data ElmTest = ElmTest
-- loading external elm code
mousePage = $(elmFile "elm_source/mouse.elm")
clockPage = $(elmFile "elm_source/clock.elm")
-- embedding elm code inside Haskell using the QuasiQuoter:
shapesPage = [elm|
square = rect 200 200 (150,150)
circle = oval 140 140 (150,150)
pentagon = ngon 5 60 (150,150)
main = collage 300 300
[ outlined black square
, filled green pentagon
, customOutline [8,4] blue circle
]
|]
-- our Yesod App
mkYesod "ElmTest" [parseRoutes|
/ RootR GET
/mouse MouseR GET
/clock ClockR GET
/shapes ShapesR GET
|]
-- Your App data type needs to have an instance of YesodElm (see line 75&76)
-- so that toWidget can work with QuasiQuoted elm code. All URL interpolation
-- is done automatically. (e.g. lines 28-30 in elm_source/index.elm)
getMouseR :: Handler RepHtml
getMouseR =
defaultLayout $ do
setTitle "Mouse position demo"
toWidget mousePage
getClockR :: Handler RepHtml
getClockR =
defaultLayout $ do
setTitle "A clock"
toWidget clockPage
getShapesR :: Handler RepHtml
getShapesR =
defaultLayout $ do
setTitle "Simple shapes"
toWidget shapesPage
getRootR :: Handler RepHtml
getRootR =
defaultLayout $ do
setTitle "Welcome!"
toWidget $(elmFile "elm_source/index.elm")
-- Our Yesod instance contains the default layout, which inserts the elm-min.js
-- file in the site's <head> tag. The YesodElm instance defines the location of
-- elm-min.js
instance Yesod ElmTest where
jsLoader _ = BottomOfHeadBlocking
defaultLayout widget = do
mmsg <- getMessage
pc <- widgetToPageContent $ do
$(whamletFile "templates/default-layout.hamlet")
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
instance YesodElm ElmTest where
urlElmJs _ = Right $ "https://raw.github.com/evancz/Elm/master/elm/elm-runtime-0.7.2.js"
main :: IO ()
main = warpDebug 3000 ElmTest

11
Examples/elm-yesod/elm_source/clock.elm
View file

@ -1,11 +0,0 @@
hand clr len time =
let t = pi * inSeconds time / 30 - pi / 2 in
solid clr $ line [(200,200), (200 + len * cos t, 200 + len * sin t)]
clock t = collage 400 400 [ filled (rgb 96 176 224) $ ngon 12 110 (200, 200)
, hand red 100 t
, hand black 100 (t/60)
, hand black 60 (t/720) ]
main = lift clock (every second)

35
Examples/elm-yesod/elm_source/index.elm
View file

@ -1,35 +0,0 @@
title w = size w 60 . text . header . toText $ "Elm-Yesod"
lightGrey = rgb 240 241 244
mediumGrey = rgb 216 221 225
heading outer inner =
color mediumGrey . size outer 61 .
color lightGrey . size outer 60 .
size inner 60 $ title inner
skeleton body outer =
let inner = if outer < 820 then outer - 20 else 800 in
flow down [ heading outer inner
, body outer inner
]
----------------------
section = text . bold . Text.height (5/4) . toText
info w = List.map (\f -> f ()) . List.intersperse (\x -> plainText "&nbsp;") . List.map ((\e x -> e) . width w) $
[ section "Written in Elm, served with Yesod"
, text $ toText "This page is written in " ++ Text.link "http://elm-lang.org/" (toText "Elm") ++
toText " and served using the " ++
Text.link "http://yesodweb.com/" (toText "Yesod Web Framework") ++
toText ". Since you are looking at this page it is safe to assume that you already have the example code. "
, text $ toText "Type-safe URLs are rendered using simple QuasiQuoter variable interpolation."
, section "More examples:"
, text $ toText "- " ++ Text.link "@{MouseR}" (toText "A simple mouse input example")
, text $ toText "- " ++ Text.link "@{ClockR}" (toText "An animated analog clock")
, text $ toText "- " ++ Text.link "@{ShapesR}" (toText "Some simple rendered shapes")
]
body outer inner = width outer . flow down . (:) (plainText "&nbsp;") $ info inner
main = lift (skeleton body) Window.width

13
Examples/elm-yesod/elm_source/mouse.elm
View file

@ -1,13 +0,0 @@
-- Move your mouse around above the canvas!
myBlue = rgb 0 85 170
myGreen = rgba 28 267 85 0.5
scene (x,y) (w,h) =
collage w h
[ rotate (toFloat (x+y) / 1000) (filled myBlue (ngon 4 100 (200,200)))
, filled myGreen (ngon 5 30 (x,y))
]
main = lift2 scene Mouse.position Window.dimensions

8
Examples/elm-yesod/templates/default-layout-wrapper.hamlet
View file

@ -1,8 +0,0 @@
$doctype 5
<html>
<head>
<meta charset="UTF-8">
<title>#{pageTitle pc}
^{pageHead pc}
<body>
^{pageBody pc}

3
Examples/elm-yesod/templates/default-layout.hamlet
View file

@ -1,3 +0,0 @@
$maybe msg <- mmsg
<div .message>#{msg}
^{widget}

2
Examples/mario_mp/.gitignore vendored
View file

@ -1,2 +0,0 @@
*.html
mario_mp

6
Examples/mario_mp/Clicks.elm
View file

@ -1,6 +0,0 @@
module Clicks where
import WebSocket
msgs = show <~ count Mouse.clicks
main = asText <~ open "ws://localhost:8080/ws" msgs

91
Examples/mario_mp/Mario.elm
View file

@ -1,91 +0,0 @@
module Mario where
import Dict
import JavaScript
import JSON
import Random
import WebSocket
{- INPUT -}
jumpStep isJump obj = if isJump && obj.y == 0 then { obj | vy <- 5 } else obj
gravityStep t obj = { obj | vy <- if obj.y > 0 then obj.vy - t/4 else obj.vy }
timeStep t obj = let {x,y,vx,vy} = obj in
{ obj | x <- x + t * vx , y <- max 0 $ y + t * vy }
walkStep dir obj = { obj | vx <- dir, dir <- if | dir < 0 -> "left"
| dir > 0 -> "right"
| otherwise -> obj.dir }
step t d j = timeStep t . gravityStep t . jumpStep j . walkStep d
delta = lift (flip (/) 20) (fps 25)
leftRight = toFloat . .x <~ Keyboard.arrows
jump = (\{y} -> y > 0) <~ Keyboard.arrows
steps = sampleOn delta (lift3 step delta leftRight jump)
{- LOCAL STATE -}
initialMario = { x = 0, y = 0, vx = 0, vy = 0, dir = "right" }
stateSignal = foldp ($) initialMario steps
encode obj id =
castJSStringToString . (toPrettyJSString "") . JSON.fromList $
[ ("id", JsonNumber id)
, ("x", JsonNumber obj.x)
, ("y", JsonNumber obj.y)
, ("vx", JsonNumber obj.vx)
, ("dir", JsonString obj.dir) ]
--encode obj id = show id ++ " " ++ show obj.x ++ " " ++ show obj.y
clientID = inRange 0 99999
myStream = encode <~ stateSignal ~ clientID
{- NETWORK LAYER -}
worldMessageStream = open "ws://localhost:8080/ws" myStream
-- :: String -> Maybe (Float, Record)
parsePlayer msg =
case fromString msg of
Nothing -> Nothing
Just json ->
let id = findNumber "id" json
x = findNumber "x" json
y = findNumber "y" json
vx = findNumber "vx" json
dir = findString "dir" json
in Just (id, { x = x, y = y, vx = vx, vy = 0, dir = dir })
-- :: Maybe (Float, Record) -> Dict String Record -> Dict String Record
updateWorldPositions maybeMario marioDict = case maybeMario of
Just (id, mario) -> (Dict.insert) (show id) mario marioDict
Nothing -> marioDict
-- :: Signal (Dict String Record)
worldPositions = foldp updateWorldPositions Dict.empty (parsePlayer <~ worldMessageStream)
--worldPositions = constant empty
marios = Dict.values <~ worldPositions
{- RENDER CODE -}
-- :: Record -> Form
mario2Form (w,h) mario =
let verb = if mario.vx /= 0 then "walk" else "stand"
src = "/imgs/mario/" ++ verb ++ "/" ++ mario.dir ++ ".gif"
in toForm (mario.x, (h-63)-mario.y) (image 35 35 src)
-- :: (Int,Int) -> [Record] -> Element
render (w,h) marios =
collage w h ( (filled cyan $ rect w h (w `div` 2, h `div` 2))
: (filled green $ rect w 50 (w `div` 2,h-25))
: List.map (mario2Form (w,h)) marios )
{- PUTTING IT TOGETHER -}
-- :: Signal Element
main = render <~ Window.dimensions ~ marios
--main = above <~ ((plainText . show) <~ (marios)) ~ (render <~ Window.dimensions ~ marios)
--main = (plainText . show) <~ (marios)

8
Examples/mario_mp/Object.elm
View file

@ -1,8 +0,0 @@
module Object where
import JavaScript
import JSON
main = plainText . castJSStringToString . (toPrettyJSString "") . fromList $ [ ("answer", JsonNumber 42) ]

7
Examples/mario_mp/Values.elm
View file

@ -1,7 +0,0 @@
module Values where
import Dict
main = constant . plainText . show . values $ empty

43
Examples/mario_mp/conn.go
View file

@ -1,43 +0,0 @@
package main
import (
"code.google.com/p/go.net/websocket"
)
type connection struct {
// The websocket connection.
ws *websocket.Conn
// Buffered channel of outbound messages.
send chan string
}
func (c *connection) reader() {
for {
var message string
err := websocket.Message.Receive(c.ws, &message)
if err != nil {
break
}
h.broadcast <- message
}
c.ws.Close()
}
func (c *connection) writer() {
for message := range c.send {
err := websocket.Message.Send(c.ws, message)
if err != nil {
break
}
}
c.ws.Close()
}
func wsHandler(ws *websocket.Conn) {
c := &connection{send: make(chan string, 256), ws: ws}
h.register <- c
defer func() { h.unregister <- c }()
go c.writer()
c.reader()
}

1
Examples/mario_mp/elm-runtime.js
View file

@ -1 +0,0 @@
../../elm/elm-runtime.js

44
Examples/mario_mp/hub.go
View file

@ -1,44 +0,0 @@
package main
type hub struct {
// Registered connections.
connections map[*connection]bool
// Inbound messages from the connections.
broadcast chan string
// Register requests from the connections.
register chan *connection
// Unregister requests from connections.
unregister chan *connection
}
var h = hub{
broadcast: make(chan string),
register: make(chan *connection),
unregister: make(chan *connection),
connections: make(map[*connection]bool),
}
func (h *hub) run() {
for {
select {
case c := <-h.register:
h.connections[c] = true
case c := <-h.unregister:
delete(h.connections, c)
close(c.send)
case m := <-h.broadcast:
for c := range h.connections {
select {
case c.send <- m:
default:
delete(h.connections, c)
close(c.send)
go c.ws.Close()
}
}
}
}
}

BIN
Examples/mario_mp/imgs/mario/stand/left.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 357 B

BIN
Examples/mario_mp/imgs/mario/stand/right.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 364 B

BIN
Examples/mario_mp/imgs/mario/walk/left.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 1.7 KiB

BIN
Examples/mario_mp/imgs/mario/walk/right.gif
View file

Binary file not shown.
Side by side

Before

Width:  |  Height:  |  Size: 1.7 KiB

24
Examples/mario_mp/main.go
View file

@ -1,24 +0,0 @@
package main
import (
"code.google.com/p/go.net/websocket"
"flag"
"log"
"net/http"
)
var addr = flag.String("addr", ":8080", "http service address")
func fileHandler(w http.ResponseWriter, r *http.Request) {
http.ServeFile(w, r, r.URL.Path[1:])
}
func main() {
flag.Parse()
go h.run()
http.HandleFunc("/", fileHandler)
http.Handle("/ws", websocket.Handler(wsHandler))
if err := http.ListenAndServe(*addr, nil); err != nil {
log.Fatal("ListenAndServe:", err)
}
}

19
Examples/mario_mp/makefile
View file

@ -1,19 +0,0 @@
all: mario_mp Mario.html Clicks.html Object.html Values.html
mario_mp: *.go
go build
Mario.html: Mario.elm
elm -r elm-runtime.js Mario.elm
Clicks.html: Clicks.elm
elm -r elm-runtime.js Clicks.elm
Object.html: Object.elm
elm -r elm-runtime.js Object.elm
Values.html: Values.elm
elm -r elm-runtime.js Values.elm
clean:
rm -rf *.html mario_mp

0
elm-server/LICENSE → LICENSE
View file

156
Setup.hs Normal file
View file

@ -0,0 +1,156 @@
import Distribution.Simple
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup
import Distribution.PackageDescription
import System.Cmd
import System.Directory
import System.FilePath
import System.IO
import System.Process
import Control.Monad
-- Part 1
-- ------
-- Add a build callout
-- We need to build elm-doc and run it because that generates the file "docs.json" needs by Libraries.hs
-- which is part of the elm library and executable
-- Unfort. there seems to be no way to tell cabal that:
-- (a) elm-doc generates docs.json, and
-- (b) elm (library) depends on docs.json
-- Therefore, we either use make instead (or a script), or hack around in cabal
-- Part 2
-- ------
-- Add a post-build callout.
-- We need to build the runtime.js after we've built elm (because we use elm to generate some of the JavaScript),
-- but before cabal does the install file copy step
-- Assumptions
-- Elm.cabal expects the generated files to end up in dist/data
rtsDir lbi = (buildDir lbi) </> ".." </> "data" -- git won't look in dist + cabal will clean it
jsDir lbi = (buildDir lbi) </> ".." </> "js"
-- The runtime is called:
rts lbi = (rtsDir lbi) </> "elm-runtime.js"
-- The json file is called:
-- The elm-docs executable is called:
elmDoc = "elm-doc"
elm_doc lbi = (buildDir lbi) </> elmDoc </> elmDoc
types lbi = (rtsDir lbi) </> "docs.json"
-- buildDir with LocalBuildInfo points to "dist/build" (usually)
elm lbi = (buildDir lbi) </> "elm" </> "elm"
-- Care! This appears to be based on an unstable API
-- See: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html#2
main :: IO ()
main = defaultMainWithHooks simpleUserHooks { {-- buildHook = myBuild, --} postBuild = myPostBuildWithTypes }
-- Build
-- Not currently used. buildTypes is in 'myPostBuildWithTypes'
-- If using this again, change postBuild to 'myPostBuild'
-- Purpose is to make sure docs.json was built before elm exec was (as elm exec depended on it)
-- This is no longer true and the code below seems to affect cabal's build dependencies
myBuild :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
myBuild pd lbi uh bf = do
putStrLn $ "Custom build step started: compile " ++ elmDoc
withExe pd (\x -> putStrLn (exeName x))
buildHook simpleUserHooks (filterExe elmDoc pd) (filterLBI elmDoc lbi) uh bf
putStrLn "Custom build step started: build docs.json"
buildTypes lbi -- see note(1) below
putStrLn "Custom build step started: compile everything"
buildHook simpleUserHooks pd lbi uh bf
-- note(1): We use to include docs.json directly into LoadLibraries at compile time
-- If docs.json is used in other (template) haskell files, they should be copied
-- and compiled in a separate directory (eg, dist/copiedSrc).
-- This is to make sure they are re-compiled on docs.json changes.
-- Copying is a better solution than 'touch'ing the source files
-- (touch is non-portable and confusing wrt RCS).
-- In the PackageDescription, the list of stuff to build is held in library (in a Maybe)
-- and the executables list. We want a PackageDescription that only mentions the executable 'name'
filterExe name pd = pd {
library = Nothing,
executables = filter (\x -> (exeName x == name)) (executables pd)
}
-- It's not enough to fix the PackageDescription, we also have to fix the LocalBuildInfo.
-- This includes the component build order (data ComponentName) which is horribly internal.
filterLBI name lbi = lbi {
libraryConfig = Nothing,
compBuildOrder = [CExeName name],
executableConfigs = filter (\a -> (fst a == name)) (executableConfigs lbi)
}
buildTypes lbi = do
createDirectoryIfMissing False (rtsDir lbi) -- dist should already exist
files <- getFiles ".elm" "libraries"
system (elm_doc lbi ++ " " ++ unwords files ++ " > " ++ (types lbi))
putStrLn $ "Custom build step completed: " ++ elmDoc
-- Post Build
myPostBuildWithTypes :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
myPostBuildWithTypes as bfs pd lbi = do
putStrLn "Custom build step started: build docs.json"
buildTypes lbi -- see note(1) below
myPostBuild as bfs pd lbi
myPostBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
myPostBuild as bfs pd lbi = do
putStrLn "Custom post build step started: build elm-runtime.js"
buildRuntime lbi
postBuild simpleUserHooks as bfs pd lbi
getFiles ext dir = do
contents <- map (dir </>) `fmap` getDirectoryContents dir
let files = filter (\f -> takeExtension f == ext) contents
dirs = filter (not . hasExtension) contents
filess <- mapM (getFiles ext) dirs
return (files ++ concat filess)
appendJS lbi file = do
putStrLn (dropExtension file)
str <- readFile file
length str `seq` return ()
appendFile (rts lbi) str
appendElm lbi file = do
jsFile <- runElm lbi file
appendJS lbi jsFile
-- replace 'system' call with 'runProcess' which handles args better and allows env variable
-- "Elm_datadir" which is used by LoadLibraries to find docs.json
runElm :: LocalBuildInfo -> String -> IO FilePath
runElm lbi file = do
rts_c <- canonicalizePath (rts lbi) -- dist/data/elm-runtime.js
let js = jsDir lbi -- dist/js
let j = dropFileName (js </> file) -- dist/js/libraries/
createDirectoryIfMissing True j -- must do before any canonicalization
out_c <- canonicalizePath js -- dist/js (root folder)
elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm
rtd_c <- canonicalizePath (rtsDir lbi) -- dist/data (for docs.json)
handle <- runProcess elm_c ["--only-js", "--no-prelude", "--output-directory="++out_c, file]
Nothing (Just [("Elm_datadir", rtd_c)]) Nothing Nothing Nothing
exitCode <- waitForProcess handle
return $ j </> replaceExtension (takeFileName file) ".js"
buildRuntime lbi = do
createDirectoryIfMissing False (rtsDir lbi) -- dist should already exist
writeFile (rts lbi) "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\
\Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"
mapM_ (appendJS lbi) =<< getFiles ".js" "libraries"
mapM_ (appendElm lbi) =<< getFiles ".elm" "libraries"
mapM_ (appendJS lbi) =<< getFiles ".js" "runtime"

0
elm/changelog.txt → changelog.txt
View file

56
elm/src/Compiler.hs → compiler/Compiler.hs
View file

@ -2,10 +2,11 @@
module Main where
import Data.Either (lefts, rights)
import Data.List (intersect, intercalate)
import Data.List (intersect, intercalate,lookup)
import Data.Maybe (fromMaybe)
import Data.Version (showVersion)
import System.Console.CmdArgs
import System.Exit
import System.FilePath
import Text.Blaze.Html.Renderer.String (renderHtml)
@ -16,6 +17,7 @@ import Ast
import Initialize
import CompileToJS
import GenerateHtml
import qualified Libraries as Libraries
import Paths_Elm
data ELM =
@ -25,7 +27,8 @@ data ELM =
, separate_js :: Bool
, only_js :: Bool
, import_js :: [FilePath]
, generate_noscript :: Bool
, no_prelude :: Bool
, noscript :: Bool
, minify :: Bool
, output_directory :: Maybe FilePath
}
@ -38,7 +41,8 @@ elm = ELM { make = False &= help "automatically compile dependencies."
, separate_js = False &= help "Compile to separate HTML and JS files."
, only_js = False &= help "Compile only to JavaScript."
, import_js = [] &= typFile &= help "Include a JavaScript file before the body of the Elm program. Can be used many times. Files will be included in the given order."
, generate_noscript = True &= help "Add generated <noscript> tag to HTML output."
, no_prelude = False &= help "Do not import Prelude by default, used only when compiling standard libraries."
, noscript = True &= help "Add generated <noscript> tag to HTML output."
, minify = False &= help "Minify generated JavaScript"
, output_directory = Nothing &= typFile &= help "Output files to directory specified. Defaults to the location of original file."
} &=
@ -47,37 +51,41 @@ elm = ELM { make = False &= help "automatically compile dependencies."
main = do
args <- cmdArgs elm
mini <- getDataFileName ("elm-runtime-" ++ showVersion version ++ ".js")
mini <- getDataFileName "elm-runtime.js"
compileArgs mini args
compileArgs mini (ELM _ [] _ _ _ _ _ _ _) =
putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
compileArgs mini (ELM make files rtLoc split only js nscrpt isMini outputDir) =
mapM_ (fileTo isMini make what js nscrpt outputDir loc) files
where loc = fromMaybe mini rtLoc
what | only = JS
| split = Split
| otherwise = HTML
compileArgs mini flags =
case files flags of
[] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
fs -> mapM_ (fileTo flags what loc) fs
where loc = fromMaybe mini (runtime flags)
what | only_js flags = JS
| separate_js flags = Split
| otherwise = HTML
data What = JS | HTML | Split
fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
let jsStyle = if isMini then Minified else Readable
formatJS = if isMini then BS.unpack . JS.minify . BS.pack else id
ems <- build make file
jss <- concat `fmap` mapM readFile jsFiles
fileTo flags what rtLoc file = do
let jsStyle = if minify flags then Minified else Readable
formatJS = if minify flags then BS.unpack . JS.minify . BS.pack else id
prelude = not (no_prelude flags)
ems <- if make flags then build prelude file
else do src <- readFile file
return (fmap (:[]) (buildFromSource prelude src))
jss <- concat `fmap` mapM readFile (import_js flags)
case ems of
Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
Right ms ->
let path = fromMaybe "" outputDir </> file
Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
exitFailure
Right ms' ->
let path = fromMaybe "" (output_directory flags) </> file
js = replaceExtension path ".js"
html = replaceExtension path ".html"
pairs = map ((,) (fst ms)) (snd ms)
txt = jss ++ concatMap jsModule pairs
ms = if no_prelude flags then ms' else map Libraries.addPrelude ms'
txt = jss ++ concatMap jsModule ms
in case what of
JS -> writeFile js (formatJS txt)
HTML -> writeFile html . renderHtml $
modulesToHtml jsStyle "" rtLoc jss noscript pairs
modulesToHtml jsStyle "" rtLoc jss (noscript flags) ms
Split ->
do writeFile html . renderHtml $ linkedHtml rtLoc js pairs
do writeFile html . renderHtml $ linkedHtml rtLoc js ms
writeFile js (formatJS txt)

65
compiler/Docs.hs Normal file
View file

@ -0,0 +1,65 @@
module Main where
import Ast
import Control.Applicative ((<$>), (<*>))
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Parse.Library
import Parse.Modules (moduleDef)
import Text.Parsec hiding (newline,spaces)
import System.Environment
import System.Exit
main = do
srcs <- mapM readFile =<< getArgs
case mapM docParse srcs of
Left err -> putStrLn err >> exitFailure
Right ms -> putStrLn (toModules ms)
toModules ms = wrap (intercalate ",\n " (map toModule ms))
where wrap s = "{ \"modules\" : [\n " ++ s ++ "\n ]\n}"
toModule (name, values) =
"{ \"name\" : " ++ show name ++ ",\n " ++
"\"values\" : [\n " ++ vs ++ "\n ]\n }"
where vs = intercalate ",\n " (map toValue values)
toValue (name, tipe, desc) =
"{ \"name\" : " ++ show name ++
",\n \"type\" : " ++ show tipe ++
",\n \"desc\" : " ++ show desc ++ "\n }"
docParse :: String -> Either String (String, [(String, String, String)])
docParse = setupParser $ do
optional freshLine
(names, exports) <- option (["Main"],[]) moduleDef
info <- many (annotation exports <|> try skip <|> end)
return (intercalate "." names, catMaybes info)
where
skip = manyTill anyChar simpleNewline >> return Nothing
end = many1 anyChar >> return Nothing
annotation :: [String] -> IParser (Maybe (String, String, String))
annotation exports =
try ((\c n t -> export (n,t,c)) <$> comment <*> (try adt <|> name) <*> tipe)
where
comment = concatMap clip <$> many lineComment
clip str = case str of { ' ':rest -> rest ; _ -> str } ++ "\n"
name = do v <- lowVar <|> parens symOp
whitespace ; hasType ; whitespace ; return v
tipe = manyTill anyChar (try (simpleNewline >> notFollowedBy (string " ")))
export info@(name,_,_) =
if null exports || name `elem` exports then Just info else Nothing
adt = lookAhead ((string "data" <|> string "type") >> whitespace >> capVar)
setupParser p source =
case iParse p "" source of
Right result -> Right result
Left err -> Left $ "Parse error at " ++ show err

11
elm/src/Gen/Cases.hs → compiler/Gen/Cases.hs
View file

@ -57,8 +57,15 @@ match vs cs def
matchVar :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
matchVar (v:vs) cs def = match vs (map subVar cs) def
where subVar (PVar x : ps, C t s e) = (ps, C t s $ subst x (Var v) e)
subVar (PAnything : ps, ce) = (ps, ce)
where
subVar (p:ps, ce@(C t s e)) =
let ctx = C t s in
(ps, case p of
PVar x -> C t s $ subst x (Var v) e
PAnything -> ce
PRecord fs ->
ctx $ foldr (\x -> subst x (Access (ctx (Var v)) x)) e fs
)
matchCon :: [String] -> [([Pattern],CExpr)] -> Match -> GuidCounter Match
matchCon (v:vs) cs def = (flip (Match v) def) `liftM` mapM toClause css

338
compiler/Gen/CompileToJS.hs Normal file
View file

@ -0,0 +1,338 @@
module CompileToJS (showErr, jsModule) where
import Control.Arrow (first,second)
import Control.Monad (liftM,(<=<),join,ap)
import Data.Char (isAlpha,isDigit)
import Data.List (intercalate,sortBy,inits,foldl')
import qualified Data.Map as Map
import Data.Either (partitionEithers)
import qualified Text.Pandoc as Pan
import Ast
import Context
import Rename (derename)
import Cases
import Guid
import Rename (deprime)
import Types.Types ( Type(RecordT) )
showErr :: String -> String
showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)
where msg = show . concatMap (++"<br>") . lines $ err
body = "var T = Elm.Text(elm);\n\
\return { main : T.text(T.monospace(" ++ msg ++ ")) };"
indent = concatMap f
where f '\n' = "\n "
f c = [c]
internalImports =
[ ("N" , "Elm.Native"),
("_N", "N.Utils(elm)"),
("_L", "N.List(elm)"),
("_E", "N.Error(elm)"),
("_str", "N.JavaScript(elm).toString")
]
parens s = "(" ++ s ++ ")"
brackets s = "{" ++ s ++ "}"
jsObj = brackets . intercalate ", "
jsList ss = "["++ intercalate "," ss ++"]"
jsFunc args body = "function(" ++ args ++ "){" ++ indent body ++ "}"
assign x e = "\nvar " ++ x ++ " = " ++ e ++ ";"
ret e = "\nreturn "++ e ++";"
iff a b c = a ++ "?" ++ b ++ ":" ++ c
quoted s = "'" ++ concatMap f s ++ "'"
where f '\n' = "\\n"
f '\'' = "\\'"
f '\t' = "\\t"
f '\"' = "\\\""
f '\\' = "\\\\"
f c = [c]
globalAssign n e = "\n" ++ assign' n e ++ ";"
assign' n e = n ++ " = " ++ e
jsModule (Module names exports imports stmts) =
setup ("Elm":modNames) ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
where
modNames = if null names then ["Main"] else names
modName = intercalate "." modNames
includes = concatMap jsImport imports
body = stmtsToJS stmts
defs = assign "$op" "{}"
program = "\nvar " ++ usefulFuncs ++ ";" ++ defs ++ includes ++ body ++
setup ("elm":"Native":modNames) ++
assign "_" ("elm.Native." ++ modName ++ "||{}") ++
getExports exports stmts ++ setup ("elm":modNames) ++
ret (assign' ("elm." ++ modName) "_") ++ "\n"
setup modNames = concatMap (\n -> globalAssign n $ n ++ "||{}") .
map (intercalate ".") . drop 2 . inits $ init modNames
usefulFuncs = intercalate ", " (map (uncurry assign') internalImports)
getExports names stmts = "\n"++ intercalate ";\n" (op : map fnPair fns)
where exNames n = either derename id n `elem` names
exports | null names = concatMap get stmts
| otherwise = filter exNames (concatMap get stmts)
(fns,ops) = partitionEithers exports
opPair op = "'" ++ op ++ "' : $op['" ++ op ++ "']"
fnPair fn = let fn' = derename fn in "_." ++ fn' ++ " = " ++ fn
op = ("_.$op = "++) . jsObj $ map opPair ops
get' (FnDef x _ _) = Left x
get' (OpDef op _ _ _) = Right op
get s = case s of Definition d -> [ get' d ]
Datatype _ _ tcs -> map (Left . fst) tcs
ImportEvent _ _ x _ -> [ Left x ]
ExportEvent _ _ _ -> []
TypeAlias _ _ _ -> []
TypeAnnotation _ _ -> []
jsImport (modul, how) =
case how of
As name -> assign name ("Elm." ++ modul ++ parens "elm")
Hiding vs -> include ++ " var hiding=" ++ (jsObj $ map (++":1") vs) ++
"; for(var k in _){if(k in hiding)continue;" ++
"eval('var '+k+'=_[\"'+k+'\"]')}"
Importing vs -> include ++ named
where
imprt v = assign' v ("_." ++ v)
def (o:p) = imprt (if isOp o then "$op['" ++ o:p ++ "']" else deprime (o:p))
named = if null vs then "" else "\nvar " ++ intercalate ", " (map def vs) ++ ";"
where
include = "\nvar _ = Elm." ++ modul ++ parens "elm" ++ ";" ++ setup modul
setup moduleName = " var " ++ concatMap (++";") (defs ++ [assign' moduleName "_"])
where
defs = map (\n -> assign' n (n ++ "||{}")) (subnames moduleName)
subnames = map (intercalate ".") . tail . inits . init . split
split names = case go [] names of
(name, []) -> [name]
(name, ns) -> name : split ns
go name str = case str of
'.':rest -> (reverse name, rest)
c:rest -> go (c:name) rest
[] -> (reverse name, [])
stmtsToJS :: [Statement] -> String
stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
return (concat program)
where
cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
valueOf s = case s of
Datatype _ _ _ -> 1
ImportEvent _ _ _ _ -> 2
Definition (FnDef f [] _) ->
if derename f == "main" then 5 else 4
Definition _ -> 3
ExportEvent _ _ _ -> 6
TypeAlias _ _ _ -> 0
TypeAnnotation _ _ -> 0
class ToJS a where
toJS :: a -> GuidCounter String
instance ToJS Def where
toJS (FnDef x [] e) = assign x `liftM` toJS' e
toJS (FnDef f as e) = (assign f . wrapper . func) `liftM` toJS' e
where
func body = jsFunc (intercalate ", " as) (ret body)
wrapper e | length as == 1 = e
| otherwise = 'F' : show (length as) ++ parens e
toJS (OpDef op a1 a2 e) =
do body <- toJS' e
let func = "F2" ++ parens (jsFunc (a1 ++ ", " ++ a2) (ret body))
return (globalAssign ("$op['" ++ op ++ "']") func)
instance ToJS Statement where
toJS stmt =
case stmt of
Definition d -> toJS d
Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
where toDef (name,args) =
let vars = map (('a':) . show) [1..length args] in
Definition . FnDef name vars . noContext $
Data (derename name) (map (noContext . Var) vars)
ImportEvent js base elm _ ->
do v <- toJS' base
return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal(elm).constant(" ++ v ++ ");"
, "\ndocument.addEventListener('", js
, "_' + elm.id, function(e) { elm.notify(", elm
, ".id, e.value); });" ]
ExportEvent js elm _ ->
return $ concat [ "\nlift(function(v) { "
, "var e = document.createEvent('Event');"
, "e.initEvent('", js, "_' + elm.id, true, true);"
, "e.value = v;"
, "document.dispatchEvent(e); return v; })(", elm, ");" ]
TypeAnnotation _ _ -> return ""
TypeAlias n _ t -> return ""
toJS' :: CExpr -> GuidCounter String
toJS' (C txt span expr) =
case expr of
MultiIf ps -> multiIfToJS span ps
Case e cases -> caseToJS span e cases
_ -> toJS expr
remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"
addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
access x e = e ++ "." ++ x
makeRecord kvs = record `liftM` collect kvs
where
combine r (k,v) = Map.insertWith (++) k v r
collect = liftM (foldl' combine Map.empty) . mapM prep
prep (k, as, e@(C t s _)) =
do v <- toJS' (foldr (\x e -> C t s $ Lambda x e) e as)
return (k,[v])
fields fs =
brackets ("\n "++intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))
hidden = fields . map (second jsList) .
filter (not . null . snd) . Map.toList . Map.map tail
record kvs = fields . (("_", hidden kvs) :) . Map.toList . Map.map head $ kvs
instance ToJS Expr where
toJS expr =
case expr of
Var x -> return $ x
Chr c -> return $ quoted [c]
Str s -> return $ "_str" ++ parens (quoted s)
IntNum n -> return $ show n
FloatNum n -> return $ show n
Boolean b -> return $ if b then "true" else "false"
Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
Access e x -> access x `liftM` toJS' e
Remove e x -> remove x `liftM` toJS' e
Insert e x v -> addField x `liftM` toJS' v `ap` toJS' e
Modify e fs -> do fs' <- (mapM (\(x,v) -> (,) x `liftM` toJS' v) fs)
setField fs' `liftM` toJS' e
Record fs -> makeRecord fs
Binop op e1 e2 -> binop op `liftM` toJS' e1 `ap` toJS' e2
If eb et ef ->
parens `liftM` (iff `liftM` toJS' eb `ap` toJS' et `ap` toJS' ef)
Lambda v e -> liftM (jsFunc v . ret) (toJS' e)
App e1 e2 -> jsApp e1 e2
Let defs e -> jsLet defs e
Data name es ->
do fs <- mapM toJS' es
return $ case name of
"Nil" -> jsNil
"Cons" -> jsCons (head fs) ((head . tail) fs)
_ -> jsObj $ ("ctor:" ++ show name) : fields
where fields = zipWith (\n e -> "_" ++ show n ++ ":" ++ e) [0..] fs
Markdown doc -> return $ "text('" ++ pad ++ md ++ pad ++ "')"
where pad = "<div style=\"height:0;width:0;\">&nbsp;</div>"
md = formatMarkdown $ Pan.writeHtmlString Pan.def doc
jsApp e1 e2 =
do f <- toJS' func
as <- mapM toJS' args
return $ case as of
[a] -> f ++ parens a
_ -> "A" ++ show (length as) ++ parens (intercalate ", " (f:as))
where
(func, args) = go [e2] e1
go args e =
case e of
(C _ _ (App e1 e2)) -> go (e2 : args) e1
_ -> (e, args)
formatMarkdown = concatMap f
where f '\'' = "\\'"
f '\n' = "\\n"
f '"' = "\""
f c = [c]
multiIfToJS span ps =
case last ps of
(C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
_ -> format ("_E.If" ++ parens (quoted (show span))) ps
where
format base ps =
foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
f (b,e) = do b' <- toJS' b
e' <- toJS' e
return (b' ++ " ? " ++ e')
jsLet defs e' = do ds <- jsDefs defs
e <- toJS' e'
return $ jsFunc "" (concat ds ++ ret e) ++ "()"
where
jsDefs defs = mapM toJS (sortBy f defs)
f a b = compare (valueOf a) (valueOf b)
valueOf (FnDef _ args _) = min 1 (length args)
valueOf (OpDef _ _ _ _) = 1
caseToJS span e ps = do
match <- caseToMatch ps
e' <- toJS' e
let (match',stmt) = case (match,e) of
(Match name _ _, C _ _ (Var x)) -> (matchSubst [(name,x)] match, "")
(Match name _ _, _) -> (match, assign name e')
_ -> (match, "")
matches <- matchToJS span match'
return $ "function(){ " ++ stmt ++ matches ++ " }()"
matchToJS span match =
case match of
Match name clauses def ->
do cases <- concat `liftM` mapM (clauseToJS span name) clauses
finally <- matchToJS span def
return $ concat [ "\nswitch (", name, ".ctor) {",
indent cases, "\n}", finally ]
Fail -> return ("_E.Case" ++ parens (quoted (show span)))
Break -> return "break;"
Other e -> ret `liftM` toJS' e
Seq ms -> concat `liftM` mapM (matchToJS span) (dropEnd [] ms)
where
dropEnd acc [] = acc
dropEnd acc (m:ms) =
case m of
Other _ -> acc ++ [m]
_ -> dropEnd (acc ++ [m]) ms
clauseToJS span var (Clause name vars e) = do
let vars' = map (\n -> var ++ "._" ++ show n) [0..]
s <- matchToJS span $ matchSubst (zip vars vars') e
return $ concat [ "\ncase ", quoted name, ":", indent s ]
jsNil = "_L.Nil"
jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"
jsRange e1 e2 = "_L.range" ++ parens (e1 ++ "," ++ e2)
jsCompare e1 e2 op = parens ("_N.cmp(" ++ e1 ++ "," ++ e2 ++ ").ctor" ++ op)
binop (o:p) e1 e2
| isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
| otherwise =
let ops = ["+","-","*","/","&&","||"] in
case o:p of
"::" -> jsCons e1 e2
"++" -> "_L.append" ++ parens (e1 ++ "," ++ e2)
"$" -> e1 ++ parens e2
"<|" -> e1 ++ parens e2
"|>" -> e2 ++ parens e1
"." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
"^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
"==" -> "_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
"/=" -> "!_N.eq(" ++ e1 ++ "," ++ e2 ++ ")"
"<" -> jsCompare e1 e2 "==='LT'"
">" -> jsCompare e1 e2 "==='GT'"
"<=" -> jsCompare e1 e2 "!=='GT'"
">=" -> jsCompare e1 e2 "!=='LT'"
"<~" -> "A2(lift," ++ e1 ++ "," ++ e2 ++ ")"
"~" -> "A3(lift2,F2(function(f,x){return f(x)}),"++e1++","++e2++")"
_ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
| otherwise -> concat [ "$op['", o:p, "']"
, parens e1, parens e2 ]

1
elm/src/Gen/ExtractNoscript.hs → compiler/Gen/ExtractNoscript.hs
View file

@ -36,7 +36,6 @@ instance Extract Expr where
(_ , ss1 , ss2 ) -> ss1 ++ ss2
Lambda v e -> f e
App (C _ _ (App (C _ _ (Var "link")) src)) txt -> linkExtract src txt
App (C _ _ (App (C _ _ (Var "Graphics.link")) src)) txt -> linkExtract src txt
App (C _ _ (App (C _ _ (Var "Text.link")) src)) txt -> linkExtract src txt
App (C _ _ (Var "header")) e -> tag "h1" e
App (C _ _ (Var "bold")) e -> tag "b" e

75
compiler/Gen/GenerateHtml.hs Normal file
View file

@ -0,0 +1,75 @@
{-# LANGUAGE OverloadedStrings #-}
module GenerateHtml (generateHtml,
modulesToHtml, linkedHtml,
JSStyle (..)
) where
import Data.List (intercalate)
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (Html)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5 ((!))
import qualified Text.Blaze.Html5.Attributes as A
import Text.Jasmine (minify)
import qualified Data.ByteString.Lazy.Char8 as BS
import Ast
import Initialize (buildFromSource)
import CompileToJS
import ExtractNoscript
import Libraries as Libraries
data JSStyle = Minified | Readable
makeScript :: JSStyle -> Either String String -> H.Html
makeScript _ (Left s) =
H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""
makeScript jsStyle (Right s) =
H.script ! A.type_ "text/javascript" $ preEscapedToMarkup content
where content = case jsStyle of
Minified -> BS.unpack . minify . BS.pack $ s
Readable -> s
-- |This function compiles Elm code into simple HTML.
--
-- Usage example:
--
-- > generateHtml "/elm-min.js" "Some title" [elmFile|elm-source/somePage.elm|]
generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browser
-> String -- ^ The page title
-> String -- ^ The elm source code.
-> Html
generateHtml libLoc title source =
case buildFromSource True source of
Right modul -> modulesToHtml Readable title libLoc [] True [modul]
Left err -> createHtml Readable libLoc title (Right $ showErr err)
(H.noscript "") "Main"
modulesToHtml jsStyle title libLoc jss nscrpt modules =
createHtml jsStyle libLoc title' js noscript altTitle
where
js = Right $ jss ++ concatMap jsModule modules
noscript = if nscrpt then extractNoscript $ last modules else ""
title' = if null title then altTitle else title
altTitle = intercalate "." names
where Module names _ _ _ = last modules
linkedHtml rtLoc jsLoc modules =
createHtml Readable rtLoc title (Left jsLoc) (H.noscript "") title
where
title = (\(Module names _ _ _) -> intercalate "." names) (last modules)
createHtml jsStyle libLoc title js noscript moduleToLoad =
H.docTypeHtml $ do
H.head $ do
H.meta ! A.charset "UTF-8"
H.title . H.toHtml $ title
makeScript Readable (Left libLoc)
makeScript jsStyle js
H.body $ do
H.script ! A.type_ "text/javascript" $ preEscapedToMarkup ("Elm.fullscreen(Elm." ++ moduleToLoad ++ ")" :: String)
H.noscript $ preEscapedToMarkup noscript

97
compiler/Initialize.hs Normal file
View file

@ -0,0 +1,97 @@
module Initialize (build, buildFromSource) where
import Control.Applicative ((<$>))
import Control.Monad.Error
import Data.List (lookup,nub)
import qualified Data.Map as Map
import Ast
import Data.Either (lefts,rights)
import Data.List (intercalate,partition)
import Parse.Parser (parseProgram, preParse)
import Rename
import qualified Libraries as Libs
import Types.Types ((-:))
import Types.Hints (hints)
import Types.Unify
import Types.Alias (dealias, mistakes)
import Optimize
import CompileToJS (jsModule)
checkMistakes :: Module -> Either String Module
checkMistakes modul@(Module name ex im stmts) =
case mistakes stmts of
m:ms -> Left (unlines (m:ms))
[] -> return modul
checkTypes :: Module -> Either String Module
checkTypes modul =
do subs <- unify hints modul
subs `seq` return (optimize (renameModule modul))
check :: Module -> Either String Module
check = checkMistakes >=> checkTypes
buildFromSource :: Bool -> String -> Either String Module
buildFromSource withPrelude src = (check . add) =<< (parseProgram src)
where add = if withPrelude then Libs.addPrelude else id
build :: Bool -> FilePath -> IO (Either String [Module])
build withPrelude root = do
names <- getSortedModuleNames root
case names of
Left err -> return (Left err)
Right ns -> do srcs <- zipWithM buildFile' [1..] ns
return (sequence srcs)
where
buildFile' n name = putStrLn (msg n name) >> buildFile withPrelude name
msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
buildFile :: Bool -> String -> IO (Either String Module)
buildFile withPrelude moduleName =
let filePath = toFilePath moduleName in
case isNative moduleName of
True -> return (Right $ Module [moduleName] [] [] [])
--return (Left "Can't do that yet")
--Right `liftM` readFile filePath
False -> do txt <- readFile filePath
return $ buildFromSource withPrelude txt
getSortedModuleNames :: FilePath -> IO (Either String [String])
getSortedModuleNames root = do
deps <- readDeps [] root
return (sortDeps =<< deps)
type Deps = (String, [String])
sortDeps :: [Deps] -> Either String [String]
sortDeps deps = go [] (nub deps)
where
msg = "A cyclical or missing module dependency or was detected in: "
go :: [String] -> [Deps] -> Either String [String]
go sorted [] = Right sorted
go sorted unsorted =
case partition (all (`elem` sorted) . snd) unsorted of
([],m:ms) -> Left (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
(srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
readDeps :: [FilePath] -> FilePath -> IO (Either String [Deps])
readDeps seen root = do
txt <- readFile root
case preParse txt of
Left err -> return (Left err)
Right (name,deps) -> do rest <- mapM (readDeps seen' . toFilePath) newDeps
return $ do rs <- sequence rest
return ((name, realDeps) : concat rs)
where realDeps = filter (`notElem` builtIns) deps
newDeps = filter (`notElem` seen) realDeps
seen' = root : seen ++ newDeps
builtIns = Map.keys Libs.libraries
isNative name = takeWhile (/='.') name == "Native"
toFilePath name = map swapDots name ++ ext
where swapDots '.' = '/'
swapDots c = c
ext = if isNative name then ".js" else ".elm"

58
compiler/Language/Elm.hs Normal file
View file

@ -0,0 +1,58 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{- | This module exports the functions necessary for compiling Elm code into the
respective HTML, JS and CSS code.
The type class @'ElmSource'@ requires an instance for all types that the Elm
compiler understands. The provided instances for String, Text and QuasiQuoted
Elm source code should be sufficient.
The documentation for the Elm language is available at
<http://elm-lang.org/Documentation.elm>, and many interactive examples are
available at <http://elm-lang.org/Examples.elm>
Example implementations using Yesod and Happstack are available
at <https://github.com/tazjin/Elm/tree/master/Examples>
-}
module Language.Elm (
compile, toHtml,
moduleName,
runtime, docs
) where
import qualified Ast as Ast
import qualified Libraries as Libraries
import Data.List (intercalate)
import Data.Version (showVersion)
import CompileToJS (showErr, jsModule)
import ExtractNoscript
import GenerateHtml
import Initialize
import Text.Blaze.Html (Html)
import Paths_Elm
-- |This function compiles Elm code to JavaScript.
compile :: String -> String
compile source = either showErr jsModule modul
where modul = buildFromSource True source
-- |This function extracts the module name of a given source program.
moduleName :: String -> String
moduleName source = either (const "Main") getName modul
where modul = buildFromSource False source
getName (Ast.Module names _ _ _) = intercalate "." names
-- |This function compiles Elm code into a full HTML page.
toHtml :: String -- ^ Location of elm-min.js as expected by the browser
-> String -- ^ The page title
-> String -- ^ The elm source code
-> Html
toHtml = generateHtml
-- |The absolute path to Elm's runtime system.
runtime :: IO FilePath
runtime = getDataFileName "elm-runtime.js"
-- |The absolute path to Elm's core library documentation.
docs :: IO FilePath
docs = getDataFileName "docs.json"

0
elm/src/Language/Elm/Quasi.hs → compiler/Language/Elm/Quasi.hs
View file

53
elm/src/Ast.hs → compiler/Model/Ast.hs
View file

@ -2,7 +2,7 @@
module Ast where
import Context
import Data.Char (isDigit)
import Data.Char (isDigit, isSymbol)
import Data.List (intercalate)
import Types.Types
import qualified Text.Pandoc as Pandoc
@ -12,8 +12,8 @@ data Module = Module [String] Exports Imports [Statement]
type Exports = [String]
type Imports = [(String, ImportMethod)]
data ImportMethod = As String | Hiding [String] | Importing [String]
deriving (Eq,Ord)
data ImportMethod = As String | Importing [String] | Hiding [String]
deriving (Eq, Ord, Show)
data Pattern = PData String [Pattern]
@ -73,24 +73,27 @@ plist = foldr pcons pnil
ptuple es = PData ("Tuple" ++ show (length es)) es
brkt s = "{ " ++ s ++ " }"
parensIf b s = if b then parens s else s
isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
instance Show Pattern where
show (PRecord fs) = brkt (intercalate ", " fs)
show (PVar x) = x
show PAnything = "_"
show (PData "Cons" [hd@(PData "Cons" _),tl]) =
parens (show hd) ++ " : " ++ show tl
where parens s = "(" ++ s ++ ")"
show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl
show (PData "Nil" []) = "[]"
show (PData name ps) =
show p =
case p of
PRecord fs -> brkt (intercalate ", " fs)
PVar x -> x
PAnything -> "_"
PData "Cons" [hd@(PData "Cons" _),tl] ->
parens (show hd) ++ " :: " ++ show tl
PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl
PData "Nil" [] -> "[]"
PData name ps ->
if take 5 name == "Tuple" && all isDigit (drop 5 name) then
parens . intercalate ", " $ map show ps
else (if null ps then id else parens) $ unwords (name : map show ps)
where parens s = "(" ++ s ++ ")"
else parensIf (not (null ps)) $ unwords (name : map show ps)
instance Show Expr where
show e =
let show' (C _ _ e) = parensIf (needsParens e) (show e) in
case e of
IntNum n -> show n
FloatNum n -> show n
@ -116,7 +119,7 @@ instance Show Expr where
where iff (b,e) = show b ++ " -> " ++ show e
sep = concatMap ("\n | " ++)
Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
Var x -> x
Var (c:cs) -> if isOp c then parens (c:cs) else c:cs
Case e pats -> "case "++ show e ++" of " ++ brkt (intercalate " ; " pats')
where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
Data name es
@ -138,13 +141,13 @@ getLambdas (C _ _ (Lambda x e)) = (x:xs,e')
where (xs,e') = getLambdas e
getLambdas e = ([],e)
show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e
needsParens (Binop _ _ _) = True
needsParens (Lambda _ _) = True
needsParens (App _ _) = True
needsParens (If _ _ _) = True
needsParens (Let _ _) = True
needsParens (Case _ _) = True
needsParens (Data name (x:xs)) = name /= "Cons"
needsParens _ = False
needsParens e =
case e of
Binop _ _ _ -> True
Lambda _ _ -> True
App _ _ -> True
If _ _ _ -> True
Let _ _ -> True
Case _ _ -> True
Data name (x:xs) -> name /= "Cons"
_ -> False

0
elm/src/Context.hs → compiler/Model/Context.hs
View file

4
elm/src/Guid.hs → compiler/Model/Guid.hs
View file

@ -1,5 +1,5 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Guid (guid, run, runAt, GuidCounter) where
module Guid (guid, set, run, runAt, GuidCounter) where
import Control.Monad.State (evalState, State, get, put)
@ -13,5 +13,7 @@ guid = GC $ do n <- get
put (n + 1)
return n
set n = GC (put n)
run = runAt 0
runAt n x = evalState (runGC x) n

59
compiler/Model/Libraries.hs Normal file
View file

@ -0,0 +1,59 @@
module Libraries (libraries, addPrelude) where
import Ast
import Control.Applicative ((<$>),(<*>))
import qualified Data.Map as Map
import Data.List (inits)
import Text.JSON
import LoadLibraries as Libs
addPrelude :: Module -> Module
addPrelude (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts
where customIms = concatMap addModule prelude
addModule (n, method) = case lookup n ims of
Nothing -> [(n, method)]
Just (As m) -> [(n, method)]
Just _ -> []
prelude = text : map (\n -> (n, Hiding [])) modules
where
text = ("Text", Hiding ["link", "color", "height"])
modules = [ "Prelude", "Signal", "List", "Maybe", "Time"
, "Graphics.Element", "Color", "Graphics.Collage" ]
libraries :: Map.Map String (Map.Map String String)
libraries =
case getLibs of
Error err -> error err
Ok libs -> Map.unionWith Map.union libs nilAndTuples
where nilAndTuples = Map.singleton "Prelude" (Map.fromList pairs)
pairs =
[ ("Cons", "a -> [a] -> [a]")
, ("Nil", "[a]")
] ++ map makeTuple (inits ['a'..'i'])
makeTuple cs =
let name = "Tuple" ++ show (length cs)
in (name, concatMap (\c -> c : " -> ") cs ++
name ++ concatMap (\c -> [' ',c]) cs)
getLibs :: Result (Map.Map String (Map.Map String String))
getLibs = do
obj <- decodeStrict Libs.docs :: Result (JSObject JSValue)
modules <- valFromObj "modules" obj :: Result [JSObject JSValue]
Map.fromList `fmap` mapM getValues modules
get :: String -> JSObject JSValue -> Result String
get = valFromObj
getValue :: JSObject JSValue -> Result (String,String)
getValue obj = (,) <$> get "name" obj <*> get "type" obj
getValues :: JSObject JSValue -> Result (String, Map.Map String String)
getValues obj = do
name <- get "name" obj
vs <- valFromObj "values" obj
vals <- mapM getValue vs
return (name, Map.fromList vals)

34
compiler/Model/LoadLibraries.hs Normal file
View file

@ -0,0 +1,34 @@
module LoadLibraries (docs) where
import Control.DeepSeq (force)
import qualified Control.Exception as E
import Paths_Elm
import System.Directory
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
-- See stackoverflow discussion for trade-off between using unsafeIO or TemplateHaskell:
-- http://stackoverflow.com/questions/12716215/load-pure-global-variable-from-file
-- Given the awkwardness of including a compile-time generated file
-- vs loading static data, then the unsafeIO seems better.
{-# NOINLINE docs #-}
docs :: String
docs = force $ unsafePerformIO (safeReadDocs =<< getDataFileName "docs.json")
safeReadDocs :: FilePath -> IO String
safeReadDocs name = E.catch (readDocs name) (emitError name)
readDocs :: FilePath -> IO String
readDocs name = do
exists <- doesFileExist name
if exists then readFile name
else ioError . userError $ "File Not Found"
emitError :: FilePath -> IOError -> IO String
emitError name err = do
putStrLn $ "Error! Types for standard library not loaded properly!\n File should be here:" ++ name ++ "\n The file is created and copied by command: cabal install"
putStrLn (show err)
return "{\"modules\":[]}"

1
elm/src/Parse/Binops.hs → compiler/Parse/Binops.hs
View file

@ -28,6 +28,7 @@ table = [ (9, R, ".")
, (3, R, "&&")
, (2, R, "||")
, (0, R, "$")
, (0, R, "<|"), (0, L, "|>")
]
opLevel op = Map.findWithDefault 9 op dict

0
elm/src/Parse/Expr.hs → compiler/Parse/Expr.hs
View file

0
elm/src/Parse/Foreign.hs → compiler/Parse/Foreign.hs
View file

8
elm/src/Parse/Library.hs → compiler/Parse/Library.hs
View file

@ -6,7 +6,7 @@ import Context
import Control.Applicative ((<$>),(<*>))
import Control.Monad
import Control.Monad.State
import Data.Char (isSymbol,isUpper)
import Data.Char (isUpper)
import Rename (deprime)
import Text.Parsec hiding (newline,spaces,State)
import Text.Parsec.Indent
@ -16,7 +16,7 @@ reserveds = [ "if", "then", "else"
, "let", "in"
, "data", "type"
, "module", "where"
, "import", "as", "hiding"
, "import", "as", "hiding", "open"
, "export", "foreign" ]
expecting = flip (<?>)
@ -58,8 +58,6 @@ reserved word =
anyOp :: IParser String
anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
symOp :: IParser String
symOp = do op <- many1 (satisfy isOp)
guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
@ -162,7 +160,7 @@ whitespace :: IParser ()
whitespace = optional forcedWS <?> ""
freshLine :: IParser [[String]]
freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
where space_nl = try $ spaces >> many1 newline
newline :: IParser String

13
elm/src/Parse/Modules.hs → compiler/Parse/Modules.hs
View file

@ -30,18 +30,17 @@ import' :: IParser (String, ImportMethod)
import' = do
reserved "import"
whitespace
open <- optionMaybe (reserved "open")
whitespace
name <- intercalate "." <$> dotSep1 capVar
method <- option (Hiding []) $ try (whitespace >>
(as' <|> hiding' <|> importing'))
return (name, method)
case open of
Just _ -> return (name, Hiding [])
Nothing -> let how = try (whitespace >> (as' <|> importing'))
in (,) name <$> option (Importing []) how
as' :: IParser ImportMethod
as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
hiding' :: IParser ImportMethod
hiding' = reserved "hiding" >> whitespace >>
Hiding <$> varList <?> "listing of hidden values"
importing' :: IParser ImportMethod
importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"

25
elm/src/Parse/Parser.hs → compiler/Parse/Parser.hs
View file

@ -1,10 +1,10 @@
module Parse.Parser (parseProgram) where
module Parse.Parser (parseProgram, preParse) where
import Ast
import Control.Applicative ((<$>), (<*>))
import Control.Monad
import Data.Char (isSymbol, isDigit)
import Data.List (foldl')
import Data.List (foldl',intercalate)
import Text.Parsec hiding (newline,spaces)
import Parse.Library
@ -14,8 +14,8 @@ import Parse.Modules
import Parse.Foreign
statement = let defs = [ foreignDef, datatype, typeAlias, typeAnnotation ] in
(:[]) <$> choice defs <|> def <?> "datatype or variable definition"
statement = choice (typeAlias:defs) <|> def <?> "datatype or variable definition"
where defs = map ((:[]) <$>) [ foreignDef, datatype, typeAnnotation ]
freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do
freshLine
@ -33,7 +33,20 @@ program = do
optional freshLine ; optional spaces ; eof
return $ Module names exports is statements
parseProgram source =
case iParse program "" source of
parseProgram = setupParser program
preParse :: String -> Either String (String, [String])
preParse = setupParser $ do
optional skip
(,) <$> option "Main" moduleName <*> option [] imprts
where
skip = try (manyTill anyChar (try (string "/**")))
imprts = fmap (map fst) imports `followedBy` freshLine
getName = intercalate "." . fst
moduleName = do optional freshLine
getName <$> moduleDef `followedBy` freshLine
setupParser p source =
case iParse p "" source of
Right result -> Right result
Left err -> Left $ "Parse error at " ++ show err

9
elm/src/Parse/Patterns.hs → compiler/Parse/Patterns.hs
View file

@ -88,10 +88,11 @@ matchSingle :: Pattern -> CExpr -> Pattern -> GuidCounter [Def]
matchSingle pat exp@(C t s _) p =
let ctx = C t s in
case p of
PData _ ps -> do x <- guid
let v = '_' : show x
dss <- mapM (matchSingle p . ctx $ Var v) ps
return (FnDef v [] exp : concat dss)
PData _ ps -> do
x <- guid
let v = '_' : show x
dss <- mapM (matchSingle pat . ctx $ Var v) ps
return (FnDef v [] exp : concat dss)
PVar x ->
return [ FnDef x [] (ctx $ Case exp [(pat, ctx $ Var x)]) ]

25
elm/src/Parse/Types.hs → compiler/Parse/Types.hs
View file

@ -9,8 +9,9 @@ import Data.List (lookup)
import Text.Parsec
import Text.Parsec.Indent
import Context
import Parse.Library
import Types.Types hiding (string,parens)
import Types.Types hiding (parens,string)
import Guid
data ParseType = VarPT String
@ -46,10 +47,7 @@ typeUnambiguous :: IParser ParseType
typeUnambiguous = typeList <|> typeTuple <|> typeRecord
typeSimple :: IParser ParseType
typeSimple = dealias <$> var
where dealias "String" = listPT (VarPT "Char")
dealias "Time" = VarPT "Float"
dealias v = VarPT v
typeSimple = VarPT <$> var
typeApp :: IParser ParseType
typeApp = do name <- capVar <?> "type constructor"
@ -70,8 +68,9 @@ typeConstructor :: IParser (String, [ParseType])
typeConstructor = (,) <$> (capVar <?> "another type constructor")
<*> spacePrefix (typeSimple <|> typeUnambiguous)
typeAlias :: IParser Statement
typeAlias :: IParser [Statement]
typeAlias = do
start <- getPosition
reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
forcedWS
alias <- capVar
@ -79,9 +78,21 @@ typeAlias = do
whitespace ; string "=" ; whitespace
let n = length args
tipe <- typeExpr
end <- getPosition
case toTypeWith alias (zip args [1..n]) tipe of
Right t -> return (TypeAlias alias [1..n] t)
Left msg -> fail msg
Right t -> return (TypeAlias alias [1..n] t : ctor)
where ctor = case tipe of
RecordPT _ kvs -> [toConstructor start end alias kvs]
_ -> []
toConstructor start end alias kvs =
Definition (FnDef alias args (ctxt (Record rec)))
where
ctxt = pos start end
args = map fst kvs
rec = map (\a -> (a, [], ctxt (Var a))) args
typeAnnotation :: IParser Statement
typeAnnotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)

53
compiler/Transform/LetBoundVars.hs Normal file
View file

@ -0,0 +1,53 @@
module LetBoundVars (letBoundVars) where
import Context
import Ast
class LetBoundVars a where
letBoundVars :: a -> [String]
instance LetBoundVars a => LetBoundVars [a] where
letBoundVars = concatMap letBoundVars
instance LetBoundVars Statement where
letBoundVars stmt =
case stmt of
Definition d -> letBoundVars d
Datatype _ _ tcs -> []
ImportEvent _ e _ _ -> letBoundVars e
ExportEvent _ _ _ -> []
TypeAnnotation _ _ -> []
TypeAlias _ _ _ -> []
instance LetBoundVars Def where
letBoundVars (FnDef n _ e) = n : letBoundVars e
letBoundVars (OpDef _ _ _ e) = letBoundVars e
instance LetBoundVars e => LetBoundVars (Context e) where
letBoundVars (C _ _ e) = letBoundVars e
instance LetBoundVars Expr where
letBoundVars expr =
let f = letBoundVars in
case expr of
IntNum _ -> []
FloatNum _ -> []
Chr _ -> []
Str _ -> []
Boolean _ -> []
Range e1 e2 -> f e1 ++ f e2
Access e _ -> []
Remove e _ -> []
Insert e1 _ e2 -> f e1 ++ f e2
Modify e ps -> f e ++ concatMap (f . snd) ps
Record trps -> concatMap (\(_,_,e) -> f e) trps
Binop op e1 e2 -> f e1 ++ f e2
Lambda x e -> f e
App e1 e2 -> f e1 ++ f e2
If e1 e2 e3 -> concatMap f [e1,e2,e3]
MultiIf ps -> concatMap (\(b,e) -> f b ++ f e) ps
Let defs e -> concatMap letBoundVars defs ++ f e
Var x -> []
Data name es -> concatMap f es
Case e cases -> f e ++ concatMap (f . snd) cases
Markdown _ -> []

4
elm/src/Optimize.hs → compiler/Transform/Optimize.hs
View file

@ -112,7 +112,7 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
("||", Boolean True, _) -> Boolean True
("||", Boolean False, _) -> e2
(":", _, _) -> let (C _ _ e) = cons ce1 ce2 in e
("::", _, _) -> let (C _ _ e) = cons ce1 ce2 in e
("++", Str s1, Str s2) -> Str $ s1 ++ s2
("++", Str s1, Binop "++" (C _ _ (Str s2)) ce) ->
@ -124,6 +124,8 @@ binop op ce1@(C t1 s1 e1) ce2@(C t2 s2 e2) =
("++", _, Data "Nil" []) -> e1
("++", Data "Cons" [h,t], _) -> Data "Cons" [h, noContext $ binop "++" t ce2]
("|>", _, _) -> App ce2 ce1
("<|", _, _) -> App ce1 ce2
("$", _, _) -> App ce1 ce2
(".", _, _) ->
Lambda "x" (noContext $

2
elm/src/Rename.hs → compiler/Transform/Rename.hs
View file

@ -133,6 +133,8 @@ patternExtend pattern env =
first (PData name . reverse) `liftM` foldM f ([], env) ps
where f (rps,env') p = do (rp,env'') <- patternExtend p env'
return (rp:rps, env'')
PRecord fs ->
return (pattern, foldr (\f e n -> if n == f then f else env n) env fs)
patternRename :: (String -> String) -> (Pattern, CExpr) -> GuidCounter (Pattern, CExpr)
patternRename env (p,e) = do

0
elm/src/Replace.hs → compiler/Transform/Replace.hs
View file

0
elm/src/Substitute.hs → compiler/Transform/Substitute.hs
View file

58
elm/src/Types/Alias.hs → compiler/Types/Alias.hs
View file

@ -1,5 +1,5 @@
module Types.Alias (dealias, mistakes) where
module Types.Alias (dealias, get, mistakes) where
import Ast
import Control.Arrow (second)
@ -10,37 +10,39 @@ import Types.Substitutions (subst)
import Types.Types
builtins :: [(String,([X],Type))]
builtins = [ ("String", ([], string)) ]
builtins =
let touch = ("t0", time) : map (flip (,) int) ["x","y","x0","y0","id"]
state = [("string", string), ("selectionStart", int), ("selectionEnd", int)]
line = [("color", tipe "Color"), ("width", float),
("cap", tipe "LineCap"), ("join", tipe "LineJoin"),
("miterLimit", float), ("dashing", listOf int),
("dashOffset", int)]
makeRecord fields =
RecordT (Map.fromList $ map (second (:[])) fields) EmptyRecord
in [ ("String", ([], listOf char)),
("Time", ([], float)),
("KeyCode", ([], int)),
("Touch", ([], makeRecord touch)),
("FieldState", ([], makeRecord state)),
("LineStyle", ([], makeRecord line))
]
getAliases :: [Statement] -> Map.Map String ([X],Type)
getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
get :: [Statement] -> Map.Map String ([X],Type)
get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
where getAlias stmt = case stmt of
TypeAlias alias xs t -> [(alias, (xs,t))]
_ -> []
dealias :: [Statement] -> [Statement]
dealias stmts = map dealiasS stmts
where
dealiasT :: Type -> Type
dealiasT t =
case t of
ADT name ts -> case Map.lookup name (getAliases stmts) of
Just (xs,t) -> dealiasT (subst (zip xs ts) t)
Nothing -> ADT name (map dealiasT ts)
LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)
RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)
_ -> t
dealiasS :: Statement -> Statement
dealiasS s =
case s of
Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)
ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)
ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)
TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)
TypeAlias alias xs tipe -> TypeAlias alias xs (dealiasT tipe)
Definition _ -> s
dealias :: Map.Map String ([X],Type) -> Type -> Type
dealias aliases t =
let f = dealias aliases in
case t of
ADT name ts -> case Map.lookup name aliases of
Just (xs,t) -> f (subst (zip xs ts) t)
Nothing -> ADT name (map f ts)
LambdaT t u -> LambdaT (f t) (f u)
RecordT r t -> RecordT (Map.map (map f) r) (f t)
_ -> t
mistakes :: [Statement] -> [String]
mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
@ -55,7 +57,7 @@ badKinds stmts = map msg (concatMap badS stmts)
badT t =
case t of
ADT name ts ->
case Map.lookup name (getAliases stmts) of
case Map.lookup name (get stmts) of
Just (xs,t) | length xs == length ts -> []
| otherwise -> [name]
Nothing -> concatMap badT ts

70
elm/src/Types/Constrain.hs → compiler/Types/Constrain.hs
View file

@ -4,6 +4,7 @@ module Types.Constrain (constrain) where
import Control.Arrow (second)
import Control.Monad (liftM,mapM,zipWithM,foldM)
import Control.Monad.State (evalState)
import Data.Char (isDigit)
import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
import qualified Data.Map as Map
import qualified Data.Set as Set
@ -13,32 +14,33 @@ import Context
import Guid
import Types.Types
import Types.Substitutions
import qualified Types.Substitutions as Subs
beta = VarT `liftM` guid
unionA = Map.unionWith (++)
unionsA = Map.unionsWith (++)
getAliases imports hints = hints ++ concatMap aliasesFrom imports'
where imports' = map head . group $ sort imports
aliasesFrom (name,method) =
case method of
As alias -> concatMap (findAlias name alias) hints
Hiding [] -> concatMap (findAlias name "") hints
_ -> []
findAlias mName' mAlias (name,tipe) =
let mName = mName' ++ "." in
case mName `isPrefixOf` name of
True -> [ (mAlias ++ drop (length mName) name, tipe) ]
False -> []
getAliases imports hints = concatMap aliasesFrom imports
where aliasesFrom (name,method) =
let values = concatMap (getValue name) hints
in case method of
As alias -> map (\(n,t) -> (alias ++ "." ++ n, t)) values
Hiding vs -> filter (\(n,t) -> n `notElem` vs) values
Importing vs -> filter (\(n,t) -> n `elem` vs) values
getValue inModule (name,tipe) =
case inModule `isPrefixOf` name of
True -> [ (drop (length inModule + 1) name, tipe) ]
False -> []
findAmbiguous hints hints' assumptions continue =
let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints'
dups = filter (\k -> Map.member k assumptions) potentialDups
in case dups of
n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ "' could refer to " ++
intercalate ", " (filter (isSuffixOf n) hints)
_ -> continue
findAmbiguous hints assumptions continue =
let potentialDups = map head . filter (\g -> length g > 1) . group . sort $
filter (elem '.') hints
dups = filter (\k -> Map.member k assumptions) potentialDups
in case dups of
n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++
"' could refer to " ++
intercalate ", " (filter (isSuffixOf n) hints)
_ -> continue
mergeSchemes :: [Map.Map String Scheme]
-> GuidCounter (TVarMap, ConstraintSet, Map.Map String Scheme)
@ -59,21 +61,20 @@ mergeSchemes schmss = do (ass,css,sss) <- unzip3 `liftM` mapM split kvs
constrain typeHints (Module _ _ imports stmts) = do
(ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
hints <- typeHints
aliasHints <- getAliases imports `liftM` typeHints
(as', cs', schemes) <- mergeSchemes schemess
let constraints = Set.unions (cs':css)
as = unionsA (as':ass)
extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))
["List","Signal","Text","Graphics","Color"]
aliasHints = getAliases (imports ++ extraImports) hints
allHints = Map.union schemes (Map.fromList aliasHints)
insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
assumptions <- foldM insert as (Map.keys schemes)
findAmbiguous (map fst hints) (map fst aliasHints) assumptions $ do
findAmbiguous (map fst aliasHints) assumptions $ do
let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
escapees = Map.keys $ Map.difference assumptions allHints
return . Right . (,) escapees $ Set.toList constraints ++ cs
return $ case escapees of
_ -> Right (Set.toList constraints ++ cs)
--_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
type TVarMap = Map.Map String [X]
type ConstraintSet = Set.Set (Context Constraint)
@ -232,13 +233,13 @@ caseGen tipe (p, ce@(C _ span e)) = do
return ( as', Set.union cs cs', t )
patternGen :: (Constraint -> Context Constraint)
-> Type
-> Type -- Type of e in `case e of ...`
-> TVarMap
-> Pattern
-> GuidCounter (TVarMap, ConstraintSet, Type)
patternGen ctxt tipe as pattern =
case pattern of
PAnything -> do b <- beta ; return (Map.empty, Set.empty, b)
PAnything -> do b <- beta ; return ( as, Set.empty, b )
PVar v -> do
b <- beta
let cs = map (ctxt . (b :=:) . VarT) (Map.findWithDefault [] v as)
@ -253,6 +254,15 @@ patternGen ctxt tipe as pattern =
return ( Map.insert name [constr] as'
, Set.insert (ctxt (VarT constr :=: t)) cs
, output )
PRecord fs ->
do pairs <- mapM (\f -> do b <- beta; return (f,b)) fs
b <- beta
let t = RecordT (Map.fromList $ map (second (:[])) pairs) b
mkCs (name,tipe) = map (ctxt . (tipe :=:) . VarT)
(Map.findWithDefault [] name as)
return ( foldr Map.delete as fs
, Set.fromList (ctxt (t :=: tipe) : concatMap mkCs pairs)
, t )
defScheme :: Def -> GuidCounter (Map.Map String [X], Scheme)
@ -273,7 +283,7 @@ defGenHelp name args e = do
let as' = Map.findWithDefault [v] arg as
return $ map (\y -> ctx arg NoSpan $ VarT x :=: VarT y) as'
cs' <- concat `liftM` mapM genCs argDict
scheme <- generalize (concat $ Map.elems as') $
scheme <- Subs.generalize (concat $ Map.elems as') $
Forall (map snd argDict) (cs' ++ Set.toList cs) tipe
return ( as', Set.empty, (name, scheme) )
@ -302,7 +312,7 @@ stmtGen stmt =
, Map.singleton elm (Forall [] [] tipe) )
TypeAnnotation name tipe ->
do schm <- generalize [] (Forall [] [] tipe)
do schm <- Subs.generalize [] =<< Subs.superize name tipe
return (Map.empty, Set.empty, Map.singleton name schm)
TypeAlias _ _ _ -> return (Map.empty, Set.empty, Map.empty)

31
compiler/Types/Hints.hs Normal file
View file

@ -0,0 +1,31 @@
module Types.Hints (hints) where
import Control.Arrow (first)
import Control.Monad (liftM)
import Data.Maybe (catMaybes)
import qualified Data.Map as Map
import Guid
import qualified Libraries as Libs
import Parse.Library (iParse)
import Parse.Types
import qualified Types.Substitutions as Subs
import Types.Types
hints :: GuidCounter [(String, Scheme)]
hints = liftM catMaybes (mapM toScheme values)
where
values :: [(String, String)]
values = addPrefixes (Map.toList (Map.map Map.toList Libs.libraries))
addPrefixes :: [(String,[(String, String)])] -> [(String, String)]
addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
toScheme :: (String, String) -> GuidCounter (Maybe (String, Scheme))
toScheme (name, 't':'y':'p':'e':' ':_) = return Nothing
toScheme (name, 'd':'a':'t':'a':' ':_) = return Nothing
toScheme (name, tipeString) =
let err = "compiler error parsing type of " ++ name ++ ":\n" ++ tipeString in
case iParse (fmap toType typeExpr) err tipeString of
Left err -> error (show err)
Right tipe -> do scheme <- Subs.generalize [] =<< Subs.superize name tipe
return (Just (name, scheme))

102
elm/src/Types/Solver.hs → compiler/Types/Solver.hs
View file

@ -13,14 +13,17 @@ import Guid
import Types.Types
import Types.Constrain
import Types.Substitutions
import Types.Alias (dealias)
isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2
isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)
isSolved ss c = False
crush :: Scheme -> GuidCounter (Either String Scheme)
crush (Forall xs cs t) =
do subs <- solver cs Map.empty
type Aliases = Map.Map String ([X],Type)
crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)
crush aliases (Forall xs cs t) =
do subs <- solver aliases Map.empty cs
return $ do ss' <- subs
let ss = Map.toList ss'
cs' = filter (not . isSolved ss) (subst ss cs)
@ -34,10 +37,11 @@ schemeSubHelp txt span x s t1 rltn t2 = do
| otherwise = do (st, cs) <- concretize s
return (subst [(x,st)] t, cs)
schemeSub x s c = do s' <- crush s
case s' of
Right s'' -> Right `liftM` schemeSub' x s'' c
Left err -> return $ Left err
schemeSub aliases x s c =
do s' <- crush aliases s
case s' of
Right s'' -> Right `liftM` schemeSub' x s'' c
Left err -> return $ Left err
schemeSub' x s c@(C txt span constraint) =
case constraint of
@ -77,29 +81,32 @@ recordConstraints eq fs t fs' t' =
let tipe = RecordT (Map.singleton k bs) (VarT x)
return (cs ++ [eq t tipe])
solver :: [Context Constraint]
solver :: Aliases
-> Map.Map X Type
-> [Context Constraint]
-> GuidCounter (Either String (Map.Map X Type))
solver [] subs = return $ Right subs
solver (C txt span c : cs) subs =
solver _ subs [] = return $ Right subs
solver aliases subs (C txt span c : cs) =
let ctx = C txt span
eq t1 t2 = ctx (t1 :=: t2)
solv = solver aliases subs
uniError' = uniError (\t1 t2 -> solv (eq t1 t2 : cs)) aliases txt span
in case c of
-- Destruct Type-constructors
t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
if n1 /= n2 then uniError txt span t1 t2 else
solver (zipWith eq ts1 ts2 ++ cs) subs
if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)
else uniError' t1 t2
LambdaT t1 t2 :=: LambdaT t1' t2' ->
solver ([ eq t1 t1', eq t2 t2' ] ++ cs) subs
solv ([ eq t1 t1', eq t2 t2' ] ++ cs)
RecordT fs t :=: RecordT fs' t' ->
do cs' <- recordConstraints eq fs t fs' t'
solver (cs' ++ cs) subs
solv (cs' ++ cs)
-- Type-equality
VarT x :=: VarT y
| x == y -> solver cs subs
| x == y -> solv cs
| otherwise ->
case (Map.lookup x subs, Map.lookup y subs) of
(Just (Super xts), Just (Super yts)) ->
@ -108,68 +115,69 @@ solver (C txt span c : cs) subs =
in case Set.toList ts of
[] -> unionError txt span xts yts
[t] -> let cs1 = subst [(x,t),(y,t)] cs in
cs1 `seq` solver cs1 (setXY t subs)
_ -> solver cs $ setXY (Super ts) subs
cs1 `seq` solver aliases (setXY t subs) cs1
_ -> solver aliases (setXY (Super ts) subs) cs
(Just (Super xts), _) ->
let cs2 = subst [(y,VarT x)] cs in
solver cs2 $ Map.insert y (VarT x) subs
solver aliases (Map.insert y (VarT x) subs) cs2
(_, _) ->
let cs3 = subst [(x,VarT y)] cs in
solver cs3 $ Map.insert x (VarT y) subs
solver aliases (Map.insert x (VarT y) subs) cs3
VarT x :=: t -> do
if x `occurs` t then occursError txt span (VarT x) t else
(case Map.lookup x subs of
Nothing -> let cs4 = subst [(x,t)] cs in
solver cs4 . Map.map (subst [(x,t)]) $
Map.insert x t subs
Nothing ->
let cs4 = subst [(x,t)] cs
subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs
in solver aliases subs' cs4
Just (Super ts) ->
let ts' = Set.intersection ts (Set.singleton t) in
case Set.toList ts' of
[] -> solver (ctx (t :<: Super ts) : cs) subs
[] -> solv (ctx (t :<: Super ts) : cs)
[t'] -> let cs5 = subst [(x,t)] cs in
solver cs5 $ Map.insert x t' subs
_ -> solver cs $ Map.insert x (Super ts') subs
Just t' -> solver (ctx (t' :=: t) : cs) subs
solver aliases (Map.insert x t' subs) cs5
_ -> solver aliases (Map.insert x (Super ts') subs) cs
Just t' -> solv (ctx (t' :=: t) : cs)
)
t :=: VarT x -> solver ((ctx (VarT x :=: t)) : cs) subs
t :=: VarT x -> solv ((ctx (VarT x :=: t)) : cs)
t1 :=: t2 | t1 == t2 -> solver cs subs
| otherwise -> uniError txt span t1 t2
t1 :=: t2 | t1 == t2 -> solv cs
| otherwise -> uniError' t1 t2
-- subtypes
VarT x :<: Super ts ->
case Map.lookup x subs of
Nothing -> solver cs $ Map.insert x (Super ts) subs
Nothing -> solver aliases (Map.insert x (Super ts) subs) cs
Just (Super ts') ->
case Set.toList $ Set.intersection ts ts' of
[] -> unionError txt span ts ts'
[t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs
ts'' -> solver cs $
Map.insert x (Super $ Set.fromList ts'') subs
[t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)
ts'' -> solver aliases subs' cs
where subs' = Map.insert x (Super $ Set.fromList ts'') subs
ADT "List" [t] :<: Super ts
| any f (Set.toList ts) -> solver cs subs
| any f (Set.toList ts) -> solv cs
| otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
where f (ADT "List" [VarT _]) = True
f (ADT "List" [t']) = t == t'
f (ADT "List" [t']) = dealias aliases t == t'
f _ = False
t :<: Super ts
| Set.member t ts -> solver cs subs
| otherwise -> subtypeError txt span t (Super ts)
| Set.member t ts -> solv cs
| Set.member (dealias aliases t) ts -> solv cs
| otherwise -> subtypeError txt span t (Super ts)
x :<<: s
| any (occurs x) cs ->
do css <- mapM (schemeSub x s) cs
do css <- mapM (schemeSub aliases x s) cs
case lefts css of
err : _ -> return $ Left err
[] -> solver (concat (rights css)) subs
[] -> solv (concat (rights css))
| otherwise ->
do (t,cs7) <- concretize s
let cs'' = (cs ++ ctx (VarT x :=: t) : cs7)
solver cs'' subs
solv (cs ++ ctx (VarT x :=: t) : cs7)
showMsg msg = case msg of
Just str -> "\nIn context: " ++ str
@ -181,10 +189,14 @@ occursError msg span t1 t2 =
, "Occurs check: cannot construct the infinite type:\n"
, show t1, " = ", show t2, showMsg msg ]
uniError msg span t1 t2 =
return . Left $ concat
[ "Type error (" ++ show span ++ "):\n"
, show t1, " is not equal to ", show t2, showMsg msg ]
uniError solveWith aliases msg span t1 t2 =
let t1' = dealias aliases t1
t2' = dealias aliases t2
in if t1 /= t1' || t2 /= t2'
then solveWith t1' t2'
else return . Left $ concat
[ "Type error (" ++ show span ++ "):\n"
, show t1, " is not equal to ", show t2, showMsg msg ]
unionError msg span ts ts' =
return . Left $ concat

70
elm/src/Types/Substitutions.hs → compiler/Types/Substitutions.hs
View file

@ -1,16 +1,17 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Types.Substitutions (subst,
occurs,
freeVars,
concretize,
rescheme,
generalize) where
generalize,
superize) where
import Ast
import Context
import Control.DeepSeq (NFData (..), deepseq)
import Control.Monad (liftM)
import Data.List (foldl')
import Control.Monad (liftM, liftM2)
import Control.Monad.State (runState, State, get, put)
import Data.List (nub)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Guid
@ -51,13 +52,14 @@ class FreeVars a where
freeVars :: a -> [X]
instance FreeVars Type where
freeVars (VarT v) = [v]
freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2
freeVars (ADT _ ts) = concatMap freeVars ts
freeVars (RecordT fs t) =
freeVars (concat $ Map.elems fs) ++ freeVars t
freeVars EmptyRecord = []
freeVars (Super _ ) = []
freeVars t =
case t of
VarT v -> [v]
LambdaT t1 t2 -> freeVars t1 ++ freeVars t2
ADT _ ts -> concatMap freeVars ts
RecordT fs t -> freeVars (concat $ Map.elems fs) ++ freeVars t
EmptyRecord -> []
Super _ -> []
instance FreeVars Constraint where
freeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2
@ -88,3 +90,47 @@ generalize :: [X] -> Scheme -> GuidCounter Scheme
generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)
where allFrees = Set.fromList $ freeVars t ++ concatMap freeVars cs
frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)
newtype Superize a = S { runSuper :: State ([X], [X], [X]) a }
deriving (Monad)
superize :: String -> Type -> GuidCounter Scheme
superize name tipe =
do constraints <- liftM concat $
sequence [ mapM (<: nmbr) (nub ns)
, mapM (<: apnd) (nub as)
, mapM (<: comp) (nub cs) ]
return (Forall (concat [ns,as,cs]) constraints tipe')
where
(tipe', (ns,as,cs)) = runState (runSuper (go tipe)) ([],[],[])
t <: super = do x <- guid
return $ C (Just name) NoSpan (VarT t :<: super x)
nmbr t = number
apnd t = appendable t
comp t = comparable t
go :: Type -> Superize Type
go t =
case t of
EmptyRecord -> return t
Super _ -> return t
VarT _ -> return t
LambdaT t1 t2 -> liftM2 LambdaT (go t1) (go t2)
ADT "Number" [VarT t] -> addNumber t
ADT "Appendable" [VarT t] -> addAppendable t
ADT "Comparable" [VarT t] -> addComparable t
ADT name ts -> liftM (ADT name) (mapM go ts)
RecordT fs t -> liftM2 RecordT fs' (go t)
where pairs = Map.toList fs
fs' = do ps <- mapM (\(f,t) -> liftM ((,) f) (mapM go t)) pairs
return (Map.fromList ps)
add :: (X -> ([X],[X],[X]) -> ([X],[X],[X])) -> X -> Superize Type
add f v = S $ do (ns, as, cs) <- get
put $ f v (ns, as, cs)
return (VarT v)
addNumber = add (\n (ns,as,cs) -> (n:ns,as,cs))
addAppendable = add (\a (ns,as,cs) -> (ns,a:as,cs))
addComparable = add (\c (ns,as,cs) -> (ns,as,c:cs))

94
compiler/Types/Types.hs Normal file
View file

@ -0,0 +1,94 @@
module Types.Types where
import Context
import Data.Char (isDigit)
import Data.List (intercalate,isPrefixOf)
import qualified Data.Set as Set
import qualified Data.Map as Map
type X = Int
data Type = LambdaT Type Type
| VarT X
| ADT String [Type]
| EmptyRecord
| RecordT (Map.Map String [Type]) Type
| Super (Set.Set Type)
deriving (Eq, Ord)
data Scheme = Forall [X] [Context Constraint] Type deriving (Eq, Ord, Show)
data Constraint = Type :=: Type
| Type :<: Type
| X :<<: Scheme
deriving (Eq, Ord, Show)
recordT :: [(String,Type)] -> Map.Map String [Type]
recordT fields =
foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
recordOf :: [(String,Type)] -> Type
recordOf fields = RecordT (recordT fields) EmptyRecord
tipe t = ADT t []
int = tipe "Int"
float = tipe "Float"
time = tipe "Time"
date = tipe "Date"
char = tipe "Char"
bool = tipe "Bool"
text = tipe "Text"
order = tipe "Order"
string = tipe "String"
number = Super $ Set.fromList [ int, float, time ]
appendable t = Super $ Set.fromList [ string, text, listOf (VarT t) ]
comparable t = Super $ Set.fromList [ int, float, char, string, time, date ]
element = tipe "Element"
listOf t = ADT "List" [t]
signalOf t = ADT "Signal" [t]
tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
maybeOf t = ADT "Maybe" [t]
eitherOf a b = ADT "Either" [a,b]
pairOf t = tupleOf [t,t]
point = pairOf int
infixr ==>
t1 ==> t2 = LambdaT t1 t2
infix 8 -:
name -: tipe = (,) name $ Forall [] [] tipe
parens = ("("++) . (++")")
instance Show Type where
show t =
let addParens (c:cs) =
if notElem ' ' cs || c == '(' then c:cs else parens (c:cs)
in case t of
LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
VarT x -> 't' : show x
ADT "List" [ADT "Char" []] -> "String"
ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
ADT name cs ->
if isTupleString name
then parens . intercalate "," $ map show cs
else name ++ concatMap ((' ':) . addParens . show) cs
Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"
EmptyRecord -> "{}"
RecordT fs t ->
start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"
where field n s = n ++ " : " ++ show s
fields (n,ss) = map (field n) ss
start = case t of
EmptyRecord -> "{ "
_ -> "{ " ++ show t ++ " | "
isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)

16
compiler/Types/Unify.hs Normal file
View file

@ -0,0 +1,16 @@
module Types.Unify (unify) where
import Control.Monad (liftM)
import qualified Data.Map as Map
import Ast
import Guid
import Types.Constrain
import Types.Solver
import Types.Alias as Alias
unify hints modul@(Module _ _ _ stmts) = run $ do
constraints <- constrain hints modul
either (return . Left) (solver (Alias.get stmts) Map.empty) constraints

221
core-js/Automaton.js
View file

@ -1,221 +0,0 @@
(function() {
try{
var $op={};
for(this['i'] in Elm){eval('var '+this['i']+'=Elm[this.i];');}
if (Elm.Automaton) throw new Error("Module name collision, 'Automaton' is already defined.");
Elm.Automaton=function(){
try{
if (!(Elm.Prelude instanceof Object)) throw 'module not found';
} catch(e) {
throw ("Module 'Prelude' is missing. Compile with --make flag or load missing module in a separate JavaScript file.");
}
var hiddenVars={};
for (this['i'] in Elm.Prelude) {
if (hiddenVars[this['i']]) continue;
eval('var ' + this['i'] + ' = Elm.Prelude[this.i];');}
function Automaton_0(a1){
return ["Automaton",a1];}
var Listen_8=["Listen"];
var Ignore_9=["Ignore"];
function DragFrom_10(a1){
return ["DragFrom",a1];}
$op['>>>'] = function(a1_24){
return function(a2_25){
return function(){
var Automaton$m1_26=a1_24;
var m1_27=function(){
switch(Automaton$m1_26[0]){
case "Automaton":
return Automaton$m1_26[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var Automaton$m2_28=a2_25;
var m2_29=function(){
switch(Automaton$m2_28[0]){
case "Automaton":
return Automaton$m2_28[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
return Automaton_0(function(a_32){
return function(){
var Tuple2$bm1__33=m1_27(a_32);
var b_34=function(){
switch(Tuple2$bm1__33[0]){
case "Tuple2":
return Tuple2$bm1__33[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var m1__35=function(){
switch(Tuple2$bm1__33[0]){
case "Tuple2":
return Tuple2$bm1__33[2];
}
throw new Error("Non-exhaustive pattern match in case");}();
return function(){
var Tuple2$cm2__40=m2_29(b_34);
var c_41=function(){
switch(Tuple2$cm2__40[0]){
case "Tuple2":
return Tuple2$cm2__40[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var m2__42=function(){
switch(Tuple2$cm2__40[0]){
case "Tuple2":
return Tuple2$cm2__40[2];
}
throw new Error("Non-exhaustive pattern match in case");}();
return ["Tuple2",c_41,$op['>>>'](m1__35)(m2__42)];}();}();});}();};};
$op['<<<'] = function(a2_47){
return function(a1_48){
return $op['>>>'](a1_48)(a2_47);};};
$op['^>>'] = function(f_49){
return function(a_50){
return $op['>>>'](pure_4(f_49))(a_50);};};
$op['>>^'] = function(a_51){
return function(f_52){
return $op['>>>'](a_51)(pure_4(f_52));};};
$op['^<<'] = function(f_53){
return function(a_54){
return $op['>>>'](a_54)(pure_4(f_53));};};
$op['<<^'] = function(a_55){
return function(f_56){
return $op['>>>'](pure_4(f_56))(a_55);};};
var count_7=init_5(0)(function(__84){
return function(c_85){
return (1+c_85);};});
function run_1(Automaton$m0_14){
return function(input_15){
return function(){
switch(Automaton$m0_14[0]){
case "Automaton":
return lift(fst)(foldp$(function(a_17){
return function(Tuple2$bAutomaton$m_18){
return function(){
switch(Tuple2$bAutomaton$m_18[0]){
case "Tuple2":
switch(Tuple2$bAutomaton$m_18[2][0]){
case "Automaton":
return Tuple2$bAutomaton$m_18[2][1](a_17);
}break;
}
throw new Error("Non-exhaustive pattern match in case");}();};})(Automaton$m0_14[1])(input_15));
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function step_2(Automaton$m_21){
return function(a_22){
return function(){
switch(Automaton$m_21[0]){
case "Automaton":
return Automaton$m_21[1](a_22);
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function combine_3(autos_57){
return Automaton_0(function(a_58){
return function(){
var Tuple2$bsautos__59=unzip(map(function(Automaton$m_62){
return function(){
switch(Automaton$m_62[0]){
case "Automaton":
return Automaton$m_62[1](a_58);
}
throw new Error("Non-exhaustive pattern match in case");}();})(autos_57));
var bs_60=function(){
switch(Tuple2$bsautos__59[0]){
case "Tuple2":
return Tuple2$bsautos__59[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var autos__61=function(){
switch(Tuple2$bsautos__59[0]){
case "Tuple2":
return Tuple2$bsautos__59[2];
}
throw new Error("Non-exhaustive pattern match in case");}();
return ["Tuple2",bs_60,combine_3(autos__61)];}();});}
function pure_4(f_68){
return Automaton_0(function(x_69){
return ["Tuple2",f_68(x_69),pure_4(f_68)];});}
function init_5(s_70){
return function(step_71){
return Automaton_0(function(a_72){
return function(){
var s__73=step_71(a_72)(s_70);
return ["Tuple2",s__73,init_5(s__73)(step_71)];}();});};}
function init__6(s_74){
return function(step_75){
return Automaton_0(function(a_76){
return function(){
var Tuple2$bs__77=step_75(a_76)(s_74);
var b_78=function(){
switch(Tuple2$bs__77[0]){
case "Tuple2":
return Tuple2$bs__77[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var s__79=function(){
switch(Tuple2$bs__77[0]){
case "Tuple2":
return Tuple2$bs__77[2];
}
throw new Error("Non-exhaustive pattern match in case");}();
return ["Tuple2",b_78,init__6(s__79)(step_75)];}();});};}
function vecSub_11(Tuple2$x1y1_86){
return function(Tuple2$x2y2_87){
return function(){
switch(Tuple2$x1y1_86[0]){
case "Tuple2":
return function(){
switch(Tuple2$x2y2_87[0]){
case "Tuple2":
return ["Tuple2",(Tuple2$x1y1_86[1]-Tuple2$x2y2_87[1]),(Tuple2$x1y1_86[2]-Tuple2$x2y2_87[2])];
}
throw new Error("Non-exhaustive pattern match in case");}();
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function stepDrag_12(Tuple2$presspos_92){
return function(Tuple2$dsform_93){
return function(){
switch(Tuple2$presspos_92[0]){
case "Tuple2":
return function(){
switch(Tuple2$dsform_93[0]){
case "Tuple2":
return function(){
function wrap_98(ds__99){
return ["Tuple2",Tuple2$dsform_93[2],["Tuple2",ds__99,Tuple2$dsform_93[2]]];}
return function(){
switch(Tuple2$dsform_93[1][0]){
case "DragFrom":
return (Tuple2$presspos_92[1]?["Tuple2",uncurry(move)(vecSub_11(Tuple2$presspos_92[2])(Tuple2$dsform_93[1][1]))(Tuple2$dsform_93[2]),["Tuple2",DragFrom_10(Tuple2$dsform_93[1][1]),Tuple2$dsform_93[2]]]:function(){
var form__101=uncurry(move)(vecSub_11(Tuple2$presspos_92[2])(Tuple2$dsform_93[1][1]))(Tuple2$dsform_93[2]);
return ["Tuple2",form__101,["Tuple2",Listen_8,form__101]];}());
case "Ignore":
return wrap_98((Tuple2$presspos_92[1]?Ignore_9:Listen_8));
case "Listen":
return wrap_98((not(Tuple2$presspos_92[1])?Listen_8:(isWithin(Tuple2$presspos_92[2])(Tuple2$dsform_93[2])?DragFrom_10(Tuple2$presspos_92[2]):Ignore_9)));
}
throw new Error("Non-exhaustive pattern match in case");}();}();
}
throw new Error("Non-exhaustive pattern match in case");}();
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function draggable_13(form_102){
return init__6(["Tuple2",Listen_8,form_102])(stepDrag_12);}
return {$op : {'>>>' : $op['>>>'], '<<<' : $op['<<<'], '^>>' : $op['^>>'], '>>^' : $op['>>^'], '^<<' : $op['^<<'], '<<^' : $op['<<^']},
run:run_1,
step:step_2,
combine:combine_3,
pure:pure_4,
init:init_5,
init$:init__6,
count:count_7,
draggable:draggable_13};}();
Elm.main=function(){
return Elm.Automaton.main;};
} catch (e) {
Elm.main=function() {
var msg = ('<br/><h2>Your browser may not be supported. Are you using a modern browser?</h2>' + '<br/><span style="color:grey">Runtime Error in Automaton module:<br/>' + e + '</span>');
document.body.innerHTML = Elm.Text.monospace(msg);throw e;};}}());

64
core-js/Char.js
View file

@ -1,64 +0,0 @@
/*! Char !*/
/*[Classification]*/
/** isUpper : Char -> Bool
Selects upper case letters.
**/
/** isLower : Char -> Bool
Selects lower case letters.
**/
/** isDigit : Char -> Bool
Selects ASCII digits (0..9).
**/
/** isOctDigit : Char -> Bool
Selects ASCII octal digits (0..7).
**/
/** isHexDigit : Char -> Bool
Selects ASCII hexadecimal digits (0..9a..fA..F).
**/
/*[Conversion]*/
/** toUpper : Char -> Char
Convert to upper case.
**/
/** toLower : Char -> Char
Convert to lower case.
**/
/** toLocaleUpper : Char -> Char
Convert to upper case, according to any locale-specific case mappings.
**/
/** toLocaleLower : Char -> Char
Convert to lower case, according to any locale-specific case mappings.
**/
/** toCode : Char -> Int
Convert to unicode.
**/
/** fromCode : Int -> Char
Convert from unicode.
**/
Elm.Char = function() {
function isBetween(lo,hi) { return function(chr) {
var c = chr.charCodeAt(0);
return lo <= c && c <= hi;
};
}
var isDigit = isBetween('0'.charCodeAt(0),'9'.charCodeAt(0));
var chk1 = isBetween('a'.charCodeAt(0),'f'.charCodeAt(0));
var chk2 = isBetween('A'.charCodeAt(0),'F'.charCodeAt(0));
return {fromCode : function(c) { return String.fromCharCode(c); },
toCode : function(c) { return c.charCodeAt(0); },
toUpper : function(c) { return c.toUpperCase(); },
toLower : function(c) { return c.toLowerCase(); },
toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },
toLocaleLower : function(c) { return c.toLocaleLowerCase(); },
isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),
isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),
isDigit : isDigit,
isOctDigit : isBetween('0'.charCodeAt(0),'7'.charCodeAt(0)),
isHexDigit : function(c) { return isDigit(c) || chk1(c) || chk2(c); }
};
}();

32
core-js/Date.js
View file

@ -1,32 +0,0 @@
Elm.Date = function() {
function dateNow() { return new window.Date; }
function readDate(str) {
var d = new window.Date(Elm.JavaScript.castStringToJSString(str));
if (isNaN(d.getTime())) return ["Nothing"];
return ["Just",d];
}
var dayTable = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"];
var monthTable = ["Jan", "Feb", "Mar", "Apr", "May", "Jun",
"Jul", "Aug", "Sep", "Oct", "Nov", "Dec"];
return {
read : readDate,
year : function(d) { return d.getFullYear(); },
month : function(d) { return [monthTable[d.getMonth()]]; },
day : function(d) { return d.getDate(); },
hour : function(d) { return d.getHours(); },
minute : function(d) { return d.getMinutes(); },
second : function(d) { return d.getSeconds(); },
dayOfWeek : function(d) { return [dayTable[d.getDay()]]; },
toTime : function(d) { return d.getTime(); },
Mon : ["Mon"], Tue : ["Tue"], Wed : ["Wed"],
Thu : ["Thu"], Fri : ["Fri"], Sat : ["Sat"], Sun : ["Sun"],
Jan : ["Jan"], Feb : ["Feb"], Mar : ["Mar"], Apr : ["Apr"],
May : ["May"], Jun : ["Jun"], Jul : ["Jul"], Aug : ["Aug"],
Sep : ["Sep"], Oct : ["Oct"], Nov : ["Nov"], Dec : ["Dec"]
};
}();

485
core-js/Dict.js
View file

@ -1,485 +0,0 @@
Elm.Dict=function(){
var compare = Elm.Prelude.compare;
var uncurry = Elm.Prelude.uncurry;
var Nothing = Elm.Prelude.Nothing;
var Just = Elm.Prelude.Just;
var not = Elm.Prelude.not;
var eq = Elm.Prelude.eq;
var isJust=Elm.Maybe.isJust;
var Red_0=['Red'];
var Black_1=['Black'];
function RBNode_2(a1){
return function(a2){
return function(a3){
return function(a4){
return function(a5){
return ['RBNode',a1,a2,a3,a4,a5];};};};};}
var RBEmpty_3=['RBEmpty'];
function min_6(t_42){
return function(){
switch(t_42[0]){
case 'RBEmpty':
throw '(min RBEmpty) is not defined';
case 'RBNode':
switch(t_42[4][0]){
case 'RBEmpty':
return ['Tuple2',t_42[2],t_42[3]];
}
return min_6(t_42[4]);
}
throw new Error("Non-exhaustive pattern match in case");}();}
function lookup_7(k_46){
return function(t_47){
return function(){
switch(t_47[0]){
case 'RBEmpty':
return Nothing;
case 'RBNode':
return function(){
var case12=compare(k_46)(t_47[2]);
switch(case12[0]){
case 'EQ':
return Just(t_47[3]);
case 'GT':
return lookup_7(k_46)(t_47[5]);
case 'LT':
return lookup_7(k_46)(t_47[4]);
}
throw new Error("Non-exhaustive pattern match in case");}();
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function findWithDefault_8(base_52){
return function(k_53){
return function(t_54){
return function(){
switch(t_54[0]){
case 'RBEmpty':
return base_52;
case 'RBNode':
return function(){
var case19=compare(k_53)(t_54[2]);
switch(case19[0]){
case 'EQ':
return t_54[3];
case 'GT':
return findWithDefault_8(base_52)(k_53)(t_54[5]);
case 'LT':
return findWithDefault_8(base_52)(k_53)(t_54[4]);
}
throw new Error("Non-exhaustive pattern match in case");}();
}
throw new Error("Non-exhaustive pattern match in case");}();};};}
function member_9(k_59){
return function(t_60){
return isJust(lookup_7(k_59)(t_60));};}
function rotateLeft_10(t_61){
return function(){
switch(t_61[0]){
case 'RBNode':
switch(t_61[5][0]){
case 'RBNode':
return RBNode_2(t_61[1])(t_61[5][2])(t_61[5][3])(RBNode_2(Red_0)(t_61[2])(t_61[3])(t_61[4])(t_61[5][4]))(t_61[5][5]);
}break;
}
throw 'rotateLeft of a node without enough children';}();}
function rotateRight_11(t_71){
return function(){
switch(t_71[0]){
case 'RBNode':
switch(t_71[4][0]){
case 'RBNode':
return RBNode_2(t_71[1])(t_71[4][2])(t_71[4][3])(t_71[4][4])(RBNode_2(Red_0)(t_71[2])(t_71[3])(t_71[4][5])(t_71[5]));
}break;
}
throw 'rotateRight of a node without enough children';}();}
function rotateLeftIfNeeded_12(t_81){
return function(){
switch(t_81[0]){
case 'RBNode':
switch(t_81[5][0]){
case 'RBNode':
switch(t_81[5][1][0]){
case 'Red':
return rotateLeft_10(t_81);
}break;
}break;
}
return t_81;}();}
function rotateRightIfNeeded_13(t_82){
return function(){
switch(t_82[0]){
case 'RBNode':
switch(t_82[4][0]){
case 'RBNode':
switch(t_82[4][1][0]){
case 'Red':
switch(t_82[4][4][0]){
case 'RBNode':
switch(t_82[4][4][1][0]){
case 'Red':
return rotateRight_11(t_82);
}break;
}break;
}break;
}break;
}
return t_82;}();}
function otherColor_14(c_83){
return function(){
switch(c_83[0]){
case 'Black':
return Red_0;
case 'Red':
return Black_1;
}
throw new Error("Non-exhaustive pattern match in case");}();}
function color_flip_15(t_84){
return function(){
switch(t_84[0]){
case 'RBNode':
switch(t_84[4][0]){
case 'RBNode':
switch(t_84[5][0]){
case 'RBNode':
return RBNode_2(otherColor_14(t_84[1]))(t_84[2])(t_84[3])(RBNode_2(otherColor_14(t_84[4][1]))(t_84[4][2])(t_84[4][3])(t_84[4][4])(t_84[4][5]))(RBNode_2(otherColor_14(t_84[5][1]))(t_84[5][2])(t_84[5][3])(t_84[5][4])(t_84[5][5]));
}break;
}break;
}
throw 'color_flip called on a RBEmpty or RBNode with a RBEmpty child';}();}
function color_flipIfNeeded_16(t_98){
return function(){
switch(t_98[0]){
case 'RBNode':
switch(t_98[4][0]){
case 'RBNode':
switch(t_98[4][1][0]){
case 'Red':
switch(t_98[5][0]){
case 'RBNode':
switch(t_98[5][1][0]){
case 'Red':
return color_flip_15(t_98);
}break;
}break;
}break;
}break;
}
return t_98;}();}
function fixUp_17(t_99){
return color_flipIfNeeded_16(rotateRightIfNeeded_13(rotateLeftIfNeeded_12(t_99)));}
function ensureBlackRoot_18(t_100){
return function(){
switch(t_100[0]){
case 'RBNode':
switch(t_100[1][0]){
case 'Red':
return RBNode_2(Black_1)(t_100[2])(t_100[3])(t_100[4])(t_100[5]);
}break;
}
return t_100;}();}
function insert_19(k_105){
return function(v_106){
return function(t_107){
return function(){
function ins_108(t_109){
return function(){
switch(t_109[0]){
case 'RBEmpty':
return RBNode_2(Red_0)(k_105)(v_106)(RBEmpty_3)(RBEmpty_3);
case 'RBNode':
return function(){
var h_115=function(){
var case114=compare(k_105)(t_109[2]);
switch(case114[0]){
case 'EQ':
return RBNode_2(t_109[1])(t_109[2])(v_106)(t_109[4])(t_109[5]);
case 'GT':
return RBNode_2(t_109[1])(t_109[2])(t_109[3])(t_109[4])(ins_108(t_109[5]));
case 'LT':
return RBNode_2(t_109[1])(t_109[2])(t_109[3])(ins_108(t_109[4]))(t_109[5]);
}
throw new Error("Non-exhaustive pattern match in case");}();
return fixUp_17(h_115);}();
}
throw new Error("Non-exhaustive pattern match in case");}();}
return ensureBlackRoot_18(ins_108(t_107));}();};};}
function singleton_20(k_116){
return function(v_117){
return insert_19(k_116)(v_117)(RBEmpty_3);};}
function isRed_21(t_118){
return function(){
switch(t_118[0]){
case 'RBNode':
switch(t_118[1][0]){
case 'Red':
return true;
}break;
}
return false;}();}
function isRedLeft_22(t_119){
return function(){
switch(t_119[0]){
case 'RBNode':
switch(t_119[4][0]){
case 'RBNode':
switch(t_119[4][1][0]){
case 'Red':
return true;
}break;
}break;
}
return false;}();}
function isRedLeftLeft_23(t_120){
return function(){
switch(t_120[0]){
case 'RBNode':
switch(t_120[4][0]){
case 'RBNode':
switch(t_120[4][4][0]){
case 'RBNode':
switch(t_120[4][4][1][0]){
case 'Red':
return true;
}break;
}break;
}break;
}
return false;}();}
function isRedRight_24(t_121){
return function(){
switch(t_121[0]){
case 'RBNode':
switch(t_121[5][0]){
case 'RBNode':
switch(t_121[5][1][0]){
case 'Red':
return true;
}break;
}break;
}
return false;}();}
function isRedRightLeft_25(t_122){
return function(){
switch(t_122[0]){
case 'RBNode':
switch(t_122[5][0]){
case 'RBNode':
switch(t_122[5][4][0]){
case 'RBNode':
switch(t_122[5][4][1][0]){
case 'Red':
return true;
}break;
}break;
}break;
}
return false;}();}
function moveRedLeft_26(t_123){
return function(){
var t__124=color_flip_15(t_123);
return function(){
switch(t__124[0]){
case 'RBNode':
return function(){
switch(t__124[5][0]){
case 'RBNode':
switch(t__124[5][4][0]){
case 'RBNode':
switch(t__124[5][4][1][0]){
case 'Red':
return color_flip_15(rotateLeft_10(RBNode_2(t__124[1])(t__124[2])(t__124[3])(t__124[4])(rotateRight_11(t__124[5]))));
}break;
}break;
}
return t__124;}();
}
return t__124;}();}();}
function moveRedRight_27(t_130){
return function(){
var t__131=color_flip_15(t_130);
return (isRedLeftLeft_23(t__131)?color_flip_15(rotateRight_11(t__131)):t__131);}();}
function moveRedLeftIfNeeded_28(t_132){
return ((not(isRedLeft_22(t_132))&&not(isRedLeftLeft_23(t_132)))?moveRedLeft_26(t_132):t_132);}
function moveRedRightIfNeeded_29(t_133){
return ((not(isRedRight_24(t_133))&&not(isRedRightLeft_25(t_133)))?moveRedRight_27(t_133):t_133);}
function deleteMin_30(t_134){
return function(){
function del_135(t_136){
return function(){
switch(t_136[0]){
case 'RBNode':
switch(t_136[4][0]){
case 'RBEmpty':
return RBEmpty_3;
}break;
}
return function(){
var case198=moveRedLeftIfNeeded_28(t_136);
switch(case198[0]){
case 'RBEmpty':
return RBEmpty_3;
case 'RBNode':
return fixUp_17(RBNode_2(case198[1])(case198[2])(case198[3])(del_135(case198[4]))(case198[5]));
}
throw new Error("Non-exhaustive pattern match in case");}();}();}
return ensureBlackRoot_18(del_135(t_134));}();}
function remove_31(k_142){
return function(t_143){
return function(){
function eq_and_noRightNode_144(t_150){
return function(){
switch(t_150[0]){
case 'RBNode':
switch(t_150[5][0]){
case 'RBEmpty':
return eq(k_142,t_150[2]);
}break;
}
return false;}();}
function eq_145(t_152){
return function(){
switch(t_152[0]){
case 'RBNode':
return eq(k_142,t_152[2]);
}
return false;}();}
function delLT_146(t_154){
return function(){
var case216=moveRedLeftIfNeeded_28(t_154);
switch(case216[0]){
case 'RBEmpty':
throw 'delLT on RBEmpty';
case 'RBNode':
return fixUp_17(RBNode_2(case216[1])(case216[2])(case216[3])(del_149(case216[4]))(case216[5]));
}
throw new Error("Non-exhaustive pattern match in case");}();}
function delEQ_147(t_160){
return function(){
switch(t_160[0]){
case 'RBEmpty':
throw 'delEQ called on a RBEmpty';
case 'RBNode':
return function(){
var Tuple2$k_v__164=min_6(t_160[5]);
var k__165=function(){
switch(Tuple2$k_v__164[0]){
case 'Tuple2':
return Tuple2$k_v__164[1];
}
throw new Error("Non-exhaustive pattern match in case");}();
var v__166=function(){
switch(Tuple2$k_v__164[0]){
case 'Tuple2':
return Tuple2$k_v__164[2];
}
throw new Error("Non-exhaustive pattern match in case");}();
return fixUp_17(RBNode_2(t_160[1])(k__165)(v__166)(t_160[4])(deleteMin_30(t_160[5])));}();
}
throw new Error("Non-exhaustive pattern match in case");}();}
function delGT_148(t_171){
return function(){
switch(t_171[0]){
case 'RBEmpty':
throw 'delGT called on a RBEmpty';
case 'RBNode':
return fixUp_17(RBNode_2(t_171[1])(t_171[2])(t_171[3])(t_171[4])(del_149(t_171[5])));
}
throw new Error("Non-exhaustive pattern match in case");}();}
function del_149(t_177){
return function(){
switch(t_177[0]){
case 'RBEmpty':
return RBEmpty_3;
case 'RBNode':
return ((compare(k_142)(t_177[2])[0] === 'LT')?delLT_146(t_177):function(){
var u_179=(isRedLeft_22(t_177)?rotateRight_11(t_177):t_177);
return (eq_and_noRightNode_144(u_179)?u_179[4]:function(){
var t__180=moveRedRightIfNeeded_29(t_177);
return (eq_145(t__180)?delEQ_147(t__180):delGT_148(t__180));}());}());
}
throw new Error("Non-exhaustive pattern match in case");}();}
return (member_9(k_142)(t_143)?ensureBlackRoot_18(del_149(t_143)):t_143);}();};}
function map_32(f_181){
return function(t_182){
return function(){
switch(t_182[0]){
case 'RBEmpty':
return RBEmpty_3;
case 'RBNode':
return RBNode_2(t_182[1])(t_182[2])(f_181(t_182[3]))(map_32(f_181)(t_182[4]))(map_32(f_181)(t_182[5]));
}
throw new Error("Non-exhaustive pattern match in case");}();};}
function foldl_33(f_188){
return function(acc_189){
return function(t_190){
return function(){
switch(t_190[0]){
case 'RBEmpty':
return acc_189;
case 'RBNode':
return foldl_33(f_188)(f_188(t_190[2])(t_190[3])(foldl_33(f_188)(acc_189)(t_190[4])))(t_190[5]);
}
throw new Error("Non-exhaustive pattern match in case");}();};};}
function foldr_34(f_195){
return function(acc_196){
return function(t_197){
return function(){
switch(t_197[0]){
case 'RBEmpty':
return acc_196;
case 'RBNode':
return foldr_34(f_195)(f_195(t_197[2])(t_197[3])(foldr_34(f_195)(acc_196)(t_197[5])))(t_197[4]);
}
throw new Error("Non-exhaustive pattern match in case");}();};};}
function union_35(t1_202){
return function(t2_203){
return foldl_33(insert_19)(t2_203)(t1_202);};}
function intersect_36(t1_204){
return function(t2_205){
return foldl_33(function(k_206){
return function(v_207){
return function(t_208){
return (member_9(k_206)(t2_205)?insert_19(k_206)(v_207)(t_208):t_208);};};})(empty_4)(t1_204);};}
function diff_37(t1_209){
return function(t2_210){
return foldl_33(function(k_211){
return function(v_212){
return function(t_213){
return remove_31(k_211)(t_213);};};})(t1_209)(t2_210);};}
function keys_38(t_214){
return foldr_34(function(k_215){
return function(v_216){
return function(acc_217){
return ['Cons',k_215,acc_217];};};})(['Nil'])(t_214);}
function values_39(t_218){
return foldr_34(function(k_219){
return function(v_220){
return function(acc_221){
return ['Cons',v_220,acc_221];};};})(['Nil'])(t_218);}
function toList_40(t_222){
return foldr_34(function(k_223){
return function(v_224){
return function(acc_225){
return ['Cons',['Tuple2',k_223,v_224],acc_225];};};})(['Nil'])(t_222);}
function fromList_41(assocs_226){
return Elm.List.foldl(uncurry(insert_19))(empty_4)(assocs_226);}
var empty_4=RBEmpty_3;
return {$op : {},
empty:empty_4,
lookup:lookup_7,
findWithDefault:findWithDefault_8,
member:member_9,
insert:insert_19,
singleton:singleton_20,
remove:remove_31,
map:map_32,
foldl:foldl_33,
foldr:foldr_34,
union:union_35,
intersect:intersect_36,
diff:diff_37,
keys:keys_38,
values:values_39,
toList:toList_40,
fromList:fromList_41};}();

75
core-js/Either.js
View file

@ -1,75 +0,0 @@
/*! Either
!*/
Elm.Either = function() {
/*[Definition]*/
/** data Either a b = Left a | Right b
Represents any data that can take two different types.
This can also be used for error handling (`Either String a`) where
error messages are stored on the left, and the correct values
("right" values) are stored on the right.
**/
function Left(a1) { return ['Left',a1]; }
function Right(a1){ return ['Right',a1]; }
/*[Basics]*/
/** either : (a -> c) -> (b -> c) -> Either a b -> c
Apply the first function to a `Left` and the second function to a `Right`.
This allows the extraction of a value from an `Either`.
**/
function either(f){ return function(g){ return function(e){
switch(e[0]){
case 'Left': return f(e[1]);
case 'Right': return g(e[1]);
}
};};}
/** isLeft : Either a b -> Bool
True if the value is a `Left`.
**/
function isLeft(e) { return e[0] == 'Left'; }
/** isRight : Either a b -> Bool
True if the value is a `Right`.
**/
function isRight(e) { return e[0] == 'Right'; }
/*[With Lists]*/
function get(es) { return Elm.List.map(function(x){return x[1];})(es); }
/** lefts : [Either a b] -> [a]
Keep only the values held in `Left` values.
**/
function lefts(es) { return get(Elm.List.filter(isLeft)(es)); }
/** rights : [Either a b] -> [a]
Keep only the values held in `Right` values.
**/
function rights(es) { return get(Elm.List.filter(isRight)(es)); }
/** partition : [Either a b] -> ([a],[b])
Split into two lists, lefts on the left and rights on the right.
So we have the equivalence:
partition es == (lefts es, rights es)
**/
function partition(es) {
var lrs = Elm.List.partition(isLeft)(es);
lrs[1] = get(lrs[1]);
lrs[2] = get(lrs[2]);
return lrs;
}
return {Left:Left,
Right:Right,
either:either,
isLeft:isLeft,
isRight:isRight,
lefts:lefts,
rights:rights,
partition:partition};
}();

317
core-js/Graphics/Collage.js
View file

@ -1,317 +0,0 @@
var Collage = function() {
var JS = Elm.JavaScript;
function tracePoints(ctx,points) {
var i = points.length - 1;
if (i <= 0) return;
ctx.moveTo(points[i][1], points[i][2]);
while (i--) { ctx.lineTo(points[i][1], points[i][2]); }
}
function solid(ctx,color,points) {
tracePoints(ctx,points);
ctx.strokeStyle = Elm.Color.extract(color);
ctx.stroke();
};
function filled(ctx,color,points) {
tracePoints(ctx,points);
ctx.fillStyle = Elm.Color.extract(color);
ctx.fill();
}
function textured(redo,ctx,src,points) {
var img = new Image();
img.src = JS.castStringToJSString(src);
img.onload = redo;
tracePoints(ctx,points);
ctx.fillStyle = ctx.createPattern(img,'repeat');
ctx.fill();
}
function customLine(pattern,ctx,color,points) {
if (pattern.length === 0) { pattern = [8,4]; }
customLineHelp(ctx, pattern, points);
ctx.strokeStyle = Elm.Color.extract(color);
ctx.stroke();
};
var customLineHelp = function(ctx, pattern, points) {
var i = points.length - 1;
if (i <= 0) return;
var x0 = points[i][1], y0 = points[i][2];
var x1=0, y1=0, dx=0, dy=0, remaining=0, nx=0, ny=0;
var pindex = 0, plen = pattern.length;
var draw = true, segmentLength = pattern[0];
ctx.moveTo(x0,y0);
while (i--) {
x1 = points[i][1]; y1 = points[i][2];
dx = x1 - x0; dy = y1 - y0;
remaining = Math.sqrt(dx * dx + dy * dy);
while (segmentLength <= remaining) {
x0 += dx * segmentLength / remaining;
y0 += dy * segmentLength / remaining;
ctx[draw ? 'lineTo' : 'moveTo'](x0, y0);
// update starting position
dx = x1 - x0; dy = y1 - y0;
remaining = Math.sqrt(dx * dx + dy * dy);
// update pattern
draw = !draw;
pindex = (pindex + 1) % plen;
segmentLength = pattern[pindex];
}
if (remaining > 0) {
ctx[draw ? 'lineTo' : 'moveTo'](x1, y1);
segmentLength -= remaining;
}
x0 = x1; y0 = y1;
}
};
function drawLine(ctx,form) {
var points = form[3][1];
switch(form[1][0]) {
case "Solid" : return solid(ctx,form[2],points);
case "Dotted": return customLine([3,3],ctx,form[2],points);
case "Dashed": return customLine([8,4],ctx,form[2],points);
case "Custom": return customLine(form[1][1],ctx,form[2],points);
}
};
function drawShape(redo,ctx,shapeStyle,color,points) {
switch(shapeStyle[0]) {
case "Filled": return filled(ctx,color,points);
case "Outlined": return solid(ctx,color,points);
case "Textured": return textured(redo,ctx,shapeStyle[1],points);
case "CustomOutline":
return customLine(shapeStyle[1],ctx,color,points);
}
};
function drawImage(redo,ctx,w,h,src) {
var img = new Image();
img.onload = redo;
img.src = JS.castStringToJSString(src);
ctx.drawImage(img,-w/2,-h/2,w,h);
}
function renderForm(redo,ctx,theta,scale,x,y,form) {
ctx.save();
if (x !== 0 || y !== 0) ctx.translate(x,y);
if (theta !== ~~theta) ctx.rotate(2*Math.PI*theta);
if (scale !== 1) ctx.scale(scale,scale);
ctx.beginPath();
switch(form[0]) {
case "FLine": drawLine(ctx,form); break;
case "FShape": drawShape(redo,ctx,form[1],form[2],form[3][1]); break;
case "FImage": drawImage(redo,ctx,form[1],form[2],form[3]); break;
}
ctx.restore();
};
function renderForms(redo,ctx,w,h,forms) {
ctx.clearRect(0,0,w,h);
for (var i = forms.length; i--; ) {
var f = forms[i];
renderForm(redo,ctx,f[1],f[2],f[3][1],f[3][2],f[4]);
}
}
function collageForms(w,h,forms) {
var canvas = Render.newElement('canvas');
w = ~~w;
h = ~~h;
canvas.style.width = w + 'px';
canvas.style.height = h + 'px';
canvas.style.display = "block";
canvas.width = w;
canvas.height = h;
if (canvas.getContext) {
var ctx = canvas.getContext('2d');
function redo() { renderForms(this,ctx,w,h,forms); }
renderForms(redo,ctx,w,h,forms);
return canvas;
}
canvas.innerHTML = "Your browser does not support the canvas element.";
return canvas;
};
function applyTransforms(theta,scale,x,y,w,h,e) {
var t = "translate(" + (x - w / 2) + "px,"+ (y - h / 2) + "px)";
var r = theta === (~~theta) ? "" : "rotate(" + theta*360 + "deg)";
var s = scale === 1 ? "" : "scale(" + scale + "," + scale + ")";
var transforms = t + " " + s + " " + r;
e.style.transform = transforms;
e.style.msTransform = transforms;
e.style.MozTransform = transforms;
e.style.webkitTransform = transforms;
e.style.OTransform = transforms;
}
function collageElement(w,h,theta,scale,x,y,elem) {
var e = Render.render(elem);
applyTransforms(theta,scale,x,y,elem[3],elem[4],e);
var div = Render.newElement('div');
Render.addTo(div,e);
div.style.width = (~~w) + "px";
div.style.height = (~~h) + "px";
div.style.overflow = "hidden";
return div;
}
function collage(w,h,formss) {
if (formss.length === 0) { return collageForms(w,h,[]); }
var elems = new Array(formss.length);
for (var i = formss.length; i--; ) {
var f = formss[i];
if (typeof f[0] === "string") {
elems[i] = collageElement(w,h,f[1],f[2],f[3][1],f[3][2],f[4][1]);
} else {
elems[i] = collageForms(w,h,f);
}
}
if (formss.length === 1) { return elems[0]; }
return Render.flowWith(Render.goIn,function(x){return x},elems);
}
function updateFormSet(node,currSet,nextSet) {
if (Value.eq(nextSet,currSet)) return;
var w = node.style.width.slice(0,-2) - 0;
var h = node.style.height.slice(0,-2) - 0;
if (typeof nextSet[0] === "object") {
if (typeof currSet[0] === "object") {
if (node.getContext) {
var ctx = node.getContext('2d');
function redo() { renderForms(this,ctx,w,h,nextSet); }
return renderForms(redo,ctx,w,h,nextSet);
}
}
var newNode = collageForms(w,h,nextSet);
newNode.style.position = 'absolute';
return node.parentNode.replaceChild(newNode,node);
}
node.style.width = (~~w) + "px";
node.style.height = (~~h) + "px";
var f = nextSet;
var next = nextSet[4][1];
Render.update(node.firstChild, currSet[4][1], next);
applyTransforms(f[1],f[2],f[3][1],f[3][2],next[3],next[4],node.firstChild);
}
// assumes that the form sets are the same length.
function updateCollage(node,currs,nexts) {
if (nexts.length === 1) {
return updateFormSet(node,currs[0],nexts[0]);
}
var kids = node.childNodes;
var len = kids.length;
for (var i = len; i--; ) {
updateFormSet(kids[len-i-1], currs[i], nexts[i]);
}
}
function style(clr,n,list) {
return ["Tuple2",
'<span style="font-size:100%;color:' + clr + ';">' + n + '</span>',
list];
}
function insideForm(point) { return function(form) {
if (!inBoundsOf(point[1],point[2],form)) return false;
var hw, hh;
switch (form[4][0]) {
case "FShape": return insideShape(point,form[1],form[2],form[3],form[4][3][1]);
case "FLine": return false;
case "FImage":
hw = form[4][1] / 2;
hh = form[4][2] / 2;
break;
case "FElement":
hw = form[4][1][3] / 2;
hh = form[4][1][4] / 2;
break;
}
return insideShape(point,form[1],form[2],form[3],
[ [null, hw, hh],
[null,-hw, hh],
[null,-hw,-hh],
[null, hw,-hh],
[null, hw, hh] ]);
};
}
function inBoundsOf(px,py,form) {
if (form.length < 6) {
var fx = form[3][1], fy = form[3][2];
var radiusSquared = 0;
var scale = form[2];
switch (form[4][0]) {
case "FShape":
var points = form[4][3][1];
for (var i = points.length; --i; ) {
var p = points[i];
radiusSquared = Math.max(radiusSquared, p[1]*p[1] + p[2]*p[2]);
}
radiusSquared *= scale * scale;
break;
case "FLine":
break;
case "FImage":
var x = scale * form[4][1] / 2;
var y = scale * form[4][2] / 2;
radiusSquared = x*x + y*y;
break;
case "FElement":
var x = scale * form[4][1][3] / 2;
var y = scale * form[4][1][4] / 2;
radiusSquared = x*x + y*y;
break;
}
form.push(function(px,py) {
var dx = px - fx;
var dy = py - fy;
return dx*dx + dy*dy < radiusSquared + 1;
});
}
return form[5](px,py);
}
function insideShape(point,theta,scale,pos,points) {
var counter = 0;
var list = ["Nil"];
var p1,p2;
var x = (point[1] - pos[1]) / scale;
var y = (point[2] - pos[2]) / scale;
if (theta !== 0) {
var t = -2 * Math.PI * theta;
var nx = x * Math.cos(t) - y * Math.sin(t);
y = x * Math.sin(t) + y * Math.cos(t);
x = nx;
}
if (points.length === 0) { return false; }
p1 = points[0];
for (var i = points.length - 1; i--; ) {
p2 = points[i];
var p1x = p1[1], p1y = p1[2], p2x = p2[1], p2y = p2[2];
if (p1y < p2y) {var ymin=p1y, ymax=p2y;} else {var ymin=p2y, ymax=p1y;}
if (p1x < p2x) {var xmin=p1x, xmax=p2x;} else {var xmin=p2x, xmax=p1x;}
if (ymin < y && y <= ymax && x <= xmax) {
if (x <= xmin || x <= ((y-p1y)*(p2x-p1x)/(p2y-p1y)+p1x)) {
++counter;
}
}
p1 = p2;
}
return (counter % 2) === 1;
}
return {collage:collage, updateCollage:updateCollage, insideForm:insideForm};
}();

86
core-js/Graphics/Color.js
View file

@ -1,86 +0,0 @@
Elm.Color = function() {
function Color_0(a1) {
return function(a2) {
return function(a3) {
return function(a4) {
return["Color", a1, a2, a3, a4]
}
}
}
}
var rgba_1 = Color_0;
var red_3 = ["Color",255,0,0,1];
var green_4 = ["Color",0,255,0,1];
var blue_5 = ["Color",0,0,255,1];
var yellow_6 = ["Color",255,255,0,1];
var cyan_7 = ["Color",0,255,255,1];
var magenta_8 = ["Color",255,0,255,1];
var black_9 = ["Color",0,0,0,1];
var white_10 = ["Color",255,255,255,1];
var gray_11 = ["Color",128,128,128,1];
var grey_12 = ["Color",128,128,128,1];
function rgb_2(r_13) {
return function(g_14) {
return function(b_15) {
return ["Color",r_13,g_14,b_15,1]
}
}
}
function extract(c) {
if (c[4] === 1) { return 'rgb(' + c[1] + ',' + c[2] + ',' + c[3] + ')'; }
return 'rgba(' + c[1] + ',' + c[2] + ',' + c[3] + ',' + c[4] + ')';
}
function complement(rgb) {
var hsv = toHSV(rgb);
hsv.hue = (hsv.hue + 180) % 360;
return toRGB(hsv);
}
function hsva(h) { return function(s) { return function(v) { return function(a) {
var clr = toRGB({hue:h, saturation:s, value:v});
clr[4] = a;
return clr;
}; }; };
}
function hsv(h) { return function(s) { return function(v) {
return toRGB({hue:h, saturation:s, value:v}); }; }; }
function toHSV(rgb) {
var hsv = {};
var r = rgb[1] / 255.0, g = rgb[2] / 255.0, b = rgb[3] / 255.0;
var M = Math.max(r,g,b);
var m = Math.min(r,g,b);
var c = M - m;
var h = 0;
if (c === 0) { h = 0; }
else if (M === r) { h = ((g - b) / c) % 6; }
else if (M === g) { h = ((b - r) / c) + 2; }
else if (M === b) { h = ((r - g) / c) + 4; }
h *= 60;
return { value : M, hue : h, saturation : (M === 0 ? 0 : c / M) };
}
function between(lo,hi,x) { return lo <= x && x < hi; }
function norm(n) { return Math.round(n*255); }
function toRGB(hsv) {
var c = hsv.value * hsv.saturation;
var hue = hsv.hue / 60;
var x = c * (1 - Math.abs((hue % 2) - 1));
var r = 0, g = 0, b = 0;
if (between(0,1,hue)) { r = c; g = x; b = 0; }
else if (between(1,2,hue)) { r = x; g = c; b = 0; }
else if (between(2,3,hue)) { r = 0; g = c; b = x; }
else if (between(3,4,hue)) { r = 0; g = x; b = c; }
else if (between(4,5,hue)) { r = x; g = 0; b = c; }
else if (between(5,6,hue)) { r = c; g = 0; b = x; }
var m = hsv.value - c;
return ["Color", norm(r+m), norm(g+m), norm(b+m), 1 ];
}
return{rgba:rgba_1, rgb:rgb_2, hsva:hsva, hsv:hsv, red:red_3, green:green_4, blue:blue_5, yellow:yellow_6, cyan:cyan_7, magenta:magenta_8, black:black_9, white:white_10, gray:gray_11, grey:grey_12,complement:complement,extract:extract}
}();

517
core-js/Graphics/Element.js
View file

@ -1,517 +0,0 @@
Elm.Graphics = function() {
for (this['i'] in Elm.List) {
eval('var ' + this['i'] + ' = Elm.List[this.i];');
}
var JS = Elm.JavaScript;
var DLeft_0 = ["DLeft"];
var DRight_1 = ["DRight"];
var DUp_2 = ["DUp"];
var DDown_3 = ["DDown"];
var DIn_4 = ["DIn"];
var DOut_5 = ["DOut"];
function Absolute_12(a1) {
return["Absolute", a1]
}
function Relative_13(a1) {
return["Relative", a1]
}
var Near_14 = ["Near"];
var Mid_15 = ["Mid"];
var Far_16 = ["Far"];
function Position_17(a1) {
return function(a2) {
return["Position", a1, a2]
}
}
function PositionTL_18(a1) {
return function(a2) {
return["PositionTL", a1, a2]
}
}
function PositionTR_19(a1) {
return function(a2) {
return["PositionTR", a1, a2]
}
}
function PositionBL_20(a1) {
return function(a2) {
return["PositionBL", a1, a2]
}
}
function PositionBR_21(a1) {
return function(a2) {
return["PositionBR", a1, a2]
}
}
function Element_37(id,e,w,h,o,c,l) {
return["Element", id, e, w, h, o, c, l ]
}
function EText_39(a1) {
return function(a2) {
return["EText", a1, a2]
}
}
function EImage_40(a1) {
return["EImage", JS.castStringToJSString(a1)]
}
function EVideo_41(a1) {
return["EVideo", JS.castStringToJSString(a1)]
}
function EFittedImage_42(a1) {
return["EFittedImage", JS.castStringToJSString(a1)]
}
function EFlow_43(a1) {
return function(a2) {
return["EFlow", a1, JS.castListToJSArray(a2)]
}
}
function ECollage_44(a1) {
return function(a2) {
return function(a3) {
return["ECollage", a1, a2, Value.groupForms(a3)]
}
}
}
var EEmpty_45 = ["EEmpty"];
function EContainer_46(a1) {
return function(a2) {
return["EContainer", a1, a2]
}
}
var Solid_68 = ["Solid"];
var Dotted_69 = ["Dotted"];
var Dashed_70 = ["Dashed"];
function Custom_71(a1) {
return["Custom", JS.castListToJSArray(a1)]
}
var Filled_72 = ["Filled"];
var Outlined_73 = ["Outlined"];
function CustomOutline_74(a1) {
return["CustomOutline", JS.castListToJSArray(a1)]
}
function Line_75(a1) {
return["Line", JS.castListToJSArray(a1)]
}
function Shape_78(a1) {
return function(a2) {
var points = JS.castListToJSArray(a1);
if (points.length > 0) { points.push(points[0]); }
return["Shape", points, a2];
}
}
function Form_84(a1) {
return function(a2) {
return function(a3) {
return function(a4) {
return["Form", a1, a2, a3, a4]
}
}
}
}
function FLine_85(a1) {
return function(a2) {
return function(a3) {
return["FLine", a1, a2, a3]
}
}
}
function FShape_86(a1) {
return function(a2) {
return function(a3) {
return["FShape", a1, a2, a3]
}
}
}
function FImage_87(a1) {
return function(a2) {
return function(a3) {
return["FImage", a1, a2, JS.castStringToJSString(a3)]
}
}
}
function FElement_88(a1) {
return["FElement", a1]
}
var left_6 = DLeft_0;
var right_7 = DRight_1;
var down_8 = DDown_3;
var up_9 = DUp_2;
var inward_10 = DIn_4;
var outward_11 = DOut_5;
var topLeft_22 = Position_17(Near_14)(Near_14);
var topRight_23 = Position_17(Far_16)(Near_14);
var bottomLeft_24 = Position_17(Near_14)(Far_16);
var bottomRight_25 = Position_17(Far_16)(Far_16);
var midLeft_26 = Position_17(Near_14)(Mid_15);
var midRight_27 = Position_17(Far_16)(Mid_15);
var midTop_28 = Position_17(Mid_15)(Near_14);
var midBottom_29 = Position_17(Mid_15)(Far_16);
var middle_30 = Position_17(Mid_15)(Mid_15);
function middleAt(a1) {
return function(a2) {
return["PositionAt", a1, a2]
}
}
var topLeftAt_31 = PositionTL_18;
var topRightAt_32 = PositionTR_19;
var bottomLeftAt_33 = PositionBL_20;
var bottomRightAt_34 = PositionBR_21;
var absolute_35 = Absolute_12;
var relative_36 = Relative_13;
function newElement_38(e,w,h,o,c,l) { return Element_37(Guid.guid(),e,w,h,o,c,l); }
function basicNewElement(e,w,h) { return Element_37(Guid.guid(),e,w,h,1,["Nothing"],["Nothing"]); }
var line_76 = Line_75;
var polygon_79 = Shape_78;
function sprite_96(src) {
return function(w) {
return function(h) {
return function(pos) {
return Form_84(0)(1)(pos)(FImage_87(w)(h)(src))
}
}
}
}
function toForm_97(pos) {
return function(e) {
return Form_84(0)(1)(pos)(FElement_88(e))
}
}
function width_47(w__101) {
return function(e) {
var be = e[2];
switch(be[0]) {
case "EImage":
case "EVideo":
return newElement_38(e[2],w__101,e[4] * w__101 / e[3], e[5], e[6], e[7]);
case "EText":
var p = Value.getTextSize(w__101,e[4],be[2]);
return newElement_38(e[2], w__101, p[1], e[5], e[6], e[7]);
}
return newElement_38(e[2], w__101, e[4], e[5], e[6], e[7]);
}
}
function height_48(h__108) {
return function(e) {
var be = e[2];
switch(be[0]) {
case "EImage":
case "EVideo":
return newElement_38(e[2], e[3] * h__108 / e[4], h__108, e[5], e[6], e[7]);
}
return newElement_38(e[2], e[3], h__108, e[5], e[6], e[7]);
}
}
function size_49(w) {
return function(h) {
return function(e) {
return newElement_38(e[2], w, h, e[5], e[6], e[7]);
}
}
}
function opacity_50(o) {
return function(e) {
return newElement_38(e[2], e[3], e[4], o, e[6], e[7]);
}
}
function color_51(c) {
return function(e) {
return newElement_38(e[2], e[3], e[4], e[5], ["Just",c], e[7]);
}
}
function link(lnk) {
return function(e) {
return newElement_38(e[2], e[3], e[4], e[5], e[6], ["Just", JS.castStringToJSString(lnk)]);
}
}
function widthOf_52(e) { return ~~e[3]; }
function heightOf_53(e) { return ~~e[4]; }
function sizeOf_54(e) { return["Tuple2", ~~e[3], ~~e[4]] }
function text_56(txt) {
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("left")(txt), p[0], p[1])
}
function plainText(str) {
var txt = Value.toText(str);
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("left")(txt),p[0],p[1])
}
function asText(v) {
var txt = Elm.Text.monospace(Value.toText(Value.show(v)));
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("left")(txt),p[0],p[1])
}
function centeredText(txt) {
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("center")(txt),p[0],p[1])
}
function justifiedText(txt) {
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("justify")(txt),p[0],p[1])
}
function rightedText(txt) {
var p = Value.getTextSize(0,0,txt);
return basicNewElement(EText_39("right")(txt),p[0],p[1])
}
function image_57(w) {
return function(h) {
return function(src) {
return basicNewElement(EImage_40(src),w,h)
}
}
}
function images(srcs) {
var pics = Elm.Signal.constant(spacer_66(0)(0));
var update = Elm.Signal.lift(function(src) {
src = JS.castStringToJSString(src);
var img = new Image();
img.onload = function() {
Dispatcher.notify(pics.id,
image_57(this.width)(this.height)(src));
};
img.src = src;
})(srcs);
function f(x) { return function(y) { return x; } }
var combine = Elm.Signal.lift2(f)(pics)(update);
return combine;
}
function video_58(w) {
return function(h) {
return function(src) {
return basicNewElement(EVideo_41(src),w,h)
}
}
}
function fittedImage_59(w_147) {
return function(h_148) {
return function(s_149) {
return basicNewElement(EFittedImage_42(s_149),w_147,h_148)
}
}
}
function flow_60(dir_150) {
return function(es_151) {
return function() {
var w_152 = function() {
var ws_154 = map(widthOf_52)(es_151);
return function(case1) {
var case0 = case1;
switch(case0[0]) {
case "DLeft":
return sum(ws_154);
case "DRight":
return sum(ws_154)
}
return maximum(ws_154)
}(dir_150)
}();
var h_153 = function() {
var hs_155 = map(heightOf_53)(es_151);
return function(case3) {
var case2 = case3;
switch(case2[0]) {
case "DDown":
return sum(hs_155);
case "DUp":
return sum(hs_155)
}
return maximum(hs_155)
}(dir_150)
}();
return basicNewElement(EFlow_43(dir_150)(es_151), w_152, h_153)
}()
}
}
function above_61(e1_156) {
return function(e2_157) {
return basicNewElement(EFlow_43(DDown_3)(["Cons", e1_156, ["Cons", e2_157, ["Nil"]]]), Math.max(widthOf_52(e1_156),widthOf_52(e2_157)), heightOf_53(e1_156) + heightOf_53(e2_157));
}
}
function below_62(e1_158) {
return function(e2_159) {
return basicNewElement(EFlow_43(DDown_3)(["Cons", e2_159, ["Cons", e1_158, ["Nil"]]]), Math.max(widthOf_52(e1_158),widthOf_52(e2_159)), heightOf_53(e1_158) + heightOf_53(e2_159));
}
}
function beside_63(e1_160) {
return function(e2_161) {
return basicNewElement(EFlow_43(DRight_1)(["Cons", e1_160, ["Cons", e2_161, ["Nil"]]]), widthOf_52(e1_160) + widthOf_52(e2_161), Math.max(heightOf_53(e1_160),heightOf_53(e2_161)));
}
}
function layers_64(es_162) {
return basicNewElement(EFlow_43(DOut_5)(es_162), maximum(map(widthOf_52)(es_162)), maximum(map(heightOf_53)(es_162)))
}
function collage_65(w_163) {
return function(h_164) {
return function(forms_165) {
return basicNewElement(ECollage_44(w_163)(h_164)(forms_165),w_163,h_164)
}
}
}
function spacer_66(w_166) {
return function(h_167) {
return basicNewElement(EEmpty_45,w_166,h_167)
}
}
function container_67(w_169) {
return function(h_170) {
return function(pos_168) {
return function(e_171) {
return basicNewElement(EContainer_46(pos_168)(e_171),w_169,h_170)
}
}
}
}
function segment_77(p1_172) {
return function(p2_173) {
return Line_75(["Cons", p1_172, ["Cons", p2_173, ["Nil"]]])
}
}
function rect_80(w_174) {
return function(h_175) {
return function(pos_176) {
return Shape_78(["Cons", ["Tuple2", 0 - w_174 / 2, 0 - h_175 / 2],
["Cons", ["Tuple2", 0 - w_174 / 2, h_175 / 2],
["Cons", ["Tuple2", w_174 / 2, h_175 / 2],
["Cons", ["Tuple2", w_174 / 2, 0 - h_175 / 2], ["Nil"]]]]])(pos_176)
}
}
}
function oval_81(w_177) {
return function(h_178) {
return function(pos_179) {
return function() {
var n_180 = 50;
return function() {
function f_181(i_182) {
return["Tuple2", w_177 / 2 * Math.cos(2 * (Math.PI / n_180) * i_182), h_178 / 2 * Math.sin(2 * (Math.PI / n_180) * i_182)];
}
return Shape_78(map(f_181)(function() {
var lo = 0;
var hi = n_180 - 1;
var lst = ["Nil"];
if(lo <= hi) {
do {
lst = ["Cons", hi, lst]
}while(hi-- > lo)
}
return lst
}()))(pos_179)
}()
}()
}
}
}
function circle_82(r_183) {
return oval_81(2 * r_183)(2 * r_183)
}
function ngon_83(n_184) {
return function(r_185) {
return function(pos_186) {
return function() {
var m_187 = n_184;
return function() {
function f_188(i_189) {
return["Tuple2", r_185 * Math.cos(2 * (Math.PI / m_187) * i_189), r_185 * Math.sin(2 * (Math.PI / m_187) * i_189)];
}
return Shape_78(map(f_188)(function() {
var lo = 0;
var hi = n_184 - 1;
var lst = ["Nil"];
if(lo <= hi) {
do {
lst = ["Cons", hi, lst]
}while(hi-- > lo)
}
return lst
}()))(pos_186)
}()
}()
}
}
}
function solid_89(clr_190) {
return function(ln_191) {
return Form_84(0)(1)(["Tuple2", 0, 0])(FLine_85(Solid_68)(clr_190)(ln_191))
}
}
function dotted_90(clr_192) {
return function(ln_193) {
return Form_84(0)(1)(["Tuple2", 0, 0])(FLine_85(Dotted_69)(clr_192)(ln_193))
}
}
function dashed_91(clr_194) {
return function(ln_195) {
return Form_84(0)(1)(["Tuple2", 0, 0])(FLine_85(Dashed_70)(clr_194)(ln_195))
}
}
function customLine_92(pattern_196) {
return function(clr_197) {
return function(ln_198) {
return Form_84(0)(1)(["Tuple2", 0, 0])(FLine_85(Custom_71(pattern_196))(clr_197)(ln_198))
}
}
}
function filled_93(clr) {
return function(shape) {
return Form_84(0)(1)(shape[2])(FShape_86(Filled_72)(clr)(shape));
}
}
function outlined_94(clr) {
return function(shape) {
return Form_84(0)(1)(shape[2])(FShape_86(Outlined_73)(clr)(shape));
}
}
function customOutline_95(pattern) {
return function(clr) {
return function(shape) {
return Form_84(0)(1)(shape[2])(FShape_86(CustomOutline_74(pattern))(clr)(shape));
}
}
}
function textured(src) {
return function(shape) {
return Form_84(0)(1)(shape[2])(FShape_86(["Textured",src])(null)(shape));
}
}
function rotate_98(t_212) {
return function(Form$thetascaleposform_213) {
return function(case5) {
var case0 = case5;
switch(case0[0]) {
case "Form":
var case1 = case0[1], case2 = case0[2], case3 = case0[3], case4 = case0[4];
return Form_84(t_212 + case1)(case2)(case3)(case4)
}
throw new Error("Non-exhaustive pattern match in case");
}(Form$thetascaleposform_213)
}
}
function scale_99(s) {
return function(form) {
return Form_84(form[1])(s * form[2])(form[3])(form[4])
}
}
function move_100(x_224) {
return function(y_225) {
return function(Form$thetascaleTuple2$pxpyform_226) {
return function(case7) {
var case0 = case7;
switch(case0[0]) {
case "Form":
var case1 = case0[1], case2 = case0[2], case3 = case0[3], case4 = case0[4];
switch(case3[0]) {
case "Tuple2":
var case5 = case3[1], case6 = case3[2];
return Form_84(case1)(case2)(["Tuple2", x_224 + case5, y_225 + case6])(case4)
}
break
}
throw new Error("Non-exhaustive pattern match in case");
}(Form$thetascaleTuple2$pxpyform_226)
}
}
}
return{left:left_6, right:right_7, down:down_8, up:up_9, inward:inward_10, outward:outward_11, topLeft:topLeft_22, topRight:topRight_23, bottomLeft:bottomLeft_24, bottomRight:bottomRight_25, midLeft:midLeft_26, midRight:midRight_27, midTop:midTop_28, midBottom:midBottom_29, middle:middle_30, middleAt:middleAt, topLeftAt:topLeftAt_31, topRightAt:topRightAt_32, bottomLeftAt:bottomLeftAt_33, bottomRightAt:bottomRightAt_34, absolute:absolute_35, relative:relative_36, width:width_47, height:height_48, size:size_49, opacity:opacity_50,
color:color_51, link:link, widthOf:widthOf_52, heightOf:heightOf_53, sizeOf:sizeOf_54, text:text_56, asText:asText, plainText:plainText, centeredText:centeredText, justifiedText:justifiedText, rightedText:rightedText, image:image_57, images:images, video:video_58, fittedImage:fittedImage_59, flow:flow_60, above:above_61, below:below_62, beside:beside_63, layers:layers_64, collage:collage_65, spacer:spacer_66, container:container_67, line:line_76, segment:segment_77, polygon:polygon_79, rect:rect_80, oval:oval_81, circle:circle_82, ngon:ngon_83, solid:solid_89, dotted:dotted_90, dashed:dashed_91, customLine:customLine_92, filled:filled_93,
outlined:outlined_94, customOutline:customOutline_95, textured:textured, sprite:sprite_96, toForm:toForm_97, rotate:rotate_98, scale:scale_99, move:move_100,
isWithin: Collage.insideForm}
}();

277
core-js/Graphics/Render.js
View file

@ -1,277 +0,0 @@
var Render = function(){
function newElement(elementType) {
var e = document.createElement(elementType);
e.style.padding = "0";
e.style.margin = "0";
return e;
};
function addTo(container, elem) {
container.appendChild(elem);
};
function makeText(pos,txt) {
var e = newElement('div');
e.innerHTML = txt;
e.style.textAlign = pos;
return e;
};
function image(src) {
var img = newElement('img');
img.src = src;
img.name = src;
img.style.display = "block";
return img;
}
function fittedImage(w,h,src) {
var e = newElement('div');
e.style.width = w + 'px';
e.style.height = h + 'px';
e.style.position = "relative";
e.style.overflow = "hidden";
var img = newElement('img');
img.onload = function() {
img.style.position = 'absolute';
img.style.margin = 'auto';
var sw = w, sh = h;
if (w / h > this.width / this.height) {
sh = Math.round(this.height * w / this.width);
} else {
sw = Math.round(this.width * h / this.height);
}
img.style.width = sw + 'px';
img.style.height = sh + 'px';
img.style.left = ((w - sw) / 2) + 'px';
img.style.top = ((h - sh) / 2) + 'px';
};
img.src = src;
img.name = src;
addTo(e,img);
return e;
};
var video = function(src) {
var e = newElement('video');
e.controls = "controls";
var source = newElement('source');
source.src = src;
var segs = src.split('.');
source.type = "video/" + segs[segs.length-1];
addTo(e, source);
e.style.display = "block";
return e;
};
function divify(e) {
var div = newElement('div');
addTo(div, e);
return div;
};
function goDown(e) {
return e //.tagName === "DIV" ? e : divify(e);
};
function goRight(e) {
e.style.styleFloat = "left";
e.style.cssFloat = "left";
return e;
};
function goIn(e) {
e.style.position = 'absolute';
return e;
};
function flowWith(f, prep, elist) {
var container = newElement('div');
for (var i = elist.length; i--; ) {
addTo(container, f(prep(elist[i])));
}
return container;
};
function flow(dir,elist) {
switch(dir) {
case "DDown": elist = elist.slice(0).reverse();
case "DUp": return flowWith(goDown,render,elist);
case "DRight": elist = elist.slice(0).reverse();
case "DLeft": return flowWith(goRight,render,elist);
case "DOut": elist = elist.slice(0).reverse();
case "DIn": return flowWith(goIn,render,elist);
};
};
function toPos(pos) {
switch(pos[0]) {
case "Absolute": return pos[1] + "px";
case "Relative": return (pos[1] * 100) + "%";
}
}
function setPos(pos,e) {
e.style.position = 'absolute';
e.style.margin = 'auto';
switch(pos[0]) {
case "Position":
if (pos[1][0] !== "Far") e.style.left = 0;
if (pos[1][0] !== "Near") e.style.right = 0;
if (pos[2][0] !== "Far") e.style.top = 0;
if (pos[2][0] !== "Near") e.style.bottom = 0;
break;
case "PositionAt":
e.style.top = toPos(pos[2]);
e.style.left = toPos(pos[1]);
var shift = "translate(" + ~~(-e.style.width.slice(0,-2) / 2) + "px," + ~~(-e.style.height.slice(0,-2) / 2) + "px)";
e.style.transform = shift;
e.style.msTransform = shift;
e.style.MozTransform = shift;
e.style.webkitTransform = shift;
e.style.OTransform = shift;
break;
default:
var p = pos[0].slice(-2);
e.style[p[0] === "T" ? 'top' : 'bottom'] = toPos(pos[2]);
e.style[p[1] === "L" ? 'left' : 'right'] = toPos(pos[1]);
}
}
function container(pos,elem) {
var e = render(elem);
setPos(pos,e);
var div = newElement('div');
div.style.position = "relative";
div.style.overflow = "hidden";
addTo(div,e);
return div;
};
function render(elem) {
var e = {};
switch(elem[2][0]) {
case "EText": e = makeText(elem[2][1],elem[2][2]); break;
case "EImage": e = image(elem[2][1]); break;
case "EVideo": e = video(elem[2][1]); break;
case "EFittedImage": e = fittedImage(elem[3],elem[4],elem[2][1]); break;
case "EFlow": e = flow(elem[2][1][0],elem[2][2]); break;
case "ECollage": e = Collage.collage(elem[2][1],elem[2][2],elem[2][3]); break;
case "EEmpty": e = newElement('div'); break;
case "EContainer": e = container(elem[2][1],elem[2][2]); break;
case "EHtml":
e = elem[2][1];
if (e.type !== 'button') {
var p = Value.getExcess(e);
elem[3] -= p[0];
elem[4] -= p[1];
}
break;
case "EExternalHtml":
e = newElement('div');
addTo(e, elem[2][1]);
break;
}
e.id = elem[1];
e.style.width = (~~elem[3]) + 'px';
e.style.height = (~~elem[4]) + 'px';
if (elem[5] !== 1) { e.style.opacity = elem[5]; }
if (elem[6][0] === "Just") {
e.style.backgroundColor = Elm.Color.extract(elem[6][1]);
}
if (elem[7][0] === "Just") {
var a = newElement('a');
a.href = elem[7][1];
addTo(a,e);
return a;
}
return e;
};
function update(node,curr,next) {
if (node.tagName === 'A') { node = node.firstChild; }
if (curr[1] === next[1]) return;
if (curr[2][0] !== next[2][0]) {
return node.parentNode.replaceChild(render(next),node);
}
var nextE = next[2], currE = curr[2];
switch(nextE[0]) {
case "EText":
if (nextE[1] !== currE[1]) node.style.textAlign = nextE[1];
if (nextE[2] !== currE[2]) node.innerHTML = nextE[2];
break;
case "EImage":
if (nextE[1] !== currE[1]) node.src = nextE[1];
break;
case "EVideo":
case "EFittedImage":
if (!Value.eq(nextE,currE) || next[3]!==curr[3] || next[4]!==curr[4]) {
return node.parentNode.replaceChild(render(next),node);
}
break;
case "ECollage":
if (nextE[1] !== currE[1] || nextE[2] !== currE[2] || nextE[3].length !== currE[3].length) {
return node.parentNode.replaceChild(render(next),node);
}
Collage.updateCollage(node,currE[3],nextE[3]);
break;
case "EFlow":
if (nextE[1] !== currE[1]) {
return node.parentNode.replaceChild(render(next),node);
}
var nexts = nextE[2];
var kids = node.childNodes;
if (nexts.length !== kids.length) {
return node.parentNode.replaceChild(render(next),node);
}
var currs = currE[2];
var goDir = function(x) { return x; };
switch(nextE[1][0]) {
case "DDown": case "DUp": goDir = goDown; break;
case "DRight": case "DLeft": goDir = goRight; break;
case "DOut": case "DIn": goDir = goIn; break;
}
for (var i = kids.length; i-- ;) {
update(kids[i],currs[i],nexts[i]);
goDir(kids[i]);
}
break;
case "EContainer":
update(node.childNodes[0],currE[2],nextE[2]);
setPos(nextE[1],node.childNodes[0]);
break;
case "EEmpty":
break;
case "EHtml":
if (next[1] !== curr[1]) {
var e = render(next);
node.parentNode.replaceChild(e,node);
node = e;
}
if (e.type !== 'button') {
var p = Value.getExcess(node);
next[3] -= p[0];
next[4] -= p[1];
}
break;
case "EExternalHtml":
if (next[1] !== curr[1])
node.parentNode.replaceChild(render(next),node);
break;
}
if (next[3] !== curr[3]) node.style.width = (~~next[3]) + 'px';
if (next[4] !== curr[4]) node.style.height = (~~next[4]) + 'px';
if (next[5] !== curr[5]) node.style.opacity = next[5];
if (next[6].length === 2) {
var clr = Elm.Color.extract(next[6][1]);
if (clr !== node.style.backgroundColor) node.style.backgroundColor = clr;
}
if (next[7].length === 2) {
if (curr[7].length === 1 || next[7][1] !== curr[7][1]) node.parentNode.href = next[7][1];
}
next[1] = curr[1];
}
return {render:render,update:update,addTo:addTo,newElement:newElement,flowWith:flowWith,goIn:goIn};
}();

8
core-js/Guid.js
View file

@ -1,8 +0,0 @@
Elm = {};
var Guid = function() {
var counter = 0;
var guid = function() { counter += 1; return counter; };
return {guid : guid};
}();

482
core-js/List.js
View file

@ -1,482 +0,0 @@
Elm.List = function() {
var throwError = function(f) {
throw new Error("Function '" + f + "' expecting a list!");
}
function length(xs) {
var out = 0;
while (xs[0] === "Cons") {
out += 1;
xs = xs[2];
}
return out;
};
var reverse = foldl(function(x_72) {
return function(y_73) {
return["Cons", x_72, y_73]
}
})(["Nil"]);
var concat = foldr(function(x_74) {
return function(y_75) {
return Value.append(x_74, y_75)
}
})(["Nil"]);
var and = foldl(function(x_77) {
return function(y_78) {
return x_77 && y_78
}
})(true);
var or = foldl(function(x_79) {
return function(y_80) {
return x_79 || y_80
}
})(false);
var sum = foldl(function(x_89) {
return function(y_90) {
return x_89 + y_90
}
})(0);
var product = foldl(function(x_91) {
return function(y_92) {
return x_91 * y_92
}
})(1);
var maximum = foldl1(function(x) { return function(y) { return Math.max(x,y) } });
var minimum = foldl1(function(x) { return function(y) { return Math.min(x,y) } });
function head(v) {
if (v[0] !== "Cons") {
throw new Error("Error: 'head' only accepts lists of length greater than one.");
}
return v[1];
}
function tail(v) {
if (v[0] !== "Cons") {
throw new Error("Error: 'tail' only accepts lists of length greater than one.");
}
return v[2];
}
function last(v) {
if (v[0] !== "Cons") {
throw new Error("Error: 'last' only accepts lists of length greater than one.");
}
var out = v[1];
while (v[0] === "Cons") {
out = v[1];
v = v[2];
}
return out;
}
function map(f) {
return function(xs) {
if (xs[0] === "Nil") { return xs; }
if (xs[0] !== "Cons") { throwError('map'); }
var root = ["Cons", f(xs[1]), ["Nil"]];
var curr = root;
xs = xs[2];
while (xs[0]==="Cons") {
curr[2] = ["Cons", f(xs[1]), ["Nil"]];
xs = xs[2];
curr = curr[2];
}
return root;
}
}
function foldl(f) {
return function(b) {
return function(xs) {
var acc = b;
if (xs[0] === "Nil") { return acc; }
if (xs[0] !== "Cons") { throwError('foldl'); }
while (xs[0] === "Cons") {
acc = f(xs[1])(acc);
xs = xs[2];
}
return acc;
}
}
}
function foldr(f) {
return function(b) {
return function(xs) {
var acc = b;
if (xs[0] === "Nil") { return acc; }
if (xs[0] !== "Cons") { throwError('foldr'); }
var arr = [];
while (xs[0] === "Cons") {
arr.push(xs[1]);
xs = xs[2];
}
for (var i = arr.length; i--; ) {
acc = f(arr[i])(acc);
}
return acc;
}
}
}
function foldl1(f_49) {
return function(_temp_50) {
return function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var x_51 = v[1];
var xs_52 = v[2];
return foldl(f_49)(x_51)(xs_52)
}
}(_temp_50)
}
}
function foldr1(f) {
return function(xs) {
if (xs[0] === "Nil") { throw new Error("'foldr1' requires an non-empty list.") }
if (xs[0] !== "Cons") { throwError('foldr1'); }
var arr = [];
while (xs[0] === "Cons") {
arr.push(xs[1]);
xs = xs[2];
}
var acc = arr.pop();
for (var i = arr.length; i--; ) {
acc = f(arr[i])(acc);
}
return acc;
}
}
function scanl(f) {
return function(b) {
return function(xs) {
if (xs[0] === "Nil") { return ["Cons",b,["Nil"]]; }
if (xs[0] !== "Cons") { throwError('scanl'); }
var arr = [b];
while (xs[0] === "Cons") {
b = f(xs[1])(b);
arr.push(b);
xs = xs[2];
}
var out = ["Nil"];
for (var i = arr.length; i--; ) {
out = ["Cons", arr[i], out];
}
return out;
}
}
}
function scanl1(f) {
return function(xs) {
if (xs[0] !== "Cons") {
throw new Error("Error: 'scanl1' requires a list of at least length 1.");
}
return scanl(f)(xs[1])(xs[2]);
}
}
function filter(pred) {
return function(xs) {
if (xs[0] === "Nil") { return xs; }
if (xs[0] !== "Cons") { throwError('filter'); }
var arr = [];
while (xs[0] === "Cons") {
if (pred(xs[1])) { arr.push(xs[1]); }
xs = xs[2];
}
var out = ["Nil"];
for (var i = arr.length; i--; ) {
out = ["Cons", arr[i], out];
}
return out;
}
}
function concatMap(f_76) {
return function(x) {
return concat(map(f_76)(x))
}
}
function all(pred) {
return foldl(function(x) { return function(acc) {
return acc && pred(x);
};})(true);
}
function any(pred) {
return foldl(function(x) { return function(acc) {
return acc || pred(x);
};})(false);
}
function partition(pred_93) {
return function(lst_94) {
return function() {
var v = lst_94;
var c = [function(v) {
if("Nil" !== v[0]) {
return undefined
}else {
return["Tuple2", ["Nil"], ["Nil"]]
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var x_95 = v[1];
var xs_96 = v[2];
return function(v) {
if("Tuple2" !== v[0]) {
return undefined
}else {
var as_97 = v[1];
var bs_98 = v[2];
return pred_93(x_95) ? ["Tuple2", ["Cons", x_95, as_97], bs_98] : ["Tuple2", as_97, ["Cons", x_95, bs_98]]
}
}(partition(pred_93)(xs_96))
}
}];
for(var i = c.length;i--;) {
var r = c[i](v);
if(r !== undefined) {
return r
}
}
}()
}
}
function zipWith(f) {
return function(listA) {
return function(listB) {
if (listA[0] === "Nil" || listB[0] === "Nil") { return ["Nil"]; }
if (listA[0] !== "Cons" || listB[0] !== "Cons") { throwError('zipWith'); }
var arr = [];
while (listA[0] === "Cons" && listB[0] === "Cons") {
arr.push(f(listA[1])(listB[1]));
listA = listA[2];
listB = listB[2];
}
var out = ["Nil"];
for (var i = arr.length; i--; ) {
out = ["Cons", arr[i], out];
}
return out;
}
}
}
function zip(listA) {
return function(listB) {
if (listA[0] === "Nil" || listB[0] === "Nil") { return ["Nil"]; }
if (listA[0] !== "Cons" || listB[0] !== "Cons") { throwError('zip'); }
var arr = [];
while (listA[0] === "Cons" && listB[0] === "Cons") {
arr.push(["Tuple2", listA[1], listB[1]]);
listA = listA[2];
listB = listB[2];
}
var out = ["Nil"];
for (var i = arr.length; i--; ) {
out = ["Cons", arr[i], out];
}
return out;
}
}
function unzip(pairs_112) {
return function() {
var v = pairs_112;
var c = [function(v) {
if("Nil" !== v[0]) {
return undefined
}else {
return["Tuple2", ["Nil"], ["Nil"]]
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var p_113 = v[1];
var ps_114 = v[2];
return function(v) {
if("Tuple2" !== v[0]) {
return undefined
}else {
if("Tuple2" !== v[1][0]) {
return undefined
}else {
var x_115 = v[1][1];
var y_116 = v[1][2];
if("Tuple2" !== v[2][0]) {
return undefined
}else {
var xs_117 = v[2][1];
var ys_118 = v[2][2];
return["Tuple2", ["Cons", x_115, xs_117], ["Cons", y_116, ys_118]]
}
}
}
}(["Tuple2", p_113, unzip(ps_114)])
}
}];
for(var i = c.length;i--;) {
var r = c[i](v);
if(r !== undefined) {
return r
}
}
}()
}
function intersperse(sep_119) {
return function(xs_120) {
return function() {
var v = xs_120;
var c = [function(v) {
if("Nil" !== v[0]) {
return undefined
}else {
return["Nil"]
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var a_124 = v[1];
if("Nil" !== v[2][0]) {
return undefined
}else {
return["Cons", a_124, ["Nil"]]
}
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var a_121 = v[1];
if("Cons" !== v[2][0]) {
return undefined
}else {
var b_122 = v[2][1];
var cs_123 = v[2][2];
return["Cons", a_121, ["Cons", sep_119, intersperse(sep_119)(["Cons", b_122, cs_123])]]
}
}
}];
for(var i = c.length;i--;) {
var r = c[i](v);
if(r !== undefined) {
return r
}
}
}()
}
}
function intercalate(sep_125) {
return function(xs_126) {
return function() {
var v = xs_126;
var c = [function(v) {
if("Nil" !== v[0]) {
return undefined
}else {
return["Nil"]
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var a_130 = v[1];
if("Nil" !== v[2][0]) {
return undefined
}else {
return a_130
}
}
}, function(v) {
if("Cons" !== v[0]) {
return undefined
}else {
var a_127 = v[1];
if("Cons" !== v[2][0]) {
return undefined
}else {
var b_128 = v[2][1];
var cs_129 = v[2][2];
return Value.append(a_127, Value.append(sep_125, intercalate(sep_125)(["Cons", b_128, cs_129])))
}
}
}];
for(var i = c.length;i--;) {
var r = c[i](v);
if(r !== undefined) {
return r
}
}
}()
}
}
function sort(xs) {
if (xs[0] === "Nil") { return xs; }
if (xs[0] !== "Cons") { throwError('sort'); }
var arr = [];
while (xs[0] === "Cons") {
arr.push(xs[1]);
xs = xs[2];
}
arr.sort(function(a,b) { return a - b});
var out = ["Nil"];
for (var i = arr.length; i--; ) {
out = [ "Cons", arr[i], out ];
}
return out;
}
function take(n) { return function(xs) {
if (n <= 0) { return ["Nil"]; }
if (xs[0] === "Nil") { return xs; }
if (xs[0] !== "Cons") { throwError('take'); }
var out = [ "Cons", xs[1], ["Nil"] ];
var temp = out;
xs = xs[2];
--n;
while (xs[0] === "Cons" && n > 0) {
temp[2] = [ "Cons", xs[1], ["Nil"] ];
temp = temp[2];
xs = xs[2];
--n;
}
return out;
};
}
function drop(n) { return function(xs) {
if (xs[0] === "Nil") { return xs; }
if (xs[0] !== "Cons") { throwError('drop'); }
while (xs[0] === "Cons" && n > 0) {
xs = xs[2];
--n;
}
return xs;
};
}
return {head:head,
tail:tail,
last:last,
map:map,
foldl:foldl,
foldr:foldr,
foldl1:foldl1,
foldr1:foldr1,
scanl:scanl,
scanl1:scanl1,
filter:filter,
length:length,
reverse:reverse,
concat:concat,
concatMap:concatMap,
and:and,
or:or,
all:all,
any:any,
sum:sum,
product:product,
maximum:maximum,
minimum:minimum,
partition:partition,
zipWith:zipWith,
zip:zip,
unzip:unzip,
intersperse:intersperse,
intercalate:intercalate,
sort:sort,
take:take,
drop:drop};
}();

62
core-js/Maybe.js
View file

@ -1,62 +0,0 @@
/*! Maybe
!*/
/*[Definition]*/
/** data Maybe a = Just a | Nothing
The Maybe datatype. Useful when a computation may or may not
result in a value (e.g. logarithm is defined only for positive numbers).
**/
/*[Basic Utilities]*/
/** maybe : b -> (a -> b) -> Maybe a -> b
Apply a function to the contents of a `Maybe`.
Return default when given `Nothing`.
**/
/** isJust : Maybe a -> Bool
Check if constructed with `Just`.
**/
/** isNothing : Maybe a -> Bool
Check if constructed with `Nothing`.
**/
/*[Maybe with Lists]*/
/** cons : Maybe a -> [a] -> [a]
If `Just`, adds the value to the front of the list.
If `Nothing`, list is unchanged.
**/
/** justs : [Maybe a] -> [a]
Filters out Nothings and extracts the remaining values.
**/
Elm.Maybe = function() {
function consMaybe(x) { return function(xs) {
if (x[0] === "Just") return ["Cons", x[1], xs];
return xs;
};
}
function mapCons(f) { return function(y) { return function(xs) {
var x = f(y);
if (x[0] === "Just") return ["Cons", x[1], xs];
return xs;
};
};
}
function maybe(b) { return function(f) { return function(m) {
if (m[0] === "Just") return f(m[1]);
return b;
};
};
}
return {Just : function(x) { return ["Just",x]; },
Nothing : ["Nothing"],
justs : Elm.List.foldr(consMaybe)(["Nil"]),
isJust : function(m) { return m[0] === "Just"; },
isNothing : function(m) { return m[0] === "Nothing"; },
cons : consMaybe,
maybe : maybe
};
}();

243
core-js/Prelude.js
View file

@ -1,243 +0,0 @@
function elmRecordCopy(r) {
var o = {};
for (var i in r) { o[i] = r[i]; }
return o;
}
function elmRecordRemove(x,r) {
var o = elmRecordCopy(r);
if (x in o._) {
o[x] = o._[x][0];
o._[x] = o._[x].slice(1);
if (o._[x].length === 0) { delete o._[x]; }
} else {
delete o[x];
}
return o;
}
function elmRecordReplace(kvs,r) {
var o = elmRecordCopy(r);
for (var i = kvs.length; i--; ) {
kvsi = kvs[i];
o[kvsi[0]] = kvsi[1];
}
return o;
}
function elmRecordInsert(x,v,r) {
var o = elmRecordCopy(r);
if (x in o) o._[x] = [o[x]].concat(x in o._ ? o._[x].slice(0) : []);
o[x] = v;
return o;
}
Value.addListener(document, 'elm_log', function(e) { console.log(e.value); });
Value.addListener(document, 'elm_title', function(e) {document.title = e.value;});
Value.addListener(document, 'elm_redirect', function(e) {
if (e.value.length > 0) { window.location = e.value; }
});
Value.addListener(document, 'elm_viewport', function(e) {
var node = document.getElementById('elm_viewport');
if (!node) {
node = document.createElement('meta');
node.id = 'elm_viewport';
node.name = 'viewport';
document.head.appendChild(node);
}
node.content = e.value;
Dispatcher.notify(Elm.Window.dimensions.id,
Value.Tuple(window.innerWidth, window.innerHeight));
});
Elm.Prelude = function() {
var mod = function(x) { return function(y) {
var r = x % y;
var m = x==0 ? 0 : (y>0 ? (x>=0 ? r : r+y) : -mod(-x)(-y));
return m == y ? 0 : m;
}; };
var min = function(x) { return function(y) { return Math.min(x,y); }; };
var max = function(x) { return function(y) { return Math.max(x,y); }; };
var flip=function(f){return function(x){return function(y){return f(y)(x);};};};
var clamp = function(lo) { return function(hi) {
return function(x) { return Math.min(hi, Math.max(lo, x)); };
};
};
var curry = function(f) { return function(x) { return function(y) {
return f(["Tuple2",x,y]); }; };
};
var uncurry = function(f) { return function(p) {
if (p[0] !== "Tuple2") {
throw new Error("Function was uncurry'd but was not given a pair.");
}
return f(p[1])(p[2]); };
};
var logBase=function(b){return function(x){return Math.log(x)/Math.log(b);};};
function readInt(str) {
var s = Elm.JavaScript.castStringToJSString(str);
var len = s.length;
if (len === 0) { return ["Nothing"]; }
var start = 0;
if (s[0] == '-') {
if (len === 1) { return ["Nothing"]; }
start = 1;
}
for (var i = start; i < len; ++i) {
if (!Elm.Char.isDigit(s[i])) { return ["Nothing"]; }
}
return ["Just", parseInt(s)];
}
function readFloat(str) {
var s = Elm.JavaScript.castStringToJSString(str);
var len = s.length;
if (len === 0) { return ["Nothing"]; }
var start = 0;
if (s[0] == '-') {
if (len === 1) { return ["Nothing"]; }
start = 1;
}
var dotCount = 0;
for (var i = start; i < len; ++i) {
if (Elm.Char.isDigit(s[i])) { continue; }
if (s[i] === '.') {
dotCount += 1;
if (dotCount <= 1) { continue; }
}
return ["Nothing"];
}
return ["Just", parseFloat(s)];
}
function compare(x) { return function (y) {
if (x instanceof Array && y instanceof Array) {
var len = x.length;
if (len == y.length) {
for (var i = 1; i < len; ++i) {
var cmp = compare(x[i])(y[i]);
if (cmp[0] === 'EQ') continue;
return cmp;
}
return ['EQ'];
}
return [ y.length == 1 ? 'GT' : 'LT' ];
}
return [ x === y ? 'EQ' : (x < y ? 'LT' : 'GT') ];
};
}
return {eq : Value.eq,
id : function(x) { return x; },
not : function(b) { return !b; },
xor : function(x) { return function(y) { return x != y; }; },
fst : function(p) { return p[1]; },
snd : function(p) { return p[2]; },
rem : function(x) { return function(y) { return x % y; }; },
div : function(x) { return function(y) { return ~~(x / y); }; },
otherwise : true,
compare : compare,
toFloat : function(x) { return x; },
round : function(n) { return Math.round(n); },
floor : function(n) { return Math.floor(n); },
ceiling : function(n) { return Math.ceil(n); },
truncate : function(n) { return ~~n; },
readInt : readInt,
readFloat : readFloat,
sqrt : Math.sqrt,
abs : Math.abs,
pi : Math.PI,
e : Math.E,
sin : Math.sin,
cos : Math.cos,
tan : Math.tan,
asin : Math.asin,
acos : Math.acos,
atan : Math.atan,
atan2 : function(y) { return function(x) { return Math.atan2(y,x); }; },
mod : mod,
min : min,
max : max,
flip : flip,
clamp : clamp,
curry : curry,
uncurry : uncurry,
logBase : logBase,
Just : Elm.Maybe.Just,
Nothing : Elm.Maybe.Nothing,
maybe : Elm.Maybe.maybe,
map : Elm.List.map,
zip : Elm.List.zip,
zipWith : Elm.List.zipWith,
filter : Elm.List.filter,
head : Elm.List.head,
tail : Elm.List.tail,
last : Elm.List.last,
length : Elm.List.length,
reverse : Elm.List.reverse,
foldr : Elm.List.foldr,
foldr1 : Elm.List.foldr1,
foldl : Elm.List.foldl,
foldl1 : Elm.List.foldl1,
and : Elm.List.and,
or : Elm.List.or,
all : Elm.List.all,
any : Elm.List.any,
sum : Elm.List.sum,
product : Elm.List.product,
concat : Elm.List.concat,
concatMap : Elm.List.concatMap,
maximum : Elm.List.maximum,
minimum : Elm.List.minimum,
scanl : Elm.List.scanl,
scanl1 : Elm.List.scanl1,
take : Elm.List.take,
drop : Elm.List.drop,
zip : Elm.List.zip,
unzip : Elm.List.unzip,
lift : Elm.Signal.lift,
lift2 : Elm.Signal.lift2,
lift3 : Elm.Signal.lift3,
lift4 : Elm.Signal.lift4,
lift5 : Elm.Signal.lift5,
lift6 : Elm.Signal.lift6,
lift7 : Elm.Signal.lift7,
lift8 : Elm.Signal.lift8,
foldp : Elm.Signal.foldp,
foldp1 : Elm.Signal.foldp1,
foldp$ : Elm.Signal.foldp$,
constant : Elm.Signal.constant,
merge : Elm.Signal.merge,
merges : Elm.Signal.merges,
mergeEither : Elm.Signal.mergeEither,
count : Elm.Signal.count,
countIf : Elm.Signal.countIf,
average : Elm.Signal.average,
keepIf : Elm.Signal.keepIf,
dropIf : Elm.Signal.dropIf,
keepWhen : Elm.Signal.keepWhen,
dropWhen : Elm.Signal.dropWhen,
dropRepeats : Elm.Signal.dropRepeats,
sampleOn : Elm.Signal.sampleOn,
timestamp : Elm.Signal.timestamp,
timeOf : Elm.Signal.timeOf
};
}();
(function() {
var include = function(library) {
for (var i in library) {
Elm.Prelude[i] = library[i];
}
};
include (Elm.Color);
include (Elm.Text);
include (Elm.Graphics);
include (Elm.Time);
show = Value.show;
}());

31
core-js/Set.js
View file

@ -1,31 +0,0 @@
Elm.Set=function(){
var empty_0=Elm.Dict.empty;
var remove_3=Elm.Dict.remove;
var member_4=Elm.Dict.member;
var union_5=Elm.Dict.union;
var intersect_6=Elm.Dict.intersect;
var diff_7=Elm.Dict.diff;
var toList_8=Elm.Dict.keys;
var fromList_9=Elm.List.foldl(function(k_15){
return function(t_16){
return Elm.Dict.insert(k_15)(["Tuple0"])(t_16);};})(empty_0);
function singleton_1(k_13){
return Elm.Dict.singleton(k_13)(["Tuple0"]);};
function insert_2(k_14){
return Elm.Dict.insert(k_14)(["Tuple0"]);};
function foldl_10(f_17){
return Elm.Dict.foldl(function(k_18){
return function(v_19){
return function(b_20){
return f_17(k_18)(b_20);};};});};
function foldr_11(f_21){
return Elm.Dict.foldr(function(k_22){
return function(v_23){
return function(b_24){
return f_21(k_22)(b_24);};};});};
function map_12(f_25){
return function(t_26){
return function(x){
return fromList_9(Elm.List.map(f_25)(x));}(toList_8(t_26));};};
return {empty:empty_0,singleton:singleton_1,insert:insert_2,remove:remove_3,member:member_4,union:union_5,intersect:intersect_6,diff:diff_7,toList:toList_8,fromList:fromList_9,foldl:foldl_10,foldr:foldr_11,map:map_12};}();

111
core-js/Signal/HTTP.js
View file

@ -1,111 +0,0 @@
/*! HTTP
A library for asynchronous HTTP requests (AJAX). See the
[WebSocket](http://elm-lang.org/docs/WebSocket.elm) library if
you have very strict latency requirements.
!*/
Elm.HTTP = function() {
var JS = Elm.JavaScript;
var toElmString = Elm.JavaScript.castJSStringToString;
/*[Creating Requests]*/
/** get : String -> Request String
Create a GET request to the given url.
**/
function get(url) { return request("GET")(url)(null)(["Nil"]); }
/** post : String -> String -> Request String
Create a POST request to the given url, carrying the given data.
**/
function post(url) { return function(data) {
return request("POST")(url)(data)(["Nil"]); }; }
/** request : String -> String -> String -> [(String,String)] -> Request String
Create a customized request. Arguments are request type (get, post, put,
delete, etc.), target url, data, and a list of additional headers.
**/
function request(verb) { return function(url) { return function(data) {
return function(headers) {
return {0 : "Request",
length : 1,
verb : JS.castStringToJSString(verb),
url : JS.castStringToJSString(url),
data : data === null ? null : JS.castStringToJSString(data),
headers : headers }; }; }; };
}
function registerReq(queue,responses) { return function(req) {
if (req.url !== "") { sendReq(queue,responses,req); }
};
}
function updateQueue(queue,responses) {
if (queue.length > 0) {
Dispatcher.notify(responses.id, queue[0].value);
if (queue[0].value[0] !== "Waiting") {
queue.shift();
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
}
}
function sendReq(queue,responses,req) {
var response = { value: ["Waiting"] };
queue.push(response);
var request = null;
if (window.ActiveXObject) { request = new ActiveXObject("Microsoft.XMLHTTP"); }
if (window.XMLHttpRequest) { request = new XMLHttpRequest(); }
request.onreadystatechange = function(e) {
if (request.readyState === 4) {
response.value = (request.status === 200
? ["Success", toElmString(request.responseText)]
: ["Failure", request.status,
toElmString(request.statusText)]);
setTimeout(function() { updateQueue(queue,responses); }, 0);
}
};
request.open(req.verb, req.url, true);
Elm.List.map(function(pair) {
request.setRequestHeader(
JS.castStringToJSString(pair[1]),
JS.castStringToJSString(pair[2]));
})(req.headers);
request.send(req.data);
return null;
}
/*[Responses]*/
/** data Response a = Waiting | Success a | Failure Int String
The datatype for responses. Success contains only the returned message.
Failures contain both an error code and an error message.
**/
/*[Sending Requests]*/
/** send : Signal (Request a) -> Signal (Response String)
Performs an HTTP request with the given requests. Produces a signal
that carries the responses.
**/
function send(requests) {
var responses = Elm.Signal.constant(["Waiting"]);
var sender = Elm.Signal.lift(registerReq([],responses))(requests);
function f(x) { return function(y) { return x; } }
return Elm.Signal.lift2(f)(responses)(sender);
}
/** sendGet : Signal String -> Signal (Response String)
Performs an HTTP GET request with the given urls. Produces a signal
that carries the responses.
**/
return {get : get,
post : post,
request : request,
send : send,
sendGet : function(urls){return send(Elm.Signal.lift(get)(urls));}
};
}();

84
core-js/Signal/Input.js
View file

@ -1,84 +0,0 @@
Elm.Input = function() {
var JS = Elm.JavaScript;
var toElmString = Elm.JavaScript.castJSStringToString;
var newTextInput = function(elem, ghostText) {
elem.placeholder = JS.castStringToJSString(ghostText);
var str = Elm.Signal.constant(["Nil"]);
Value.addListener(elem, 'keyup', function(e) {
Dispatcher.notify(str.id, toElmString(elem.value));
elem.focus();
});
elem.style.padding = "1px";
return Value.Tuple(Value.wrap(elem), str);
};
var newElement = function(name) {
var e = document.createElement(name);
e.style.padding = "0";
e.style.margin = "0";
return e;
};
var textArea = function(cols) { return function(rows) {
var textarea = newElement('textarea');
textarea.rows = rows;
textarea.cols = cols;
return newTextInput(textarea, "");
};
};
var textField = function(ghostText) {
var field = newElement('input');
field.type = 'text';
return newTextInput(field, ghostText);
};
var password = function(ghostText) {
var field = newElement('input');
field.type = 'password';
return newTextInput(field, ghostText);
};
var checkbox = function(checked) {
var box = newElement('input');
box.type = 'checkbox';
box.checked = checked;
var status = Elm.Signal.constant(checked);
Value.addListener(box, 'change', function(e) {
Dispatcher.notify(status.id, box.checked);
});
return Value.Tuple(Value.wrap(box), status);
};
var dropDown = function(options) {
var slct = newElement('select');
var opts = [];
while (options[0] === "Cons") {
var opt = newElement('option');
var str = Value.toText(options[1][1]);
opt.value = str;
opt.innerHTML = str;
slct.appendChild(opt);
opts.push(options[1][2]);
options = options[2];
}
var status = Elm.Signal.constant(opts[0]);
Value.addListener(slct, 'change', function(e) {
Dispatcher.notify(status.id, opts[slct.selectedIndex]);
});
return Value.Tuple(Value.wrap(slct), status);
};
var stringDropDown = function(opts) {
return dropDown(Elm.List.map (function(x) {return Value.Tuple(x,x);}) (opts));
};
var button = function(name) {
var b = newElement('button');
b.type = "button";
b.innerText = JS.castStringToJSString(name);
var press = Elm.Signal.constant(false);
Value.addListener(b, 'click', function(e) {
Dispatcher.notify(press.id, true);
Dispatcher.notify(press.id, false);
});
return Value.Tuple(Value.wrap(b),press);
};
return {textArea:textArea, textField:textField,
password:password, checkbox:checkbox,
dropDown:dropDown, stringDropDown:stringDropDown,
button:button};
}();

123
core-js/Signal/Keyboard.js
View file

@ -1,123 +0,0 @@
Elm.Keyboard = { Raw : function() {
var keysDown = Elm.Signal.constant(["Nil"]);
var charPressed = Elm.Signal.constant(["Nothing"]);
function remove(x,xs) {
if (xs[0] === "Nil") return xs;
if (xs[1] === x) return xs[2];
return ["Cons", xs[1], remove(x,xs[2])];
}
function has(x,xs) {
while (xs[0] !== "Nil") {
if (xs[1] === x) return true;
xs = xs[2];
}
return false;
}
Value.addListener(document, 'keydown', function(e) {
if (has(e.keyCode, keysDown.value)) return;
var hasListener = Dispatcher.notify(keysDown.id, ["Cons", e.keyCode, keysDown.value]);
if (!hasListener)
this.removeEventListener('keydown',arguments.callee,false);
});
Value.addListener(document, 'keyup', function(e) {
var codes = remove(e.keyCode, keysDown.value);
var hasListener = Dispatcher.notify(keysDown.id, codes);
if (!hasListener)
this.removeEventListener('keyup',arguments.callee,false);
});
Value.addListener(window, 'blur', function(e) {
var hasListener = Dispatcher.notify(keysDown.id, ["Nil"]);
if (!hasListener)
this.removeEventListener('blur',arguments.callee,false);
});
Value.addListener(document, 'keypress', function(e) {
var hasListener = Dispatcher.notify(charPressed.id, ["Just",e.charCode || e.keyCode]);
Dispatcher.notify(charPressed.id, ["Nothing"]);
if (!hasListener)
this.removeEventListener('keypress',arguments.callee,false);
});
return {keysDown:keysDown,
charPressed:charPressed};
}()
};
/*! Keyboard
These are nicely curated inputs from the keyboard. See the
[Keyboard.Raw library](/docs/Signal/KeyboardRaw.elm) for a
lower-level interface that will let you define more complicated behavior.
!*/
(function() {
function keySignal(f) {
var signal = Elm.Signal.lift(f)(Elm.Keyboard.Raw.keysDown);
Elm.Keyboard.Raw.keysDown.defaultNumberOfKids += 1;
signal.defaultNumberOfKids = 0;
return signal;
}
function dir(left,right,up,down) {
function f(ks) {
var x = 0, y = 0;
while (ks[0] == "Cons") {
switch (ks[1]) {
case left : --x; break;
case right: ++x; break;
case up : ++y; break;
case down : --y; break;
}
ks = ks[2];
}
return { _:[true], x:[x], y:[y] };
}
return keySignal(f);
}
function is(key) {
function f(ks) {
while (ks[0] == "Cons") {
if (key == ks[1]) return true;
ks = ks[2];
}
return false;
}
return keySignal(f);
}
/*[Directions]*/
/** arrows : Signal { x:Int, y:Int }
A signal of records indicating which arrow keys are pressed.
`{ x = 0, y = 0 }` when pressing no arrows.
`{ x =-1, y = 0 }` when pressing the left arrow.
`{ x = 1, y = 1 }` when pressing the up and right arrows.
`{ x = 0, y =-1 }` when pressing the down, left, and right arrows.
**/
Elm.Keyboard.arrows = dir(37,39,38,40);
/** wasd : Signal { x:Int, y:Int }
Just like the arrows signal, but this uses keys w, a, s, and d,
which are common controls for many computer games.
**/
Elm.Keyboard.wasd = dir(65,68,87,83);
/*[Modifiers]*/
/** shift : Signal Bool
Whether the shift key is pressed.
**/
Elm.Keyboard.shift = is(16);
/** ctrl : Signal Bool
Whether the control key is pressed.
**/
Elm.Keyboard.ctrl = is(17);
/** space : Signal Bool
Whether the space key is pressed.
**/
Elm.Keyboard.space = is(32);
}());

106
core-js/Signal/Mouse.js
View file

@ -1,106 +0,0 @@
/*! Mouse
!*/
Elm.Mouse = function() {
/*[Position]*/
/** position : Signal (Int,Int)
The current mouse position.
**/
var position = Elm.Signal.constant(Value.Tuple(0,0));
position.defaultNumberOfKids = 2;
/** x : Signal Int
The current x-coordinate of the mouse.
**/
var x = Elm.Signal.lift(function(p){return p[1];})(position);
x.defaultNumberOfKids = 0;
/** y : Signal Int
The current y-coordinate of the mouse.
**/
var y = Elm.Signal.lift(function(p){return p[2];})(position);
y.defaultNumberOfKids = 0;
/*[Button Status]*/
/** isDown : Signal Bool
The current state of the left mouse-button.
True when the button is down, and false otherwise.
**/
var isDown = Elm.Signal.constant(false);
/** isClicked : Signal Bool
True immediately after the left mouse-button has been clicked,
and false otherwise.
**/
var isClicked = Elm.Signal.constant(false);
/** clicks : Signal ()
Always equal to unit. Event triggers on every mouse click.
**/
var clicks = Elm.Signal.constant(Value.Tuple());
function getXY(e) {
var posx = 0;
var posy = 0;
if (!e) e = window.event;
if (e.pageX || e.pageY) {
posx = e.pageX;
posy = e.pageY;
} else if (e.clientX || e.clientY) {
posx = e.clientX + document.body.scrollLeft +
document.documentElement.scrollLeft;
posy = e.clientY + document.body.scrollTop +
document.documentElement.scrollTop;
}
return Value.Tuple(posx, posy);
}
Value.addListener(document, 'click', function(e) {
var hasListener1 = Dispatcher.notify(isClicked.id, true);
var hasListener2 = Dispatcher.notify(clicks.id, Value.Tuple());
Dispatcher.notify(isClicked.id, false);
if (!hasListener1 && !hasListener2)
this.removeEventListener('click',arguments.callee,false);
});
Value.addListener(document, 'mousedown', function(e) {
var hasListener = Dispatcher.notify(isDown.id, true);
if (!hasListener)
this.removeEventListener('mousedown',arguments.callee,false);
});
Value.addListener(document, 'mouseup', function(e) {
var hasListener = Dispatcher.notify(isDown.id, false);
if (!hasListener)
this.removeEventListener('mouseup',arguments.callee,false);
});
Value.addListener(document, 'mousemove', function(e) {
var hasListener = Dispatcher.notify(position.id, getXY(e));
if (!hasListener)
this.removeEventListener('mousemove',arguments.callee,false);
});
/** isClickedOn : Element -> (Element, Signal Bool)
Determine whether an element has been clicked. The resulting pair
is a signal of booleans that is true when its paired element has
been clicked. The signal is True immediately after the left
mouse-button has been clicked, and false otherwise.
**/
var clickedOn = function(elem) {
var node = Render.render(elem);
var click = Elm.Signal.constant(false);
Value.addListener(node, 'click', function(e) {
Dispatcher.notify(click.id, true);
Dispatcher.notify(click.id, false);
});
return Value.Tuple(Value.wrap(node), click);
};
return {position: position,
x:x,
y:y,
isClicked: isClicked,
isDown: isDown,
clicks: clicks,
isClickedOn: clickedOn
};
}();

29
core-js/Signal/Random.js
View file

@ -1,29 +0,0 @@
/*! Random
!*/
Elm.Random = function() {
/*[In a Range]*/
/** inRange : Int -> Int -> Signal Int
Given a range from low to high, this produces a random number
between 'low' and 'high' inclusive. The value in the signal does
not change after the page has loaded.
**/
var inRange = function(min) { return function(max) {
return Elm.Signal.constant(Math.floor(Math.random() * (max-min+1)) + min);
};
};
/** randomize : Int -> Int -> Signal a -> Signal Int
Given a range from low to high and a signal of values, this produces
a new signal that changes whenever the input signal changes. The new
values are random number between 'low' and 'high' inclusive.
**/
var randomize = function(min) { return function(max) { return function(signal) {
function f(x) { return Math.floor(Math.random() * (max-min+1)) + min; }
return Elm.Signal.lift(f)(signal);
};
};
};
return { inRange:inRange, randomize:randomize };
}();

112
core-js/Signal/Time.js
View file

@ -1,112 +0,0 @@
/*! Time
Library for working with time. Type `Time` represents some number of
milliseconds.
!*/
Elm.Time = function() {
/*[Times]*/
/** hour, minute, second, ms : Time
Units of time, making it easier to specify things like a
half-second `(second / 2)`.
**/
function timeNow() { return (new window.Date).getTime(); }
/*[Tickers]*/
/** fps : Number -> Signal Time
Takes desired number of frames per second (fps). The resulting signal
gives a sequence of time deltas as quickly as possible until it reaches
the desired FPS. A time delta is the time between the last frame and the
current frame.
**/
/** fpsWhen : Number -> Signal Bool -> Signal Time
Same as the fps function, but you can turn it on and off. Allows you
to do brief animations based on user input without major ineffeciencies.
The first time delta after a pause is always zero, no matter how long
the pause was. This way summing the deltas will actually give the amount
of time that the output signal has been running.
**/
function fpsWhen(desiredFPS) { return function (isOn) {
var msPerFrame = 1000 / desiredFPS;
var prev = timeNow(), curr = prev, diff = 0, wasOn = true;
var ticker = Elm.Signal.constant(diff);
function tick(zero) { return function() {
curr = timeNow();
diff = zero ? 0 : curr - prev;
prev = curr;
Dispatcher.notify(ticker.id, diff);
};
}
var timeoutID = 0;
function f(isOn) { return function(t) {
if (isOn) {
timeoutID = setTimeout(tick(!wasOn && isOn), msPerFrame);
} else if (wasOn) {
clearTimeout(timeoutID);
}
wasOn = isOn;
return t;
};
}
return Elm.Signal.lift2(f)(isOn)(ticker);
};
}
/** every : Time -> Signal Time
Takes a time interval t. The resulting signal is the current time,
updated every t.
**/
function everyWhen(isOn) { return function(t) {
var clock = Elm.Signal.constant(timeNow());
function tellTime() { Dispatcher.notify(clock.id, timeNow()); }
setInterval(tellTime, t);
return clock;
};
}
function since(t) { return function(s) {
function cmp(a) { return function(b) { return !Value.eq(a,b); }; }
var dcount = Elm.Signal.count(Elm.Signal.delay(t)(s));
return Elm.Signal.lift2(cmp)(Elm.Signal.count(s))(dcount);
};
}
function after(t) {
t *= 1000;
var thread = Elm.Signal.constant(false);
setTimeout(function() { Dispatcher.notify(thread.id, true); }, t);
return thread;
}
function before(t) {
t *= 1000;
var thread = Elm.Signal.constant(true);
setTimeout(function() { Dispatcher.notify(thread.id, false); }, t);
return thread;
}
function read(s) {
var t = window.Date.parse(s);
return isNaN(t) ? ["Nothing"] : ["Just",t];
}
return {fpsWhen : fpsWhen,
fps : function(t) { return fpsWhen(t)(Elm.Signal.constant(true)); },
every : everyWhen(Elm.Signal.constant(true)),
delay : Elm.Signal.delay,
since : since,
after : after,
before : before,
hour : 3600000,
minute : 60000,
second : 1000,
ms : 1,
inHours : function(t) { return t / 3600000; },
inMinutes : function(t) { return t / 60000; },
inSeconds : function(t) { return t / 1000; },
inMss : function(t) { return t; },
toDate : function(t) { return new window.Date(t); },
read : read
};
}();

109
core-js/Signal/Touch.js
View file

@ -1,109 +0,0 @@
/*! Touch
This is an early version of the touch library. It will likely grow to
include gestures that would be useful for both games and web-pages.
!*/
Elm.Touch = function() {
function Dict() {
this.keys = [];
this.values = [];
this.insert = function(key,value) {
this.keys.push(key);
this.values.push(value);
};
this.lookup = function(key) {
var i = this.keys.indexOf(key)
return i >= 0 ? this.values[i] : {x:0,y:0,t:0};
};
this.remove = function(key) {
var i = this.keys.indexOf(key);
if (i < 0) return;
var t = this.values[i];
this.keys.splice(i,1);
this.values.splice(i,1);
return t;
};
}
var root = Elm.Signal.constant([]),
tapTime = 500,
hasTap = false,
tap = {_:[true],x:[0],y:[0]},
dict = new Dict();
function touch(t) {
var r = dict.lookup(t.identifier);
return {_ : [true], id: [t.identifier],
x: [t.pageX], y: [t.pageY],
x0: [r.x], y0: [r.y],
t0: [r.t] };
}
function start(e) {
dict.insert(e.identifier,{x:e.pageX,y:e.pageY,t:Date.now()});
}
function end(e) {
var t = dict.remove(e.identifier);
if (Date.now() - t.t < tapTime) {
hasTap = true;
tap = {_:[true], x:[t.x], y:[t.y]};
}
}
function listen(name, f) {
function update(e) {
for (var i = e.changedTouches.length; i--; ) { f(e.changedTouches[i]); }
var ts = new Array(e.touches.length);
for (var i = e.touches.length; i--; ) { ts[i] = touch(e.touches[i]); }
var hasListener = Dispatcher.notify(root.id, ts);
if (!hasListener) return document.removeEventListener(name, update);
e.preventDefault();
}
Value.addListener(document, name, update);
}
listen("touchstart", start);
listen("touchmove", function(_){});
listen("touchend", end);
listen("touchcancel", end);
listen("touchleave", end);
function dependency(f) {
var sig = Elm.Signal.lift(f)(root);
root.defaultNumberOfKids += 1;
sig.defaultNumberOfKids = 0;
return sig;
}
/*[Touches]*/
/** touches : Signal [{ x:Int, y:Int, id:Int, x0:Int, y0:Int, t0:Time }]
A list of touches. Each ongoing touch is represented by a set of
coordinates and an identifier id that allows you to distinguish
between different touches. Each touch also contains the coordinates and
time of the initial contact (x0, y0, and t0) which helps compute more
complicated gestures.
**/
var touches = dependency(function(ts) {
return Elm.JavaScript.castJSArrayToList(ts);
});
/*[Gestures]*/
/** taps : Signal { x:Int, y:Int }
The last position that was tapped. Default value is `{x=0,y=0}`.
Updates whenever the user taps the screen.
**/
var taps = function() {
var sig = dependency(function(_) { return tap; });
sig.defaultNumberOfKids = 1;
function pred(_) { var b = hasTap; hasTap = false; return b; }
var sig2 = Elm.Signal.keepIf(pred)({_:[true],x:[0],y:[0]})(sig);
sig2.defaultNumberOfKids = 0;
return sig2;
}();
return { touches: touches, taps: taps };
}();

41
core-js/Signal/WebSocket.js
View file

@ -1,41 +0,0 @@
/*! WebSocket
A library for low latency HTTP communication. See the HTTP library for standard
requests like GET, POST, etc.
!*/
Elm.WebSocket = function() {
var JS = Elm.JavaScript;
/** open : String -> Signal String -> Signal String
Create a web-socket. The first argument is the URL of the desired
web-socket server. The input signal holds the outgoing messages,
and the resulting signal contains the incoming ones.
**/
function open(url) { return function(outgoing) {
var incoming = Elm.Signal.constant(["Nil"]);
var ws = new window.WebSocket(JS.castStringToJSString(url));
var pending = [];
var ready = false;
ws.onopen = function(e) {
var len = pending.length;
for (var i = 0; i < len; ++i) { ws.send(pending[i]); }
ready = true;
};
ws.onmessage = function(event) {
Dispatcher.notify(incoming.id, JS.castJSStringToString(event.data));
};
function send(msg) {
var s = JS.castStringToJSString(msg);
ready ? ws.send(s) : pending.push(s);
}
function take1(x) { return function(y) { return x; } }
return Elm.Signal.lift2(take1)(incoming)(Elm.Signal.lift(send)(outgoing));
};
}
return {open:open};
}();

35
core-js/Signal/Window.js
View file

@ -1,35 +0,0 @@
/*! Window !*/
Elm.Window = function() {
/*[Dimensions]*/
/** dimensions : Signal (Int,Int)
The current dimensions of the window (i.e. the area viewable to the
user, not including scroll bars).
**/
var dimensions = Elm.Signal.constant(Value.Tuple(window.innerWidth,
window.innerHeight));
dimensions.defaultNumberOfKids = 2;
/** width : Signal Int
The current width of the window.
**/
var width = Elm.Signal.lift(function(p){return p[1];})(dimensions);
width.defaultNumberOfKids = 0;
/** height : Signal Int
The current height of the window.
**/
var height = Elm.Signal.lift(function(p){return p[2];})(dimensions);
height.defaultNumberOfKids = 0;
Value.addListener(window, 'resize', function(e) {
var w = document.getElementById('widthChecker').offsetWidth;
var hasListener = Dispatcher.notify(dimensions.id,
Value.Tuple(w, window.innerHeight));
if (!hasListener)
this.removeEventListener('resize',arguments.callee,false);
});
return {dimensions:dimensions,width:width,height:height};
}();

Some files were not shown because too many files have changed in this diff Show more