476e87f · elk · git.iko.soy

.gitignore+1

compare with master

unifiedsplit

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

7*.aes

8*.elmi

9*.elmo

10+data

10*/ElmFiles/*

11*/ElmFiles/*

11.DS_Store

12.DS_Store

Elm.cabal+4−4

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

1Name: Elm

2−Version: 0.8.0.3

2+Version: 0.9.0.2

3Synopsis: The Elm language module.

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

5 It is a statically/strongly typed, functional reactive

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

21Build-type: Custom

22

23Extra-source-files: changelog.txt

24−Data-dir: dist/data

24+Data-dir: data

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

26Cabal-version: >=1.9

27

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

167Test-Suite test-elm

168 Type: exitcode-stdio-1.0

169 Hs-Source-Dirs: tests

170− Main-is: Everything.hs

170+ Main-is: Main.hs

171− build-depends: base

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/)

3

4## Install

5

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−

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

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

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

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

16Once the Haskell Platform is installed:

8Once the Haskell Platform is installed:

Setup.hs+19−10

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

11

12import Control.Monad

13import qualified Data.Binary as Binary

14+import qualified Data.ByteString.Lazy as BS

14

15

15-- Part 1

16-- Part 1

16-- ------

17-- ------

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

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

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

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

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

34rtsDir :: LocalBuildInfo -> FilePath

35rtsDir :: LocalBuildInfo -> FilePath

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

36+rtsDir lbi = "data"

36

37

37tempDir :: LocalBuildInfo -> FilePath

38tempDir :: LocalBuildInfo -> FilePath

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

39+tempDir lbi = "temp"

39

40

40-- The runtime is called:

41-- The runtime is called:

41rts :: LocalBuildInfo -> FilePath

42rts :: LocalBuildInfo -> FilePath

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

95 buildInterfaces lbi elmis

96 buildInterfaces lbi elmis

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

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

97 buildRuntime lbi elmos

98 buildRuntime lbi elmos

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

99+ removeDirectoryRecursive (tempDir lbi)

99 postBuild simpleUserHooks as bfs pd lbi

100 postBuild simpleUserHooks as bfs pd lbi

100

101

102

102compileLibraries lbi = do

103compileLibraries lbi = do

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

104+ let temp = tempDir lbi -- temp

104− rts = rtsDir lbi -- dist/data

105+ rts = rtsDir lbi -- data

105 createDirectoryIfMissing True temp

106 createDirectoryIfMissing True temp

106 createDirectoryIfMissing True rts

107 createDirectoryIfMissing True rts

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

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

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

109 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

110

111

111 let make file = do

112 let make file = do

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

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

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

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

114 -- to find docs.json

115 -- 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 ]

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

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

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

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

118 exitCode <- waitForProcess handle

120 exitCode <- waitForProcess handle

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

130buildInterfaces lbi elmis = do

132buildInterfaces lbi elmis = do

131 createDirectoryIfMissing True (rtsDir lbi)

133 createDirectoryIfMissing True (rtsDir lbi)

132 let ifaces = interfaces lbi

134 let ifaces = interfaces lbi

135+ ifaceHandle <- openBinaryFile ifaces WriteMode

133− Binary.encodeFile ifaces (length elmis)

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

134− mapM_ (\elmi -> readFile elmi >>= appendFile ifaces) 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

135

144

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

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

137buildRuntime lbi elmos = do

146buildRuntime lbi elmos = do

changelog.txt+13−2

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

6 * Major speed improvements to type-checker

7 * Type-checker should catch _all_ type errors now

8 * 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.

10

14

11Error Messages:

15Error Messages:

12 * Cross-module type errors

16 * Cross-module type errors

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

22 * Record Constructors

26 * Record Constructors

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

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

24 * (,,) syntax in types

28 * (,,) syntax in types

25− * "(+) = " is permitted

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

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

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

27

31

32+elm-server:

33+ * Build multi-module projects

34+ * Report all errors in browser

35+

28Libraries:

36Libraries:

29 * Detect hovering over any Element

37 * Detect hovering over any Element

30 * Set alpha of arbitrary forms in collages

38 * Set alpha of arbitrary forms in collages

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

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

32

40

41+Bug Fixes:

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

43+

33Website:

44Website:

34 * Hot-swapping

45 * Hot-swapping

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

46 * 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)

10import System.Directory

11import System.Exit

12import System.FilePath

13+import System.IO

13import GHC.Conc

14import GHC.Conc

14

15

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

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

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

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

17import qualified Text.Jasmine as JS

18import qualified Text.Jasmine as JS

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

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

20+import qualified Data.ByteString.Lazy as L

19

21

20import qualified Metadata.Prelude as Prelude

22import qualified Metadata.Prelude as Prelude

21import qualified Transform.Canonicalize as Canonical

23import qualified Transform.Canonicalize as Canonical

22import SourceSyntax.Module

24import SourceSyntax.Module

25+import Parse.Module (getModuleName)

23import Initialize (buildFromSource, getSortedDependencies)

26import Initialize (buildFromSource, getSortedDependencies)

24import Generate.JavaScript (jsModule)

27import Generate.JavaScript (jsModule)

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

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

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

40 , scripts :: [FilePath]

43 , scripts :: [FilePath]

41 , no_prelude :: Bool

44 , no_prelude :: Bool

42 , minify :: Bool

45 , minify :: Bool

43− , output_directory :: FilePath

46+ , cache_dir :: FilePath

47+ , build_dir :: FilePath

44 }

48 }

45 deriving (Data,Typeable,Show,Eq)

49 deriving (Data,Typeable,Show,Eq)

46

50

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

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

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

63 , minify = False

67 , minify = False

64 &= help "Minify generated JavaScript and HTML"

68 &= help "Minify generated JavaScript and HTML"

65− , output_directory = "ElmFiles" &= typFile

69+ , cache_dir = "cache" &= typFile

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

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."

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

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

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

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

69

75

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

78 fs -> mapM_ (build flags) fs

84 fs -> mapM_ (build flags) fs

79

85

80

86

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

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

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

89+

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

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

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

83

92

84elmo :: Flags -> FilePath -> FilePath

93elmo :: Flags -> FilePath -> FilePath

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

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

86

95

87elmi :: Flags -> FilePath -> FilePath

96elmi :: Flags -> FilePath -> FilePath

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

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

89

98

90

99

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

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

92buildFile flags moduleNum numModules interfaces filePath =

101buildFile flags moduleNum numModules interfaces filePath =

93 do compiled <- alreadyCompiled

102 do compiled <- alreadyCompiled

94− if not compiled then compile

103+ case compiled of

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

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

96 where

112 where

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

98− getInterface = snd

99−

100 alreadyCompiled :: IO Bool

113 alreadyCompiled :: IO Bool

101 alreadyCompiled = do

114 alreadyCompiled = do

102 existsi <- doesFileExist (elmi flags filePath)

115 existsi <- doesFileExist (elmi flags filePath)

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

110 number :: String

123 number :: String

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

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

112

125

113− name :: String

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

115−

116− compile :: IO ModuleInterface

126+ compile :: IO (String,ModuleInterface)

117 compile = do

127 compile = do

128+ source <- readFile filePath

129+ let name = case getModuleName source of

130+ Just n -> n

131+ Nothing -> "Main"

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

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

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

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

120 , "( " ++ filePath ++ " )" ]

134 , "( " ++ filePath ++ " )" ]

121− source <- readFile filePath

135+

136+ createDirectoryIfMissing True (cache_dir flags)

122− createDirectoryIfMissing True (output_directory flags)

137+ createDirectoryIfMissing True (build_dir flags)

123 metaModule <-

138 metaModule <-

124 case buildFromSource (no_prelude flags) interfaces source of

139 case buildFromSource (no_prelude flags) interfaces source of

125 Left errors -> do

140 Left errors -> do

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

139 iAliases = aliases metaModule

154 iAliases = aliases metaModule

140 }

155 }

141 createDirectoryIfMissing True . dropFileName $ elmi flags filePath

156 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

143 writeFile (elmo flags filePath) (jsModule metaModule)

160 writeFile (elmo flags filePath) (jsModule metaModule)

144− return interface

161+ return (name,interface)

145

162

146printTypes metaModule = do

163printTypes metaModule = do

147 putStrLn ""

164 putStrLn ""

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

161 let noPrelude = no_prelude flags

178 let noPrelude = no_prelude flags

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

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

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

180 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

165 js <- foldM appendToOutput "" files

182 js <- foldM appendToOutput "" files

166 case only_js flags of

183 case only_js flags of

167 True -> do

184 True -> do

168 putStr "Generating JavaScript ... "

185 putStr "Generating JavaScript ... "

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

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

170 putStrLn "Done"

187 putStrLn "Done"

171 False -> do

188 False -> do

172 putStr "Generating HTML ... "

189 putStr "Generating HTML ... "

173 runtime <- getRuntime flags

190 runtime <- getRuntime flags

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

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

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

192+ htmlFile = buildPath flags rootFile "html"

193+ createDirectoryIfMissing True (takeDirectory htmlFile)

194+ writeFile htmlFile html

176 putStrLn "Done"

195 putStrLn "Done"

177

196

178 where

197 where

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

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

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

188

207

189

208

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

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

191−buildFiles _ _ interfaces [] = return interfaces

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

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

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

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

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

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

195− interfaces' = Map.insert moduleName interface interfaces

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

196− buildFiles flags numModules interfaces' rest

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

40 -> String -- ^ The page title

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

42 -> H.Html

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

43+generateHtml libLoc title source = error "function 'generateHtml' is unimplemented 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−--}

61

44

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

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

63−createHtml libLoc title scripts noscript =

46+createHtml libLoc title scripts moduleName noscript =

64 H.docTypeHtml $ do

47 H.docTypeHtml $ do

65 H.head $ do

48 H.head $ do

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

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

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

68 makeScript (Link libLoc)

51 makeScript (Link libLoc)

69 mapM_ makeScript scripts

52 mapM_ makeScript scripts

70 H.body $ do

53 H.body $ do

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

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

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

72 H.noscript $ preEscapedToMarkup noscript

56 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

2

3import Control.Arrow (first,second)

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

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

15import SourceSyntax.Location

16import qualified Transform.SortDefinitions as SD

17

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−

27indent = concatMap f

18indent = concatMap f

28 where f '\n' = "\n "

19 where f '\n' = "\n "

29 f c = [c]

20 f c = [c]

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

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

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

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

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

86 where

77 where

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

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

88 pair x | isOp x = []

79 pair x | isOp x = []

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

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

90

81

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

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

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

130 toJS (Def (PVar x) e)

121 toJS (Def (PVar x) e)

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

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

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

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

133

124

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

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

135 do n <- guid

126 do n <- guid

136 let x = "_" ++ show n

127 let x = "_" ++ show n

137 var = L s . Var

128 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)])

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

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

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

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

142 return (stmt ++ vars)

132 return (stmt ++ vars)

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

154 Case e cases -> caseToJS span e cases

144 Case e cases -> caseToJS span e cases

155 _ -> toJS expr

145 _ -> toJS expr

156

146

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

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

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

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

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

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

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

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

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

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

162makeRecord kvs = record `liftM` collect kvs

152makeRecord kvs = record `liftM` collect kvs

163 where

153 where

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

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

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

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

166 prep (k, e) =

156 prep (k, e) =

167 do v <- toJS' e

157 do v <- toJS' e

168− return (deprime k, [v])

158+ return (k, [v])

169 fields fs =

159 fields fs =

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

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

171 hidden = fields . map (second jsList) .

161 hidden = fields . map (second jsList) .

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

186instance ToJS (Expr t v) where

176instance ToJS (Expr t v) where

187 toJS expr =

177 toJS expr =

188 case expr of

178 case expr of

189− Var x -> return (deprime x)

179+ Var x -> return x

190 Literal lit -> toJS lit

180 Literal lit -> toJS lit

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

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

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

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

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

197 Record fs -> makeRecord fs

187 Record fs -> makeRecord fs

198 Binop op e1 e2 -> binop op e1 e2

188 Binop op e1 e2 -> binop op e1 e2

199

189

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

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

201 where

191 where

202 fastFunc body

192 fastFunc body

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

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

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

195+ | otherwise =

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

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

197+

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

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

206

199

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

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

208 case pattern of

201 case pattern of

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

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

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

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

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

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

212

205

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

274 (tempVar,match) <- caseToMatch ps

267 (tempVar,match) <- caseToMatch ps

275 e' <- toJS' e

268 e' <- toJS' e

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

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

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

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

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

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

279 matches <- matchToJS span match'

272 matches <- matchToJS span match'

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

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

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

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

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

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

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

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

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

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

300+ pattern <- case value of

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

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

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

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

310− Right lit -> show lit

303+ Right lit -> toJS lit

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

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

312− [] -> name

305+ [] -> name

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

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

314− , ":", indent s ]

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

315

308

316jsNil = "_L.Nil"

309jsNil = "_L.Nil"

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

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

compiler/Language/Elm.hs+4−17

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

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

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

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

3 respective HTML, CSS, and JS code.

2 respective HTML, CSS, and JS code.

4

3

5 The documentation for the Elm language is available at

4 The documentation for the Elm language is available at

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

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

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

6 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>

11-}

7-}

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

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

13

9

14import qualified Data.List as List

10import qualified Data.List as List

15import qualified Data.Map as Map

11import qualified Data.Map as Map

16import Data.Version (showVersion)

12import Data.Version (showVersion)

17−import Generate.JavaScript (showErr, jsModule)

13+import Generate.JavaScript (jsModule)

18import Generate.Html (generateHtml)

14import Generate.Html (generateHtml)

19import Initialize (buildFromSource)

15import Initialize (buildFromSource)

20−import Parse.Helpers

16+import Parse.Module (getModuleName)

21−import Parse.Module (moduleDef)

22import SourceSyntax.Module

17import SourceSyntax.Module

23import Text.Blaze.Html (Html)

18import Text.Blaze.Html (Html)

24−import Text.Parsec (option,optional)

25import qualified Text.PrettyPrint as P

19import qualified Text.PrettyPrint as P

26import qualified Metadata.Prelude as Prelude

20import qualified Metadata.Prelude as Prelude

27import Paths_Elm

21import Paths_Elm

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

36

30

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

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

38moduleName :: String -> Maybe String

32moduleName :: String -> Maybe String

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

33+moduleName = getModuleName

40− Right name -> Just name

41− Left _ -> Nothing

42− where

43− getModuleName = do

44− optional freshLine

45− (names, _) <- moduleDef

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

47

34

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

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

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

36toHtml :: 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

6import System.Directory

7import System.Exit

8import System.FilePath

9+import System.IO

9import System.IO.Unsafe (unsafePerformIO)

10import System.IO.Unsafe (unsafePerformIO)

10import SourceSyntax.Module

11import SourceSyntax.Module

11import qualified Data.Binary as Binary

12import qualified Data.Binary as Binary

13+import qualified Data.ByteString.Lazy as BS

12

14

13

15

14add :: Module t v -> Module t v

16add :: Module t v -> Module t v

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

47readDocs :: FilePath -> IO Interfaces

49readDocs :: FilePath -> IO Interfaces

48readDocs name = do

50readDocs name = do

49 exists <- doesFileExist name

51 exists <- doesFileExist name

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

52+ case exists of

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

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 =

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

81joinL [e] [] = return e

82joinL (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."

84

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

86joinR [e] [] = return e

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

88 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."

90

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

92getAssoc table n eops

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

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

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

96− _ -> fail msg

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

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

97 where levelOps = filter (hasLevel table n) eops

98 where levelOps = filter (hasLevel table n) eops

98 assocs = map (opAssoc table . fst) levelOps

99 assocs = map (opAssoc table . fst) levelOps

100+ msg problem =

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

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

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

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

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

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

102

104

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

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

104infixStmt =

106infixStmt =

compiler/Parse/Helpers.hs+18−6

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

49innerVarChar :: IParser Char

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

51

52+deprime :: String -> String

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

54+

52makeVar :: IParser Char -> IParser String

55makeVar :: IParser Char -> IParser String

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

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

54 guard (v `notElem` reserveds)

57 guard (v `notElem` reserveds)

55− return v

58+ return (deprime v)

56

59

57reserved :: String -> IParser String

60reserved :: String -> IParser String

58reserved word =

61reserved word =

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

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

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

111

114

112constrainedSpacePrefix p constraint =

115constrainedSpacePrefix p constraint =

113− many . try $ do

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

117+ , try (spacing >> p)

118+ ]

119+ where

120+ spacing = do

114− n <- whitespace

121+ n <- whitespace

115− constraint n

122+ constraint n

116− indented

123+ indented

117− p

124+

125+failure msg = do

126+ inp <- getInput

127+ setInput ('x':inp)

128+ anyToken

129+ fail msg

118

130

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

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

120

132

compiler/Parse/Literal.hs+17−5

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

19 string "."

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

21

22+chr :: IParser Literal

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

24+ <?> "character"

25+

22str :: IParser Literal

26str :: 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

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

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

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

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

27 ]

30 ]

31+ where

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

33+ str = Str . dewindows

28

34

29−chr :: IParser Literal

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

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

36+ dewindows [] = []

31− <?> "character"

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 @@

1

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

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

3

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

5import Data.List (intercalate)

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

11varList :: IParser [String]

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

13

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+

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

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

15moduleDef = do

26moduleDef = do

16 try (reserved "module")

27 try (reserved "module")

compiler/Parse/Pattern.hs−68

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

64expr = do

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

66 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

64expr =

65 do t1 <- app <|> term

66 whitespace

67− arr <- optionMaybe arrow

67+ arr <- optionMaybe (try arrow)

68 whitespace

69 case arr of

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

compiler/SourceSyntax/Expression.hs+6−6

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

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

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

77 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

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

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

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

80 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)

82 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)

84

85 Modify e fs ->

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

87 4

88 (commaSep $ map field fs)

89 where

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

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

91

92 Record fs ->

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

94 where

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

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

96

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

98

compiler/SourceSyntax/Location.hs+1−1

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

49 Span start end _ ->

50 case line start == line end of

51 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 " ++

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

54

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

compiler/SourceSyntax/Pattern.hs+2−2

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

27 case pattern of

28 PVar x -> variable x

29 PLiteral lit -> pretty lit

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

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

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

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

32 PAnything -> PP.text "_"

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

34 where isCons = case hd of

compiler/SourceSyntax/PrettyPrint.hs+6−1

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

15

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

17

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 =

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

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

63 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)

65

66 get1 (a,_,_) = a

67 canon (name, importMethod) =

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

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

93

94

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

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

96−replace env v =

96+replace variable env v =

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

98 case Map.lookup v env of

99 Just v' -> return v'

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

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

101 where

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

103 msg = if null matches then "" else

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

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

130

131 Binop op e1 e2 ->

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

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

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

134

135 Lambda pattern e ->

136 let env' = extend env pattern in

137− Lambda pattern `liftM` rename env' e

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

138

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

140

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

149 Def p exp ->

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

151 TypeAnnotation name tipe ->

152+ TypeAnnotation name `liftM`

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

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

153

154

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

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

155

156

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

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

157

158

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

173 PRecord _ -> return pattern

174 PRecord _ -> return pattern

174 PAnything -> return pattern

175 PAnything -> return pattern

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

176 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

177 `ap` mapM (renamePattern env) ps

178 `ap` mapM (renamePattern env) ps

compiler/Transform/Check.hs+2−2

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

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

40

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

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

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

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

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

44

45

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

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

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

6import Control.Arrow (second)

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

8import qualified Control.Monad as Monad

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

9import Control.Monad.State

10import Control.Monad.State

10import Data.Traversable (traverse)

11import Data.Traversable (traverse)

11

12

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

33 case expr of

34 case expr of

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

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

35

36

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

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

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

37

39

38 Range lo hi ->

40 Range lo hi ->

39 exists $ \x -> do

41 exists $ \x -> do

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

56 Lambda p e ->

58 Lambda p e ->

57 exists $ \t1 ->

59 exists $ \t1 ->

58 exists $ \t2 -> do

60 exists $ \t2 -> do

59− fragment <- Pattern.constrain env p t1

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

60 c2 <- constrain env e t2

62 c2 <- constrain env e t2

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

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

62 (typeConstraint fragment /\ c2 ))

64 (typeConstraint fragment /\ c2 ))

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

80 exists $ \t -> do

82 exists $ \t -> do

81 ce <- constrain env exp t

83 ce <- constrain env exp t

82 let branch (p,e) = do

84 let branch (p,e) = do

83− fragment <- Pattern.constrain env p t

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

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

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

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

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

86

88

87 Data name exprs ->

89 Data name exprs ->

88− do pairs <- mapM pair exprs

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

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

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

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

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

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

91 where

94 where

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

93− return (e, VarN v)

94−

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

96 c' <- constrain env e x

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

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

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

138

139 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

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

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

144 Monad.foldM (constrainDef env)

142 Monad.foldM (constrainDef env)

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

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

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

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

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

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

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

154 in

152 in

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

155+ case (pattern, maybeTipe) of

156− (PVar name, Just tipe) ->

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

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

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

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

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

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

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

168 , flexibleQuantifiers

169 , headers

170 , c2

171− , fl rigidQuantifiers c /\ c1 )

171+ , fl rigidVars c /\ c1 )

172

173− (PVar name, Nothing) ->

173+ (PVar name, Nothing) -> do

174− do v <- var Flexible

174+ v <- var Flexible

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

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

177 let tipe = VarN v

175 let tipe = VarN v

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

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

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

177 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) =

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

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

195 where

193 where

196 vars = Set.toList $ SD.boundVars pattern

194 vars = Set.toList $ SD.boundVars pattern

197− x = concat vars

195+ x = "$" ++ concat vars

198 var = L s . Var

196 var = L s . Var

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

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

200

198

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

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

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

214 TypeAnnotation name typ ->

212 TypeAnnotation name typ ->

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

213 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

3import Control.Arrow (second)

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

5import qualified Control.Monad as Monad

6+import Control.Monad.Error

6import qualified Data.List as List

7import qualified Data.List as List

7import qualified Data.Maybe as Maybe

8import qualified Data.Maybe as Maybe

8import qualified Data.Map as Map

9import qualified Data.Map as Map

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

17import qualified Type.Constrain.Literal as Literal

18import qualified Type.Constrain.Literal as Literal

18

19

20

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

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

21constrain env pattern tipe =

22constrain env pattern tipe =

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

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

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

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

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

27 PAnything -> return emptyFragment

28 PAnything -> return emptyFragment

28

29

29 PLiteral lit -> do

30 PLiteral lit -> do

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

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

31 return $ emptyFragment { typeConstraint = c }

32 return $ emptyFragment { typeConstraint = c }

32

33

33 PVar name -> do

34 PVar name -> do

34− v <- var Flexible

35+ v <- liftIO $ var Flexible

35 return $ Fragment {

36 return $ Fragment {

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

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

37 vars = [v],

38 vars = [v],

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

46 }

47 }

47

48

48 PData name patterns -> do

49 PData name patterns -> do

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

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

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

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

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

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

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

53 , " 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

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

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

55 return $ fragment {

56 return $ fragment {

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

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

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

58 }

59 }

59

60

60 PRecord fields -> do

61 PRecord fields -> do

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

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

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

63 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)

64 return $ Fragment {

65 return $ Fragment {

65 typeEnv = tenv,

66 typeEnv = tenv,

66 vars = map snd pairs,

67 vars = map snd pairs,

compiler/Type/Environment.hs+29−27

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

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

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

101 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."

103

104

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

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

122

123 Src.Var x -> do

124 (dict, aliases) <- State.get

125− case Map.lookup x dict of

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

126− Just var -> return (VarN var)

127− Nothing ->

128− case Map.lookup x aliases of

129− Just t -> return t

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

130− Nothing ->

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

128+ _ ->

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

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

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

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

133− return (VarN var)

131+ return (VarN var)

134− where

132+ where

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

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

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

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

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

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

138− | otherwise = Flexible

136+ | otherwise = Flexible

139

137

140 Src.Data "String" [] ->

138 Src.Data "String" [] ->

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

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

142

140

143 Src.Data name ts -> do

141 Src.Data name ts -> do

144 ts' <- mapM go ts

142 ts' <- mapM go ts

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

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

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

144+ (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) ->

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

146+ let tvarLen = length tvars

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

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

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

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

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

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

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

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

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

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

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

153+ State.put (dict, aliases')

156− go t

154+ t' <- go t

155+ State.put (dict, aliases)

156+ return t'

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

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

157

159

158 Src.EmptyRecord -> return (TermN EmptyRecord1)

160 Src.EmptyRecord -> return (TermN EmptyRecord1)

159

161

compiler/Type/PrettyPrint.hs+4−1

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

2module Type.PrettyPrint where

3

4import Text.PrettyPrint

5+import qualified SourceSyntax.PrettyPrint as Src

5

6

6data ParensWhen = Fn | App | Never

7data ParensWhen = Fn | App | Never

7

8

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

10

11

11commaSep docs = sep (punctuate comma docs)

12commaSep docs = sep (punctuate comma docs)

12

13

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

49 -- otherwise generalize

50 let registerIfLowerRank var = do

51 isRedundant <- liftIO $ UF.redundant var

52− if isRedundant then return () else do

52+ case isRedundant of

53+ True -> return ()

54+ False -> do

53 desc <- liftIO $ UF.descriptor var

55 desc <- liftIO $ UF.descriptor var

54− if rank desc < youngRank

56+ case rank desc < youngRank of

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

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

58+ False -> do

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

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

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

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

58−

61+

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

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

60−

61− return ()

62

63

64

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

65-- 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 =

62 NoSpan msg -> display msg

63 Span _ _ msg -> display msg

64

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

66+

65 makeError pt1 pt2 =

67 makeError pt1 pt2 =

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

68 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

68 , P.text src

70 , P.text src

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

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

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

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

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

137 () | mark desc == alreadyCopied ->

139 () | mark desc == alreadyCopied ->

138 case copy desc of

140 case copy desc of

139 Just v -> return v

141 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!"

141

144

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

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

143 return variable

146 return variable

compiler/Type/Type.hs+7−3

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

176 prettyExt = prty ext

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

178 | 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

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

181

182

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

191 pretty when desc =

192 case (structure desc, name desc) of

193 (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

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

196 _ -> P.text "?"

197

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

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

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

279 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 -> "#"

281

285

282

286

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

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

compiler/Type/Unify.hs+15−5

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

7import Control.Arrow (first,second)

8import Control.Monad.State

9import SourceSyntax.Location

10+import Type.PrettyPrint

11+import Text.PrettyPrint (render)

10

12

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

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

12unify span variable1 variable2 = do

14unify span variable1 variable2 = do

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

75 unify' variable1 variable2

77 unify' variable1 variable2

76

78

77 unifyNumber svar name

79 unifyNumber svar name

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

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

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

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

80

82

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

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

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

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

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

84

86

85 unifyComparable var name

87 unifyComparable var name

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

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

87 | otherwise = comparableError ""

89 | otherwise = comparableError ""

88

90

89 unifyComparableStructure varSuper varFlex =

91 unifyComparableStructure varSuper varFlex =

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

106 List _ -> flexAndUnify varSuper

108 List _ -> flexAndUnify varSuper

107 _ -> comparableError ""

109 _ -> comparableError ""

108

110

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+

109 superUnify =

117 superUnify =

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

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

111 (Is super1, Is super2, _, _)

119 (Is super1, Is super2, _, _)

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

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

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

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

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

128

136

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

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

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

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

130

140

131 case (structure desc1, structure desc2) of

141 case (structure desc1, structure desc2) of

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

158

168

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

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

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

170 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

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

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

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

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

164 (True , False) -> do

174 (True , False) -> do

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

168 record1' <- mkRecord fields1' ext1

178 record1' <- mkRecord fields1' ext1

169 unify' record1' ext2

179 unify' record1' ext2

170 (False, False) -> do

180 (False, False) -> do

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

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

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

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

173 unify' record1' ext2

183 unify' record1' ext2

174 unify' ext1 record2'

184 unify' ext1 record2'

175 where

185 where

libraries/Automaton.elm+2−2

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

80average k =

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

82 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))

84 stepFull n (ns,len,sum) =

85 case dequeue ns of

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

87 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)

89 in hiddenState (empty,0,0) step

90

91

libraries/Color.elm+29−33

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

14rgb : Int -> Int -> Int -> Color

15rgb r g b = Color r g b 1

16

17−red : Color

17+lightYellow = Color 255 233 79 1

18−red = Color 255 0 0 1

18+yellow = Color 237 212 0 1

19−lime : Color

19+darkYellow = Color 196 160 0 1

20−lime = Color 0 255 0 1

20+

21−blue : Color

21+lightOrange = Color 252 175 62 1

22−blue = Color 0 0 255 1

22+orange = Color 245 121 0 1

23−

23+darkOrange = Color 206 92 0 1

24−yellow : Color

24+

25−yellow = Color 255 255 0 1

25+lightBrown = Color 233 185 110 1

26−cyan : Color

26+brown = Color 193 125 17 1

27−cyan = Color 0 255 255 1

27+darkBrown = Color 143 89 2 1

28−magenta : Color

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

29−magenta = Color 255 0 255 1

42+red = Color 204 0 0 1

30−

43+darkRed = Color 164 0 0 1

31−black : Color

44+

32black = Color 0 0 0 1

45black = Color 0 0 0 1

33−white : Color

34white = Color 255 255 255 1

46white = Color 255 255 255 1

35

47

36gray : Color

48gray : Color

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

38grey : Color

50grey : Color

39grey = Color 128 128 128 1

51grey = Color 128 128 128 1

40

52

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−

58-- Produce a “complementary color”.

53-- Produce a “complementary color”.

59-- The two colors will accent each other.

54-- The two colors will accent each other.

60complement : Color -> Color

55complement : Color -> Color

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

67

62

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

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

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

64-- 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).

70--

66--

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

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

72hsv : Float -> Float -> Float -> Color

68hsv : Float -> Float -> Float -> Color

libraries/Graphics/Collage.elm+15−15

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

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

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

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

131−rotate : Float -> Form -> Form

131+rotate : number -> Form -> Form

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

133

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

135−scale : Float -> Form -> Form

135+scale : number -> Form -> Form

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

137

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

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

140-- right.

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

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

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

143

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

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

146−moveX : Float -> Form -> Form

146+moveX : number -> Form -> Form

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

148

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

150-- `form` upwards by 10 pixels.

151−moveY : Float -> Form -> Form

151+moveY : number -> Form -> Form

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

153

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

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

161collage = Native.Graphics.Collage.collage

162

163

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

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

165

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

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

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

168path ps = ps

169

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

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

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

172segment p1 p2 = [p1,p2]

173

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

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

175

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

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

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

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

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

180polygon points = points

181

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

183−rect : Float -> Float -> Shape

183+rect : number -> number -> Shape

184rect w h = let hw = w/2

185 hh = h/2

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

187

188-- A square with a given edge length.

189−square : Float -> Shape

189+square : number -> Shape

190square n = rect n n

191

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

193−oval : Float -> Float -> Shape

193+oval : number -> number -> Shape

194oval w h =

195 let n = 50

196 t = 2 * pi / n

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

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

201

202-- A circle with a given radius.

203−circle : Float -> Shape

203+circle : number -> Shape

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

205

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

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

208-- 30 you would say:

209--

210-- ngon 5 30

211−ngon : Int -> Float -> Shape

211+ngon : Int -> number -> Shape

212ngon n r =

213 let m = toFloat n

214 t = 2 * pi / m

libraries/Graphics/Input.elm+4

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

75 let cbs = checkboxes b

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

77

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.

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

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

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

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

80hoverables = Native.Graphics.Input.hoverables

83hoverables = Native.Graphics.Input.hoverables

81

84

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

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

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

83hoverable elem =

87hoverable elem =

84 let pool = hoverables False

88 let pool = hoverables False

libraries/List.elm+2−2

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

91

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

93and : [Bool] -> Bool

94−and = Native.List.and

94+and = foldl (&&) True

95

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

97or : [Bool] -> Bool

98−or = Native.List.or

98+or = foldl (||) False

99

100-- Concatenate a list of appendable things:

101--

libraries/Native/Char.js+1−1

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

16

17 return elm.Native.Char = {

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

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

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

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

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

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

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

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

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

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

6

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+

7 var Signal = Elm.Signal(elm);

15 var Signal = Elm.Signal(elm);

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

16 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;

9

45

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

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

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

47+ ++count;

12−

48+ if (changed) {

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

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

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

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

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

51+ isChanged = true;

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

16− });

53+ }

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

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

55+ isChanged = true;

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

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

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

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

20− });

58+ }

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

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

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

60+ isChanged = true;

61+ this.value = NList.Nil;

62+ }

23− });

63+ }

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

64+ if (count == n) {

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

65+ send(this, timestep, isChanged);

26− });

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));

27

76

28 function keySignal(f) {

77 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

30 keysDown.defaultNumberOfKids += 1;

80 keysDown.defaultNumberOfKids += 1;

31 signal.defaultNumberOfKids = 0;

81 signal.defaultNumberOfKids = 0;

32 return signal;

82 return signal;

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

51

101

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

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

53

103

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

105+

54 return elm.Native.Keyboard = {

106 return elm.Native.Keyboard = {

55− isDown:is,

107+ isDown:is,

56− directions:F4(dir),

108+ directions:F4(dir),

57− keysDown:keysDown,

109+ keysDown:keysDown,

58− lastPressed:lastKey

110+ lastPressed:lastPressed

59 };

111 };

60

112

61};

113};

libraries/Signal.elm+2−1

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

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

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

54--

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.

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

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

57foldp = Native.Signal.foldp

58foldp = Native.Signal.foldp

58

59

runtime/Init.js−1

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

115

116 // rerender scene if graphics are enabled.

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

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

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

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

120 }

119 }

121 }

120 }

runtime/Render/Element.js+2−2

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

252 e.style.opacity = props.opacity;

253 }

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

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

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

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

257− e.style.backgroundColor = nextColor;

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

258 }

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

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

runtime/Render/Utils.js+2−2

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

14}

15

16function extract(c) {

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

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

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

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

19}

20

21function addTransform(style, trans) {

server/Server.hs+33−14

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

7import Data.Version (showVersion)

8import Happstack.Server

9import Happstack.Server.Compression

10+import System.Directory

10import System.Environment

11import System.Environment

12+import System.Exit

11import System.FilePath

13import System.FilePath

14+import System.Process

15+import GHC.IO.Handle

12import qualified Language.Elm as Elm

16import qualified Language.Elm as Elm

13import Paths_elm_server

17import Paths_elm_server

14

18

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

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

16

20

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

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

18serve portNumber libLoc = do

22serve portNumber libLoc = do

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

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

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

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

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

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

22 simpleHTTP httpConf $ do

26 simpleHTTP httpConf $ do

23 _ <- compressedResponseFilter

27 _ <- compressedResponseFilter

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

30pageTitle :: String -> String

34pageTitle :: String -> String

31pageTitle = dropExtension . takeBaseName

35pageTitle = dropExtension . takeBaseName

32

36

37+serveElm :: FilePath -> ServerPartT IO Response

33serveElm fp = do

38serveElm fp = do

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

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

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

40+ let file = tail fp

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

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")

37

53

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

38serveLib libLoc fp = do

55serveLib libLoc fp = do

39 guard (fp == runtime)

56 guard (fp == runtime)

40 serveFile (asContentType "application/javascript") libLoc

57 serveFile (asContentType "application/javascript") libLoc

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

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

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

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

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

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

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

65+parse args =

48−parse args = if null remainingArgs

66+ case null remainingArgs of

49− then serve portNumber =<< elmRuntime

67+ True -> serve portNumber =<< elmRuntime

50− else putStrLn usageMini

68+ False -> putStrLn usageMini

69+ where

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

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

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

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

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

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

54

73

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

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

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

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

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

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

58

77

59usageMini :: String

78usageMini :: String

60usageMini =

79usageMini =

server/elm-server.cabal+5−3

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

1Name: elm-server

2−Version: 0.8

2+Version: 0.9.0.2

3Synopsis: The Elm language server.

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

5

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

27 Main-is: Server.hs

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

29 containers >= 0.3,

30+ directory,

30 transformers >= 0.2,

31 transformers >= 0.2,

31 mtl >= 2,

32 mtl >= 2,

32 parsec >= 3.1.1,

33 parsec >= 3.1.1,

33 blaze-html >= 0.5.1,

34 blaze-html >= 0.5.1,

34 HTTP >= 4000,

35 HTTP >= 4000,

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

36+ happstack-server,

36 deepseq,

37 deepseq,

37 filepath,

38 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 =

2 let id x = x in id

3 let id x = x in id

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

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

1+

1−test = let id : a -> a

2+myId = let id : a -> a

2 id x = x

3 id x = x

3 in id

4 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 "\\" "\\\\")