476e87f · elk · git.iko.soy

.gitignore+1

@@ -7,5 +7,6 @@ cabal-dev

77*.aes

88*.elmi

99*.elmo

10+data

1011*/ElmFiles/*

1112.DS_Store

Elm.cabal+4−4

@@ -1,5 +1,5 @@

11Name: Elm

2−Version: 0.8.0.3

2+Version: 0.9.0.2

33Synopsis: The Elm language module.

44Description: Elm aims to make client-side web-development more pleasant.

55 It is a statically/strongly typed, functional reactive

@@ -21,7 +21,7 @@ Category: Compiler, Language

2121Build-type: Custom

2222

2323Extra-source-files: changelog.txt

24−Data-dir: dist/data

24+Data-dir: data

2525Data-files: elm-runtime.js interfaces.data

2626Cabal-version: >=1.9

2727

@@ -167,5 +167,5 @@ Executable elm

167167Test-Suite test-elm

168168 Type: exitcode-stdio-1.0

169169 Hs-Source-Dirs: tests

170− Main-is: Everything.hs

171− build-depends: base

170+ Main-is: Main.hs

171+ build-depends: base, directory, HTF

README.md−8

@@ -3,14 +3,6 @@ Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/)

33

44## Install

55

6−#### On Mac OSX

7−

8−Use [the installer](https://dl.dropboxusercontent.com/u/5850974/Elm/Elm.pkg) and you are done.

9−Let us know on [the list](https://groups.google.com/forum/?fromgroups#!forum/elm-discuss)

10−if you have any trouble.

11−

12−#### On any platform

13−

146Download the [Haskell Platform 2012.2.0.0](http://hackage.haskell.org/platform/).

157Elm definitely works with GHC 7.4, so newer versions of the Haskell Platform may work too.

168Once the Haskell Platform is installed:

Setup.hs+19−10

@@ -11,6 +11,7 @@ import System.Process

1111

1212import Control.Monad

1313import qualified Data.Binary as Binary

14+import qualified Data.ByteString.Lazy as BS

1415

1516-- Part 1

1617-- ------

@@ -32,10 +33,10 @@ import qualified Data.Binary as Binary

3233-- Elm.cabal expects the generated files to end up in dist/data

3334-- git won't look in dist + cabal will clean it

3435rtsDir :: LocalBuildInfo -> FilePath

35−rtsDir lbi = buildDir lbi </> ".." </> "data"

36+rtsDir lbi = "data"

3637

3738tempDir :: LocalBuildInfo -> FilePath

38−tempDir lbi = buildDir lbi </> ".." </> "temp"

39+tempDir lbi = "temp"

3940

4041-- The runtime is called:

4142rts :: LocalBuildInfo -> FilePath

@@ -95,24 +96,25 @@ myPostBuild as bfs pd lbi = do

9596 buildInterfaces lbi elmis

9697 putStrLn "Custom build step: build elm-runtime.js"

9798 buildRuntime lbi elmos

98− removeDirectoryRecursive ("dist" </> "temp")

99+ removeDirectoryRecursive (tempDir lbi)

99100 postBuild simpleUserHooks as bfs pd lbi

100101

101102

102103compileLibraries lbi = do

103− let temp = tempDir lbi -- dist/temp

104− rts = rtsDir lbi -- dist/data

104+ let temp = tempDir lbi -- temp

105+ rts = rtsDir lbi -- data

105106 createDirectoryIfMissing True temp

106107 createDirectoryIfMissing True rts

107− out_c <- canonicalizePath temp -- dist/temp (root folder)

108+ out_c <- canonicalizePath temp -- temp (root folder)

108109 elm_c <- canonicalizePath (elm lbi) -- dist/build/elm/elm

109− rtd_c <- canonicalizePath rts -- dist/data (for docs.json)

110+ rtd_c <- canonicalizePath rts -- data

110111

111112 let make file = do

112113 -- replace 'system' call with 'runProcess' which handles args better

113114 -- and allows env variable "Elm_datadir" which is used by LoadLibraries

114115 -- to find docs.json

115− let args = ["--only-js","--make","--no-prelude","--output-directory="++out_c,file]

116+ let args = [ "--only-js", "--make", "--no-prelude"

117+ , "--cache-dir="++out_c, "--build-dir="++out_c, file ]

116118 arg = Just [("Elm_datadir", rtd_c)]

117119 handle <- runProcess elm_c args Nothing arg Nothing Nothing Nothing

118120 exitCode <- waitForProcess handle

@@ -130,8 +132,15 @@ buildInterfaces :: LocalBuildInfo -> [FilePath] -> IO ()

130132buildInterfaces lbi elmis = do

131133 createDirectoryIfMissing True (rtsDir lbi)

132134 let ifaces = interfaces lbi

133− Binary.encodeFile ifaces (length elmis)

134− mapM_ (\elmi -> readFile elmi >>= appendFile ifaces) elmis

135+ ifaceHandle <- openBinaryFile ifaces WriteMode

136+ BS.hPut ifaceHandle (Binary.encode (length elmis))

137+ let append file = do

138+ handle <- openBinaryFile file ReadMode

139+ bits <- hGetContents handle

140+ length bits `seq` hPutStr ifaceHandle bits

141+ hClose handle

142+ mapM_ append elmis

143+ hClose ifaceHandle

135144

136145buildRuntime :: LocalBuildInfo -> [FilePath] -> IO ()

137146buildRuntime lbi elmos = do

changelog.txt+13−2

@@ -6,7 +6,11 @@ Build Improvements:

66 * Major speed improvements to type-checker

77 * Type-checker should catch _all_ type errors now

88 * Module-level compilation, only re-compile if necessary

9− * Import type aliases between modules

9+ * Import types and type aliases between modules

10+ * Intermediate files are generated to avoid unneeded recompilation

11+ and shorten compile time. These files go in ElmFiles/ by default

12+ * Generated files are placed in ElmFiles/ by default, replicating

13+ the directory structure of your source code.

1014

1115Error Messages:

1216 * Cross-module type errors

@@ -22,14 +26,21 @@ Syntax:

2226 * Record Constructors

2327 * Record type aliases can be closed on the zeroth column

2428 * (,,) syntax in types

25− * "(+) = " is permitted

29+ * Allow infix op definitions without args: (*) = add

2630 * Unparenthesized if, let, case, lambda at end of binary expressions

2731

32+elm-server:

33+ * Build multi-module projects

34+ * Report all errors in browser

35+

2836Libraries:

2937 * Detect hovering over any Element

3038 * Set alpha of arbitrary forms in collages

3139 * Switch Text.height to use px instead of em

3240

41+Bug Fixes:

42+ * Many bug fixes for collage, especially when rendering Elements.

43+

3344Website:

3445 * Hot-swapping

3546 * Much faster page load with pre-compiled Elm files (Max New)

compiler/Compiler.hs+50−32

@@ -10,16 +10,19 @@ import System.Console.CmdArgs hiding (program)

1010import System.Directory

1111import System.Exit

1212import System.FilePath

13+import System.IO

1314import GHC.Conc

1415

1516import qualified Text.Blaze.Html.Renderer.Pretty as Pretty

1617import qualified Text.Blaze.Html.Renderer.String as Normal

1718import qualified Text.Jasmine as JS

1819import qualified Data.ByteString.Lazy.Char8 as BS

20+import qualified Data.ByteString.Lazy as L

1921

2022import qualified Metadata.Prelude as Prelude

2123import qualified Transform.Canonicalize as Canonical

2224import SourceSyntax.Module

25+import Parse.Module (getModuleName)

2326import Initialize (buildFromSource, getSortedDependencies)

2427import Generate.JavaScript (jsModule)

2528import Generate.Html (createHtml, JSStyle(..), JSSource(..))

@@ -40,7 +43,8 @@ data Flags =

4043 , scripts :: [FilePath]

4144 , no_prelude :: Bool

4245 , minify :: Bool

43− , output_directory :: FilePath

46+ , cache_dir :: FilePath

47+ , build_dir :: FilePath

4448 }

4549 deriving (Data,Typeable,Show,Eq)

4650

@@ -62,8 +66,10 @@ flags = Flags

6266 &= help "Do not import Prelude by default, used only when compiling standard libraries."

6367 , minify = False

6468 &= help "Minify generated JavaScript and HTML"

65− , output_directory = "ElmFiles" &= typFile

66− &= help "Output files to directory specified. Defaults to ElmFiles/ directory."

69+ , cache_dir = "cache" &= typFile

70+ &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."

71+ , build_dir = "build" &= typFile

72+ &= help "Directory for generated HTML and JS files. Defaults to build/ directory."

6773 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."

6874 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")

6975

@@ -78,25 +84,32 @@ compileArgs flags =

7884 fs -> mapM_ (build flags) fs

7985

8086

81−file :: Flags -> FilePath -> String -> FilePath

82−file flags filePath ext = output_directory flags </> replaceExtension filePath ext

87+buildPath :: Flags -> FilePath -> String -> FilePath

88+buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext

89+

90+cachePath :: Flags -> FilePath -> String -> FilePath

91+cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext

8392

8493elmo :: Flags -> FilePath -> FilePath

85−elmo flags filePath = file flags filePath "elmo"

94+elmo flags filePath = cachePath flags filePath "elmo"

8695

8796elmi :: Flags -> FilePath -> FilePath

88−elmi flags filePath = file flags filePath "elmi"

97+elmi flags filePath = cachePath flags filePath "elmi"

8998

9099

91−buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface

100+buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)

92101buildFile flags moduleNum numModules interfaces filePath =

93102 do compiled <- alreadyCompiled

94− if not compiled then compile

95− else getInterface `fmap` Binary.decodeFile (elmi flags filePath)

103+ case compiled of

104+ False -> compile

105+ True -> do

106+ handle <- openBinaryFile (elmi flags filePath) ReadMode

107+ bits <- L.hGetContents handle

108+ let info :: (String, ModuleInterface)

109+ info = Binary.decode bits

110+ L.length bits `seq` hClose handle

111+ return info

96112 where

97− getInterface :: (String, ModuleInterface) -> ModuleInterface

98− getInterface = snd

99−

100113 alreadyCompiled :: IO Bool

101114 alreadyCompiled = do

102115 existsi <- doesFileExist (elmi flags filePath)

@@ -110,16 +123,18 @@ buildFile flags moduleNum numModules interfaces filePath =

110123 number :: String

111124 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"

112125

113− name :: String

114− name = List.intercalate "." (splitDirectories (dropExtensions filePath))

115−

116− compile :: IO ModuleInterface

126+ compile :: IO (String,ModuleInterface)

117127 compile = do

128+ source <- readFile filePath

129+ let name = case getModuleName source of

130+ Just n -> n

131+ Nothing -> "Main"

118132 putStrLn $ concat [ number, " Compiling ", name

119133 , replicate (max 1 (20 - length name)) ' '

120134 , "( " ++ filePath ++ " )" ]

121− source <- readFile filePath

122− createDirectoryIfMissing True (output_directory flags)

135+

136+ createDirectoryIfMissing True (cache_dir flags)

137+ createDirectoryIfMissing True (build_dir flags)

123138 metaModule <-

124139 case buildFromSource (no_prelude flags) interfaces source of

125140 Left errors -> do

@@ -139,9 +154,11 @@ buildFile flags moduleNum numModules interfaces filePath =

139154 iAliases = aliases metaModule

140155 }

141156 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

142− Binary.encodeFile (elmi flags filePath) (name,interface)

157+ handle <- openBinaryFile (elmi flags filePath) WriteMode

158+ L.hPut handle (Binary.encode (name,interface))

159+ hClose handle

143160 writeFile (elmo flags filePath) (jsModule metaModule)

144− return interface

161+ return (name,interface)

145162

146163printTypes metaModule = do

147164 putStrLn ""

@@ -161,18 +178,20 @@ build flags rootFile = do

161178 let noPrelude = no_prelude flags

162179 files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]

163180 let ifaces = if noPrelude then Map.empty else Prelude.interfaces

164− interfaces <- buildFiles flags (length files) ifaces files

181+ (moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files

165182 js <- foldM appendToOutput "" files

166183 case only_js flags of

167184 True -> do

168185 putStr "Generating JavaScript ... "

169− writeFile (file flags rootFile "js") (genJs js)

186+ writeFile (buildPath flags rootFile "js") (genJs js)

170187 putStrLn "Done"

171188 False -> do

172189 putStr "Generating HTML ... "

173190 runtime <- getRuntime flags

174− let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) ""

175− writeFile (file flags rootFile "html") html

191+ let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) moduleName ""

192+ htmlFile = buildPath flags rootFile "html"

193+ createDirectoryIfMissing True (takeDirectory htmlFile)

194+ writeFile htmlFile html

176195 putStrLn "Done"

177196

178197 where

@@ -187,10 +206,9 @@ build flags rootFile = do

187206 [ Source (if minify flags then Minified else Readable) js ]

188207

189208

190−buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces

191−buildFiles _ _ interfaces [] = return interfaces

192−buildFiles flags numModules interfaces (filePath:rest) = do

193− interface <- buildFile flags (numModules - length rest) numModules interfaces filePath

194− let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath

195− interfaces' = Map.insert moduleName interface interfaces

196− buildFiles flags numModules interfaces' rest

209+buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)

210+buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)

211+buildFiles flags numModules interfaces _ (filePath:rest) = do

212+ (name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath

213+ let interfaces' = Map.insert name interface interfaces

214+ buildFiles flags numModules interfaces' name rest

compiler/Generate/Html.hs+5−21

@@ -40,27 +40,10 @@ generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browse

4040 -> String -- ^ The page title

4141 -> String -- ^ The elm source code.

4242 -> H.Html

43−generateHtml libLoc title source = H.span "broken for now"

44−{--

45− case buildFromSource True source of

46− Right modul -> createHtml libLoc title [] "" title [modul]

47− Left err -> createHtml Readable libLoc title (Right $ showErr err)

48− (H.noscript "") "Main"

49−--}

50−{--

51−modulesToHtml :: FilePath -> String -> []

52−modulesToHtml libLoc title scripts nscrpt modules =

53− createHtml jsStyle libLoc title' js noscript altTitle

54− where

55− js = Right $ jss ++ concatMap jsModule modules

56− noscript = if nscrpt then extractNoscript $ last modules else ""

57− title' = if null title then altTitle else title

58− altTitle = intercalate "." names

59− where Module names _ _ _ = last modules

60−--}

43+generateHtml libLoc title source = error "function 'generateHtml' is unimplemented for now"

6144

62−createHtml :: FilePath -> String -> [JSSource] -> String -> H.Html

63−createHtml libLoc title scripts noscript =

45+createHtml :: FilePath -> String -> [JSSource] -> String -> String -> H.Html

46+createHtml libLoc title scripts moduleName noscript =

6447 H.docTypeHtml $ do

6548 H.head $ do

6649 H.meta ! A.charset "UTF-8"

@@ -68,5 +51,6 @@ createHtml libLoc title scripts noscript =

6851 makeScript (Link libLoc)

6952 mapM_ makeScript scripts

7053 H.body $ do

71− H.script ! A.type_ "text/javascript" $ preEscapedToMarkup ("Elm.fullscreen(Elm.Main)" :: String)

54+ H.script ! A.type_ "text/javascript" $

55+ preEscapedToMarkup ("Elm.fullscreen(Elm." ++ moduleName ++ ")")

7256 H.noscript $ preEscapedToMarkup noscript

compiler/Generate/JavaScript.hs+26−33

@@ -1,4 +1,4 @@

1−module Generate.JavaScript (showErr, jsModule) where

1+module Generate.JavaScript (jsModule) where

22

33import Control.Arrow (first,second)

44import Control.Monad (liftM,(<=<),join,ap)

@@ -15,15 +15,6 @@ import SourceSyntax.Everything

1515import SourceSyntax.Location

1616import qualified Transform.SortDefinitions as SD

1717

18−deprime :: String -> String

19−deprime = map (\c -> if c == '\'' then '$' else c)

20−

21−showErr :: String -> String

22−showErr err = globalAssign "Elm.Main" (jsFunc "elm" body)

23− where msg = show . concatMap (++"<br>") . lines $ err

24− body = "var T = Elm.Text(elm);\n\

25− \return { main : T.text(T.monospace(" ++ msg ++ ")) };"

26−

2718indent = concatMap f

2819 where f '\n' = "\n "

2920 f c = [c]

@@ -84,7 +75,7 @@ jsModule modul =

8475 jsExports = setup ("elm" : names modul) ++

8576 ret (assign' ("elm." ++ modName) (brackets exs))

8677 where

87− exs = indent . commaSep . concatMap (pair . deprime) $ "_op" : exports modul

78+ exs = indent . commaSep . concatMap pair $ "_op" : exports modul

8879 pair x | isOp x = []

8980 | otherwise = ["\n" ++ x ++ " : " ++ x]

9081

@@ -129,14 +120,13 @@ instance ToJS (Def t v) where

129120 -- TODO: Make this handle patterns besides plain variables

130121 toJS (Def (PVar x) e)

131122 | isOp x = globalAssign ("_op['" ++ x ++ "']") `liftM` toJS' e

132− | otherwise = assign (deprime x) `liftM` toJS' e

123+ | otherwise = assign x `liftM` toJS' e

133124

134125 toJS (Def pattern e@(L s _)) =

135126 do n <- guid

136127 let x = "_" ++ show n

137128 var = L s . Var

138− toDef y' = let y = deprime y' in

139− Def (PVar y) (L s $ Case (var x) [(pattern, var y)])

129+ toDef y = Def (PVar y) (L s $ Case (var x) [(pattern, var y)])

140130 stmt <- assign x `liftM` toJS' e

141131 vars <- toJS . map toDef . Set.toList $ SD.boundVars pattern

142132 return (stmt ++ vars)

@@ -154,18 +144,18 @@ toJS' (L span expr) =

154144 Case e cases -> caseToJS span e cases

155145 _ -> toJS expr

156146

157−remove x e = "_N.remove('" ++ deprime x ++ "', " ++ e ++ ")"

158−addField x v e = "_N.insert('" ++ deprime x ++ "', " ++ v ++ ", " ++ e ++ ")"

147+remove x e = "_N.remove('" ++ x ++ "', " ++ e ++ ")"

148+addField x v e = "_N.insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"

159149setField fs e = "_N.replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"

160− where f (x,v) = "['" ++ deprime x ++ "'," ++ v ++ "]"

161−access x e = e ++ "." ++ deprime x

150+ where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"

151+access x e = e ++ "." ++ x

162152makeRecord kvs = record `liftM` collect kvs

163153 where

164154 combine r (k,v) = Map.insertWith (++) k v r

165155 collect = liftM (List.foldl' combine Map.empty) . mapM prep

166156 prep (k, e) =

167157 do v <- toJS' e

168− return (deprime k, [v])

158+ return (k, [v])

169159 fields fs =

170160 brackets ("\n "++List.intercalate ",\n " (map (\(k,v) -> k++":"++v) fs))

171161 hidden = fields . map (second jsList) .

@@ -186,7 +176,7 @@ instance ToJS Literal where

186176instance ToJS (Expr t v) where

187177 toJS expr =

188178 case expr of

189− Var x -> return (deprime x)

179+ Var x -> return x

190180 Literal lit -> toJS lit

191181 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi

192182 Access e x -> access x `liftM` toJS' e

@@ -197,16 +187,19 @@ instance ToJS (Expr t v) where

197187 Record fs -> makeRecord fs

198188 Binop op e1 e2 -> binop op e1 e2

199189

200− Lambda p e@(L s _) -> liftM (fastFunc . ret) (toJS' body)

190+ Lambda p e@(L s _) -> liftM fastFunc (toJS' body)

201191 where

202192 fastFunc body

203− | length args < 2 || length args > 9 = foldr jsFunc body args

204− | otherwise = "F" ++ show (length args) ++ parens (jsFunc (commaSep args) body)

193+ | length args < 2 || length args > 9 =

194+ foldr (\arg bod -> jsFunc arg (ret bod)) body args

195+ | otherwise =

196+ "F" ++ show (length args) ++ parens (jsFunc (commaSep args) (ret body))

197+

205198 (args, body) = first reverse $ foldr depattern ([], innerBody) (zip patterns [1..])

206199

207200 depattern (pattern,n) (args, body) =

208201 case pattern of

209− PVar x -> (deprime x : args, body)

202+ PVar x -> (x : args, body)

210203 _ -> let arg = "arg" ++ show n

211204 in (arg:args, L s (Case (L s (Var arg)) [(pattern, body)]))

212205

@@ -274,7 +267,7 @@ caseToJS span e ps = do

274267 (tempVar,match) <- caseToMatch ps

275268 e' <- toJS' e

276269 let (match',stmt) = case e of

277− L _ (Var x) -> (matchSubst [(tempVar,deprime x)] match, "")

270+ L _ (Var x) -> (matchSubst [(tempVar,x)] match, "")

278271 _ -> (match, assign tempVar e')

279272 matches <- matchToJS span match'

280273 return $ jsFunc "" (stmt ++ matches) ++ "()"

@@ -304,14 +297,14 @@ matchToJS span match =

304297clauseToJS span var (Clause value vars e) = do

305298 let vars' = map (\n -> var ++ "._" ++ show n) [0..]

306299 s <- matchToJS span $ matchSubst (zip vars vars') e

307− return $ concat [ "\ncase ", case value of

308− Right (Boolean True) -> "true"

309− Right (Boolean False) -> "false"

310− Right lit -> show lit

311− Left name -> quoted $ case List.elemIndices '.' name of

312− [] -> name

313− is -> drop (last is + 1) name

314− , ":", indent s ]

300+ pattern <- case value of

301+ Right (Boolean True) -> return "true"

302+ Right (Boolean False) -> return "false"

303+ Right lit -> toJS lit

304+ Left name -> return . quoted $ case List.elemIndices '.' name of

305+ [] -> name

306+ is -> drop (last is + 1) name

307+ return $ concat [ "\ncase ", pattern, ":", indent s ]

315308

316309jsNil = "_L.Nil"

317310jsCons e1 e2 = "_L.Cons(" ++ e1 ++ "," ++ e2 ++ ")"

compiler/Language/Elm.hs+4−17

@@ -1,27 +1,21 @@

1−{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}

21{- | This module exports the functions necessary for compiling Elm code into the

32 respective HTML, CSS, and JS code.

43

54 The documentation for the Elm language is available at

65 <http://elm-lang.org/Documentation.elm>, and many interactive examples are

76 available at <http://elm-lang.org/Examples.elm>

8−

9− Example implementations using Yesod and Happstack are available

10− at <https://github.com/tazjin/Elm/tree/master/Examples>

117-}

12−module Language.Elm (compile, toHtml, moduleName, runtime, docs) where

8+module Language.Elm (compile, moduleName, runtime) where

139

1410import qualified Data.List as List

1511import qualified Data.Map as Map

1612import Data.Version (showVersion)

17−import Generate.JavaScript (showErr, jsModule)

13+import Generate.JavaScript (jsModule)

1814import Generate.Html (generateHtml)

1915import Initialize (buildFromSource)

20−import Parse.Helpers

21−import Parse.Module (moduleDef)

16+import Parse.Module (getModuleName)

2217import SourceSyntax.Module

2318import Text.Blaze.Html (Html)

24−import Text.Parsec (option,optional)

2519import qualified Text.PrettyPrint as P

2620import qualified Metadata.Prelude as Prelude

2721import Paths_Elm

@@ -36,14 +30,7 @@ compile source =

3630

3731-- |This function extracts the module name of a given source program.

3832moduleName :: String -> Maybe String

39−moduleName source = case iParse getModuleName "" source of

40− Right name -> Just name

41− Left _ -> Nothing

42− where

43− getModuleName = do

44− optional freshLine

45− (names, _) <- moduleDef

46− return (List.intercalate "." names)

33+moduleName = getModuleName

4734

4835-- |This function compiles Elm code into a full HTML page.

4936toHtml :: String -- ^ Location of elm-min.js as expected by the browser

compiler/Metadata/Prelude.hs+10−2

@@ -6,9 +6,11 @@ import qualified Paths_Elm as Path

66import System.Directory

77import System.Exit

88import System.FilePath

9+import System.IO

910import System.IO.Unsafe (unsafePerformIO)

1011import SourceSyntax.Module

1112import qualified Data.Binary as Binary

13+import qualified Data.ByteString.Lazy as BS

1214

1315

1416add :: Module t v -> Module t v

@@ -47,5 +49,11 @@ safeReadDocs name =

4749readDocs :: FilePath -> IO Interfaces

4850readDocs name = do

4951 exists <- doesFileExist name

50− if exists then Map.fromList `fmap` Binary.decodeFile name

51− else ioError . userError $ "File Not Found"

52+ case exists of

53+ False -> ioError . userError $ "File Not Found"

54+ True -> do

55+ handle <- openBinaryFile name ReadMode

56+ bits <- BS.hGetContents handle

57+ let ifaces = Map.fromList (Binary.decode bits)

58+ BS.length bits `seq` hClose handle

59+ return ifaces

compiler/Parse/Binop.hs+8−6

@@ -80,25 +80,27 @@ splitLevel table n e eops =

8080joinL :: [LExpr t v] -> [String] -> IParser (LExpr t v)

8181joinL [e] [] = return e

8282joinL (a:b:es) (op:ops) = joinL (merge a b (Binop op a b) : es) ops

83−joinL _ _ = fail "Ill-formed binary expression. Report a compiler bug."

83+joinL _ _ = failure "Ill-formed binary expression. Report a compiler bug."

8484

8585joinR :: [LExpr t v] -> [String] -> IParser (LExpr t v)

8686joinR [e] [] = return e

8787joinR (a:b:es) (op:ops) = do e <- joinR (b:es) ops

8888 return (merge a e (Binop op a e))

89−joinR _ _ = fail "Ill-formed binary expression. Report a compiler bug."

89+joinR _ _ = failure "Ill-formed binary expression. Report a compiler bug."

9090

9191getAssoc :: OpTable -> Int -> [(String,LExpr t v)] -> IParser Assoc

9292getAssoc table n eops

9393 | all (==L) assocs = return L

9494 | all (==R) assocs = return R

9595 | all (==N) assocs = case assocs of [_] -> return N

96− _ -> fail msg

96+ _ -> failure (msg "precedence")

97+ | otherwise = failure (msg "associativity")

9798 where levelOps = filter (hasLevel table n) eops

9899 assocs = map (opAssoc table . fst) levelOps

99− msg = concat [ "Conflicting precedence for binary operators ("

100− , intercalate ", " (map fst eops), "). "

101− , "Consider adding parentheses to disambiguate." ]

100+ msg problem =

101+ concat [ "Conflicting " ++ problem ++ " for binary operators ("

102+ , intercalate ", " (map fst eops), "). "

103+ , "Consider adding parentheses to disambiguate." ]

102104

103105infixStmt :: IParser (Int, Assoc, String)

104106infixStmt =

compiler/Parse/Helpers.hs+18−6

@@ -49,10 +49,13 @@ rLabel = lowVar

4949innerVarChar :: IParser Char

5050innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""

5151

52+deprime :: String -> String

53+deprime = map (\c -> if c == '\'' then '$' else c)

54+

5255makeVar :: IParser Char -> IParser String

5356makeVar p = do v <- (:) <$> p <*> many innerVarChar

5457 guard (v `notElem` reserveds)

55− return v

58+ return (deprime v)

5659

5760reserved :: String -> IParser String

5861reserved word =

@@ -110,11 +113,20 @@ spaceSep1 p = (:) <$> p <*> spacePrefix p

110113spacePrefix p = constrainedSpacePrefix p (\_ -> return ())

111114

112115constrainedSpacePrefix p constraint =

113− many . try $ do

114− n <- whitespace

115− constraint n

116− indented

117− p

116+ many $ choice [ try (spacing >> lookAhead (oneOf "[({")) >> p

117+ , try (spacing >> p)

118+ ]

119+ where

120+ spacing = do

121+ n <- whitespace

122+ constraint n

123+ indented

124+

125+failure msg = do

126+ inp <- getInput

127+ setInput ('x':inp)

128+ anyToken

129+ fail msg

118130

119131followedBy a b = do x <- a ; b ; return x

120132

compiler/Parse/Literal.hs+17−5

@@ -19,13 +19,25 @@ num = fmap toLit (preNum <?> "number")

1919 string "."

2020 ('.':) <$> many1 digit

2121

22+chr :: IParser Literal

23+chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

24+ <?> "character"

25+

2226str :: IParser Literal

23−str = choice [ let quote = try (string "\"\"\"")

24− in quote >> Str <$> manyTill (backslashed <|> anyChar) quote

27+str = choice [ quote >> str <$> manyTill (backslashed <|> anyChar) quote

2528 , liftM Str . expecting "string" . betwixt '"' '"' . many $

2629 backslashed <|> satisfy (/='"')

2730 ]

31+ where

32+ quote = try (string "\"\"\"")

33+ str = Str . dewindows

2834

29−chr :: IParser Literal

30−chr = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

31− <?> "character"

35+ -- Remove \r from strings to fix generated JavaScript

36+ dewindows [] = []

37+ dewindows cs =

38+ let (pre, suf) = break (`elem` ['\r','\n']) cs

39+ in pre ++ case suf of

40+ ('\r':'\n':rest) -> '\n' : dewindows rest

41+ ('\n':rest) -> '\n' : dewindows rest

42+ ('\r':rest) -> '\n' : dewindows rest

43+ _ -> []

compiler/Parse/Module.hs+12−1

@@ -1,5 +1,5 @@

11

2−module Parse.Module (moduleDef, imports) where

2+module Parse.Module (moduleDef, getModuleName, imports) where

33

44import Control.Applicative ((<$>), (<*>))

55import Data.List (intercalate)

@@ -11,6 +11,17 @@ import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)

1111varList :: IParser [String]

1212varList = parens $ commaSep1 (var <|> parens symOp)

1313

14+getModuleName :: String -> Maybe String

15+getModuleName source =

16+ case iParse getModuleName "" source of

17+ Right name -> Just name

18+ Left _ -> Nothing

19+ where

20+ getModuleName = do

21+ optional freshLine

22+ (names, _) <- moduleDef

23+ return (intercalate "." names)

24+

1425moduleDef :: IParser ([String], [String])

1526moduleDef = do

1627 try (reserved "module")

compiler/Parse/Pattern.hs−68

@@ -64,71 +64,3 @@ expr :: IParser Pattern

6464expr = do

6565 patterns <- consSep1 (patternConstructor <|> term)

6666 asPattern (foldr1 Pattern.cons patterns) <?> "pattern"

67−

68−{--

69−extract :: Pattern -> LExpr t v -> Unique (String, LExpr t v)

70−extract pattern body@(L t s _) =

71− let loc = L t s in

72− let fn x e = (x,e) in

73− case pattern of

74− PAnything -> return $ fn "_" body

75− PVar x -> return $ fn x body

76− PAlias x PAnything -> return $ fn x body

77− PAlias x p -> do

78− (x', body') <- extract p body

79− return $ fn x (loc $ Let [FnDef x' [] (loc $ Var x)] body')

80− PData name ps -> do

81− x <- guid

82− let a = '_' : show x

83− return . fn a . loc $ Case (loc (Var a)) [(pattern, body)]

84− PRecord fs -> do

85− x <- guid

86− let a = '_' : show x

87− toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

88− return . fn a . loc $ Let (map toDef fs) body

89−

90−extracts :: [Pattern] -> LExpr t v -> Unique ([String], LExpr t v)

91−extracts ps body = go [] (reverse ps) body

92− where go args [] body = return (args, body)

93− go args (p:ps) body = do (x,e) <- extract p body

94− go (x:args) ps e

95−

96−flatten :: [Pattern] -> LExpr t v -> Unique (IParser [Def t v])

97−flatten patterns exp@(L t s _) =

98− let loc = L t s in

99− case patterns of

100− PVar f : args -> do

101− (as,e) <- extracts args exp

102− return . return $

103− if isOp (head f) then let [a,b] = as in [ OpDef f a b e ]

104− else [ FnDef f as e ]

105−

106− [p] -> return `liftM` matchSingle p exp p

107−

108− _ -> return . fail $ "Pattern (" ++ unwords (map show patterns) ++

109− ") cannot be used on the left-hand side of an assign statement."

110−

111−matchSingle :: Pattern -> LExpr t v -> Pattern -> Unique [Def t v]

112−matchSingle pat exp@(L t s _) p =

113− let loc = L t s in

114− case p of

115− PData _ ps -> do

116− x <- guid

117− let v = '_' : show x

118− dss <- mapM (matchSingle pat . loc $ Var v) ps

119− return (FnDef v [] exp : concat dss)

120−

121− PVar x ->

122− return [ FnDef x [] (loc $ Case exp [(pat, loc $ Var x)]) ]

123−

124− PAlias x p' -> do

125− subPat <- matchSingle p' (loc $ Var x) p'

126− return $ (FnDef x [] (loc $ Case exp [(pat, loc $ Var x)])):subPat

127−

128− PRecord fs -> do

129− a <- (\x -> '_' : show x) `liftM` guid

130− let toDef f = FnDef f [] (loc $ Access (loc $ Var a) f)

131− return (FnDef a [] exp : map toDef fs)

132−

133− PAnything -> return []

134−--}

compiler/Parse/Type.hs+1−1

@@ -64,7 +64,7 @@ expr :: IParser T.Type

6464expr =

6565 do t1 <- app <|> term

6666 whitespace

67− arr <- optionMaybe arrow

67+ arr <- optionMaybe (try arrow)

6868 whitespace

6969 case arr of

7070 Just _ -> T.Lambda t1 <$> expr

compiler/SourceSyntax/Expression.hs+6−6

@@ -75,24 +75,24 @@ instance Pretty (Expr t v) where

7575 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

7676 Data "[]" [] -> P.text "[]"

7777 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

78− Access e x -> prettyParens e <> P.text "." <> P.text x

79− Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)

78+ Access e x -> prettyParens e <> P.text "." <> variable x

79+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)

8080 Insert (Location.L _ (Remove e y)) x v ->

81− P.braces (pretty e <+> P.text "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

81+ P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)

8282 Insert e x v ->

83− P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)

83+ P.braces (pretty e <+> P.text "|" <+> variable x <+> P.text "=" <+> pretty v)

8484

8585 Modify e fs ->

8686 P.braces $ P.hang (pretty e <+> P.text "|")

8787 4

8888 (commaSep $ map field fs)

8989 where

90− field (x,e) = P.text x <+> P.text "<-" <+> pretty e

90+ field (x,e) = variable x <+> P.text "<-" <+> pretty e

9191

9292 Record fs ->

9393 P.braces $ P.nest 2 (commaSep $ map field fs)

9494 where

95− field (x,e) = P.text x <+> P.text "=" <+> pretty e

95+ field (x,e) = variable x <+> P.text "=" <+> pretty e

9696

9797 Markdown _ -> P.text "[markdown| ... |]"

9898

compiler/SourceSyntax/Location.hs+1−1

@@ -49,7 +49,7 @@ instance Show SrcSpan where

4949 Span start end _ ->

5050 case line start == line end of

5151 False -> "between lines " ++ show (line start) ++ " and " ++ show (line end)

52− True -> "line " ++ show (line end) ++ ", column " ++

52+ True -> "on line " ++ show (line end) ++ ", column " ++

5353 show (column start) ++ " to " ++ show (column end)

5454

5555instance Show e => Show (Located e) where

compiler/SourceSyntax/Pattern.hs+2−2

@@ -27,8 +27,8 @@ instance Pretty Pattern where

2727 case pattern of

2828 PVar x -> variable x

2929 PLiteral lit -> pretty lit

30− PRecord fs -> PP.braces (commaCat $ map PP.text fs)

31− PAlias x p -> prettyParens p <+> PP.text "as" <+> PP.text x

30+ PRecord fs -> PP.braces (commaCat $ map variable fs)

31+ PAlias x p -> prettyParens p <+> PP.text "as" <+> variable x

3232 PAnything -> PP.text "_"

3333 PData "::" [hd,tl] -> parensIf isCons (pretty hd) <+> PP.text "::" <+> pretty tl

3434 where isCons = case hd of

compiler/SourceSyntax/PrettyPrint.hs+6−1

@@ -15,4 +15,9 @@ commaSep docs = sep (punctuate comma docs)

1515

1616parensIf bool doc = if bool then parens doc else doc

1717

18−variable x = parensIf (Help.isOp x) (text x)

18+variable x =

19+ if Help.isOp x then parens (text x)

20+ else text (reprime x)

21+

22+reprime :: String -> String

23+reprime = map (\c -> if c == '$' then '\'' else c)

compiler/Transform/Canonicalize.hs+10−9

@@ -61,7 +61,7 @@ metadataModule ifaces modul =

6161 second f (a,b) = (,) a `fmap` f b

6262 third f (a,b,c) = (,,) a b `fmap` f c

6363 renameType' =

64− Either.either (\err -> Left [P.text err]) return . renameType (replace initialEnv)

64+ Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

6565

6666 get1 (a,_,_) = a

6767 canon (name, importMethod) =

@@ -92,12 +92,12 @@ extend env pattern = Map.union (Map.fromList (zip xs xs)) env

9292 where xs = Set.toList (SD.boundVars pattern)

9393

9494

95−replace :: Env -> String -> Either String String

96−replace env v =

95+replace :: String -> Env -> String -> Either String String

96+replace variable env v =

9797 if List.isPrefixOf "Native." v then return v else

9898 case Map.lookup v env of

9999 Just v' -> return v'

100− Nothing -> Left $ "Could not find variable '" ++ v ++ "'." ++ msg

100+ Nothing -> Left $ "Could not find " ++ variable ++ " '" ++ v ++ "'." ++ msg

101101 where

102102 matches = filter (List.isInfixOf v) (Map.keys env)

103103 msg = if null matches then "" else

@@ -129,12 +129,12 @@ rename env lexpr@(L s expr) =

129129 frnm (f,e) = (,) f `liftM` rename env e

130130

131131 Binop op e1 e2 ->

132− do op' <- format (replace env op)

132+ do op' <- format (replace "variable" env op)

133133 Binop op' `liftM` rnm e1 `ap` rnm e2

134134

135135 Lambda pattern e ->

136136 let env' = extend env pattern in

137− Lambda pattern `liftM` rename env' e

137+ Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e

138138

139139 App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

140140

@@ -149,9 +149,10 @@ rename env lexpr@(L s expr) =

149149 Def p exp ->

150150 Def `liftM` format (renamePattern env' p) `ap` rename env' exp

151151 TypeAnnotation name tipe ->

152− TypeAnnotation name `liftM` renameType (format . replace env') tipe

152+ TypeAnnotation name `liftM`

153+ renameType (format . replace "variable" env') tipe

153154

154− Var x -> Var `liftM` format (replace env x)

155+ Var x -> Var `liftM` format (replace "variable" env x)

155156

156157 Data name es -> Data name `liftM` mapM rnm es

157158

@@ -173,5 +174,5 @@ renamePattern env pattern =

173174 PRecord _ -> return pattern

174175 PAnything -> return pattern

175176 PAlias x p -> PAlias x `liftM` renamePattern env p

176− PData name ps -> PData `liftM` replace env name

177+ PData name ps -> PData `liftM` replace "pattern" env name

177178 `ap` mapM (renamePattern env) ps

compiler/Transform/Check.hs+2−2

@@ -39,8 +39,8 @@ duplicates defs =

3939 dups = map head . filter ((>1) . length) . List.group

4040

4141 msg = "Syntax Error: There can only be one "

42− defMsg x = msg ++ " definition of '" ++ x ++ "'."

43− annMsg x = msg ++ " type annotation for '" ++ x ++ "'."

42+ defMsg x = msg ++ "definition of '" ++ x ++ "'."

43+ annMsg x = msg ++ "type annotation for '" ++ x ++ "'."

4444

4545

4646badOrder :: [Def t v] -> [String]

compiler/Type/Constrain/Expression.hs+25−20

@@ -6,6 +6,7 @@ import qualified Data.Set as Set

66import Control.Arrow (second)

77import Control.Applicative ((<$>),(<*>))

88import qualified Control.Monad as Monad

9+import Control.Monad.Error (ErrorT, runErrorT)

910import Control.Monad.State

1011import Data.Traversable (traverse)

1112

@@ -33,7 +34,8 @@ constrain env (L span expr) tipe =

3334 case expr of

3435 Literal lit -> Literal.constrain env span lit tipe

3536

36− Var name -> return (name <? tipe)

37+ Var name | name == saveEnvName -> return (L span CSaveEnv)

38+ | otherwise -> return (name <? tipe)

3739

3840 Range lo hi ->

3941 exists $ \x -> do

@@ -56,7 +58,7 @@ constrain env (L span expr) tipe =

5658 Lambda p e ->

5759 exists $ \t1 ->

5860 exists $ \t2 -> do

59− fragment <- Pattern.constrain env p t1

61+ fragment <- try span $ Pattern.constrain env p t1

6062 c2 <- constrain env e t2

6163 let c = ex (vars fragment) (clet [monoscheme (typeEnv fragment)]

6264 (typeConstraint fragment /\ c2 ))

@@ -80,18 +82,16 @@ constrain env (L span expr) tipe =

8082 exists $ \t -> do

8183 ce <- constrain env exp t

8284 let branch (p,e) = do

83− fragment <- Pattern.constrain env p t

85+ fragment <- try span $ Pattern.constrain env p t

8486 clet [toScheme fragment] <$> constrain env e tipe

8587 and . (:) ce <$> mapM branch branches

8688

8789 Data name exprs ->

88− do pairs <- mapM pair exprs

90+ do vars <- forM exprs $ \_ -> var Flexible

91+ let pairs = zip exprs (map VarN vars)

8992 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)

90− return (cs /\ name <? ctipe)

93+ return $ ex vars (cs /\ name <? ctipe)

9194 where

92− pair e = do v <- var Flexible -- needs an ex

93− return (e, VarN v)

94−

9595 step (t,c) (e,x) = do

9696 c' <- constrain env e x

9797 return (x ==> t, c /\ c')

@@ -137,9 +137,7 @@ constrain env (L span expr) tipe =

137137 return ("Graphics.Element.markdown" <? tipe)

138138

139139 Let defs body ->

140− do c <- case body of

141− L _ (Var name) | name == saveEnvName -> return (L span CSaveEnv)

142− _ -> constrain env body tipe

140+ do c <- constrain env body tipe

143141 (schemes, rqs, fqs, header, c2, c1) <-

144142 Monad.foldM (constrainDef env)

145143 ([], [], [], Map.empty, true, true)

@@ -152,9 +150,11 @@ constrainDef env info (pattern, expr, maybeTipe) =

152150 let qs = [] -- should come from the def, but I'm not sure what would live there...

153151 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

154152 in

155− case (pattern, maybeTipe) of

156− (PVar name, Just tipe) ->

157− do flexiVars <- mapM (\_ -> var Flexible) qs

153+ do rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.

154+ -- Currently, qs is always the empty list.

155+ case (pattern, maybeTipe) of

156+ (PVar name, Just tipe) -> do

157+ flexiVars <- mapM (\_ -> var Flexible) qs

158158 let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars

159159 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

160160 (vars, typ) <- Env.instantiateType env tipe Map.empty

@@ -168,12 +168,10 @@ constrainDef env info (pattern, expr, maybeTipe) =

168168 , flexibleQuantifiers

169169 , headers

170170 , c2

171− , fl rigidQuantifiers c /\ c1 )

171+ , fl rigidVars c /\ c1 )

172172

173− (PVar name, Nothing) ->

174− do v <- var Flexible

175− rigidVars <- mapM (\_ -> var Rigid) qs -- Some mistake may be happening here.

176− -- Currently, qs is always the empty list.

173+ (PVar name, Nothing) -> do

174+ v <- var Flexible

177175 let tipe = VarN v

178176 inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars

179177 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }

@@ -194,7 +192,7 @@ expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

194192 _ -> (PVar x, lexpr, maybeType) : map toDef vars

195193 where

196194 vars = Set.toList $ SD.boundVars pattern

197− x = concat vars

195+ x = "$" ++ concat vars

198196 var = L s . Var

199197 toDef y = (PVar y, L s $ Case (var x) [(pattern, var y)], Nothing)

200198

@@ -213,3 +211,10 @@ collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty

213211 go ((pattern, body, Nothing) : output) defs typs ds

214212 TypeAnnotation name typ ->

215213 go output defs (Map.insert name typ typs) ds

214+

215+try :: SrcSpan -> ErrorT String IO a -> IO a

216+try span computation = do

217+ result <- runErrorT computation

218+ case result of

219+ Left msg -> error $ "\nType error " ++ show span ++ "\n" ++ msg

220+ Right value -> return value

compiler/Type/Constrain/Pattern.hs+8−7

@@ -3,6 +3,7 @@ module Type.Constrain.Pattern where

33import Control.Arrow (second)

44import Control.Applicative ((<$>))

55import qualified Control.Monad as Monad

6+import Control.Monad.Error

67import qualified Data.List as List

78import qualified Data.Maybe as Maybe

89import qualified Data.Map as Map

@@ -17,7 +18,7 @@ import Type.Environment as Env

1718import qualified Type.Constrain.Literal as Literal

1819

1920

20−constrain :: Environment -> Pattern -> Type -> IO Fragment

21+constrain :: Environment -> Pattern -> Type -> ErrorT String IO Fragment

2122constrain env pattern tipe =

2223 let span = Loc.NoSpan (render $ pretty pattern)

2324 t1 === t2 = Loc.L span (CEqual t1 t2)

@@ -27,11 +28,11 @@ constrain env pattern tipe =

2728 PAnything -> return emptyFragment

2829

2930 PLiteral lit -> do

30− c <- Literal.constrain env span lit tipe

31+ c <- liftIO $ Literal.constrain env span lit tipe

3132 return $ emptyFragment { typeConstraint = c }

3233

3334 PVar name -> do

34− v <- var Flexible

35+ v <- liftIO $ var Flexible

3536 return $ Fragment {

3637 typeEnv = Map.singleton name (VarN v),

3738 vars = [v],

@@ -46,11 +47,11 @@ constrain env pattern tipe =

4647 }

4748

4849 PData name patterns -> do

49− (kind, cvars, args, result) <- freshDataScheme env name

50+ (kind, cvars, args, result) <- liftIO $ freshDataScheme env name

5051 let msg = concat [ "Constructor '", name, "' expects ", show kind

5152 , " argument", if kind == 1 then "" else "s"

5253 , " but was given ", show (length patterns), "." ]

53− if length patterns /= kind then error msg else do

54+ if length patterns /= kind then throwError msg else do

5455 fragment <- Monad.liftM joinFragments (Monad.zipWithM (constrain env) patterns args)

5556 return $ fragment {

5657 typeConstraint = typeConstraint fragment /\ tipe === result,

@@ -58,9 +59,9 @@ constrain env pattern tipe =

5859 }

5960

6061 PRecord fields -> do

61− pairs <- mapM (\name -> (,) name <$> var Flexible) fields

62+ pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields

6263 let tenv = Map.fromList (map (second VarN) pairs)

63− c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

64+ c <- liftIO . exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)

6465 return $ Fragment {

6566 typeEnv = tenv,

6667 vars = map snd pairs,

compiler/Type/Environment.hs+29−27

@@ -99,7 +99,7 @@ ctorToType env (name, tvars, ctors) =

9999get :: Environment -> (Environment -> Map.Map String a) -> String -> a

100100get env subDict key = Map.findWithDefault err key (subDict env)

101101 where

102− err = error $ "Could not find type constructor '" ++ key ++ "' while checking types."

102+ err = error $ "\nCould not find type constructor '" ++ key ++ "' while checking types."

103103

104104

105105freshDataScheme :: Environment -> String -> IO (Int, [Variable], [Type], Type)

@@ -122,38 +122,40 @@ instantiator env sourceType = go sourceType

122122

123123 Src.Var x -> do

124124 (dict, aliases) <- State.get

125− case Map.lookup x dict of

126− Just var -> return (VarN var)

127− Nothing ->

128− case Map.lookup x aliases of

129− Just t -> return t

130− Nothing ->

131− do var <- State.liftIO $ namedVar flex x

132− State.put (Map.insert x var dict, aliases)

133− return (VarN var)

134− where

135− flex | "number" `isPrefixOf` x = Is Number

136− | "comparable" `isPrefixOf` x = Is Comparable

137− | "appendable" `isPrefixOf` x = Is Appendable

138− | otherwise = Flexible

125+ case (Map.lookup x dict, Map.lookup x aliases) of

126+ (_, Just t) -> return t

127+ (Just v, _) -> return (VarN v)

128+ _ ->

129+ do var <- State.liftIO $ namedVar flex x

130+ State.put (Map.insert x var dict, aliases)

131+ return (VarN var)

132+ where

133+ flex | "number" `isPrefixOf` x = Is Number

134+ | "comparable" `isPrefixOf` x = Is Comparable

135+ | "appendable" `isPrefixOf` x = Is Appendable

136+ | otherwise = Flexible

139137

140138 Src.Data "String" [] ->

141139 return (get env types "_List" <| get env types "Char")

142140

143141 Src.Data name ts -> do

144142 ts' <- mapM go ts

145− case Map.lookup name (types env) of

146− Just t -> return $ foldl (<|) t ts'

147− Nothing ->

148− case Map.lookup name (aliases env) of

149− Nothing -> error $ "Could not find type constructor '" ++ name ++ "' while checking types."

150− Just (tvars, t) ->

151− let msg = "Type alias '" ++ name ++ "' expects " ++ show (length tvars) ++

152− " but was given " ++ show (length ts')

153− in if length ts' /= length tvars then error msg else

154− do (dict, aliases) <- State.get

155− State.put (dict, Map.union aliases . Map.fromList $ zip tvars ts')

156− go t

143+ case (Map.lookup name (types env), Map.lookup name (aliases env)) of

144+ (Just t, _) -> return $ foldl (<|) t ts'

145+ (_, Just (tvars, t)) ->

146+ let tvarLen = length tvars

147+ msg = "\nType alias '" ++ name ++ "' expects " ++ show tvarLen ++

148+ " type argument" ++ (if tvarLen == 1 then "" else "s") ++

149+ " but was given " ++ show (length ts')

150+ in if length ts' /= length tvars then error msg else

151+ do (dict, aliases) <- State.get

152+ let aliases' = Map.union (Map.fromList $ zip tvars ts') aliases

153+ State.put (dict, aliases')

154+ t' <- go t

155+ State.put (dict, aliases)

156+ return t'

157+ _ -> error $ "\nCould not find type constructor '" ++

158+ name ++ "' while checking types."

157159

158160 Src.EmptyRecord -> return (TermN EmptyRecord1)

159161

compiler/Type/PrettyPrint.hs+4−1

@@ -2,6 +2,7 @@

22module Type.PrettyPrint where

33

44import Text.PrettyPrint

5+import qualified SourceSyntax.PrettyPrint as Src

56

67data ParensWhen = Fn | App | Never

78

@@ -10,4 +11,6 @@ class PrettyType a where

1011

1112commaSep docs = sep (punctuate comma docs)

1213

13−parensIf bool doc = if bool then parens doc else doc

14+parensIf bool doc = if bool then parens doc else doc

15+

16+reprime = Src.reprime

compiler/Type/Solve.hs+10−9

@@ -49,16 +49,17 @@ generalize youngPool = do

4949 -- otherwise generalize

5050 let registerIfLowerRank var = do

5151 isRedundant <- liftIO $ UF.redundant var

52− if isRedundant then return () else do

52+ case isRedundant of

53+ True -> return ()

54+ False -> do

5355 desc <- liftIO $ UF.descriptor var

54− if rank desc < youngRank

55− then TS.register var >> return ()

56− else let flex' = if flex desc == Flexible then Rigid else flex desc

57− in liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

58−

59− mapM registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

60−

61− return ()

56+ case rank desc < youngRank of

57+ True -> TS.register var >> return ()

58+ False -> do

59+ let flex' = case flex desc of { Flexible -> Rigid ; other -> other }

60+ liftIO $ UF.setDescriptor var (desc { rank = noRank, flex = flex' })

61+

62+ mapM_ registerIfLowerRank (Map.findWithDefault [] youngRank rankDict)

6263

6364

6465-- adjust the ranks of variables such that ranks never increase as you

compiler/Type/State.hs+5−2

@@ -62,9 +62,11 @@ addError span message t1 t2 =

6262 NoSpan msg -> display msg

6363 Span _ _ msg -> display msg

6464

65+ defaultMessage = "Something weird is happening with this value:"

66+

6567 makeError pt1 pt2 =

6668 P.vcat [ P.text $ "Type error" ++ location ++ ":"

67− , if null message then empty else P.vcat . map P.text $ lines message

69+ , P.vcat . map P.text . lines $ if null message then defaultMessage else message

6870 , P.text src

6971 , P.text " Expected Type:" <+> pt1

7072 , P.text " Actual Type:" <+> pt2 <> P.text "\n"

@@ -137,7 +139,8 @@ makeCopy alreadyCopied variable = do

137139 () | mark desc == alreadyCopied ->

138140 case copy desc of

139141 Just v -> return v

140− Nothing -> error "This should be impossible."

142+ Nothing -> error $ "Error copying type variable. This should be impossible." ++

143+ " Please report an error to the github repo!"

141144

142145 | rank desc /= noRank || flex desc == Constant ->

143146 return variable

compiler/Type/Type.hs+7−3

@@ -176,7 +176,7 @@ instance PrettyType a => PrettyType (Term1 a) where

176176 prettyExt = prty ext

177177 extend | P.render prettyExt == "{}" = P.empty

178178 | otherwise = prettyExt <+> P.text "|"

179− mkPretty f t = P.text f <+> P.text ":" <+> prty t

179+ mkPretty f t = P.text (reprime f) <+> P.text ":" <+> prty t

180180 prettyFields = concatMap (\(f,ts) -> map (mkPretty f) ts) (Map.toList fields)

181181

182182

@@ -191,7 +191,7 @@ instance PrettyType Descriptor where

191191 pretty when desc =

192192 case (structure desc, name desc) of

193193 (Just term, _) -> pretty when term

194− (_, Just name) -> if not (isTuple name) then P.text name else

194+ (_, Just name) -> if not (isTuple name) then P.text (reprime name) else

195195 P.parens . P.text $ replicate (read (drop 6 name) - 1) ','

196196 _ -> P.text "?"

197197

@@ -277,7 +277,11 @@ addNames value = do

277277 Is Number -> (Just $ "number" ++ replicate a '\'', (vars, a+1, b, c))

278278 Is Comparable -> (Just $ "comparable" ++ replicate b '\'', (vars, a, b+1, c))

279279 Is Appendable -> (Just $ "appendable" ++ replicate c '\'', (vars, a, b, c+1))

280− _ -> (Just $ head vars, (tail vars, a, b, c))

280+ other -> (Just $ head vars, (tail vars, a, b, c))

281+ where mark = case other of

282+ Flexible -> ""

283+ Rigid -> "!"

284+ Constant -> "#"

281285

282286

283287type CrawlState = ([String], Int, Int, Int)

compiler/Type/Unify.hs+15−5

@@ -7,6 +7,8 @@ import qualified Type.State as TS

77import Control.Arrow (first,second)

88import Control.Monad.State

99import SourceSyntax.Location

10+import Type.PrettyPrint

11+import Text.PrettyPrint (render)

1012

1113unify :: SrcSpan -> Variable -> Variable -> StateT TS.SolverState IO ()

1214unify span variable1 variable2 = do

@@ -75,7 +77,7 @@ actuallyUnify span variable1 variable2 = do

7577 unify' variable1 variable2

7678

7779 unifyNumber svar name

78− | name `elem` ["Int","Float"] = flexAndUnify svar

80+ | name `elem` ["Int","Float","number"] = flexAndUnify svar

7981 | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2

8082

8183 comparableError str = TS.addError span (str ++ msg) variable1 variable2

@@ -83,7 +85,7 @@ actuallyUnify span variable1 variable2 = do

8385 "Int, Float, Char, or a list or tuple of comparables."

8486

8587 unifyComparable var name

86− | name `elem` ["Int","Float","Char"] = flexAndUnify var

88+ | name `elem` ["Int","Float","Char","comparable"] = flexAndUnify var

8789 | otherwise = comparableError ""

8890

8991 unifyComparableStructure varSuper varFlex =

@@ -106,6 +108,12 @@ actuallyUnify span variable1 variable2 = do

106108 List _ -> flexAndUnify varSuper

107109 _ -> comparableError ""

108110

111+ rigidError variable = TS.addError span msg variable1 variable2

112+ where

113+ msg = concat

114+ [ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"

115+ , "It is likely that a type annotation is not general enough." ]

116+

109117 superUnify =

110118 case (flex desc1, flex desc2, name desc1, name desc2) of

111119 (Is super1, Is super2, _, _)

@@ -126,6 +134,8 @@ actuallyUnify span variable1 variable2 = do

126134 (Is Appendable, _, _, _) -> unifyAppendable variable1 variable2

127135 (_, Is Appendable, _, _) -> unifyAppendable variable2 variable1

128136

137+ (Rigid, _, _, _) -> rigidError variable1

138+ (_, Rigid, _, _) -> rigidError variable2

129139 _ -> TS.addError span "" variable1 variable2

130140

131141 case (structure desc1, structure desc2) of

@@ -158,7 +168,7 @@ actuallyUnify span variable1 variable2 = do

158168

159169 (Record1 fields1 ext1, Record1 fields2 ext2) ->

160170 do sequence . concat . Map.elems $ Map.intersectionWith (zipWith unify') fields1 fields2

161− let mkRecord fs ext = liftIO . structuredVar $ Record1 fs ext

171+ let mkRecord fs ext = fresh . Just $ Record1 fs ext

162172 case (Map.null fields1', Map.null fields2') of

163173 (True , True ) -> unify' ext1 ext2

164174 (True , False) -> do

@@ -168,8 +178,8 @@ actuallyUnify span variable1 variable2 = do

168178 record1' <- mkRecord fields1' ext1

169179 unify' record1' ext2

170180 (False, False) -> do

171− record1' <- mkRecord fields1' =<< liftIO (var Flexible)

172− record2' <- mkRecord fields2' =<< liftIO (var Flexible)

181+ record1' <- mkRecord fields1' =<< fresh Nothing

182+ record2' <- mkRecord fields2' =<< fresh Nothing

173183 unify' record1' ext2

174184 unify' ext1 record2'

175185 where

libraries/Automaton.elm+2−2

@@ -80,12 +80,12 @@ average : Int -> Automaton Float Float

8080average k =

8181 let step n (ns,len,sum) =

8282 if len == k then stepFull n (ns,len,sum)

83− else ((enqueue n ns, len+1, sum+n), (sum+n) / (len+1))

83+ else ((enqueue n ns, len+1, sum+n), (sum+n) / (toFloat len+1))

8484 stepFull n (ns,len,sum) =

8585 case dequeue ns of

8686 Nothing -> ((ns,len,sum), 0)

8787 Just (m,ns') -> let sum' = sum + n - m

88− in ((enqueue n ns', len, sum'), sum' / len)

88+ in ((enqueue n ns', len, sum'), sum' / toFloat len)

8989 in hiddenState (empty,0,0) step

9090

9191

libraries/Color.elm+29−33

@@ -14,23 +14,35 @@ rgba = Color

1414rgb : Int -> Int -> Int -> Color

1515rgb r g b = Color r g b 1

1616

17−red : Color

18−red = Color 255 0 0 1

19−lime : Color

20−lime = Color 0 255 0 1

21−blue : Color

22−blue = Color 0 0 255 1

23−

24−yellow : Color

25−yellow = Color 255 255 0 1

26−cyan : Color

27−cyan = Color 0 255 255 1

28−magenta : Color

29−magenta = Color 255 0 255 1

30−

31−black : Color

17+lightYellow = Color 255 233 79 1

18+yellow = Color 237 212 0 1

19+darkYellow = Color 196 160 0 1

20+

21+lightOrange = Color 252 175 62 1

22+orange = Color 245 121 0 1

23+darkOrange = Color 206 92 0 1

24+

25+lightBrown = Color 233 185 110 1

26+brown = Color 193 125 17 1

27+darkBrown = Color 143 89 2 1

28+

29+lightGreen = Color 138 226 52 1

30+green = Color 115 210 22 1

31+darkGreen = Color 78 154 6 1

32+

33+lightBlue = Color 114 159 207 1

34+blue = Color 52 101 164 1

35+darkBlue = Color 32 74 135 1

36+

37+lightPurple = Color 173 127 168 1

38+purple = Color 117 80 123 1

39+darkPurple = Color 92 53 102 1

40+

41+lightRed = Color 239 41 41 1

42+red = Color 204 0 0 1

43+darkRed = Color 164 0 0 1

44+

3245black = Color 0 0 0 1

33−white : Color

3446white = Color 255 255 255 1

3547

3648gray : Color

@@ -38,23 +50,6 @@ gray = Color 128 128 128 1

3850grey : Color

3951grey = Color 128 128 128 1

4052

41−maroon : Color

42−maroon = Color 128 0 0 1

43−navy : Color

44−navy = Color 0 0 128 1

45−green : Color

46−green = Color 0 128 0 1

47−

48−teal : Color

49−teal = Color 0 128 128 1

50−purple : Color

51−purple = Color 128 0 128 1

52−

53−violet : Color

54−violet = Color 238 130 238 1

55−forestGreen : Color

56−forestGreen = Color 34 139 34 1

57−

5853-- Produce a “complementary color”.

5954-- The two colors will accent each other.

6055complement : Color -> Color

@@ -67,6 +62,7 @@ hsva = Native.Color.hsva

6762

6863-- Create [HSV colors](http://en.wikipedia.org/wiki/HSL_and_HSV).

6964-- This is very convenient for creating colors that cycle and shift.

65+-- Hue is an angle and should be given in standard Elm angles (radians).

7066--

7167-- hsv (degrees 240) 1 1 == blue

7268hsv : Float -> Float -> Float -> Color

libraries/Graphics/Collage.elm+15−15

@@ -128,27 +128,27 @@ groupTransform matrix fs = form (FGroup matrix fs)

128128-- Rotate a form by a given angle. Rotate takes standard Elm angles (radians)

129129-- and turns things counterclockwise. So to turn `form` 30° to the left

130130-- you would say, `(rotate (degrees 30) form)`.

131−rotate : Float -> Form -> Form

131+rotate : number -> Form -> Form

132132rotate t f = { f | theta <- f.theta + t }

133133

134134-- Scale a form by a given factor. Scaling by 2 doubles the size.

135−scale : Float -> Form -> Form

135+scale : number -> Form -> Form

136136scale s f = { f | scale <- f.scale * s }

137137

138138-- Move a form by the given amount. This is a relative translation so

139139-- `(move (10,10) form)` would move `form` ten pixels up and ten pixels to the

140140-- right.

141−move : (Float,Float) -> Form -> Form

141+move : (number,number) -> Form -> Form

142142move (x,y) f = { f | x <- f.x + x, y <- f.y + y }

143143

144144-- Move a shape in the x direction. This is relative so `(moveX 10 form)` moves

145145-- `form` 10 pixels to the right.

146−moveX : Float -> Form -> Form

146+moveX : number -> Form -> Form

147147moveX x f = { f | x <- f.x + x }

148148

149149-- Move a shape in the y direction. This is relative so `(moveY 10 form)` moves

150150-- `form` upwards by 10 pixels.

151−moveY : Float -> Form -> Form

151+moveY : number -> Form -> Form

152152moveY y f = { f | y <- f.y + y }

153153

154154-- Set the alpha of a `Form`. The default is 1, and 0 is totally transparent.

@@ -161,36 +161,36 @@ collage : Int -> Int -> [Form] -> Element

161161collage = Native.Graphics.Collage.collage

162162

163163

164−type Path = [(Float,Float)]

164+type Path = [(number,number)]

165165

166166-- Create a path that follows a sequence of points.

167−path : [(Float,Float)] -> Path

167+path : [(number,number)] -> Path

168168path ps = ps

169169

170170-- Create a path along a given line segment.

171−segment : (Float,Float) -> (Float,Float) -> Path

171+segment : (number,number) -> (number,number) -> Path

172172segment p1 p2 = [p1,p2]

173173

174−type Shape = [(Float,Float)]

174+type Shape = [(number,number)]

175175

176176-- Create an arbitrary polygon by specifying its corners in order.

177177-- `polygon` will automatically close all shapes, so the given list

178178-- of points does not need to start and end with the same position.

179−polygon : [(Float,Float)] -> Shape

179+polygon : [(number,number)] -> Shape

180180polygon points = points

181181

182182-- A rectangle with a given width and height.

183−rect : Float -> Float -> Shape

183+rect : number -> number -> Shape

184184rect w h = let hw = w/2

185185 hh = h/2

186186 in [ (0-hw,0-hh), (0-hw,hh), (hw,hh), (hw,0-hh) ]

187187

188188-- A square with a given edge length.

189−square : Float -> Shape

189+square : number -> Shape

190190square n = rect n n

191191

192192-- An oval with a given width and height.

193−oval : Float -> Float -> Shape

193+oval : number -> number -> Shape

194194oval w h =

195195 let n = 50

196196 t = 2 * pi / n

@@ -200,7 +200,7 @@ oval w h =

200200 in List.map f [0..n-1]

201201

202202-- A circle with a given radius.

203−circle : Float -> Shape

203+circle : number -> Shape

204204circle r = oval (2*r) (2*r)

205205

206206-- A regular polygon with N sides. The first argument specifies the number

@@ -208,7 +208,7 @@ circle r = oval (2*r) (2*r)

208208-- 30 you would say:

209209--

210210-- ngon 5 30

211−ngon : Int -> Float -> Shape

211+ngon : Int -> number -> Shape

212212ngon n r =

213213 let m = toFloat n

214214 t = 2 * pi / m

libraries/Graphics/Input.elm+4

@@ -75,10 +75,14 @@ checkbox b =

7575 let cbs = checkboxes b

7676 in (lift (cbs.checkbox id) cbs.events, cbs.events)

7777

78+-- Detect when the mouse is hovering over some elements. This

79+-- allows you to create and destroy elements dynamically and still

80+-- detect hover information.

7881hoverables : a -> { events : Signal a,

7982 hoverable : (Bool -> a) -> Element -> Element }

8083hoverables = Native.Graphics.Input.hoverables

8184

85+-- Detect when the mouse is hovering over a specifici `Element`.

8286hoverable : Element -> (Element, Signal Bool)

8387hoverable elem =

8488 let pool = hoverables False

libraries/List.elm+2−2

@@ -91,11 +91,11 @@ any = Native.List.any

9191

9292-- Check to see if all elements are True.

9393and : [Bool] -> Bool

94−and = Native.List.and

94+and = foldl (&&) True

9595

9696-- Check to see if any elements are True.

9797or : [Bool] -> Bool

98−or = Native.List.or

98+or = foldl (||) False

9999

100100-- Concatenate a list of appendable things:

101101--

libraries/Native/Char.js+1−1

@@ -16,7 +16,7 @@ Elm.Native.Char = function(elm) {

1616

1717 return elm.Native.Char = {

1818 fromCode : function(c) { return String.fromCharCode(c); },

19− toCode : function(c) { return c.charCodeAt(0); },

19+ toCode : function(c) { return c.toUpperCase().charCodeAt(0); },

2020 toUpper : function(c) { return c.toUpperCase(); },

2121 toLower : function(c) { return c.toLowerCase(); },

2222 toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },

libraries/Native/Signal/Keyboard.js+74−22

@@ -4,29 +4,79 @@ Elm.Native.Keyboard = function(elm) {

44 elm.Native = elm.Native || {};

55 if (elm.Native.Keyboard) return elm.Native.Keyboard;

66

7+ // Duplicated from Native.Signal

8+ function send(node, timestep, changed) {

9+ var kids = node.kids;

10+ for (var i = kids.length; i--; ) {

11+ kids[i].recv(timestep, changed, node.id);

12+ }

13+ }

14+

715 var Signal = Elm.Signal(elm);

816 var NList = Elm.Native.List(elm);

17+ var Utils = Elm.Native.Utils(elm);

18+

19+ var downEvents = Signal.constant(0);

20+ var upEvents = Signal.constant(0);

21+ var blurEvents = Signal.constant(0);

22+

23+ elm.addListener([downEvents.id], document, 'keydown', function down(e) {

24+ elm.notify(downEvents.id, e.keyCode);

25+ });

26+

27+ elm.addListener([upEvents.id], document, 'keyup', function up(e) {

28+ elm.notify(upEvents.id, e.keyCode);

29+ });

30+

31+ elm.addListener([blurEvents.id], document, 'blur', function blur(e) {

32+ elm.notify(blurEvents.id, NList.Nil);

33+ });

34+

35+ function KeyMerge(down, up, blur) {

36+ var args = [down,up,blur];

37+ this.id = Utils.guid();

38+ // Ignore starting values here

39+ this.value = NList.Nil

40+ this.kids = [];

41+

42+ var n = args.length;

43+ var count = 0;

44+ var isChanged = false;

945

10− var keysDown = Signal.constant(NList.Nil);

11− var lastKey = Signal.constant('\0');

12−

13− elm.addListener([keysDown.id], document, 'keydown', function down(e) {

14− if (NList.member(e.keyCode)(keysDown.value)) return;

15− elm.notify(keysDown.id, NList.Cons(e.keyCode, keysDown.value));

16− });

17− elm.addListener([keysDown.id], document, 'keyup', function up(e) {

18− function notEq(kc) { return kc !== e.keyCode; }

19− elm.notify(keysDown.id, NList.filter(notEq)(keysDown.value));

20− });

21− elm.addListener([keysDown.id], document, 'blur', function blur(e) {

22− elm.notify(keysDown.id, NList.Nil);

23− });

24− elm.addListener([lastKey.id], document, 'keypress', function press(e) {

25− elm.notify(lastKey.id, e.charCode || e.keyCode);

26− });

46+ this.recv = function(timestep, changed, parentID) {

47+ ++count;

48+ if (changed) {

49+ // We know this a change must only be one of the following cases

50+ if (parentID === down.id && !(NList.member(down.value)(this.value))) {

51+ isChanged = true;

52+ this.value = NList.Cons(down.value, this.value);

53+ }

54+ if (parentID === up.id) {

55+ isChanged = true;

56+ var notEq = function(kc) { return kc !== up.value };

57+ this.value = NList.filter(notEq)(this.value);

58+ }

59+ if (parentID === blur.id) {

60+ isChanged = true;

61+ this.value = NList.Nil;

62+ }

63+ }

64+ if (count == n) {

65+ send(this, timestep, isChanged);

66+ isChanged = false;

67+ count = 0;

68+ }

69+ };

70+

71+ for (var i = n; i--; ) { args[i].kids.push(this); }

72+

73+ }

74+

75+ var keysDown = Signal.dropRepeats(new KeyMerge(downEvents,upEvents,blurEvents));

2776

2877 function keySignal(f) {

29− var signal = Signal.dropRepeats(A2(Signal.lift, f, keysDown));

78+ var signal = A2(Signal.lift, f, keysDown);

79+ // what's the significance of these two following lines? -jpm

3080 keysDown.defaultNumberOfKids += 1;

3181 signal.defaultNumberOfKids = 0;

3282 return signal;

@@ -51,11 +101,13 @@ Elm.Native.Keyboard = function(elm) {

51101

52102 function is(key) { return keySignal(NList.member(key)); }

53103

104+ var lastPressed = Signal.dropRepeats(downEvents);

105+

54106 return elm.Native.Keyboard = {

55− isDown:is,

56− directions:F4(dir),

57− keysDown:keysDown,

58− lastPressed:lastKey

107+ isDown:is,

108+ directions:F4(dir),

109+ keysDown:keysDown,

110+ lastPressed:lastPressed

59111 };

60112

61113};

libraries/Signal.elm+2−1

@@ -52,7 +52,8 @@ lift8 = Native.Signal.lift8

5252-- Create a past-dependent signal. Each value given on the input signal will

5353-- be accumulated, producing a new output value.

5454--

55−-- For instance, `(foldp (\\t acc -> acc + 1) 0 (Time.every second))` increments every second.

55+-- For instance, `(foldp (\\arrows number -> number + arrows.y) 0 Keyboard.arrows)`

56+-- increments or decrements the accumulated value (which starts at zero) when the up or down arrow keys are pressed.

5657foldp : (a -> b -> b) -> b -> Signal a -> Signal b

5758foldp = Native.Signal.foldp

5859

runtime/Init.js−1

@@ -115,7 +115,6 @@ function init(display, container, module, moduleToReplace) {

115115

116116 // rerender scene if graphics are enabled.

117117 if (typeof graphicsNode !== 'undefined') {

118− graphicsNode.value = A2( Elm.Graphics.Element(elm).spacer, 0, 0 );

119118 graphicsNode.recv(0, true, 0);

120119 }

121120 }

runtime/Render/Element.js+2−2

@@ -252,9 +252,9 @@ function updateProps(node, curr, next) {

252252 e.style.opacity = props.opacity;

253253 }

254254 var nextColor = (props.color.ctor === 'Just' ?

255− extract(props.color._0) : 'transparent');

255+ extract(props.color._0) : '');

256256 if (e.style.backgroundColor !== nextColor) {

257− e.style.backgroundColor = nextColor;

257+ e.style.backgroundColor = (nextColor === '' ? 'transparent' : nextColor);

258258 }

259259 if (props.tag !== currP.tag) { e.id = props.tag; }

260260 if (props.href !== currP.href) {

runtime/Render/Utils.js+2−2

@@ -14,8 +14,8 @@ function addTo(container, elem) {

1414}

1515

1616function extract(c) {

17− if (c._3 === 1) { return 'rgb(' + c._0 + ',' + c._1 + ',' + c._2 + ')'; }

18− return 'rgba(' + c._0 + ',' + c._1 + ',' + c._2 + ',' + c._3 + ')';

17+ if (c._3 === 1) { return 'rgb(' + c._0 + ', ' + c._1 + ', ' + c._2 + ')'; }

18+ return 'rgba(' + c._0 + ', ' + c._1 + ', ' + c._2 + ', ' + c._3 + ')';

1919}

2020

2121function addTransform(style, trans) {

server/Server.hs+33−14

@@ -7,17 +7,21 @@ import Data.List (isPrefixOf, isSuffixOf, (\\))

77import Data.Version (showVersion)

88import Happstack.Server

99import Happstack.Server.Compression

10+import System.Directory

1011import System.Environment

12+import System.Exit

1113import System.FilePath

14+import System.Process

15+import GHC.IO.Handle

1216import qualified Language.Elm as Elm

1317import Paths_elm_server

1418

15−runtime = "/elm-" ++ showVersion version ++ ".js"

19+runtime = "/elm-runtime.js"

1620

1721serve :: Int -> String -> IO ()

1822serve portNumber libLoc = do

19− putStrLn ("Elm Server " ++ showVersion version ++

20− ": running at <http://localhost:" ++ (show portNumber) ++ ">")

23+ putStrLn $ "Elm Server " ++ showVersion version ++

24+ ": running at <http://localhost:" ++ show portNumber ++ ">"

2125 putStrLn "Just refresh a page to recompile it!"

2226 simpleHTTP httpConf $ do

2327 _ <- compressedResponseFilter

@@ -30,11 +34,24 @@ serve portNumber libLoc = do

3034pageTitle :: String -> String

3135pageTitle = dropExtension . takeBaseName

3236

37+serveElm :: FilePath -> ServerPartT IO Response

3338serveElm fp = do

3439 guard (takeExtension fp == ".elm")

35− content <- liftIO (readFile (tail fp))

36− length content `seq` (ok . toResponse $ Elm.toHtml runtime (pageTitle fp) content)

40+ let file = tail fp

41+ args = [ "--make" ,"--runtime=" ++ runtime, "--cache-dir=elm-server-cache", file ]

42+ (_, stdout, _, handle) <- liftIO $ createProcess $ (proc "elm" args) { std_out = CreatePipe }

43+ exitCode <- liftIO $ waitForProcess handle

44+ liftIO $ removeDirectoryRecursive "elm-server-cache"

45+ case (exitCode, stdout) of

46+ (ExitFailure _, Just out) ->

47+ do str <- liftIO $ hGetContents out

48+ badRequest $ toResponse str

49+ (ExitFailure _, Nothing) ->

50+ badRequest $ toResponse "See command line for error message."

51+ (ExitSuccess, _) ->

52+ serveFile (asContentType "text/html") ("build" </> replaceExtension file "html")

3753

54+serveLib :: FilePath -> [Char] -> ServerPartT IO Response

3855serveLib libLoc fp = do

3956 guard (fp == runtime)

4057 serveFile (asContentType "application/javascript") libLoc

@@ -45,16 +62,18 @@ main = getArgs >>= parse

4562parse :: [String] -> IO ()

4663parse ("--help":_) = putStrLn usage

4764parse ("--version":_) = putStrLn ("The Elm Server " ++ showVersion version)

48−parse args = if null remainingArgs

49− then serve portNumber =<< elmRuntime

50− else putStrLn usageMini

51− where runtimeArg = filter (isPrefixOf "--runtime-location=") args

52− portArg = filter (isPrefixOf "--port=") args

53− remainingArgs = (args \\ runtimeArg) \\ portArg

65+parse args =

66+ case null remainingArgs of

67+ True -> serve portNumber =<< elmRuntime

68+ False -> putStrLn usageMini

69+ where

70+ runtimeArg = filter (isPrefixOf "--runtime-location=") args

71+ portArg = filter (isPrefixOf "--port=") args

72+ remainingArgs = (args \\ runtimeArg) \\ portArg

5473

55− argValue arg = tail $ dropWhile (/= '=') (head arg)

56− portNumber = if null portArg then 8000 else read (argValue portArg) :: Int

57− elmRuntime = if null runtimeArg then Elm.runtime else return $ argValue runtimeArg

74+ argValue arg = tail $ dropWhile (/= '=') (head arg)

75+ portNumber = if null portArg then 8000 else read (argValue portArg) :: Int

76+ elmRuntime = if null runtimeArg then Elm.runtime else return $ argValue runtimeArg

5877

5978usageMini :: String

6079usageMini =

server/elm-server.cabal+5−3

@@ -1,5 +1,5 @@

11Name: elm-server

2−Version: 0.8

2+Version: 0.9.0.2

33Synopsis: The Elm language server.

44Description: This package provides a standalone, Happstack-based Elm server.

55

@@ -27,12 +27,14 @@ Executable elm-server

2727 Main-is: Server.hs

2828 Build-depends: base >=4.2 && <5,

2929 containers >= 0.3,

30+ directory,

3031 transformers >= 0.2,

3132 mtl >= 2,

3233 parsec >= 3.1.1,

3334 blaze-html >= 0.5.1,

3435 HTTP >= 4000,

35− happstack-server == 7.1.1 || == 7.1.7 || == 7.0.2,

36+ happstack-server,

3637 deepseq,

3738 filepath,

38− Elm >= 0.8

39+ Elm >= 0.9.0.2,

40+ process

tests/Everything.hsdeleted−7

@@ -1,7 +0,0 @@

1−module Everything where

2−

3−import System.Exit

4−

5−main = do

6− putStrLn "This test always fails"

7− exitFailure

tests/Main.hsnew file+22

@@ -0,0 +1,22 @@

1+module Main where

2+

3+import System.Directory

4+import System.Exit (exitWith)

5+import System.Environment (getArgs)

6+import Test.Framework.TestManager

7+import Test.Framework.BlackBoxTest

8+

9+main :: IO ()

10+main = do

11+ args <- getArgs

12+ tests <- blackBoxTests "tests/good" "dist/build/elm/elm" ".elm" bbtArgs

13+ code <- runTestWithArgs args tests

14+ removeDirectoryRecursive "cache"

15+ removeDirectoryRecursive "build"

16+ exitWith code

17+

18+bbtArgs = defaultBBTArgs { bbtArgs_stdoutDiff = ignoreDiff

19+ , bbtArgs_stderrDiff = ignoreDiff }

20+

21+ignoreDiff :: Diff

22+ignoreDiff _ _ = return Nothing

tests/good/AliasSubstitution.elmnew file+6

@@ -0,0 +1,6 @@

1+

2+type Vec2Ext a = { a | x:Float, y:Float }

3+type Vec2 = Vec2Ext {}

4+

5+extractVec : Vec2Ext a -> Vec2

6+extractVec v = { x = v.x, y = v.y }

tests/good/Apply.elmdeleted−3

@@ -1,3 +0,0 @@

1−let apply f x = f x

2− id x = x

3− in apply id (apply id (apply id (apply id (apply id (apply id 4)))))

tests/good/NoExpressions.elmnew file+3

@@ -0,0 +1,3 @@

1+

2+type Width = Float

3+type Height = Float

tests/good/Soundness.elmdeleted−8

@@ -1,8 +0,0 @@

1−

2−trickyID x = let y = x in y

3−

4−quad f = twice (twice f)

5−twice f x = f (f x)

6−

7−n = quad (quad trickyID) 4

8−c = twice trickyID 'a'

tests/good/Soundness/Apply.elmnew file+3

@@ -0,0 +1,3 @@

1+

2+apply f = let g x = f x

3+ in g

tests/good/Soundness/ApplyAnnotated.elmnew file+4

@@ -0,0 +1,4 @@

1+

2+apply : (a -> b) -> a -> b

3+apply f = let g x = f x

4+ in g

tests/good/Soundness1.elm → tests/good/Soundness/Id.elmrenamed+2−1

@@ -1,2 +1,3 @@

1−test =

1+

2+myId =

23 let id x = x in id

tests/good/SoundnessAnnotated1.elm → tests/good/Soundness/IdAnnotated.elmrenamed+2−1

@@ -1,3 +1,4 @@

1−test = let id : a -> a

1+

2+myId = let id : a -> a

23 id x = x

34 in id

tests/good/Soundness/TrickyId.elmnew file+2

@@ -0,0 +1,2 @@

1+

2+myId x = let y = x in y

tests/good/Soundness/TrickyIdAnnotated.elmnew file+3

@@ -0,0 +1,3 @@

1+

2+myId : a -> a

3+myId x = let y = x in y

tests/good/Soundness2.elmdeleted−1

@@ -1 +0,0 @@

1−test x = let y = x in y

tests/good/Soundness3.elmdeleted−2

@@ -1,2 +0,0 @@

1−test f = let g x = f x

2− in g

tests/good/SoundnessAnnotated2.elmdeleted−2

@@ -1,2 +0,0 @@

1−test : a -> a

2−test x = let y = x in y

tests/good/SoundnessAnnotated3.elmdeleted−3

@@ -1,3 +0,0 @@

1−test : (a -> b) -> a -> b

2−test f = let g x = f x

3− in g

tests/good/Unify/LockedVars.elmnew file+6

@@ -0,0 +1,6 @@

1+-- unify flexible and locked types

2+import Dict

3+

4+multiplyKey ((i,j), _) = (i*j)

5+

6+x = map multiplyKey (Dict.toList (Dict.singleton (1,2) 0))

tests/good/Unify/NonHomogeneousRecords.elmnew file+8

@@ -0,0 +1,8 @@

1+

2+type Thing = { x:Float, y:Float }

3+

4+f : Thing -> Thing

5+f t =

6+ let x = t.x

7+ y = t.y

8+ in t

tests/testdeleted−7

@@ -1,7 +0,0 @@

1−#!/bin/sh

2−(

3− cd `dirname $0` &&

4− cabal configure --enable-tests &&

5− cabal build &&

6− cabal test

7−) || exit 1

tests/testRepldeleted−5

@@ -1,5 +0,0 @@

1−#!/bin/sh

2−

3−here=`cd \`dirname $0\` && pwd`

4−cd "$here/tests" &&

5−ghci

tests/tests/.ghcideleted−5

@@ -1,5 +0,0 @@

1−:set -i../src -i.

2−:l Main Parse.Parser

3−:m + Test.QuickCheck Main

4−:set prompt "test>> "

5−:set -Wall

tests/tests/Main.hsdeleted−54

@@ -1,54 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances, QuasiQuotes, ExtendedDefaultRules #-}

2−

3−

4−module Main where

5−

6−import Test.Framework as TF (defaultMain, testGroup, Test)

7−import Test.Framework.Providers.QuickCheck2 (testProperty)

8−

9−import Text.InterpolatedString.Perl6 (qq)

10−import Parse.Parser

11−import Util.Arbs

12−

13−import Debug.Trace

14−

15−main :: IO ()

16−main = defaultMain tests

17−

18−parses :: String -> Bool

19−parses code = either (const False) (const True) (parseProgram code)

20−

21−parseFails :: String -> Bool

22−parseFails = not . parses

23−

24−tests :: [TF.Test]

25−tests = [

26− testGroup "String Assignments" [

27− testProperty "prop_assignString" prop_assignString

28− , testProperty "prop_invalidIdent" prop_invalidIdent

29− , testProperty "prop_emptyList" prop_emptyList

30− , testProperty "prop_record" prop_record

31− ]

32− ]

33−

34−prop_assignString :: ValidIdent -> StringLiteral -> Bool

35−prop_assignString i s = parses [qq|

36−{i} = {s}

37−|]

38−

39−prop_invalidIdent :: ValidIdent -> InvalidIdentChar -> StringLiteral -> Bool

40−prop_invalidIdent i z s = parseFails [qq|

41−{i}{z} = {s}

42−|]

43−

44−prop_emptyList :: ValidIdent -> Bool

45−prop_emptyList i = parses [qq|

46−{i}=[]

47−|]

48−

49−prop_record :: ValidIdent -> ValidIdent -> ValidIdent -> ValidIdent -> StringLiteral -> Bool

50−prop_record a b c k v = parses [qq|

51−{a} = \{{k} = {v} \}

52−{b} = .{k} {a}

53−{c} = {a}.{k}

54−|]

tests/tests/Util/Arbs.hsdeleted−45

@@ -1,45 +0,0 @@

1−module Util.Arbs where

2−

3−import Control.Applicative

4−import Test.QuickCheck

5−import Util.CharGens

6−import Util.String

7−

8−import Text.InterpolatedString.Perl6 (ShowQ(showQ))

9−

10−

11−newtype ValidIdent = ValidIdent String deriving (Eq, Show)

12−

13−instance ShowQ ValidIdent where

14− showQ (ValidIdent v) = v

15−

16−instance Arbitrary ValidIdent where

17− arbitrary = ValidIdent <$> ((:) <$> lowerAlpha <*> (listOf alphaNumUnderPrime))

18−

19−

20−newtype StringLiteral = StringLiteral String deriving (Eq, Show)

21−

22−instance ShowQ StringLiteral where

23− showQ (StringLiteral v) = v

24−

25−instance Arbitrary StringLiteral where

26− arbitrary = StringLiteral <$> (\x -> "\"" ++ x ++ "\"") <$> escape <$> arbitrary

27−

28−

29−newtype InvalidIdentChar = InvalidIdentChar Char deriving (Eq, Show)

30−

31−instance ShowQ InvalidIdentChar where

32− showQ (InvalidIdentChar c) = [c]

33−

34−instance Arbitrary InvalidIdentChar where

35− arbitrary = InvalidIdentChar <$> elements "!@#$%^&*()-=+\\|/?.>,<`~"

36−

37−

38−newtype BuiltinType = BuiltinType String deriving (Eq, Show)

39−

40−instance ShowQ BuiltinType where

41− showQ (BuiltinType v) = v

42−

43−instance Arbitrary BuiltinType where

44− -- TODO: add others

45− arbitrary = BuiltinType <$> elements ["Char", "String"]

tests/tests/Util/CharGens.hsdeleted−19

@@ -1,19 +0,0 @@

1−module Util.CharGens where

2−

3−import Test.QuickCheck

4−import Test.QuickCheck.Property

5−

6−lowerAlpha :: Gen Char

7−lowerAlpha = elements ['a'..'z']

8−

9−upperAlpha :: Gen Char

10−upperAlpha = elements ['A'..'Z']

11−

12−alpha :: Gen Char

13−alpha = oneof [lowerAlpha, upperAlpha]

14−

15−alphaNum :: Gen Char

16−alphaNum = oneof [alpha, elements ['0'..'9']]

17−

18−alphaNumUnderPrime :: Gen Char

19−alphaNumUnderPrime = oneof [alphaNum, elements ['_', '\'']]

tests/tests/Util/String.hsdeleted−13

@@ -1,13 +0,0 @@

1−module Util.String where

2−

3−import qualified Data.Text as T

4−

5−replace :: String -> String -> String -> String

6−replace a b c = T.unpack (T.replace (T.pack a) (T.pack b) (T.pack c))

7−

8−escape :: String -> String

9−escape =

10− (replace "\n" "\\n") .

11− (replace "\t" "\\t") .

12− (replace "\"" "\\\"") .

13− (replace "\\" "\\\\")