892464e · elk · git.iko.soy

.gitignore+1

compare with master

unifiedsplit

@@ -10,3 +10,4 @@ cabal-dev

10data

11*/ElmFiles/*

12.DS_Store

13+*~

.travis.ymlnew file+3

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

1+language: haskell

2+ghc:

3+ - 7.6

Elm.cabal+51−7

@@ -47,18 +47,21 @@ Library

47 SourceSyntax.PrettyPrint,

48 SourceSyntax.Type,

49 Generate.JavaScript,

50+ Generate.JavaScript.Helpers,

51+ Generate.JavaScript.Ports,

50 Generate.Noscript,

52 Generate.Noscript,

51 Generate.Markdown,

53 Generate.Markdown,

52 Generate.Html,

54 Generate.Html,

53 Generate.Cases,

55 Generate.Cases,

54 Transform.Canonicalize,

56 Transform.Canonicalize,

55 Transform.Check,

57 Transform.Check,

58+ Transform.Expression,

59+ Transform.Declaration,

60+ Transform.Definition,

56 Transform.SafeNames,

61 Transform.SafeNames,

57 Transform.SortDefinitions,

62 Transform.SortDefinitions,

58 Transform.Substitute,

63 Transform.Substitute,

59− Transform.Optimize,

60 Metadata.Prelude,

64 Metadata.Prelude,

61− InterfaceSerialization,

62 Parse.Binop,

65 Parse.Binop,

63 Parse.Declaration,

66 Parse.Declaration,

64 Parse.Expression,

67 Parse.Expression,

@@ -85,6 +88,7 @@ Library

85 Build.Dependencies,

88 Build.Dependencies,

86 Build.File,

89 Build.File,

87 Build.Flags,

90 Build.Flags,

91+ Build.Interface,

88 Build.Print,

92 Build.Print,

89 Build.Source,

93 Build.Source,

90 Build.Utils,

94 Build.Utils,

@@ -125,18 +129,21 @@ Executable elm

125 SourceSyntax.PrettyPrint,

129 SourceSyntax.PrettyPrint,

126 SourceSyntax.Type,

130 SourceSyntax.Type,

127 Generate.JavaScript,

131 Generate.JavaScript,

132+ Generate.JavaScript.Helpers,

133+ Generate.JavaScript.Ports,

128 Generate.Noscript,

134 Generate.Noscript,

129 Generate.Markdown,

135 Generate.Markdown,

130 Generate.Html,

136 Generate.Html,

131 Generate.Cases,

137 Generate.Cases,

132 Transform.Canonicalize,

138 Transform.Canonicalize,

133 Transform.Check,

139 Transform.Check,

140+ Transform.Expression,

141+ Transform.Declaration,

142+ Transform.Definition,

134 Transform.SafeNames,

143 Transform.SafeNames,

135 Transform.SortDefinitions,

144 Transform.SortDefinitions,

136 Transform.Substitute,

145 Transform.Substitute,

137− Transform.Optimize,

138 Metadata.Prelude,

146 Metadata.Prelude,

139− InterfaceSerialization,

140 Parse.Binop,

147 Parse.Binop,

141 Parse.Declaration,

148 Parse.Declaration,

142 Parse.Expression,

149 Parse.Expression,

@@ -163,6 +170,7 @@ Executable elm

163 Build.Dependencies,

170 Build.Dependencies,

164 Build.File,

171 Build.File,

165 Build.Flags,

172 Build.Flags,

173+ Build.Interface,

166 Build.Print,

174 Build.Print,

167 Build.Source,

175 Build.Source,

168 Build.Utils,

176 Build.Utils,

@@ -224,10 +232,46 @@ Executable elm-doc

224 pandoc >= 1.10,

232 pandoc >= 1.10,

225 parsec >= 3.1.1,

233 parsec >= 3.1.1,

226 pretty,

234 pretty,

227− text

235+ text,

236+ union-find

228

237

229Test-Suite test-elm

238Test-Suite test-elm

230 Type: exitcode-stdio-1.0

239 Type: exitcode-stdio-1.0

231− Hs-Source-Dirs: tests

240+ Hs-Source-Dirs: tests, compiler

232 Main-is: Main.hs

241 Main-is: Main.hs

242+ other-modules: Tests.Compiler

243+ Tests.Property

244+ Tests.Property.Arbitrary

245+ SourceSyntax.Helpers

246+ SourceSyntax.Literal

247+ SourceSyntax.PrettyPrint

233− build-depends: base, directory, HTF

248+ build-depends: base,

249+ directory,

250+ Elm,

251+ test-framework,

252+ test-framework-hunit,

253+ test-framework-quickcheck2,

254+ HUnit,

255+ pretty,

256+ QuickCheck >= 2 && < 3,

257+ filemanip,

258+ aeson,

259+ base >=4.2 && <5,

260+ binary >= 0.6.4.0,

261+ blaze-html == 0.5.* || == 0.6.*,

262+ blaze-markup == 0.5.1.*,

263+ bytestring,

264+ cmdargs,

265+ containers >= 0.3,

266+ directory,

267+ filepath,

268+ indents,

269+ language-ecmascript >=0.15 && < 1.0,

270+ mtl >= 2,

271+ pandoc >= 1.10,

272+ parsec >= 3.1.1,

273+ pretty,

274+ text,

275+ transformers >= 0.2,

276+ union-find,

277+ unordered-containers

README.md+1

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

1Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/).

2

3+[![Build Status](https://travis-ci.org/evancz/Elm.png)](https://travis-ci.org/evancz/Elm)

3

4

4## Install

5## Install

5

6

compiler/Build/Dependencies.hs+47−53

@@ -1,42 +1,32 @@

1+{-# OPTIONS_GHC -W #-}

1−module Build.Dependencies (getSortedDependencies) where

2+module Build.Dependencies (getSortedDependencies, readDeps) where

2

3

3−import Data.Data

4import Control.Applicative

5import Control.Monad.Error

6import qualified Control.Monad.State as State

7import qualified Data.Aeson as Json

8import qualified Data.ByteString.Lazy.Char8 as BSC

9−import qualified Data.Char as Char

10import qualified Data.Graph as Graph

9import qualified Data.Graph as Graph

11import qualified Data.List as List

10import qualified Data.List as List

12import qualified Data.Map as Map

11import qualified Data.Map as Map

13import qualified Data.Maybe as Maybe

12import qualified Data.Maybe as Maybe

14import qualified Data.Set as Set

13import qualified Data.Set as Set

15import System.Directory

14import System.Directory

16−import System.Exit

17import System.FilePath as FP

15import System.FilePath as FP

18−import System.IO

16+

19−import Text.PrettyPrint (Doc)

17+import Build.Print (failure)

20

18

21import qualified SourceSyntax.Module as Module

19import qualified SourceSyntax.Module as Module

22−import qualified SourceSyntax.Type as Type

23import qualified Parse.Parse as Parse

20import qualified Parse.Parse as Parse

24−import qualified Metadata.Prelude as Prelude

25−import qualified Transform.Check as Check

26−import qualified Transform.SortDefinitions as SD

27−import qualified Type.Inference as TI

28−import qualified Type.Constrain.Declaration as TcDecl

29−import qualified Transform.Canonicalize as Canonical

30import qualified Elm.Internal.Paths as Path

21import qualified Elm.Internal.Paths as Path

31import qualified Elm.Internal.Name as N

22import qualified Elm.Internal.Name as N

32−import qualified Elm.Internal.Version as V

33import qualified Elm.Internal.Dependencies as Deps

23import qualified Elm.Internal.Dependencies as Deps

34

24

35getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]

25getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [String]

36getSortedDependencies srcDirs builtIns root =

26getSortedDependencies srcDirs builtIns root =

37 do extras <- extraDependencies

27 do extras <- extraDependencies

38 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras

28 let allSrcDirs = srcDirs ++ Maybe.fromMaybe [] extras

39− result <- runErrorT $ readDeps allSrcDirs builtIns root

29+ result <- runErrorT $ readAllDeps allSrcDirs builtIns root

40 case result of

30 case result of

41 Right deps -> sortDeps deps

31 Right deps -> sortDeps deps

42 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg

32 Left err -> failure $ err ++ if Maybe.isJust extras then "" else msg

@@ -44,8 +34,6 @@ getSortedDependencies srcDirs builtIns root =

44 Path.dependencyFile ++

34 Path.dependencyFile ++

45 " file if you\nare trying to use a 3rd party library."

35 " file if you\nare trying to use a 3rd party library."

46

36

47−failure msg = hPutStrLn stderr msg >> exitFailure

48−

49extraDependencies :: IO (Maybe [FilePath])

37extraDependencies :: IO (Maybe [FilePath])

50extraDependencies =

38extraDependencies =

51 do exists <- doesFileExist Path.dependencyFile

39 do exists <- doesFileExist Path.dependencyFile

@@ -86,46 +74,52 @@ sortDeps depends =

86 mistakes = filter (\scc -> length scc > 1) sccs

74 mistakes = filter (\scc -> length scc > 1) sccs

87 msg = "A cyclical module dependency or was detected in:\n"

75 msg = "A cyclical module dependency or was detected in:\n"

88

76

89−readDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]

77+readAllDeps :: [FilePath] -> Module.Interfaces -> FilePath -> ErrorT String IO [Deps]

90−readDeps srcDirs builtIns root = do

78+readAllDeps srcDirs builtIns root =

91− let ifaces = (Set.fromList . Map.keys) builtIns

79+ do let ifaces = (Set.fromList . Map.keys) builtIns

92− State.evalStateT (go ifaces root) Set.empty

80+ State.evalStateT (go ifaces root) Set.empty

93 where

81 where

94 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]

82 go :: Set.Set String -> FilePath -> State.StateT (Set.Set String) (ErrorT String IO) [Deps]

95 go builtIns root = do

83 go builtIns root = do

96− (root', txt) <- lift $ getFile srcDirs root

84+ root' <- lift $ findSrcFile srcDirs root

97− case Parse.dependencies txt of

85+ (name, deps) <- lift $ readDeps root'

98− Left err -> throwError $ msg ++ show err

99− where msg = "Error resolving dependencies in " ++ root' ++ ":\n"

100−

101− Right (name,deps) ->

102− do seen <- State.get

86+ seen <- State.get

103− let realDeps = Set.difference (Set.fromList deps) builtIns

87+ let realDeps = Set.difference (Set.fromList deps) builtIns

104− newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen

88+ newDeps = Set.difference (Set.filter (not . isNative) realDeps) seen

105− State.put (Set.insert name (Set.union newDeps seen))

89+ State.put (Set.insert name (Set.union newDeps seen))

106− rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)

90+ rest <- mapM (go builtIns . toFilePath) (Set.toList newDeps)

107− return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)

91+ return ((makeRelative "." root', name, Set.toList realDeps) : concat rest)

108−

92+

93+readDeps :: FilePath -> ErrorT String IO (String, [String])

94+readDeps path = do

95+ txt <- lift $ readFile path

96+ case Parse.dependencies txt of

97+ Left err -> throwError $ msg ++ show err

98+ where msg = "Error resolving dependencies in " ++ path ++ ":\n"

99+ Right o -> return o

100+

109−getFile :: [FilePath] -> FilePath -> ErrorT String IO (FilePath,String)

101+findSrcFile :: [FilePath] -> FilePath -> ErrorT String IO FilePath

110−getFile [] path =

102+findSrcFile dirs path = foldr tryDir notFound dirs

103+ where

111− throwError $ unlines

104+ notFound = throwError $ unlines

112− [ "Could not find file: " ++ path

105+ [ "Could not find file: " ++ path

113− , " If it is not in the root directory of your project, use"

106+ , " If it is not in the root directory of your project, use"

114− , " --src-dir to declare additional locations for source files."

107+ , " --src-dir to declare additional locations for source files."

115− , " If it is part of a 3rd party library, it needs to be declared"

108+ , " If it is part of a 3rd party library, it needs to be declared"

116− , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]

109+ , " as a dependency in the " ++ Path.dependencyFile ++ " file." ]

117−

110+ tryDir dir next = do

118−getFile (dir:dirs) path = do

119− let path' = dir </> path

111+ let path' = dir </> path

120− exists <- liftIO $ doesFileExist path'

112+ exists <- liftIO $ doesFileExist path'

121− case exists of

113+ if exists

122− True -> (,) path' `fmap` liftIO (readFile path')

114+ then return path'

123− False -> getFile dirs path

115+ else next

124−

116+

117+isNative :: String -> Bool

125isNative name = List.isPrefixOf "Native." name

118isNative name = List.isPrefixOf "Native." name

126

119

127toFilePath :: String -> FilePath

120toFilePath :: String -> FilePath

128toFilePath name = map swapDots name ++ ext

121toFilePath name = map swapDots name ++ ext

122+ where

129− where swapDots '.' = '/'

123+ swapDots '.' = '/'

130− swapDots c = c

124+ swapDots c = c

131− ext = if isNative name then ".js" else ".elm"

125+ ext = if isNative name then ".js" else ".elm"

compiler/Build/File.hs+131−81

@@ -1,93 +1,137 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.File (build) where

2module Build.File (build) where

2

3

3−import Control.Monad (when)

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

4−import qualified Data.Binary as Binary

5+import Control.Monad.Error (runErrorT)

5−import qualified Data.List as List

6+import Control.Monad.RWS.Strict

6−import qualified Data.Map as Map

7import System.Directory

8import System.Exit

9import System.FilePath

10import System.IO

11

12+import qualified Data.Binary as Binary

13+import qualified Data.Maybe as Maybe

14+import qualified Data.Map as Map

15+import qualified Data.ByteString.Lazy as L

16+

17+import qualified Build.Dependencies as Deps

18+import qualified Build.Flags as Flag

19+import qualified Build.Interface as Interface

20+import qualified Build.Print as Print

21+import qualified Build.Source as Source

22+import qualified Build.Utils as Utils

23+import qualified Generate.JavaScript as JS

24+import qualified Parse.Module as Parser

25+import qualified SourceSyntax.Module as M

12import qualified Transform.Canonicalize as Canonical

26import qualified Transform.Canonicalize as Canonical

13

27

14−import qualified Data.ByteString.Lazy as L

28+-- Reader: Runtime flags, always accessible

15−

29+-- Writer: Remember the last module to be accessed

16−import qualified Build.Utils as Utils

30+-- State: Build up a map of the module interfaces

17−import qualified Build.Flags as Flag

31+type BuildT m a = RWST Flag.Flags (Last String) BInterfaces m a

18−import qualified Build.Source as Source

32+type Build a = BuildT IO a

19−import qualified Build.Print as Print

33+

20−import qualified Generate.JavaScript as JS

34+-- Interfaces, remembering if something was recompiled

21−import qualified InterfaceSerialization as IS

35+type BInterfaces = Map.Map String (Bool, M.ModuleInterface)

22−import qualified Parse.Module as Parser

36+

23−import qualified SourceSyntax.Module as M

24−

25−build :: Flag.Flags -> Int -> M.Interfaces -> String -> [FilePath]

37+evalBuild :: Flag.Flags -> M.Interfaces -> Build () -> IO (Maybe String)

26− -> IO (String, M.Interfaces)

38+evalBuild flags interfaces b = do

27−build _ _ interfaces moduleName [] =

39+ (_, s) <- evalRWST b flags (fmap notUpdated interfaces)

28− return (moduleName, interfaces)

40+ return . getLast $ s

29−build flags numModules interfaces _ (filePath:rest) =

41+ where

30− do (name,interface) <-

42+ notUpdated i = (False, i)

31− build1 flags (numModules - length rest) numModules interfaces filePath

43+

32− let interfaces' = Map.insert name interface interfaces

44+-- | Builds a list of files, returning the moduleName of the last one.

33− build flags numModules interfaces' name rest

45+-- Returns \"\" if the list is empty

34−

46+build :: Flag.Flags -> M.Interfaces -> [FilePath] -> IO String

35−

47+build flags is = fmap (Maybe.fromMaybe "") . evalBuild flags is . buildAll

36−build1 :: Flag.Flags -> Int -> Int -> M.Interfaces -> FilePath

48+

37− -> IO (String, M.ModuleInterface)

49+buildAll :: [FilePath] -> Build ()

38−build1 flags moduleNum numModules interfaces filePath =

50+buildAll fs = mapM_ (uncurry build1) (zip [1..] fs)

39− do compiled <- alreadyCompiled flags filePath

51+ where build1 :: Integer -> FilePath -> Build ()

40− case compiled of

52+ build1 num fname = do

53+ shouldCompile <- shouldBeCompiled fname

54+ if shouldCompile

41− False -> compile flags number interfaces filePath

55+ then compile number fname

42− True -> retrieve flags interfaces filePath

56+ else retrieve fname

43− where

57+

44− number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"

58+ where number = join ["[", show num, " of ", show total, "]"]

45−

59+

46−

60+ total = length fs

47−alreadyCompiled :: Flag.Flags -> FilePath -> IO Bool

61+

48−alreadyCompiled flags filePath = do

62+shouldBeCompiled :: FilePath -> Build Bool

63+shouldBeCompiled filePath = do

64+ flags <- ask

65+ let alreadyCompiled = liftIO $ do

49− existsi <- doesFileExist (Utils.elmi flags filePath)

66+ existsi <- doesFileExist (Utils.elmi flags filePath)

50− existso <- doesFileExist (Utils.elmo flags filePath)

67+ existso <- doesFileExist (Utils.elmo flags filePath)

51− if not existsi || not existso

68+ return $ existsi && existso

52− then return False

69+

53− else do tsrc <- getModificationTime filePath

70+ outDated = liftIO $ do

54− tint <- getModificationTime (Utils.elmo flags filePath)

71+ tsrc <- getModificationTime filePath

72+ tint <- getModificationTime (Utils.elmo flags filePath)

73+ return (tsrc > tint)

74+

75+ dependenciesUpdated = do

76+ eDeps <- liftIO . runErrorT $ Deps.readDeps filePath

77+ case eDeps of

78+ -- Should never actually reach here

79+ Left err -> liftIO $ Print.failure err

80+ Right (_, deps) -> anyM wasCompiled deps

81+

82+

83+ in (not <$> alreadyCompiled) `orM` outDated `orM` dependenciesUpdated

84+

85+wasCompiled :: String -> Build Bool

86+wasCompiled modul = maybe False fst . Map.lookup modul <$> get

87+

88+-- Short-circuiting monadic (||)

89+infixr 2 `orM`

90+orM :: (Monad m) => m Bool -> m Bool -> m Bool

91+orM m1 m2 = do b1 <- m1

92+ if b1

55− return (tsrc <= tint)

93+ then return b1

56−

94+ else m2

57−retrieve :: Flag.Flags -> Map.Map String M.ModuleInterface -> FilePath

95+

58− -> IO (String, M.ModuleInterface)

96+anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool

59−retrieve flags interfaces filePath = do

97+anyM f = foldr (orM . f) (return False)

60− bytes <- IS.loadInterface (Utils.elmi flags filePath)

98+

99+retrieve :: FilePath -> Build ()

100+retrieve filePath = do

101+ flags <- ask

61− let binary = IS.interfaceDecode (Utils.elmi flags filePath) =<< bytes

102+ iface <- liftIO $ Interface.load (Utils.elmi flags filePath)

62− case IS.validVersion filePath =<< binary of

103+ case Interface.isValid filePath iface of

63 Right (name, interface) ->

104 Right (name, interface) ->

105+ do binterfaces <- get

106+ let interfaces = snd <$> binterfaces

64− do when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

107+ liftIO $ when (Flag.print_types flags) (Print.interfaceTypes interfaces interface)

65− return (name, interface)

108+ update name interface False

109+

66− Left err ->

110+ Left err -> liftIO $ Print.failure err

67− do hPutStrLn stderr err

111+

68− exitFailure

69−

70−compile :: Flag.Flags -> String -> M.Interfaces -> FilePath

112+compile :: String -> FilePath -> Build ()

71− -> IO (String, M.ModuleInterface)

72−compile flags number interfaces filePath =

113+compile number filePath =

114+ do flags <- ask

115+ binterfaces <- get

73− do source <- readFile filePath

116+ source <- liftIO $ readFile filePath

117+ let interfaces = snd <$> binterfaces

74− let name = getName source

118+ name = getName source

119+ liftIO $ do

75− printStatus name

120+ printStatus name

76−

77− createDirectoryIfMissing True (Flag.cache_dir flags)

121+ createDirectoryIfMissing True (Flag.cache_dir flags)

78− createDirectoryIfMissing True (Flag.build_dir flags)

122+ createDirectoryIfMissing True (Flag.build_dir flags)

79−

123+

80− metaModule <-

124+ metaModule <-

81− case Source.build (Flag.no_prelude flags) interfaces source of

125+ liftIO $ case Source.build (Flag.no_prelude flags) interfaces source of

82 Right modul -> return modul

126 Right modul -> return modul

83 Left errors -> do Print.errors errors

127 Left errors -> do Print.errors errors

84 exitFailure

128 exitFailure

85

129

86− when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule

130+ liftIO $ when (Flag.print_types flags) $ Print.metaTypes interfaces metaModule

87−

131+

88− let intermediate = (name, Canonical.interface name $ M.metaToInterface metaModule)

132+ let newInters = Canonical.interface name $ M.metaToInterface metaModule

89− generateCache intermediate metaModule

133+ generateCache name newInters metaModule

90− return intermediate

134+ update name newInters True

91

135

92 where

136 where

93 getName source = case Parser.getModuleName source of

137 getName source = case Parser.getModuleName source of

@@ -99,8 +143,14 @@ compile flags number interfaces filePath =

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

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

100 , "( " ++ filePath ++ " )" ]

144 , "( " ++ filePath ++ " )" ]

101

145

102− generateCache intermediate metaModule = do

146+ generateCache name interfs metaModule = do

147+ flags <- ask

148+ liftIO $ do

103− createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

149+ createDirectoryIfMissing True . dropFileName $ Utils.elmi flags filePath

104− writeFile (Utils.elmo flags filePath) (JS.generate metaModule)

150+ writeFile (Utils.elmo flags filePath) (JS.generate metaModule)

105− withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

151+ withBinaryFile (Utils.elmi flags filePath) WriteMode $ \handle ->

106− L.hPut handle (Binary.encode intermediate)

152+ L.hPut handle (Binary.encode (name, interfs))

153+

154+update :: String -> M.ModuleInterface -> Bool -> Build ()

155+update name inter wasUpdated = modify (Map.insert name (wasUpdated, inter))

156+ >> tell (Last . Just $ name)

compiler/Build/Interface.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# OPTIONS_GHC -W #-}

2+module Build.Interface (load,isValid) where

3+

4+import qualified Data.ByteString.Lazy as L

5+import qualified Data.Binary as Binary

6+

7+import qualified Elm.Internal.Version as Version

8+import System.Directory (doesFileExist)

9+import System.Exit

10+import System.IO

11+

12+import SourceSyntax.Module

13+

14+load :: Binary.Binary a => FilePath -> IO a

15+load filePath =

16+ do exists <- doesFileExist filePath

17+ case exists of

18+ False -> failure $ "Unable to find file " ++ filePath ++ " for deserialization!"

19+ True -> do

20+ bytes <- L.readFile filePath

21+ case Binary.decodeOrFail bytes of

22+ Right (_, _, binaryInfo) -> return binaryInfo

23+ Left (_, offset, err) -> failure $ msg offset err

24+

25+ where

26+ failure err = do hPutStrLn stderr err

27+ exitFailure

28+

29+ msg offset err = concat

30+ [ "Error reading build artifact: ", filePath, "\n"

31+ , " '", err, "' at offset ", show offset, "\n"

32+ , " The file was generated by a previous build and may be outdated or corrupt.\n"

33+ , " Please remove the file and try again."

34+ ]

35+

36+isValid :: FilePath -> (String, ModuleInterface) -> Either String (String, ModuleInterface)

37+isValid filePath (name, interface) =

38+ let version = iVersion interface in

39+ if version == Version.elmVersion

40+ then Right (name, interface)

41+ else Left $ concat

42+ [ "Error reading build artifact: ", filePath, "\n"

43+ , " It was generated by version ", show version, " of the compiler,\n"

44+ , " but you are using version ", show Version.elmVersion, "\n"

45+ , " Please remove the file and try again.\n"

46+ ]

compiler/Build/Print.hs+8−2

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

1module Build.Print where

2

3+import System.IO (hPutStrLn, stderr)

4+import System.Exit (exitFailure)

5+

3import qualified Data.Map as Map

6import qualified Data.Map as Map

4import qualified Data.List as List

7import qualified Data.List as List

5import qualified SourceSyntax.Module as M

8import qualified SourceSyntax.Module as M

@@ -7,7 +10,7 @@ import qualified SourceSyntax.PrettyPrint as Pretty

7import qualified Type.Alias as Alias

10import qualified Type.Alias as Alias

8import qualified Text.PrettyPrint as P

11import qualified Text.PrettyPrint as P

9

12

10−metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule () () -> IO ()

13+metaTypes :: Map.Map String M.ModuleInterface -> M.MetadataModule -> IO ()

11metaTypes interfaces meta =

14metaTypes interfaces meta =

12 types interfaces (M.types meta) (M.aliases meta) (M.imports meta)

15 types interfaces (M.types meta) (M.aliases meta) (M.imports meta)

13

16

@@ -29,4 +32,7 @@ types interfaces types' aliases imports =

29

32

30errors :: [P.Doc] -> IO ()

33errors :: [P.Doc] -> IO ()

31errors errs =

34errors errs =

32− mapM_ print (List.intersperse (P.text " ") errs)

35+ mapM_ print (List.intersperse (P.text " ") errs)

36+

37+failure :: String -> IO a

38+failure msg = hPutStrLn stderr msg >> exitFailure

compiler/Build/Source.hs+25−32

@@ -1,19 +1,15 @@

1+{-# OPTIONS_GHC -W #-}

1module Build.Source (build) where

2module Build.Source (build) where

2

3

3−import Data.Data

4−import Control.Monad.State

5−import qualified Data.Graph as Graph

6−import qualified Data.List as List

7import qualified Data.Map as Map

4import qualified Data.Map as Map

8import qualified Data.Set as Set

5import qualified Data.Set as Set

9−import System.Directory

10−import System.Exit

11import System.FilePath as FP

6import System.FilePath as FP

12import Text.PrettyPrint (Doc)

7import Text.PrettyPrint (Doc)

13

8

14import SourceSyntax.Declaration

9import SourceSyntax.Declaration

15import SourceSyntax.Module

10import SourceSyntax.Module

16import qualified SourceSyntax.Expression as Expr

11import qualified SourceSyntax.Expression as Expr

12+import qualified SourceSyntax.Pattern as Pattern

17import qualified SourceSyntax.Type as Type

13import qualified SourceSyntax.Type as Type

18import qualified Parse.Parse as Parse

14import qualified Parse.Parse as Parse

19import qualified Metadata.Prelude as Prelude

15import qualified Metadata.Prelude as Prelude

@@ -23,42 +19,39 @@ import qualified Type.Inference as TI

23import qualified Type.Constrain.Declaration as TcDecl

19import qualified Type.Constrain.Declaration as TcDecl

24import qualified Transform.Canonicalize as Canonical

20import qualified Transform.Canonicalize as Canonical

25

21

26−build :: Bool -> Interfaces -> String -> Either [Doc] (MetadataModule () ())

22+build :: Bool -> Interfaces -> String -> Either [Doc] MetadataModule

27build noPrelude interfaces source =

23build noPrelude interfaces source =

28− do let add = if noPrelude then id else Prelude.add

24+ do let add = Prelude.add noPrelude

29 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

25 infixes = Map.fromList . map (\(assoc,lvl,op) -> (op,(lvl,assoc)))

30 . concatMap iFixities $ Map.elems interfaces

26 . concatMap iFixities $ Map.elems interfaces

31

27

28+ Module names exs ims decls <- do

32− modul@(Module _ _ _ decls') <- add `fmap` Parse.program infixes source

29+ modul@(Module _ _ _ decls) <- add `fmap` Parse.program infixes source

33−

34− -- check for structural errors

35− Module names exs ims decls <-

36− case Check.mistakes decls' of

30+ case Check.mistakes decls of

37− [] -> return modul

31+ [] -> return modul

38− ms -> Left ms

32+ ms -> Left ms

39

33

40 let exports'

34 let exports'

41 | null exs =

35 | null exs =

42− let get = Set.toList . SD.boundVars in

36+ let get = Set.toList . Pattern.boundVars in

43− concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++

37+ concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++

44− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

38+ concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++

45− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

39+ [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]

46 | otherwise = exs

40 | otherwise = exs

47

41

48− metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

42+ metaModule <- Canonical.metadataModule interfaces $

43+ MetadataModule

49− names = names,

44+ { names = names

50− path = FP.joinPath names,

45+ , path = FP.joinPath names

51− exports = exports',

46+ , exports = exports'

52− imports = ims,

47+ , imports = ims

53 -- reorder AST into strongly connected components

48 -- reorder AST into strongly connected components

54− program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,

49+ , program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls

55− types = Map.empty,

50+ , types = Map.empty

56− datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],

51+ , datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ]

57− fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],

52+ , fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]

58− aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],

53+ , aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ]

59− foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],

60− foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]

61− }

54+ }

62

55

63 types <- TI.infer interfaces metaModule

56 types <- TI.infer interfaces metaModule

64

57

compiler/Build/Utils.hs+1

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

1+{-# OPTIONS_GHC -W #-}

1module Build.Utils where

2module Build.Utils where

2

3

3import System.FilePath ((</>), replaceExtension)

4import System.FilePath ((</>), replaceExtension)

compiler/Compiler.hs+3−4

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

1+{-# OPTIONS_GHC -W #-}

1module Main where

2module Main where

2

3

3import Control.Monad (foldM)

4import Control.Monad (foldM)

4−import qualified Data.Map as Map

5import qualified Data.Maybe as Maybe

6import Text.Blaze.Html.Renderer.String (renderHtml)

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

@@ -31,14 +31,13 @@ compileArgs flags =

31build :: Flag.Flags -> FilePath -> IO ()

32build flags rootFile =

33 do let noPrelude = Flag.no_prelude flags

34− builtIns <- if noPrelude then return Map.empty else Prelude.interfaces

34+ builtIns <- Prelude.interfaces noPrelude

35

36 files <- if Flag.make flags

37 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile

38 else return [rootFile]

39

40− (moduleName, interfaces) <-

41− File.build flags (length files) builtIns "" files

40+ moduleName <- File.build flags builtIns files

42

41

43 js <- foldM appendToOutput BS.empty files

42 js <- foldM appendToOutput BS.empty files

44

43

compiler/Docs.hs+21−17

@@ -7,7 +7,7 @@ import System.FilePath

7import System.Exit

8import System.IO

9

10−import Control.Applicative ((<$>), (<*>))

10+import Control.Applicative ((<$>))

11import Data.Aeson

12import Data.Aeson.Encode.Pretty

13import qualified Data.List as List

@@ -17,8 +17,8 @@ import qualified Data.Text as Text

17

18import SourceSyntax.Helpers (isSymbol)

19import SourceSyntax.Type (Type(..))

20−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

20+import qualified SourceSyntax.Expression as E

21−import SourceSyntax.Expression (Def(..))

21+import qualified SourceSyntax.Declaration as D

22

23import Text.Parsec hiding (newline,spaces)

24import Parse.Declaration (alias,datatype,infixDecl)

@@ -77,10 +77,10 @@ moduleDocs = do

77 structure <- docComment

78 return (List.intercalate "." names, exports, structure)

79

80−document :: IParser [(String, Declaration t v, String)]

80+document :: IParser [(String, D.ParseDeclaration, String)]

81document = onFreshLines (\t ts -> ts ++ [t]) [] docThing

82

83−docThing :: IParser (String, Declaration t v, String)

83+docThing :: IParser (String, D.ParseDeclaration, String)

84docThing = uncommentable <|> commented <|> uncommented ""

85 where

86 uncommentable = do

@@ -93,7 +93,7 @@ docThing = uncommentable <|> commented <|> uncommented ""

93 uncommented comment

94

95 uncommented comment = do

96− (src,def) <- withSource $ choice [ alias, datatype, Definition <$> typeAnnotation ]

96+ (src,def) <- withSource $ choice [ alias, datatype, D.Definition <$> typeAnnotation ]

97 return (comment, def, src)

98

99

@@ -121,7 +121,7 @@ collect infixes types aliases adts things =

121 where

122 nonCustomOps = Map.mapWithKey addDefaultInfix $ Map.difference types infixes

123 addDefaultInfix name pairs

124− | all isSymbol name = addInfix (L, 9 :: Int) pairs

124+ | all isSymbol name = addInfix (D.L, 9 :: Int) pairs

125 | otherwise = pairs

126

127 customOps = Map.intersectionWith addInfix infixes types

@@ -130,16 +130,18 @@ collect infixes types aliases adts things =

130

131 (comment, decl, source) : rest ->

132 case decl of

133− Fixity assoc prec name ->

133+ D.Fixity assoc prec name ->

134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

135− Definition (TypeAnnotation name tipe) ->

135+ D.Definition (E.TypeAnnotation name tipe) ->

136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

137− TypeAlias name vars tipe ->

137+ D.TypeAlias name vars tipe derivations ->

138− let fields = ["typeVariables" .= vars, "type" .= tipe ]

138+ let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]

139 in collect infixes types (insert name fields aliases) adts rest

140− Datatype name vars ctors ->

140+ D.Datatype name vars ctors derivations ->

141 let tipe = Data name (map Var vars)

142+ fields = ["typeVariables" .= vars

142− fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]

143+ , "constructors" .= map (ctorToJson tipe) ctors

144+ , "deriving" .= derivations ]

143 in collect infixes types aliases (insert name fields adts) rest

145 in collect infixes types aliases (insert name fields adts) rest

144 where

146 where

145 insert name fields dict = Map.insert name (obj name fields) dict

147 insert name fields dict = Map.insert name (obj name fields) dict

@@ -152,12 +154,14 @@ instance ToJSON Type where

152 Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]

154 Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]

153 Var x -> toJSON x

155 Var x -> toJSON x

154 Data name ts -> toJSON (toJSON name : map toJSON ts)

156 Data name ts -> toJSON (toJSON name : map toJSON ts)

155− EmptyRecord -> object []

156 Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'

157 Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'

157 where fields' = case ext of

158 where fields' = case ext of

158− EmptyRecord -> fields

159+ Nothing -> fields

159− _ -> ("_",ext) : fields

160+ Just x -> ("_", Var x) : fields

160

161

161ctorToJson tipe (ctor, tipes) =

162ctorToJson tipe (ctor, tipes) =

162 object [ "name" .= ctor

163 object [ "name" .= ctor

163− , "type" .= foldr Lambda tipe tipes ]

164+ , "type" .= foldr Lambda tipe tipes ]

165+

166+instance ToJSON D.Derivation where

167+ toJSON = toJSON . show

compiler/Elm/Internal/Utils.hs+1−1

@@ -21,7 +21,7 @@ compile source =

21

22{-# NOINLINE interfaces #-}

23interfaces :: M.Interfaces

24−interfaces = unsafePerformIO $ Prelude.interfaces

24+interfaces = unsafePerformIO $ Prelude.interfaces False

25

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

27moduleName :: String -> Maybe String

compiler/Generate/Cases.hs+21−21

@@ -1,9 +1,9 @@

1module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

2

3−import Control.Applicative ((<$>),(<*>))

3+import Control.Applicative ((<$>))

4−import Control.Arrow (first,second)

4+import Control.Arrow (first)

5import Control.Monad.State

6−import Data.List (groupBy,sortBy,lookup)

6+import Data.List (groupBy,sortBy)

7import Data.Maybe (fromMaybe)

8

9import SourceSyntax.Location

@@ -13,7 +13,7 @@ import SourceSyntax.Expression

13import Transform.Substitute

14

15

16−toMatch :: [(Pattern, LExpr t v)] -> State Int (String, Match t v)

16+toMatch :: [(Pattern, LExpr)] -> State Int (String, Match)

17toMatch patterns = do

18 v <- newVar

19 (,) v <$> match [v] (map (first (:[])) patterns) Fail

@@ -23,19 +23,19 @@ newVar = do n <- get

23 modify (+1)

24 return $ "_v" ++ show n

25

26−data Match t v

26+data Match

27− = Match String [Clause t v] (Match t v)

27+ = Match String [Clause] Match

28 | Break

29 | Fail

30− | Other (LExpr t v)

30+ | Other LExpr

31− | Seq [Match t v]

31+ | Seq [Match]

32 deriving Show

33

34−data Clause t v =

34+data Clause =

35− Clause (Either String Literal) [String] (Match t v)

35+ Clause (Either String Literal) [String] Match

36 deriving Show

37

38−matchSubst :: [(String,String)] -> Match t v -> Match t v

38+matchSubst :: [(String,String)] -> Match -> Match

39matchSubst _ Break = Break

40matchSubst _ Fail = Fail

41matchSubst pairs (Seq ms) = Seq (map (matchSubst pairs) ms)

@@ -47,7 +47,7 @@ matchSubst pairs (Match n cs m) =

47 clauseSubst (Clause c vs m) =

48 Clause c (map varSubst vs) (matchSubst pairs m)

49

50−isCon (p:ps, e) =

50+isCon (p:_, _) =

51 case p of

52 PData _ _ -> True

53 PLiteral _ -> True

@@ -55,7 +55,7 @@ isCon (p:ps, e) =

55

56isVar p = not (isCon p)

57

58−match :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

58+match :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

59match [] [] def = return def

60match [] [([],e)] Fail = return $ Other e

61match [] [([],e)] Break = return $ Other e

@@ -72,10 +72,10 @@ dealias v c@(p:ps, L s e) =

72 PAlias x pattern -> (pattern:ps, L s $ subst x (Var v) e)

73 _ -> c

74

75−matchVar :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

75+matchVar :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

76matchVar (v:vs) cs def = match vs (map subVar cs) def

77 where

78− subVar (p:ps, ce@(L s e)) = (ps, L s $ subOnePattern p e)

78+ subVar (p:ps, (L s e)) = (ps, L s $ subOnePattern p e)

79 where

80 subOnePattern pattern e =

81 case pattern of

@@ -84,7 +84,7 @@ matchVar (v:vs) cs def = match vs (map subVar cs) def

84 PRecord fs ->

85 foldr (\x -> subst x (Access (L s (Var v)) x)) e fs

86

87−matchCon :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

87+matchCon :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

88matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

89 where

90 css = groupBy eq (sortBy cmp cs)

@@ -106,10 +106,10 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

106

107matchClause :: Either String Literal

108 -> [String]

109− -> [([Pattern],LExpr t v)]

109+ -> [([Pattern],LExpr)]

110− -> Match t v

110+ -> Match

111− -> State Int (Clause t v)

111+ -> State Int Clause

112−matchClause c (v:vs) cs def =

112+matchClause c (_:vs) cs def =

113 do vs' <- getVars

114 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

115 where

@@ -124,6 +124,6 @@ matchClause c (v:vs) cs def =

124 (PData _ ps : _, _) -> forM ps (const newVar)

125 (PLiteral _ : _, _) -> return []

126

127−matchMix :: [String] -> [([Pattern],LExpr t v)] -> Match t v -> State Int (Match t v)

127+matchMix :: [String] -> [([Pattern],LExpr)] -> Match -> State Int Match

128matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

129 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

compiler/Generate/JavaScript.hs+94−131

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

1+{-# OPTIONS_GHC -W #-}

1module Generate.JavaScript (generate) where

2module Generate.JavaScript (generate) where

2

3

3import Control.Arrow (first,(***))

4import Control.Arrow (first,(***))

@@ -7,67 +8,49 @@ import qualified Data.List as List

7import qualified Data.Map as Map

8import qualified Data.Map as Map

8import qualified Data.Set as Set

9import qualified Data.Set as Set

9

10

11+import Generate.JavaScript.Helpers

10import qualified Generate.Cases as Case

12import qualified Generate.Cases as Case

13+import qualified Generate.JavaScript.Ports as Port

11import qualified Generate.Markdown as MD

14import qualified Generate.Markdown as MD

12import qualified SourceSyntax.Helpers as Help

15import qualified SourceSyntax.Helpers as Help

13import SourceSyntax.Literal

16import SourceSyntax.Literal

14−import SourceSyntax.Pattern

17+import SourceSyntax.Pattern as Pattern

15import SourceSyntax.Location

18import SourceSyntax.Location

16import SourceSyntax.Expression

19import SourceSyntax.Expression

17import SourceSyntax.Module

20import SourceSyntax.Module

18−import qualified Transform.SortDefinitions as SD

19import Language.ECMAScript3.Syntax

21import Language.ECMAScript3.Syntax

20import Language.ECMAScript3.PrettyPrint

22import Language.ECMAScript3.PrettyPrint

21import qualified Transform.SafeNames as MakeSafe

23import qualified Transform.SafeNames as MakeSafe

22

24

23−split :: String -> [String]

24−split = go []

25− where

26− go vars str =

27− case break (=='.') str of

28− (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

29− | otherwise -> go (vars ++ [x]) rest

30− (x,[]) -> vars ++ [x]

31−

32−var name = Id () name

33−ref name = VarRef () (var name)

34−prop name = PropId () (var name)

35−f <| x = CallExpr () f [x]

36−args ==> e = FuncExpr () Nothing (map var args) [ ReturnStmt () (Just e) ]

37−function args stmts = FuncExpr () Nothing (map var args) stmts

38−call = CallExpr ()

39−string = StringLit ()

40−

41−dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)

42−obj = dotSep . split

43−

44varDecl :: String -> Expression () -> VarDecl ()

25varDecl :: String -> Expression () -> VarDecl ()

45varDecl x expr =

26varDecl x expr =

46 VarDecl () (var x) (Just expr)

27 VarDecl () (var x) (Just expr)

47

28

29+include :: String -> String -> VarDecl ()

48include alias moduleName =

30include alias moduleName =

49 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

31 varDecl alias (obj (moduleName ++ ".make") <| ref "_elm")

50

32

33+internalImports :: String -> Statement ()

51internalImports name =

34internalImports name =

52 VarDeclStmt ()

35 VarDeclStmt ()

53− [ varDecl "N" (obj "Elm.Native")

36+ [ varDecl "_N" (obj "Elm.Native")

54− , include "_N" "N.Utils"

37+ , include "_U" "_N.Utils"

55− , include "_L" "N.List"

38+ , include "_L" "_N.List"

56− , include "_E" "N.Error"

39+ , include "_E" "_N.Error"

57− , include "_J" "N.JavaScript"

40+ , include "_J" "_N.JavaScript"

58 , varDecl "$moduleName" (string name)

41 , varDecl "$moduleName" (string name)

59 ]

42 ]

60

43

61literal :: Literal -> Expression ()

44literal :: Literal -> Expression ()

62literal lit =

45literal lit =

63 case lit of

46 case lit of

64− Chr c -> obj "_N.chr" <| string [c]

47+ Chr c -> obj "_U.chr" <| string [c]

65 Str s -> string s

48 Str s -> string s

66 IntNum n -> IntLit () n

49 IntNum n -> IntLit () n

67 FloatNum n -> NumLit () n

50 FloatNum n -> NumLit () n

68 Boolean b -> BoolLit () b

51 Boolean b -> BoolLit () b

69

52

70−expression :: LExpr () () -> State Int (Expression ())

53+expression :: LExpr -> State Int (Expression ())

71expression (L span expr) =

54expression (L span expr) =

72 case expr of

55 case expr of

73 Var x -> return $ ref x

56 Var x -> return $ ref x

@@ -84,19 +67,19 @@ expression (L span expr) =

84

67

85 Remove e x ->

68 Remove e x ->

86 do e' <- expression e

69 do e' <- expression e

87− return $ obj "_N.remove" `call` [string x, e']

70+ return $ obj "_U.remove" `call` [string x, e']

88

71

89 Insert e x v ->

72 Insert e x v ->

90 do v' <- expression v

73 do v' <- expression v

91 e' <- expression e

74 e' <- expression e

92− return $ obj "_N.insert" `call` [string x, v', e']

75+ return $ obj "_U.insert" `call` [string x, v', e']

93

76

94 Modify e fs ->

77 Modify e fs ->

95 do e' <- expression e

78 do e' <- expression e

96 fs' <- forM fs $ \(f,v) -> do

79 fs' <- forM fs $ \(f,v) -> do

97 v' <- expression v

80 v' <- expression v

98 return $ ArrayLit () [string f, v']

81 return $ ArrayLit () [string f, v']

99− return $ obj "_N.replace" `call` [ArrayLit () fs', e']

82+ return $ obj "_U.replace" `call` [ArrayLit () fs', e']

100

83

101 Record fields ->

84 Record fields ->

102 do fields' <- forM fields $ \(f,e) -> do

85 do fields' <- forM fields $ \(f,e) -> do

@@ -148,10 +131,10 @@ expression (L span expr) =

148 _ -> (func, args)

131 _ -> (func, args)

149

132

150 Let defs e ->

133 Let defs e ->

151− do let (defs',e') = SD.flattenLets defs e

134+ do let (defs',e') = flattenLets defs e

152 stmts <- concat <$> mapM definition defs'

135 stmts <- concat <$> mapM definition defs'

153 exp <- expression e'

136 exp <- expression e'

154− return $ function [] (stmts ++ [ ReturnStmt () (Just exp) ]) `call` []

137+ return $ function [] (stmts ++ [ ret exp ]) `call` []

155

138

156 MultiIf branches ->

139 MultiIf branches ->

157 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

140 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

@@ -192,56 +175,59 @@ expression (L span expr) =

192 pad = "<div style=\"height:0;width:0;\"> </div>"

175 pad = "<div style=\"height:0;width:0;\"> </div>"

193 md = pad ++ MD.toHtml doc ++ pad

176 md = pad ++ MD.toHtml doc ++ pad

194

177

195−definition :: Def () () -> State Int [Statement ()]

178+ PortIn name tipe ->

196−definition def =

179+ return $ obj "Native.Ports.portIn" `call` [ string name, Port.incoming tipe ]

197− case def of

180+

198− TypeAnnotation _ _ -> return []

181+ PortOut name tipe value ->

199−

182+ do value' <- expression value

183+ return $ obj "Native.Ports.portOut" `call`

184+ [ string name, Port.outgoing tipe, value' ]

185+

186+definition :: Def -> State Int [Statement ()]

200− Def pattern expr@(L span _) -> do

187+definition (Definition pattern expr@(L span _) _) = do

201− expr' <- expression expr

188+ expr' <- expression expr

202− let assign x = varDecl x expr'

189+ let assign x = varDecl x expr'

203− case pattern of

190+ case pattern of

204− PVar x

191+ PVar x

205− | Help.isOp x ->

192+ | Help.isOp x ->

206− let op = LBracket () (ref "_op") (string x) in

193+ let op = LBracket () (ref "_op") (string x) in

207− return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

194+ return [ ExprStmt () $ AssignExpr () OpAssign op expr' ]

208− | otherwise ->

195+ | otherwise ->

209− return [ VarDeclStmt () [ assign x ] ]

196+ return [ VarDeclStmt () [ assign x ] ]

210−

197+

211− PRecord fields ->

198+ PRecord fields ->

212− let setField f = varDecl f (dotSep ["$",f]) in

199+ let setField f = varDecl f (dotSep ["$",f]) in

213− return [ VarDeclStmt () (assign "$" : map setField fields) ]

200+ return [ VarDeclStmt () (assign "$" : map setField fields) ]

214−

201+

215− PData name patterns | vars /= Nothing ->

202+ PData name patterns | vars /= Nothing ->

216− case vars of

217− Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]

203+ return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

218− where

204+ where

219− vars = getVars patterns

205+ vars = getVars patterns

220− getVars patterns =

206+ getVars patterns =

221− case patterns of

207+ case patterns of

222− PVar x : rest -> (x:) `fmap` getVars rest

208+ PVar x : rest -> (x:) `fmap` getVars rest

223− [] -> Just []

209+ [] -> Just []

224− _ -> Nothing

210+ _ -> Nothing

225−

211+

226− decl x n = varDecl x (dotSep ["$","_" ++ show n])

212+ decl x n = varDecl x (dotSep ["$","_" ++ show n])

227− setup vars

213+ setup vars

228− | Help.isTuple name = assign "$" : vars

214+ | Help.isTuple name = assign "$" : vars

229− | otherwise = assign "$raw" : safeAssign : vars

215+ | otherwise = assign "$raw" : safeAssign : vars

230−

216+

231− safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

217+ safeAssign = varDecl "$" (CondExpr () if' (obj "$raw") exception)

232− if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

218+ if' = InfixExpr () OpStrictEq (obj "$raw.ctor") (string name)

233− exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

219+ exception = obj "_E.Case" `call` [ref "$moduleName", string (show span)]

234−

220+

235− _ ->

221+ _ ->

236− do defs' <- concat <$> mapM toDef vars

222+ do defs' <- concat <$> mapM toDef vars

237− return (VarDeclStmt () [assign "$"] : defs')

223+ return (VarDeclStmt () [assign "$"] : defs')

238− where

224+ where

239− vars = Set.toList $ SD.boundVars pattern

225+ vars = Set.toList $ Pattern.boundVars pattern

240− mkVar = L span . Var

226+ mkVar = L span . Var

241− toDef y = definition $

242− Def (PVar y) (L span $ Case (mkVar "$") [(pattern, mkVar y)])

227+ toDef y = let expr = L span $ Case (mkVar "$") [(pattern, mkVar y)]

243−

228+ in definition $ Definition (PVar y) expr Nothing

229+

244−match :: (Show a) => a -> Case.Match () () -> State Int [Statement ()]

230+match :: SrcSpan -> Case.Match -> State Int [Statement ()]

245match span mtch =

231match span mtch =

246 case mtch of

232 case mtch of

247 Case.Match name clauses mtch' ->

233 Case.Match name clauses mtch' ->

@@ -263,7 +249,7 @@ match span mtch =

263 Case.Break -> return [BreakStmt () Nothing]

249 Case.Break -> return [BreakStmt () Nothing]

264 Case.Other e ->

250 Case.Other e ->

265 do e' <- expression e

251 do e' <- expression e

266− return [ ReturnStmt () (Just e') ]

252+ return [ ret e' ]

267 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)

253 Case.Seq ms -> concat <$> mapM (match span) (dropEnd [] ms)

268 where

254 where

269 dropEnd acc [] = acc

255 dropEnd acc [] = acc

@@ -272,6 +258,7 @@ match span mtch =

272 Case.Other _ -> acc ++ [m]

258 Case.Other _ -> acc ++ [m]

273 _ -> dropEnd (acc ++ [m]) ms

259 _ -> dropEnd (acc ++ [m]) ms

274

260

261+clause :: SrcSpan -> String -> Case.Clause -> State Int (Bool, CaseClause ())

275clause span variable (Case.Clause value vars mtch) =

262clause span variable (Case.Clause value vars mtch) =

276 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)

263 (,) isChar . CaseClause () pattern <$> match span (Case.matchSubst (zip vars vars') mtch)

277 where

264 where

@@ -286,8 +273,13 @@ clause span variable (Case.Clause value vars mtch) =

286 [] -> name

273 [] -> name

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

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

288

275

276+flattenLets :: [Def] -> LExpr -> ([Def], LExpr)

277+flattenLets defs lexpr@(L _ expr) =

278+ case expr of

279+ Let ds body -> flattenLets (defs ++ ds) body

280+ _ -> (defs, lexpr)

289

281

290−generate :: MetadataModule () () -> String

282+generate :: MetadataModule -> String

291generate unsafeModule =

283generate unsafeModule =

292 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

284 show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

293 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

285 [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

@@ -295,17 +287,16 @@ generate unsafeModule =

295 modul = MakeSafe.metadataModule unsafeModule

287 modul = MakeSafe.metadataModule unsafeModule

296 thisModule = dotSep ("_elm" : names modul ++ ["values"])

288 thisModule = dotSep ("_elm" : names modul ++ ["values"])

297 programStmts =

289 programStmts =

290+ concat

298− concat [ setup (Just "_elm") (names modul ++ ["values"])

291+ [ setup (Just "_elm") (names modul ++ ["values"])

299− , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

292+ , [ IfSingleStmt () thisModule (ret thisModule) ]

300− , [ internalImports (List.intercalate "." (names modul)) ]

293+ , [ internalImports (List.intercalate "." (names modul)) ]

301− , concatMap jsImport (imports modul)

294+ , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

302− , concatMap importEvent (foreignImports modul)

303− , [ assign ["_op"] (ObjectLit () []) ]

295+ , [ assign ["_op"] (ObjectLit () []) ]

304− , concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0

296+ , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

305− , map exportEvent $ foreignExports modul

306− , [ jsExports ]

297+ , [ jsExports ]

307− , [ ReturnStmt () (Just thisModule) ]

298+ , [ ret thisModule ]

308− ]

299+ ]

309

300

310 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

301 jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

311 where

302 where

@@ -318,7 +309,7 @@ generate unsafeModule =

318 _ -> ExprStmt () $

309 _ -> ExprStmt () $

319 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

310 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

320

311

321− jsImport (modul,_) = setup Nothing path ++ [ include ]

312+ jsImport modul = setup Nothing path ++ [ include ]

322 where

313 where

323 path = split modul

314 path = split modul

324 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

315 include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

@@ -330,32 +321,7 @@ generate unsafeModule =

330 Nothing -> tail . init $ List.inits path

321 Nothing -> tail . init $ List.inits path

331 Just nmspc -> drop 2 . init . List.inits $ nmspc : path

322 Just nmspc -> drop 2 . init . List.inits $ nmspc : path

332

323

333− addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")

324+binop :: SrcSpan -> String -> LExpr -> LExpr -> State Int (Expression ())

334−

335− importEvent (js,base,elm,_) =

336− [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]

337− , ExprStmt () $

338− obj "document.addEventListener" `call`

339− [ addId js

340− , function ["_e"]

341− [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]

342− ]

343− ]

344−

345− exportEvent (js,elm,_) =

346− ExprStmt () $

347− ref "A2" `call`

348− [ obj "Signal.lift"

349− , function ["_v"]

350− [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]

351− , ExprStmt () $

352− obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]

353− , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")

354− , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"

355− , ReturnStmt () (Just $ ref "_v")

356− ]

357− , ref elm ]

358−

359binop span op e1 e2 =

325binop span op e1 e2 =

360 case op of

326 case op of

361 "Basics.." ->

327 "Basics.." ->

@@ -382,9 +348,6 @@ binop span op e1 e2 =

382 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

348 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

383 _ -> es ++ [e]

349 _ -> es ++ [e]

384

350

385− js1 = expression e1

386− js2 = expression e2

387−

388 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

351 func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

389 | otherwise = dotSep parts

352 | otherwise = dotSep parts

390 where

353 where

@@ -408,8 +371,8 @@ binop span op e1 e2 =

408 specialOps = concat

371 specialOps = concat

409 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

372 [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

410 , specialOp "|>" $ flip (<|)

373 , specialOp "|>" $ flip (<|)

411− , specialOp "==" $ \a b -> obj "_N.eq" `call` [a,b]

374+ , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

412− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_N.eq" `call` [a,b])

375+ , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

413 , specialOp "<" $ cmp OpLT 0

376 , specialOp "<" $ cmp OpLT 0

414 , specialOp ">" $ cmp OpGT 0

377 , specialOp ">" $ cmp OpGT 0

415 , specialOp "<=" $ cmp OpLT 1

378 , specialOp "<=" $ cmp OpLT 1

@@ -417,4 +380,4 @@ binop span op e1 e2 =

417 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

380 , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

418 ]

381 ]

419

382

420− cmp op n a b = InfixExpr () op (obj "_N.cmp" `call` [a,b]) (IntLit () n)

383+ cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# OPTIONS_GHC -W #-}

2+module Generate.JavaScript.Helpers where

3+

4+import qualified SourceSyntax.Helpers as Help

5+import Language.ECMAScript3.Syntax

6+

7+split :: String -> [String]

8+split = go []

9+ where

10+ go vars str =

11+ case break (=='.') str of

12+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

13+ | otherwise -> go (vars ++ [x]) rest

14+ (x,[]) -> vars ++ [x]

15+

16+var name = Id () name

17+ref name = VarRef () (var name)

18+prop name = PropId () (var name)

19+f <| x = CallExpr () f [x]

20+ret e = ReturnStmt () (Just e)

21+args ==> e = FuncExpr () Nothing (map var args) [ ret e ]

22+function args stmts = FuncExpr () Nothing (map var args) stmts

23+call = CallExpr ()

24+string = StringLit ()

25+

26+dotSep vars =

27+ case vars of

28+ x:xs -> foldl (DotRef ()) (ref x) (map var xs)

29+ [] -> error "dotSep must be called on a non-empty list of variables"

30+

31+obj = dotSep . split

32+

33+equal a b = InfixExpr () OpStrictEq a b

34+instanceof tipe x =

35+ InfixExpr () OpLAnd (typeof "object" x) (InfixExpr () OpInstanceof x (ref tipe))

36+typeof tipe x = equal (PrefixExpr () PrefixTypeof x) (string tipe)

37+member field x = InfixExpr () OpIn (string field) x

compiler/Generate/JavaScript/Ports.hsnew file+130

@@ -0,0 +1,130 @@

1+{-# OPTIONS_GHC -W #-}

2+module Generate.JavaScript.Ports (incoming, outgoing) where

3+

4+import Generate.JavaScript.Helpers

5+import qualified SourceSyntax.Helpers as Help

6+import SourceSyntax.Type as T

7+import Language.ECMAScript3.Syntax

8+

9+data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

10+ deriving Show

11+

12+check :: Expression () -> JSType -> Expression () -> Expression ()

13+check x jsType continue =

14+ CondExpr () (jsFold OpLOr checks x) continue throw

15+ where

16+ jsFold op checks value = foldl1 (InfixExpr () op) (map ($value) checks)

17+ throw = obj "_E.raise" <| InfixExpr () OpAdd msg x

18+ msg = string ("invalid input, expecting " ++ show jsType ++ " but got ")

19+ checks = case jsType of

20+ JSNumber -> [typeof "number"]

21+ JSBoolean -> [typeof "boolean"]

22+ JSString -> [typeof "string", instanceof "String"]

23+ JSArray -> [instanceof "Array"]

24+ JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

25+

26+incoming :: Type -> Expression ()

27+incoming tipe =

28+ case tipe of

29+ Data "Signal.Signal" [t] ->

30+ obj "Native.Ports.incomingSignal" <| incoming t

31+ _ -> ["v"] ==> inc tipe (ref "v")

32+

33+inc :: Type -> Expression () -> Expression ()

34+inc tipe x =

35+ case tipe of

36+ Lambda _ _ -> error "functions should not be allowed through input ports"

37+ Var _ -> error "type variables should not be allowed through input ports"

38+ Data ctor []

39+ | ctor == "Int" -> elm JSNumber

40+ | ctor == "Float" -> elm JSNumber

41+ | ctor == "Bool" -> elm JSBoolean

42+ | ctor == "String" -> elm JSString

43+ | ctor == "JavaScript.JSNumber" -> js JSNumber

44+ | ctor == "JavaScript.JSBool" -> js JSBoolean

45+ | ctor == "JavaScript.JSString" -> js JSString

46+ where

47+ elm checks = check x checks (obj ("_J.to" ++ ctor) <| x)

48+ js checks = check x checks x

49+

50+ Data ctor [t]

51+ | ctor == "Maybe.Maybe" ->

52+ CondExpr () (equal x (NullLit ()))

53+ (obj "Maybe.Nothing")

54+ (obj "Maybe.Just" <| inc t x)

55+

56+ | ctor == "_List" ->

57+ check x JSArray (obj "_J.toList" <| array)

58+ where

59+ array = DotRef () x (var "map") <| incoming t

60+

61+ Data ctor ts | Help.isTuple ctor -> check x JSArray tuple

62+ where

63+ tuple = ObjectLit () $ (PropId () (var "ctor"), string ctor) : values

64+ values = zipWith convert [0..] ts

65+ convert n t = ( PropId () $ var ('_':show n)

66+ , inc t (BracketRef () x (IntLit () n)))

67+

68+ Data _ _ -> error "bad ADT got to port generation code"

69+

70+ Record _ (Just _) -> error "bad record got to port generation code"

71+

72+ Record fields Nothing -> check x (JSObject (map fst fields)) object

73+ where

74+ object = ObjectLit () $ (PropId () (var "_"), ObjectLit () []) : keys

75+ keys = map convert fields

76+ convert (f,t) = (PropId () (var f), inc t (DotRef () x (var f)))

77+

78+outgoing tipe =

79+ case tipe of

80+ Data "Signal.Signal" [t] ->

81+ obj "Native.Ports.outgoingSignal" <| outgoing t

82+ _ -> ["v"] ==> out tipe (ref "v")

83+

84+out :: Type -> Expression () -> Expression ()

85+out tipe x =

86+ case tipe of

87+ Lambda _ _

88+ | numArgs > 1 && numArgs < 10 ->

89+ func (ref ('A':show numArgs) `call` (x:values))

90+ | otherwise -> func (foldl (<|) x values)

91+ where

92+ ts = T.collectLambdas tipe

93+ numArgs = length ts - 1

94+ args = map (\n -> '_' : show n) [0..]

95+ values = zipWith inc (init ts) (map ref args)

96+ func body = function (take numArgs args)

97+ [ VarDeclStmt () [VarDecl () (var "_r") (Just body)]

98+ , ret (out (last ts) (ref "_r"))

99+ ]

100+

101+ Var _ -> error "type variables should not be allowed through input ports"

102+ Data ctor []

103+ | ctor `elem` ["Int","Float","Bool","String"] -> obj ("_J.from" ++ ctor) <| x

104+ | ctor `elem` jsPrims -> x

105+ where

106+ jsPrims = map ("JavaScript.JS"++) ["Number","Bool","String"]

107+

108+ Data ctor [t]

109+ | ctor == "Maybe.Maybe" ->

110+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

111+ (NullLit ())

112+ (DotRef () x (var "_0"))

113+

114+ | ctor == "_List" ->

115+ DotRef () (obj "_J.fromList" <| x) (var "map") <| outgoing t

116+

117+ Data ctor ts | Help.isTuple ctor ->

118+ ArrayLit () $ zipWith convert [0..] ts

119+ where

120+ convert n t = out t $ DotRef () x $ var ('_':show n)

121+

122+ Data _ _ -> error "bad ADT got to port generation code"

123+

124+ Record _ (Just _) -> error "bad record got to port generation code"

125+

126+ Record fields Nothing ->

127+ ObjectLit () keys

128+ where

129+ keys = map convert fields

130+ convert (f,t) = (PropId () (var f), out t (DotRef () x (var f)))

compiler/Generate/Noscript.hs+8−9

@@ -1,35 +1,34 @@

1module Generate.Noscript (noscript) where

2

3import Data.List (isInfixOf)

4−import SourceSyntax.Declaration (Declaration(..))

4+import qualified SourceSyntax.Declaration as D

5import SourceSyntax.Expression

6import SourceSyntax.Literal

7import SourceSyntax.Location

8import SourceSyntax.Module

9import qualified Generate.Markdown as MD

10

11−noscript :: Module t v -> String

11+noscript :: Extract def => Module def -> String

12noscript modul = concat (extract modul)

13

14class Extract a where

15 extract :: a -> [String]

16

17−instance Extract (Module t v) where

17+instance Extract def => Extract (Module def) where

18 extract (Module _ _ _ stmts) =

19 map (\s -> "<p>" ++ s ++ "</p>") (concatMap extract stmts)

20

21−instance Extract (Declaration t v) where

21+instance Extract def => Extract (D.Declaration' port def) where

22− extract (Definition d) = extract d

22+ extract (D.Definition d) = extract d

23 extract _ = []

24

25−instance Extract (Def t v) where

25+instance Extract Def where

26− extract (Def _ e) = extract e

26+ extract (Definition _ e _) = extract e

27− extract _ = []

28

27

29instance Extract e => Extract (Located e) where

28instance Extract e => Extract (Located e) where

30 extract (L _ e) = extract e

29 extract (L _ e) = extract e

31

30

32−instance Extract (Expr t v) where

31+instance Extract def => Extract (Expr' def) where

33 extract expr =

32 extract expr =

34 let f = extract in

33 let f = extract in

35 case expr of

34 case expr of

compiler/InterfaceSerialization.hsdeleted−52

@@ -1,52 +0,0 @@

1−module InterfaceSerialization ( loadInterface

2− , interfaceDecode

3− , validVersion

4− ) where

5−

6−import qualified Data.ByteString.Lazy as L

7−import qualified Data.Binary as Binary

8−

9−import qualified Elm.Internal.Version as Version

10−import System.Directory (doesFileExist)

11−import System.IO (hPutStrLn, stderr)

12−import System.Exit (exitFailure)

13−

14−import SourceSyntax.Module

15−

16−loadInterface :: FilePath -> IO (Either String L.ByteString)

17−loadInterface filePath = do

18− exists <- doesFileExist filePath

19− if exists

20− then do

21− byteString <- L.readFile filePath

22− return $ Right byteString

23−

24− else

25− return $ Left $ "Unable to find file " ++ filePath ++

26− " for deserialization!"

27−

28−interfaceDecode :: Binary.Binary a =>

29− FilePath -> L.ByteString -> Either String a

30−interfaceDecode filePath bytes = do

31− case Binary.decodeOrFail bytes of

32− Right (_, _, binaryInfo) -> Right binaryInfo

33−

34− Left (_, offset, err) ->

35− Left $ concat [ "Error reading build artifact: ", filePath, "\n"

36− , " The exact error was '", err, "' at offset ", show offset, ".\n"

37− , " The file was generated by a previous build and may be outdated or corrupt.\n"

38− , " Please remove the file and try again."

39− ]

40−

41−validVersion :: FilePath -> (String, ModuleInterface) ->

42− Either String (String, ModuleInterface)

43−validVersion filePath (name, interface) =

44− if iVersion interface == Version.elmVersion then

45− Right (name, interface)

46− else

47− Left $ concat

48− [ "Error reading build artifact: ", filePath, "\n"

49− , " It was generated by a different version of the compiler: "

50− , show (iVersion interface), "\n"

51− , " Please remove the file and try again.\n"

52− ]

compiler/Metadata/Prelude.hs+27−38

@@ -1,70 +1,59 @@

1+{-# OPTIONS_GHC -W #-}

1module Metadata.Prelude (interfaces, add) where

2module Metadata.Prelude (interfaces, add) where

2

3

3import qualified Data.Map as Map

4import qualified Data.Map as Map

4import qualified Control.Exception as E

5import qualified Control.Exception as E

5import qualified Paths_Elm as Path

6import qualified Paths_Elm as Path

6−import System.Directory

7import System.Exit

8−import System.FilePath

9import System.IO

8import System.IO

10import SourceSyntax.Module

9import SourceSyntax.Module

11−import qualified Data.Binary as Binary

10+import qualified Build.Interface as Interface

12−import qualified Data.ByteString.Lazy as BS

13

11

14−import qualified InterfaceSerialization as IS

15−

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

12+add :: Bool -> Module def -> Module def

17−add (Module name exs ims stmts) = Module name exs (customIms ++ ims) stmts

13+add noPrelude (Module name exs ims decls) = Module name exs (customIms ++ ims) decls

18 where

14 where

19− customIms = concatMap addModule prelude

15+ customIms = if noPrelude then [] else concatMap addModule prelude

20

16

21 addModule (n, method) = case lookup n ims of

17 addModule (n, method) = case lookup n ims of

22 Nothing -> [(n, method)]

18 Nothing -> [(n, method)]

23− Just (As m) -> [(n, method)]

19+ Just (As _) -> [(n, method)]

24 Just _ -> []

20 Just _ -> []

25

21

26prelude :: [(String, ImportMethod)]

22prelude :: [(String, ImportMethod)]

27−prelude = text ++ map (\n -> (n, Hiding [])) modules

23+prelude = string : text ++ map (\n -> (n, Hiding [])) modules

28 where

24 where

29 text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

25 text = map ((,) "Text") [ As "Text", Hiding ["link", "color", "height"] ]

26+ string = ("String", As "String")

30 modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"

27 modules = [ "Basics", "Signal", "List", "Maybe", "Time", "Prelude"

31− , "Graphics.Element", "Color", "Graphics.Collage" ]

28+ , "Graphics.Element", "Color", "Graphics.Collage", "Native.Ports" ]

32

29

33−interfaces :: IO Interfaces

30+interfaces :: Bool -> IO Interfaces

31+interfaces noPrelude =

32+ if noPrelude

33+ then return $ Map.empty

34−interfaces = safeReadDocs =<< Path.getDataFileName "interfaces.data"

34+ else safeReadDocs =<< Path.getDataFileName "interfaces.data"

35

36safeReadDocs :: FilePath -> IO Interfaces

37safeReadDocs name =

38 E.catch (readDocs name) $ \err -> do

39 let _ = err :: IOError

40+ hPutStrLn stderr $ unlines $

40− putStrLn $ unlines [ "Error reading types for standard library!"

41+ [ "Error reading types for standard library from file " ++ name

41− , " The file should be at " ++ name

42− , " If you are using a stable version of Elm,"

42+ , " If you are using a stable version of Elm, please report an issue at"

43− , " please report an issue at github.com/evancz/Elm"

43+ , " <http://github.com/evancz/Elm/issues> specifying version numbers for"

44− , " and specify your versions of Elm and your OS" ]

44+ , " Elm and your OS." ]

45 exitFailure

46

47−firstModuleInterface :: [(String, ModuleInterface)] ->

48− Either String (String, ModuleInterface)

49−firstModuleInterface interfaces =

50− case interfaces of

51− [] -> Left "No interfaces found in serialized Prelude!"

52− iface:_ -> Right iface

53−

54readDocs :: FilePath -> IO Interfaces

47readDocs :: FilePath -> IO Interfaces

55readDocs filePath = do

48readDocs filePath = do

56− bytes <- IS.loadInterface filePath

49+ interfaces <- Interface.load filePath

57− let interfaces = IS.interfaceDecode filePath =<< bytes

50+ case mapM (Interface.isValid filePath) (interfaces :: [(String, ModuleInterface)]) of

58−

59− -- Although every ModuleInterface that is deserialized in this collection

60− -- contains the compiler version, we only check the first ModuleInterface

61− -- since it doesn't make sense that different modules in Prelude would

62− -- have been compiled by different compiler versions.

63− isValid = IS.validVersion filePath =<< firstModuleInterface =<< interfaces

64−

65− case (interfaces, isValid) of

66− (_, Left err) -> do

51+ Left err -> do

67 hPutStrLn stderr err

52 hPutStrLn stderr err

68 exitFailure

53 exitFailure

69

54

55+ Right [] -> do

56+ hPutStrLn stderr "No interfaces found in serialized Prelude!"

57+ exitFailure

58+

70− (Right ifaces, _) -> return $ Map.fromList ifaces

59+ Right ifaces -> return $ Map.fromList ifaces

compiler/Parse/Binop.hs+15−16

@@ -1,12 +1,11 @@

1module Parse.Binop (binops, OpTable) where

2

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

4−import Control.Monad.Error

5import Data.List (intercalate)

4import Data.List (intercalate)

6import qualified Data.Map as Map

5import qualified Data.Map as Map

7

6

8import SourceSyntax.Location (merge)

7import SourceSyntax.Location (merge)

9−import SourceSyntax.Expression (LExpr, Expr(Binop))

8+import qualified SourceSyntax.Expression as E

10import SourceSyntax.Declaration (Assoc(..))

9import SourceSyntax.Declaration (Assoc(..))

11import Text.Parsec

10import Text.Parsec

12import Parse.Helpers

11import Parse.Helpers

@@ -17,13 +16,13 @@ opLevel table op = fst $ Map.findWithDefault (9,L) op table

17opAssoc :: OpTable -> String -> Assoc

16opAssoc :: OpTable -> String -> Assoc

18opAssoc table op = snd $ Map.findWithDefault (9,L) op table

17opAssoc table op = snd $ Map.findWithDefault (9,L) op table

19

18

20−hasLevel :: OpTable -> Int -> (String, LExpr t v) -> Bool

19+hasLevel :: OpTable -> Int -> (String, E.LParseExpr) -> Bool

21hasLevel table n (op,_) = opLevel table op == n

20hasLevel table n (op,_) = opLevel table op == n

22

21

23−binops :: IParser (LExpr t v)

22+binops :: IParser E.LParseExpr

24− -> IParser (LExpr t v)

23+ -> IParser E.LParseExpr

25 -> IParser String

24 -> IParser String

26− -> IParser (LExpr t v)

25+ -> IParser E.LParseExpr

27binops term last anyOp =

26binops term last anyOp =

28 do e <- term

27 do e <- term

29 table <- getState

28 table <- getState

@@ -39,9 +38,9 @@ binops term last anyOp =

39

38

40split :: OpTable

39split :: OpTable

41 -> Int

40 -> Int

42− -> LExpr t v

41+ -> E.LParseExpr

43− -> [(String, LExpr t v)]

42+ -> [(String, E.LParseExpr)]

44− -> IParser (LExpr t v)

43+ -> IParser E.LParseExpr

45split _ _ e [] = return e

44split _ _ e [] = return e

46split table n e eops = do

45split table n e eops = do

47 assoc <- getAssoc table n eops

46 assoc <- getAssoc table n eops

@@ -50,26 +49,26 @@ split table n e eops = do

50 case assoc of R -> joinR es ops

49 case assoc of R -> joinR es ops

51 _ -> joinL es ops

50 _ -> joinL es ops

52

51

53−splitLevel :: OpTable -> Int -> LExpr t v -> [(String, LExpr t v)]

52+splitLevel :: OpTable -> Int -> E.LParseExpr -> [(String, E.LParseExpr)]

54− -> [IParser (LExpr t v)]

53+ -> [IParser E.LParseExpr]

55splitLevel table n e eops =

54splitLevel table n e eops =

56 case break (hasLevel table n) eops of

55 case break (hasLevel table n) eops of

57 (lops, (op,e'):rops) ->

56 (lops, (op,e'):rops) ->

58 split table (n+1) e lops : splitLevel table n e' rops

57 split table (n+1) e lops : splitLevel table n e' rops

59 (lops, []) -> [ split table (n+1) e lops ]

58 (lops, []) -> [ split table (n+1) e lops ]

60

59

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

60+joinL :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

62joinL [e] [] = return e

61joinL [e] [] = return e

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

62+joinL (a:b:es) (op:ops) = joinL (merge a b (E.Binop op a b) : es) ops

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

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

65

64

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

65+joinR :: [E.LParseExpr] -> [String] -> IParser E.LParseExpr

67joinR [e] [] = return e

66joinR [e] [] = return e

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

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

69− return (merge a e (Binop op a e))

68+ return (merge a e (E.Binop op a e))

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

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

71

70

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

71+getAssoc :: OpTable -> Int -> [(String,E.LParseExpr)] -> IParser Assoc

73getAssoc table n eops

72getAssoc table n eops

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

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

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

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

compiler/Parse/Declaration.hs+33−88

@@ -1,36 +1,36 @@

1−

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

2module Parse.Declaration where

3

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

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

5−import qualified Data.List as List

6−import qualified Data.Set as Set

7import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

8−import Text.Parsec.Indent

9

6

10import Parse.Helpers

7import Parse.Helpers

11import qualified Parse.Expression as Expr

8import qualified Parse.Expression as Expr

12−import qualified SourceSyntax.Type as T

13import qualified Parse.Type as Type

9import qualified Parse.Type as Type

14−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

10+import qualified SourceSyntax.Declaration as D

15

11

16

12

17−declaration :: IParser (Declaration t v)

13+declaration :: IParser D.ParseDeclaration

18−declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

14+declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

19

15

20−definition :: IParser (Declaration t v)

16+definition :: IParser D.ParseDeclaration

21−definition = Definition <$> Expr.def

17+definition = D.Definition <$> Expr.def

22

18

23−alias :: IParser (Declaration t v)

19+alias :: IParser D.ParseDeclaration

24alias = do

20alias = do

25 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

21 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

26 forcedWS

22 forcedWS

27− alias <- capVar

23+ name <- capVar

28− args <- spacePrefix lowVar

24+ args <- spacePrefix lowVar

29 padded equals

25 padded equals

30 tipe <- Type.expr

26 tipe <- Type.expr

27+ json <- option [] $ do

28+ try $ padded (reserved "deriving")

29+ string "Json"

30+ return [D.Json]

31− return (TypeAlias alias args tipe)

31+ return (D.TypeAlias name args tipe json)

32

33−datatype :: IParser (Declaration t v)

33+datatype :: IParser D.ParseDeclaration

34datatype = do

35 reserved "data" <?> "datatype definition (data T = A | B | ...)"

36 forcedWS

@@ -38,81 +38,26 @@ datatype = do

38 args <- spacePrefix lowVar

39 padded equals

40 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

41+ return $ D.Datatype name args tcs []

42

43

44−infixDecl :: IParser (Declaration t v)

44+infixDecl :: IParser D.ParseDeclaration

45infixDecl = do

46− assoc <- choice [ reserved "infixl" >> return L

46+ assoc <- choice [ reserved "infixl" >> return D.L

47− , reserved "infix" >> return N

47+ , reserved "infix" >> return D.N

48− , reserved "infixr" >> return R ]

48+ , reserved "infixr" >> return D.R ]

49 forcedWS

50 n <- digit

51 forcedWS

52− Fixity assoc (read [n]) <$> anyOp

52+ D.Fixity assoc (read [n]) <$> anyOp

53−

53+

54−

54+

55−foreignDef :: IParser (Declaration t v)

55+port :: IParser D.ParseDeclaration

56−foreignDef = do

56+port =

57− try (reserved "foreign")

57+ do try (reserved "port")

58− whitespace

58+ whitespace

59− importEvent <|> exportEvent

59+ name <- lowVar

60−

60+ whitespace

61−exportEvent :: IParser (Declaration t v)

61+ let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }

62−exportEvent = do

62+ D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr

63− try (reserved "export") >> padded (reserved "jsevent")

63+ , port' equals D.PPDef Expr.expr ]

64− eventName <- jsVar

65− whitespace

66− elmVar <- lowVar

67− padded hasType

68− tipe <- Type.expr

69− case tipe of

70− T.Data "Signal" [t] ->

71− case isExportable t of

72− Nothing -> return (ExportEvent eventName elmVar tipe)

73− Just err -> fail err

74− _ -> fail "When importing foreign events, the imported value must have type Signal."

75−

76−importEvent :: IParser (Declaration t v)

77−importEvent = do

78− try (reserved "import") >> padded (reserved "jsevent")

79− eventName <- jsVar

80− baseValue <- padded Expr.term

81− <?> "Base case for imported signal (signals cannot be undefined)"

82− elmVar <- lowVar <?> "Name of imported signal"

83− padded hasType

84− tipe <- Type.expr

85− case tipe of

86− T.Data "Signal" [t] ->

87− case isExportable t of

88− Nothing -> return (ImportEvent eventName baseValue elmVar tipe)

89− Just err -> fail err

90− _ -> fail "When importing foreign events, the imported value must have type Signal."

91−

92−jsVar :: IParser String

93−jsVar = betwixt '"' '"' $ do

94− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

95− if Set.notMember v jsReserveds then return v else

96− fail $ "'" ++ v ++

97− "' is not a good name for a importing or exporting JS values."

98−

99−isExportable tipe =

100− case tipe of

101− T.Lambda _ _ ->

102− Just $ "Elm's JavaScript event interface does not yet handle functions. " ++

103− "Only simple values can be imported and exported in this release."

104−

105− T.Data "JSArray" [t] -> isExportable t

106−

107− T.Data name []

108− | any (`List.isSuffixOf` name) jsTypes -> Nothing

109− | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg

110−

111− T.Data name _ ->

112− Just $ "'" ++ name ++ "' is not an exportable type " ++

113− "constructor. Only 'JSArray' is an exportable container."

114−

115− T.Var _ -> Just $ "Cannot export type variables." ++ msg

116− where

117− msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes

118− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]

compiler/Parse/Expression.hs+22−23

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

1−module Parse.Expression (def,term,typeAnnotation) where

1+module Parse.Expression (def,term,typeAnnotation,expr) where

2

3−import Control.Arrow ((***))

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

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

5import Data.List (foldl')

4import Data.List (foldl')

6import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

@@ -16,26 +15,25 @@ import SourceSyntax.Location as Location

16import SourceSyntax.Pattern hiding (tuple,list)

15import SourceSyntax.Pattern hiding (tuple,list)

17import qualified SourceSyntax.Literal as Literal

16import qualified SourceSyntax.Literal as Literal

18import SourceSyntax.Expression

17import SourceSyntax.Expression

19−import SourceSyntax.Declaration (Declaration(Definition))

20

18

21

19

22-------- Basic Terms --------

20-------- Basic Terms --------

23

21

24−varTerm :: IParser (Expr t v)

22+varTerm :: IParser ParseExpr

25varTerm = toVar <$> var <?> "variable"

23varTerm = toVar <$> var <?> "variable"

26

24

27−toVar :: String -> Expr t v

25+toVar :: String -> ParseExpr

28toVar v = case v of "True" -> Literal (Literal.Boolean True)

26toVar v = case v of "True" -> Literal (Literal.Boolean True)

29 "False" -> Literal (Literal.Boolean False)

27 "False" -> Literal (Literal.Boolean False)

30 _ -> Var v

28 _ -> Var v

31

29

32−accessor :: IParser (Expr t v)

30+accessor :: IParser ParseExpr

33accessor = do

31accessor = do

34 (start, lbl, end) <- located (try (string "." >> rLabel))

32 (start, lbl, end) <- located (try (string "." >> rLabel))

35 let loc e = Location.at start end e

33 let loc e = Location.at start end e

36 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

34 return (Lambda (PVar "_") (loc $ Access (loc $ Var "_") lbl))

37

35

38−negative :: IParser (Expr t v)

36+negative :: IParser ParseExpr

39negative = do

37negative = do

40 (start, nTerm, end) <-

38 (start, nTerm, end) <-

41 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

39 located (try (char '-' >> notFollowedBy (char '.' <|> char '-')) >> term)

@@ -45,7 +43,7 @@ negative = do

45

43

46-------- Complex Terms --------

44-------- Complex Terms --------

47

45

48−listTerm :: IParser (Expr t v)

46+listTerm :: IParser ParseExpr

49listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)

47listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)

50 where

48 where

51 range = do

49 range = do

@@ -68,7 +66,7 @@ listTerm = markdown' <|> braces (try range <|> ExplicitList <$> commaSep expr)

68 string "}}"

66 string "}}"

69 return (md ++ span uid (length exprs), exprs ++ [e])

67 return (md ++ span uid (length exprs), exprs ++ [e])

70

68

71−parensTerm :: IParser (LExpr t v)

69+parensTerm :: IParser LParseExpr

72parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

70parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

73 where

71 where

74 opFn = do

72 opFn = do

@@ -91,7 +89,7 @@ parensTerm = try (parens opFn) <|> parens (tupleFn <|> parened)

91 [e] -> e

89 [e] -> e

92 _ -> Location.at start end (tuple es)

90 _ -> Location.at start end (tuple es)

93

91

94−recordTerm :: IParser (LExpr t v)

92+recordTerm :: IParser LParseExpr

95recordTerm = brackets $ choice [ misc, addLocation record ]

93recordTerm = brackets $ choice [ misc, addLocation record ]

96 where field = do

94 where field = do

97 label <- rLabel

95 label <- rLabel

@@ -124,14 +122,14 @@ recordTerm = brackets $ choice [ misc, addLocation record ]

124 Nothing -> try (insert record) <|> try (modify record)

122 Nothing -> try (insert record) <|> try (modify record)

125

123

126

124

127−term :: IParser (LExpr t v)

125+term :: IParser LParseExpr

128term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

126term = addLocation (choice [ Literal <$> literal, listTerm, accessor, negative ])

129 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

127 <|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)

130 <?> "basic term (4, x, 'c', etc.)"

128 <?> "basic term (4, x, 'c', etc.)"

131

129

132-------- Applications --------

130-------- Applications --------

133

131

134−appExpr :: IParser (LExpr t v)

132+appExpr :: IParser LParseExpr

135appExpr = do

133appExpr = do

136 t <- term

134 t <- term

137 ts <- constrainedSpacePrefix term $ \str ->

135 ts <- constrainedSpacePrefix term $ \str ->

@@ -142,12 +140,12 @@ appExpr = do

142

140

143-------- Normal Expressions --------

141-------- Normal Expressions --------

144

142

145−binaryExpr :: IParser (LExpr t v)

143+binaryExpr :: IParser LParseExpr

146binaryExpr = binops appExpr lastExpr anyOp

144binaryExpr = binops appExpr lastExpr anyOp

147 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

145 where lastExpr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

148 <|> lambdaExpr

146 <|> lambdaExpr

149

147

150−ifExpr :: IParser (Expr t v)

148+ifExpr :: IParser ParseExpr

151ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

149ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

152 where

150 where

153 normal = do

151 normal = do

@@ -163,7 +161,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

163 b <- expr ; padded arrow

161 b <- expr ; padded arrow

164 (,) b <$> expr

162 (,) b <$> expr

165

163

166−lambdaExpr :: IParser (LExpr t v)

164+lambdaExpr :: IParser LParseExpr

167lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

165lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

168 whitespace

166 whitespace

169 args <- spaceSep1 Pattern.term

167 args <- spaceSep1 Pattern.term

@@ -171,17 +169,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

171 body <- expr

169 body <- expr

172 return (makeFunction args body)

170 return (makeFunction args body)

173

171

174−defSet :: IParser [Def t v]

172+defSet :: IParser [ParseDef]

175defSet = block (do d <- def ; whitespace ; return d)

173defSet = block (do d <- def ; whitespace ; return d)

176

174

177−letExpr :: IParser (Expr t v)

175+letExpr :: IParser ParseExpr

178letExpr = do

176letExpr = do

179 reserved "let" ; whitespace

177 reserved "let" ; whitespace

180 defs <- defSet

178 defs <- defSet

181 padded (reserved "in")

179 padded (reserved "in")

182 Let defs <$> expr

180 Let defs <$> expr

183

181

184−caseExpr :: IParser (Expr t v)

182+caseExpr :: IParser ParseExpr

185caseExpr = do

183caseExpr = do

186 reserved "case"; e <- padded expr; reserved "of"; whitespace

184 reserved "case"; e <- padded expr; reserved "of"; whitespace

187 Case e <$> (with <|> without)

185 Case e <$> (with <|> without)

@@ -191,6 +189,7 @@ caseExpr = do

191 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

189 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

192 without = block (do c <- case_ ; whitespace ; return c)

190 without = block (do c <- case_ ; whitespace ; return c)

193

191

192+expr :: IParser LParseExpr

194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

193expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

195 <|> lambdaExpr

194 <|> lambdaExpr

196 <|> binaryExpr

195 <|> binaryExpr

@@ -206,7 +205,7 @@ defStart =

206 where

205 where

207 func pattern =

206 func pattern =

208 case pattern of

207 case pattern of

209− PVar v -> (pattern:) <$> spacePrefix Pattern.term

208+ PVar _ -> (pattern:) <$> spacePrefix Pattern.term

210 _ -> do try (lookAhead (whitespace >> string "="))

209 _ -> do try (lookAhead (whitespace >> string "="))

211 return [pattern]

210 return [pattern]

212

211

@@ -216,18 +215,18 @@ defStart =

216 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

215 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

217 else [ PVar (o:p), p1, p2 ]

216 else [ PVar (o:p), p1, p2 ]

218

217

219−makeFunction :: [Pattern] -> LExpr t v -> LExpr t v

218+makeFunction :: [Pattern] -> LParseExpr -> LParseExpr

220makeFunction args body@(L s _) =

219makeFunction args body@(L s _) =

221 foldr (\arg body' -> L s $ Lambda arg body') body args

220 foldr (\arg body' -> L s $ Lambda arg body') body args

222

221

223−definition :: IParser (Def t v)

222+definition :: IParser ParseDef

224definition = withPos $ do

223definition = withPos $ do

225 (name:args) <- defStart

224 (name:args) <- defStart

226 padded equals

225 padded equals

227 body <- expr

226 body <- expr

228 return . Def name $ makeFunction args body

227 return . Def name $ makeFunction args body

229

228

230−typeAnnotation :: IParser (Def t v)

229+typeAnnotation :: IParser ParseDef

231typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

230typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

232 where

231 where

233 start = do

232 start = do

@@ -235,5 +234,5 @@ typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

235 padded hasType

234 padded hasType

236 return v

235 return v

237

236

238−def :: IParser (Def t v)

237+def :: IParser ParseDef

239def = typeAnnotation <|> definition

238def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+77−41

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

1+{-# OPTIONS_GHC -W #-}

1module Parse.Helpers where

2module Parse.Helpers where

2

3

3import Prelude hiding (until)

4import Prelude hiding (until)

@@ -7,13 +8,15 @@ import Control.Monad.State

7import Data.Char (isUpper)

8import Data.Char (isUpper)

8import qualified Data.Set as Set

9import qualified Data.Set as Set

9import qualified Data.Map as Map

10import qualified Data.Map as Map

11+import Text.Parsec hiding (newline,spaces,State)

12+import Text.Parsec.Indent

13+import qualified Text.Parsec.Token as T

14+

10import SourceSyntax.Helpers as Help

15import SourceSyntax.Helpers as Help

11import SourceSyntax.Location as Location

16import SourceSyntax.Location as Location

12import SourceSyntax.Expression

17import SourceSyntax.Expression

13import SourceSyntax.PrettyPrint

18import SourceSyntax.PrettyPrint

14import SourceSyntax.Declaration (Assoc)

19import SourceSyntax.Declaration (Assoc)

15−import Text.Parsec hiding (newline,spaces,State)

16−import Text.Parsec.Indent

17

20

18reserveds = [ "if", "then", "else"

21reserveds = [ "if", "then", "else"

19 , "case", "of"

22 , "case", "of"

@@ -22,7 +25,7 @@ reserveds = [ "if", "then", "else"

22 , "module", "where"

25 , "module", "where"

23 , "import", "as", "hiding", "open"

26 , "import", "as", "hiding", "open"

24 , "export", "foreign"

27 , "export", "foreign"

25− , "deriving" ]

28+ , "deriving", "port" ]

26

29

27jsReserveds :: Set.Set String

30jsReserveds :: Set.Set String

28jsReserveds = Set.fromList

31jsReserveds = Set.fromList

@@ -45,7 +48,8 @@ jsReserveds = Set.fromList

45expecting = flip (<?>)

48expecting = flip (<?>)

46

49

47type OpTable = Map.Map String (Int, Assoc)

50type OpTable = Map.Map String (Int, Assoc)

51+type SourceM = State SourcePos

48−type IParser a = ParsecT String OpTable (State SourcePos) a

52+type IParser a = ParsecT String OpTable SourceM a

49

53

50iParse :: IParser a -> String -> Either ParseError a

54iParse :: IParser a -> String -> Either ParseError a

51iParse = iParseWithTable "" Map.empty

55iParse = iParseWithTable "" Map.empty

@@ -54,23 +58,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE

54iParseWithTable sourceName table aParser input =

58iParseWithTable sourceName table aParser input =

55 runIndent sourceName $ runParserT aParser table sourceName input

59 runIndent sourceName $ runParserT aParser table sourceName input

56

60

57−readMaybe :: Read a => String -> Maybe a

58−readMaybe s =

59− case [ x | (x,t) <- reads s, ("","") <- lex t ] of

60− [x] -> Just x

61− _ -> Nothing

62−

63−backslashed :: IParser Char

64−backslashed = do

65− char '\\'

66− c <- anyChar

67− case readMaybe ['\'','\\',c,'\''] of

68− Just chr -> return chr

69− Nothing ->

70− fail $ "Did not recognize character '\\" ++ [c] ++

71− "'. If the backslash is meant to be a character of its own, " ++

72− "it should be escaped like this: \"\\\\" ++ [c] ++ "\""

73−

74var :: IParser String

61var :: IParser String

75var = makeVar (letter <|> char '_' <?> "variable")

62var = makeVar (letter <|> char '_' <?> "variable")

76

63

@@ -206,7 +193,7 @@ located p = do

206 end <- getPosition

193 end <- getPosition

207 return (start, e, end)

194 return (start, e, end)

208

195

209−accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

196+accessible :: IParser LParseExpr -> IParser LParseExpr

210accessible expr = do

197accessible expr = do

211 start <- getPosition

198 start <- getPosition

212 ce@(L _ e) <- expr

199 ce@(L _ e) <- expr

@@ -325,24 +312,73 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []

325 closeMarkdown (md ++ [c]) stuff

312 closeMarkdown (md ++ [c]) stuff

326 ]

313 ]

327

314

328−str :: IParser String

315+--str :: IParser String

329−str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote

316+str = expecting "String" $ do

330− , liftM dewindows . expecting "string" . betwixt '"' '"' . many $

317+ s <- choice [ multiStr, singleStr ]

331− backslashed <|> satisfy (/='"')

318+ processAs T.stringLiteral . sandwich '\"' $ concat s

332− ]

319+ where

333− where

320+ rawString quote insides =

334− quote = try (string "\"\"\"")

321+ quote >> manyTill insides quote

335−

322+

336− -- Remove \r from strings to fix generated JavaScript

323+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar

337− dewindows [] = []

324+ singleStr = rawString (char '"') stringChar

338− dewindows cs =

325+

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

326+ stringChar :: IParser String

340− in pre ++ case suf of

327+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]

341− ('\r':'\n':rest) -> '\n' : dewindows rest

328+

342− ('\n':rest) -> '\n' : dewindows rest

329+ multilineStringChar :: IParser String

343− ('\r':rest) -> '\n' : dewindows rest

330+ multilineStringChar =

344− _ -> []

331+ do noEnd

332+ choice [ newlineChar, escaped '\"', expandQuote <$> anyChar ]

333+ where

334+ noEnd = notFollowedBy (string "\"\"\"")

335+ expandQuote c = if c == '\"' then "\\\"" else [c]

336+

337+ newlineChar :: IParser String

338+ newlineChar =

339+ choice [ char '\n' >> return "\\n"

340+ , char '\r' >> return "\\r" ]

341+

342+sandwich :: Char -> String -> String

343+sandwich delim s = delim : s ++ [delim]

344+

345+escaped :: Char -> IParser String

346+escaped delim = try $ do

347+ char '\\'

348+ c <- char '\\' <|> char delim

349+ return ['\\', c]

345

350

346chr :: IParser Char

351chr :: IParser Char

347−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

352+chr = betwixt '\'' '\'' character <?> "character"

348− <?> "character"

353+ where

354+ nonQuote = satisfy (/='\'')

355+ character = do

356+ c <- choice [ escaped '\''

357+ , (:) <$> char '\\' <*> many1 nonQuote

358+ , (:[]) <$> nonQuote ]

359+ processAs T.charLiteral $ sandwich '\'' c

360+

361+processAs :: (T.GenTokenParser String u SourceM -> IParser a) -> String -> IParser a

362+processAs processor s = calloutParser s (processor lexer)

363+ where

364+ calloutParser :: String -> IParser a -> IParser a

365+ calloutParser inp p = either (fail . show) return (iParse p inp)

366+

367+ lexer :: T.GenTokenParser String u SourceM

368+ lexer = T.makeTokenParser elmDef

369+

370+ -- I don't know how many of these are necessary for charLiteral/stringLiteral

371+ elmDef :: T.GenLanguageDef String u SourceM

372+ elmDef = T.LanguageDef

373+ { T.commentStart = "{-"

374+ , T.commentEnd = "-}"

375+ , T.commentLine = "--"

376+ , T.nestedComments = True

377+ , T.identStart = undefined

378+ , T.identLetter = undefined

379+ , T.opStart = undefined

380+ , T.opLetter = undefined

381+ , T.reservedNames = reserveds

382+ , T.reservedOpNames = [":", "->", "<-", "|"]

383+ , T.caseSensitive = True

384+ }

compiler/Parse/Literal.hs+3−4

@@ -1,13 +1,12 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

1module Parse.Literal (literal) where

2module Parse.Literal (literal) where

2

3

3−import Control.Applicative ((<$>), (<*>))

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

4−import Control.Monad

5import Text.Parsec hiding (newline,spaces)

6−import Text.Parsec.Indent

7−

8import Parse.Helpers

6import Parse.Helpers

9import SourceSyntax.Literal

7import SourceSyntax.Literal

10

8

9+literal :: IParser Literal

11literal = num <|> (Str <$> str) <|> (Chr <$> chr)

10literal = num <|> (Str <$> str) <|> (Chr <$> chr)

12

11

13num :: IParser Literal

12num :: IParser Literal

compiler/Parse/Module.hs+1−2

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

1−

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

1module Parse.Module (moduleDef, getModuleName, imports) where

3

2

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

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

@@ -6,7 +5,7 @@ import Data.List (intercalate)

6import Text.Parsec hiding (newline,spaces)

5import Text.Parsec hiding (newline,spaces)

7

6

8import Parse.Helpers

7import Parse.Helpers

9−import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)

8+import SourceSyntax.Module (ImportMethod(..), Imports)

10

9

11varList :: IParser [String]

10varList :: IParser [String]

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

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

compiler/Parse/Parse.hs+23−20

@@ -1,22 +1,19 @@

1+{-# OPTIONS_GHC -W #-}

1module Parse.Parse (program, dependencies) where

2module Parse.Parse (program, dependencies) where

2

3

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

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

4−import Control.Monad

5+import qualified Data.List as List

5−import Data.Char (isSymbol, isDigit)

6−import Data.List (foldl',intercalate)

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8import Text.Parsec hiding (newline,spaces)

7import Text.Parsec hiding (newline,spaces)

9import qualified Text.PrettyPrint as P

8import qualified Text.PrettyPrint as P

10

9

11−import qualified SourceSyntax.Module as S

10+import qualified SourceSyntax.Declaration as D

12−import SourceSyntax.Declaration (Declaration(Fixity))

11+import qualified SourceSyntax.Module as M

13import Parse.Helpers

12import Parse.Helpers

14−import Parse.Binop (OpTable)

15−import Parse.Expression

16import Parse.Declaration (infixDecl)

13import Parse.Declaration (infixDecl)

17−import Parse.Type

18import Parse.Module

14import Parse.Module

19import qualified Parse.Declaration as Decl

15import qualified Parse.Declaration as Decl

16+import Transform.Declaration (combineAnnotations)

20

17

21freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

18freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

22 freshLine

19 freshLine

@@ -25,19 +22,25 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

25decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

22decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

26 (d:) <$> many freshDef

23 (d:) <$> many freshDef

27

24

28−program :: OpTable -> String -> Either [P.Doc] (S.Module t v)

25+program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program table src =

29−program table = setupParserWithTable table $ do

27+ do (M.Module names exs ims parseDecls) <- setupParserWithTable table programParser src

28+ decls <- either (\err -> Left [P.text err]) Right (combineAnnotations parseDecls)

29+ return $ M.Module names exs ims decls

30+

31+programParser :: IParser (M.Module D.ParseDeclaration)

32+programParser =

30− optional freshLine

33+ do optional freshLine

31− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

34+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

32− is <- (do try (lookAhead $ reserved "import")

35+ is <- (do try (lookAhead $ reserved "import")

33− imports `followedBy` freshLine) <|> return []

36+ imports `followedBy` freshLine) <|> return []

34− declarations <- decls

37+ declarations <- decls

35− optional freshLine ; optional spaces ; eof

38+ optional freshLine ; optional spaces ; eof

36− return $ S.Module names exports is declarations

39+ return $ M.Module names exports is declarations

37

40

38dependencies :: String -> Either [P.Doc] (String, [String])

41dependencies :: String -> Either [P.Doc] (String, [String])

39dependencies =

42dependencies =

40− let getName = intercalate "." . fst in

43+ let getName = List.intercalate "." . fst in

41 setupParser $ do

44 setupParser $ do

42 optional freshLine

45 optional freshLine

43 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

46 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

@@ -56,12 +59,12 @@ setupParserWithTable table p source =

56 msg overlap =

59 msg overlap =

57 P.vcat [ P.text "Parse error:"

60 P.vcat [ P.text "Parse error:"

58 , P.text $ "Overlapping definitions for infix operators: " ++

61 , P.text $ "Overlapping definitions for infix operators: " ++

59− intercalate " " (Map.keys overlap)

62+ List.intercalate " " (Map.keys overlap)

60 ]

63 ]

61

64

62parseFixities = do

65parseFixities = do

63 decls <- onFreshLines (:) [] infixDecl

66 decls <- onFreshLines (:) [] infixDecl

64− return $ Map.fromList [ (op,(lvl,assoc)) | Fixity assoc lvl op <- decls ]

67+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]

65

68

66setupParser :: IParser a -> String -> Either [P.Doc] a

69setupParser :: IParser a -> String -> Either [P.Doc] a

67setupParser p source =

70setupParser p source =

compiler/Parse/Pattern.hs+6−8

@@ -1,13 +1,10 @@

1−

1+{-# OPTIONS_GHC -W #-}

2module Parse.Pattern (term, expr) where

3

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

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

5−import Control.Monad

6−import Control.Monad.State

7import Data.Char (isUpper)

5import Data.Char (isUpper)

8import Data.List (intercalate)

6import Data.List (intercalate)

9import Text.Parsec hiding (newline,spaces,State)

7import Text.Parsec hiding (newline,spaces,State)

10−import Text.Parsec.Indent

11

8

12import Parse.Helpers

9import Parse.Helpers

13import Parse.Literal

10import Parse.Literal

@@ -20,9 +17,10 @@ basic = choice

20 [ char '_' >> return PAnything

17 [ char '_' >> return PAnything

21 , do v <- var

18 , do v <- var

22 return $ case v of

19 return $ case v of

23− "True" -> PLiteral (Boolean True)

20+ "True" -> PLiteral (Boolean True)

24− "False" -> PLiteral (Boolean False)

21+ "False" -> PLiteral (Boolean False)

25− c : _ -> if isUpper c then PData v [] else PVar v

22+ c:_ | isUpper c -> PData v []

23+ _ -> PVar v

26 , PLiteral <$> literal

24 , PLiteral <$> literal

27 ]

25 ]

28

26

compiler/Parse/Type.hs+10−11

@@ -1,11 +1,9 @@

1+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

1module Parse.Type where

2module Parse.Type where

2

3

3−import Control.Applicative ((<$>),(<*>))

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

4−import Control.Monad (liftM,mapM)

5−import Data.Char (isLower)

6−import Data.List (lookup,intercalate)

5+import Data.List (intercalate)

7import Text.Parsec

6import Text.Parsec

8−import Text.Parsec.Indent

9

7

10import SourceSyntax.Type as T

8import SourceSyntax.Type as T

11import Parse.Helpers

9import Parse.Helpers

@@ -25,23 +23,24 @@ tuple = do ts <- parens (commaSep expr)

25record :: IParser T.Type

23record :: IParser T.Type

26record =

24record =

27 do char '{' ; whitespace

25 do char '{' ; whitespace

28− (ext,fs) <- extended <|> normal

26+ rcrd <- extended <|> normal

29 dumbWhitespace ; char '}'

27 dumbWhitespace ; char '}'

30− return (T.Record fs ext)

28+ return rcrd

31 where

29 where

32− normal = (,) T.EmptyRecord <$> commaSep fields

30+ normal = flip T.Record Nothing <$> commaSep field

33

31

34 -- extended record types require at least one field

32 -- extended record types require at least one field

35 extended = do

33 extended = do

36− ext <- try (const <$> tvar <*> (whitespace >> string "|"))

34+ ext <- try (lowVar <* (whitespace >> string "|"))

37 whitespace

35 whitespace

38− (,) ext <$> commaSep1 fields

36+ flip T.Record (Just ext) <$> commaSep1 field

39

37

40− fields = do

38+ field = do

41 lbl <- rLabel

39 lbl <- rLabel

42 whitespace >> hasType >> whitespace

40 whitespace >> hasType >> whitespace

43 (,) lbl <$> expr

41 (,) lbl <$> expr

44

42

43+capTypeVar :: IParser String

45capTypeVar = intercalate "." <$> dotSep1 capVar

44capTypeVar = intercalate "." <$> dotSep1 capVar

46

45

47constructor0 :: IParser T.Type

46constructor0 :: IParser T.Type

compiler/SourceSyntax/Declaration.hs+95−20

@@ -1,21 +1,55 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Declaration where

2module SourceSyntax.Declaration where

2

3

4+import Data.Binary

3import qualified SourceSyntax.Expression as Expr

5import qualified SourceSyntax.Expression as Expr

4−import SourceSyntax.Type

6+import qualified SourceSyntax.Type as T

5import SourceSyntax.PrettyPrint

7import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as P

8import Text.PrettyPrint as P

7

9

8−data Declaration tipe var

10+data Declaration' port def

9− = Definition (Expr.Def tipe var)

11+ = Definition def

10− | Datatype String [String] [(String,[Type])]

12+ | Datatype String [String] [(String,[T.Type])] [Derivation]

11− | TypeAlias String [String] Type

13+ | TypeAlias String [String] T.Type [Derivation]

12− | ImportEvent String (Expr.LExpr tipe var) String Type

14+ | Port port

13− | ExportEvent String String Type

14 | Fixity Assoc Int String

15 | Fixity Assoc Int String

15− deriving (Eq, Show)

16+ deriving (Show)

16

17

17data Assoc = L | N | R

18data Assoc = L | N | R

18− deriving (Eq)

19+ deriving (Eq)

20+

21+data Derivation = Json | JS | Binary | New

22+ deriving (Eq, Show)

23+

24+data ParsePort

25+ = PPAnnotation String T.Type

26+ | PPDef String Expr.LParseExpr

27+ deriving (Show)

28+

29+data Port

30+ = Out String Expr.LExpr T.Type

31+ | In String T.Type

32+ deriving (Show)

33+

34+type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

35+type Declaration = Declaration' Port Expr.Def

36+

37+instance Binary Derivation where

38+ get = do n <- getWord8

39+ return $ case n of

40+ 0 -> Json

41+ 1 -> JS

42+ 2 -> Binary

43+ 3 -> New

44+ _ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\

45+ \so please report an issue at <https://github.com/evancz/Elm/issues>"

46+

47+ put derivation =

48+ putWord8 $ case derivation of

49+ Json -> 0

50+ JS -> 1

51+ Binary -> 2

52+ New -> 3

19

53

20instance Show Assoc where

54instance Show Assoc where

21 show assoc =

55 show assoc =

@@ -24,24 +58,65 @@ instance Show Assoc where

24 N -> "non"

58 N -> "non"

25 R -> "right"

59 R -> "right"

26

60

61+instance Binary Assoc where

62+ get = do n <- getWord8

63+ return $ case n of

64+ 0 -> L

65+ 1 -> N

66+ 2 -> R

67+ _ -> error "Error reading valid associativity from serialized string"

68+

69+ put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

70+

27−instance Pretty (Declaration t v) where

71+instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

28 pretty decl =

72 pretty decl =

29 case decl of

73 case decl of

30 Definition def -> pretty def

74 Definition def -> pretty def

31

75

32− Datatype tipe tvars ctors ->

76+ Datatype tipe tvars ctors deriveables ->

33 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

77 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

34− (P.sep $ zipWith join ("=" : repeat "|") ctors)

78+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables

35 where

79 where

36 join c ctor = P.text c <+> prettyCtor ctor

80 join c ctor = P.text c <+> prettyCtor ctor

37 prettyCtor (name, tipes) =

81 prettyCtor (name, tipes) =

38− P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

82+ P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))

83+

84+ TypeAlias name tvars tipe deriveables ->

85+ alias <+> prettyDeriving deriveables

86+ where

87+ name' = P.text name <+> P.hsep (map P.text tvars)

88+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)

89+

90+ Port port -> pretty port

91+

92+ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op

93+ where

94+ assoc' = case assoc of

95+ L -> P.text "l"

96+ N -> P.empty

97+ R -> P.text "r"

98+

99+instance Pretty ParsePort where

100+ pretty port =

101+ case port of

102+ PPAnnotation name tipe -> prettyPort name ":" tipe

103+ PPDef name expr -> prettyPort name "=" expr

104+

105+instance Pretty Port where

106+ pretty port =

107+ case port of

108+ In name tipe -> prettyPort name ":" tipe

109+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe

110+ , prettyPort name "=" expr ]

111+

39

112

40− TypeAlias name tvars tipe ->

113+prettyPort :: (Pretty a) => String -> String -> a -> Doc

41− let alias = P.text name <+> P.hsep (map P.text tvars) in

114+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

42− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)

43

115

44− -- TODO: Actually write out the contained data in these cases.

116+prettyDeriving :: [Derivation] -> Doc

45− ImportEvent _ _ _ _ -> P.text (show decl)

117+prettyDeriving deriveables =

46− ExportEvent _ _ _ -> P.text (show decl)

118+ case deriveables of

47− Fixity _ _ _ -> P.text (show decl)

119+ [] -> P.empty

120+ [d] -> P.text "deriving" <+> P.text (show d)

121+ ds -> P.text "deriving" <+>

122+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

compiler/SourceSyntax/Expression.hs+115−44

@@ -1,54 +1,106 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Expression where

2module SourceSyntax.Expression where

3+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.

4+The first is the fully general version and is labeled with a prime (Expr').

5+The others are specialized versions of the AST that represent specific phases

6+of the compilation process. I expect there to be more phases as we begin to

7+enrich the AST with more information.

8+-}

9+

2

10

3−import Data.List (intercalate)

4import SourceSyntax.PrettyPrint

11import SourceSyntax.PrettyPrint

5import Text.PrettyPrint as P

12import Text.PrettyPrint as P

6import qualified SourceSyntax.Helpers as Help

13import qualified SourceSyntax.Helpers as Help

7import qualified SourceSyntax.Location as Location

14import qualified SourceSyntax.Location as Location

8import qualified SourceSyntax.Pattern as Pattern

15import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

16+import qualified SourceSyntax.Type as SrcType

10import qualified SourceSyntax.Literal as Literal

17import qualified SourceSyntax.Literal as Literal

11

18

19+---- GENERAL AST ----

20+

21+{-| This is a located expression, meaning it is tagged with info about where it

22+came from in the source code. Expr' is defined in terms of LExpr' so that the

23+location information does not need to be an extra field on every constructor.

24+-}

12−type LExpr tipe var = Location.Located (Expr tipe var)

25+type LExpr' def = Location.Located (Expr' def)

26+

27+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

28+"type holes" that allow us to enrich the AST with additional information as we

29+move through the compilation process. The type holes let us show these

30+structural changes in the types. The only type hole right now is:

31+

32+ def: Parsing allows two kinds of definitions (type annotations or definitions),

33+ but later checks will see that they are well formed and combine them.

34+

35+-}

13−data Expr t v

36+data Expr' def

14 = Literal Literal.Literal

37 = Literal Literal.Literal

15 | Var String

38 | Var String

16− | Range (LExpr t v) (LExpr t v)

39+ | Range (LExpr' def) (LExpr' def)

17− | ExplicitList [LExpr t v]

40+ | ExplicitList [LExpr' def]

18− | Binop String (LExpr t v) (LExpr t v)

41+ | Binop String (LExpr' def) (LExpr' def)

19− | Lambda Pattern.Pattern (LExpr t v)

42+ | Lambda Pattern.Pattern (LExpr' def)

20− | App (LExpr t v) (LExpr t v)

43+ | App (LExpr' def) (LExpr' def)

21− | MultiIf [(LExpr t v,LExpr t v)]

44+ | MultiIf [(LExpr' def,LExpr' def)]

22− | Let [Def t v] (LExpr t v)

45+ | Let [def] (LExpr' def)

23− | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]

46+ | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]

24− | Data String [LExpr t v]

47+ | Data String [LExpr' def]

25− | Access (LExpr t v) String

48+ | Access (LExpr' def) String

26− | Remove (LExpr t v) String

49+ | Remove (LExpr' def) String

27− | Insert (LExpr t v) String (LExpr t v)

50+ | Insert (LExpr' def) String (LExpr' def)

28− | Modify (LExpr t v) [(String, LExpr t v)]

51+ | Modify (LExpr' def) [(String, LExpr' def)]

29− | Record [(String, LExpr t v)]

52+ | Record [(String, LExpr' def)]

30− | Markdown String String [LExpr t v]

53+ | Markdown String String [LExpr' def]

31− deriving (Eq)

54+ -- for type checking and code gen only

32−

55+ | PortIn String SrcType.Type

33−data Def tipe var

56+ | PortOut String SrcType.Type (LExpr' def)

57+

58+

59+---- SPECIALIZED ASTs ----

60+

61+{-| Expressions created by the parser. These use a split representation of type

62+annotations and definitions, which is how they appear in source code and how

63+they are parsed.

64+-}

65+type ParseExpr = Expr' ParseDef

66+type LParseExpr = LExpr' ParseDef

67+

68+data ParseDef

34− = Def Pattern.Pattern (LExpr tipe var)

69+ = Def Pattern.Pattern LParseExpr

35− | TypeAnnotation String Type.Type

70+ | TypeAnnotation String SrcType.Type

36− deriving (Eq, Show)

71+ deriving (Show)

37−

72+

73+{-| "Normal" expressions. When the compiler checks that type annotations and

74+ports are all paired with definitions in the appropriate order, it collapses

75+them into a Def that is easier to work with in later phases of compilation.

76+-}

77+type LExpr = LExpr' Def

78+type Expr = Expr' Def

79+

80+data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)

81+ deriving (Show)

82+

83+

84+---- UTILITIES ----

85+

86+tuple :: [LExpr' def] -> Expr' def

38tuple es = Data ("_Tuple" ++ show (length es)) es

87tuple es = Data ("_Tuple" ++ show (length es)) es

39

88

89+delist :: LExpr' def -> [LExpr' def]

40delist (Location.L _ (Data "::" [h,t])) = h : delist t

90delist (Location.L _ (Data "::" [h,t])) = h : delist t

41delist _ = []

91delist _ = []

42

92

93+saveEnvName :: String

43saveEnvName = "_save_the_environment!!!"

94saveEnvName = "_save_the_environment!!!"

44

95

96+dummyLet :: Pretty def => [def] -> LExpr' def

45dummyLet defs =

97dummyLet defs =

46 Location.none $ Let defs (Location.none $ Var saveEnvName)

98 Location.none $ Let defs (Location.none $ Var saveEnvName)

47

99

48−instance Show (Expr t v) where

100+instance Pretty def => Show (Expr' def) where

49 show = render . pretty

101 show = render . pretty

50

102

51−instance Pretty (Expr t v) where

103+instance Pretty def => Pretty (Expr' def) where

52 pretty expr =

104 pretty expr =

53 case expr of

105 case expr of

54 Literal lit -> pretty lit

106 Literal lit -> pretty lit

@@ -59,8 +111,10 @@ instance Pretty (Expr t v) where

59 P.text "-" <> prettyParens e

111 P.text "-" <> prettyParens e

60 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

112 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

61 where op' = if Help.isOp op then op else "`" ++ op ++ "`"

113 where op' = if Help.isOp op then op else "`" ++ op ++ "`"

114+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

115+ where

62− Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)

116+ (ps,body) = collectLambdas (Location.none $ Lambda p e)

63− in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body

117+ args = P.sep (map Pattern.prettyParens ps)

64 App _ _ -> P.hang func 2 (P.sep args)

118 App _ _ -> P.hang func 2 (P.sep args)

65 where func:args = map prettyParens (collectApps (Location.none expr))

119 where func:args = map prettyParens (collectApps (Location.none expr))

66 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

120 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

@@ -73,51 +127,68 @@ instance Pretty (Expr t v) where

73 P.hang pexpr 2 (P.vcat (map pretty' pats))

127 P.hang pexpr 2 (P.vcat (map pretty' pats))

74 where

128 where

75 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

129 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

76− pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e

130+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

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

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

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

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

133+ Data name es

134+ | Help.isTuple name -> P.parens (commaCat (map pretty es))

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

135+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

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

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

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

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

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

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

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

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

84 Insert e x v ->

140 Insert e x v ->

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

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

86

142

87 Modify e fs ->

143 Modify e fs ->

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

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

89 4

145 4

90 (commaSep $ map field fs)

146 (commaSep $ map field fs)

91 where

147 where

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

148+ field (k,v) = variable k <+> P.text "<-" <+> pretty v

93

149

94 Record fs ->

150 Record fs ->

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

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

96 where

152 where

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

153+ field (x,e) = variable x <+> P.equals <+> pretty e

98

154

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

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

100

156

157+ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

158+

159+ PortOut _ _ signal -> pretty signal

160+

101−instance Pretty (Def t v) where

161+instance Pretty ParseDef where

102 pretty def =

162 pretty def =

103 case def of

163 case def of

104 TypeAnnotation name tipe ->

164 TypeAnnotation name tipe ->

105− variable name <+> P.text ":" <+> pretty tipe

165+ variable name <+> P.colon <+> pretty tipe

106 Def pattern expr ->

166 Def pattern expr ->

107− pretty pattern <+> P.text "=" <+> pretty expr

167+ pretty pattern <+> P.equals <+> pretty expr

108−

168+

169+instance Pretty Def where

170+ pretty (Definition pattern expr maybeTipe) =

171+ P.vcat [ annotation, definition ]

172+ where

173+ definition = pretty pattern <+> P.equals <+> pretty expr

174+ annotation = case maybeTipe of

175+ Nothing -> P.empty

176+ Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

177+

178+collectApps :: LExpr' def -> [LExpr' def]

109collectApps lexpr@(Location.L _ expr) =

179collectApps lexpr@(Location.L _ expr) =

110 case expr of

180 case expr of

111 App a b -> collectApps a ++ [b]

181 App a b -> collectApps a ++ [b]

112 _ -> [lexpr]

182 _ -> [lexpr]

113

183

184+collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)

114collectLambdas lexpr@(Location.L _ expr) =

185collectLambdas lexpr@(Location.L _ expr) =

115 case expr of

186 case expr of

116− Lambda pattern body ->

187+ Lambda pattern body -> (pattern : ps, body')

117− let (ps, body') = collectLambdas body

188+ where (ps, body') = collectLambdas body

118− in (pretty pattern : ps, body')

119 _ -> ([], lexpr)

189 _ -> ([], lexpr)

120

190

191+prettyParens :: (Pretty def) => LExpr' def -> Doc

121prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

192prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

122 where

193 where

123 needed =

194 needed =

@@ -128,5 +199,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

128 MultiIf _ -> True

199 MultiIf _ -> True

129 Let _ _ -> True

200 Let _ _ -> True

130 Case _ _ -> True

201 Case _ _ -> True

131− Data name (x:xs) -> name /= "::"

202+ Data name (_:_) -> name /= "::"

132 _ -> False

203 _ -> False

compiler/SourceSyntax/Helpers.hs+1−1

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

1−

1+{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Helpers where

3

4import qualified Data.Char as Char

compiler/SourceSyntax/Literal.hs+5−4

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

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Literal where

2module SourceSyntax.Literal where

2

3

3import SourceSyntax.PrettyPrint

4import SourceSyntax.PrettyPrint

@@ -8,13 +9,13 @@ data Literal = IntNum Int

8 | Chr Char

9 | Chr Char

9 | Str String

10 | Str String

10 | Boolean Bool

11 | Boolean Bool

11− deriving (Eq, Ord, Show)

12+ deriving (Eq, Ord, Show)

12

13

13instance Pretty Literal where

14instance Pretty Literal where

14 pretty literal =

15 pretty literal =

15 case literal of

16 case literal of

16 IntNum n -> PP.int n

17 IntNum n -> PP.int n

17 FloatNum n -> PP.double n

18 FloatNum n -> PP.double n

18− Chr c -> PP.quotes (PP.char c)

19+ Chr c -> PP.text . show $ c

19− Str s -> PP.text (show s)

20+ Str s -> PP.text . show $ s

20− Boolean bool -> PP.text (show bool)

21+ Boolean bool -> PP.text (show bool)

compiler/SourceSyntax/Module.hs+28−43

@@ -1,21 +1,18 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Module where

2module SourceSyntax.Module where

2

3

3import Data.Binary

4import Data.Binary

4−import Data.List (intercalate)

5import qualified Data.Map as Map

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

7−import Control.Arrow (second)

8

7

9import SourceSyntax.Expression (LExpr)

8import SourceSyntax.Expression (LExpr)

10import SourceSyntax.Declaration

9import SourceSyntax.Declaration

11import SourceSyntax.Type

10import SourceSyntax.Type

12−import System.FilePath (joinPath)

13−import Control.Monad (liftM)

14

11

15import qualified Elm.Internal.Version as Version

12import qualified Elm.Internal.Version as Version

16

13

17−data Module tipe var =

14+data Module def =

18− Module [String] Exports Imports [Declaration tipe var]

15+ Module [String] Exports Imports [def]

19 deriving (Show)

16 deriving (Show)

20

17

21type Exports = [String]

18type Exports = [String]

@@ -25,48 +22,47 @@ data ImportMethod = As String | Importing [String] | Hiding [String]

25 deriving (Eq, Ord, Show)

22 deriving (Eq, Ord, Show)

26

23

27instance Binary ImportMethod where

24instance Binary ImportMethod where

25+ put method =

26+ let put' n info = putWord8 n >> put info in

27+ case method of

28− put (As s) = do put (0 :: Word8)

28+ As s -> put' 0 s

29− put s

30−

31− put (Importing ss) = do put (1 :: Word8)

29+ Importing ss -> put' 1 ss

32− put ss

33−

34− put (Hiding ss) = do put (2 :: Word8)

30+ Hiding ss -> put' 2 ss

35− put ss

36

31

37 get = do tag <- getWord8

32 get = do tag <- getWord8

38 case tag of

33 case tag of

39− 0 -> liftM As get

34+ 0 -> As <$> get

40− 1 -> liftM Importing get

35+ 1 -> Importing <$> get

41− 2 -> liftM Hiding get

36+ 2 -> Hiding <$> get

42 _ -> error "Error reading valid ImportMethod type from serialized string"

37 _ -> error "Error reading valid ImportMethod type from serialized string"

43

38

44−data MetadataModule t v = MetadataModule {

39+data MetadataModule =

40+ MetadataModule

45− names :: [String],

41+ { names :: [String]

46− path :: FilePath,

42+ , path :: FilePath

47− exports :: [String],

43+ , exports :: [String]

48− imports :: [(String, ImportMethod)],

44+ , imports :: [(String, ImportMethod)]

49− program :: LExpr t v,

45+ , program :: LExpr

50− types :: Map.Map String Type,

46+ , types :: Map.Map String Type

51− fixities :: [(Assoc, Int, String)],

47+ , fixities :: [(Assoc, Int, String)]

52− aliases :: [(String, [String], Type)],

48+ , aliases :: [Alias]

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

49+ , datatypes :: [ADT]

54− foreignImports :: [(String, LExpr t v, String, Type)],

55− foreignExports :: [(String, String, Type)]

56−} deriving Show

50+ } deriving Show

57

51

58type Interfaces = Map.Map String ModuleInterface

52type Interfaces = Map.Map String ModuleInterface

59−type ADT = (String, [String], [(String,[Type])])

53+type ADT = (String, [String], [(String,[Type])], [Derivation])

54+type Alias = (String, [String], Type, [Derivation])

60

55

61data ModuleInterface = ModuleInterface {

56data ModuleInterface = ModuleInterface {

62 iVersion :: Version.Version,

57 iVersion :: Version.Version,

63 iTypes :: Map.Map String Type,

58 iTypes :: Map.Map String Type,

64 iImports :: [(String, ImportMethod)],

59 iImports :: [(String, ImportMethod)],

65 iAdts :: [ADT],

60 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

61+ iAliases :: [Alias],

67 iFixities :: [(Assoc, Int, String)]

62 iFixities :: [(Assoc, Int, String)]

68} deriving Show

63} deriving Show

69

64

65+metaToInterface :: MetadataModule -> ModuleInterface

70metaToInterface metaModule =

66metaToInterface metaModule =

71 ModuleInterface

67 ModuleInterface

72 { iVersion = Version.elmVersion

68 { iVersion = Version.elmVersion

@@ -86,14 +82,3 @@ instance Binary ModuleInterface where

86 put (iAdts modul)

82 put (iAdts modul)

87 put (iAliases modul)

83 put (iAliases modul)

88 put (iFixities modul)

84 put (iFixities modul)

89−

90−

91−instance Binary Assoc where

92− get = do n <- getWord8

93− return $ case n of

94− 0 -> L

95− 1 -> N

96− 2 -> R

97− _ -> error "Error reading valid associativity from serialized string"

98−

99− put assoc = putWord8 $ case assoc of { L -> 0 ; N -> 1 ; R -> 2 }

compiler/SourceSyntax/Pattern.hs+26−7

@@ -1,9 +1,10 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Pattern where

2module SourceSyntax.Pattern where

2

3

3−import Data.List (intercalate)

4−import SourceSyntax.Helpers as Help

4+import qualified SourceSyntax.Helpers as Help

5import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

7import SourceSyntax.Literal as Literal

8import SourceSyntax.Literal as Literal

8

9

9data Pattern = PData String [Pattern]

10data Pattern = PData String [Pattern]

@@ -14,11 +15,28 @@ data Pattern = PData String [Pattern]

14 | PLiteral Literal.Literal

15 | PLiteral Literal.Literal

15 deriving (Eq, Ord, Show)

16 deriving (Eq, Ord, Show)

16

17

18+cons :: Pattern -> Pattern -> Pattern

17cons h t = PData "::" [h,t]

19cons h t = PData "::" [h,t]

20+

21+nil :: Pattern

18−nil = PData "[]" []

22+nil = PData "[]" []

23+

24+list :: [Pattern] -> Pattern

19list = foldr cons nil

25list = foldr cons nil

26+

27+tuple :: [Pattern] -> Pattern

20tuple es = PData ("_Tuple" ++ show (length es)) es

28tuple es = PData ("_Tuple" ++ show (length es)) es

21

29

30+boundVars :: Pattern -> Set.Set String

31+boundVars pattern =

32+ case pattern of

33+ PVar x -> Set.singleton x

34+ PAlias x p -> Set.insert x (boundVars p)

35+ PData _ ps -> Set.unions (map boundVars ps)

36+ PRecord fields -> Set.fromList fields

37+ PAnything -> Set.empty

38+ PLiteral _ -> Set.empty

39+

22

40

23instance Pretty Pattern where

41instance Pretty Pattern where

24 pretty pattern =

42 pretty pattern =

@@ -33,14 +51,15 @@ instance Pretty Pattern where

33 PData "::" _ -> True

51 PData "::" _ -> True

34 _ -> False

52 _ -> False

35 PData name ps ->

53 PData name ps ->

36− if isTuple name then

54+ if Help.isTuple name then

37 PP.parens . commaCat $ map pretty ps

55 PP.parens . commaCat $ map pretty ps

38− else sep (PP.text name : map prettyParens ps)

56+ else hsep (PP.text name : map prettyParens ps)

39

57

58+prettyParens :: Pattern -> Doc

40prettyParens pattern = parensIf needsThem (pretty pattern)

59prettyParens pattern = parensIf needsThem (pretty pattern)

41 where

60 where

42 needsThem =

61 needsThem =

43 case pattern of

62 case pattern of

44− PData name (_:_) | not (isTuple name) -> True

63+ PData name (_:_) | not (Help.isTuple name) -> True

45 PAlias _ _ -> True

64 PAlias _ _ -> True

46− _ -> False

65+ _ -> False

compiler/SourceSyntax/Type.hs+23−26

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

1+{-# OPTIONS_GHC -W #-}

1module SourceSyntax.Type where

2module SourceSyntax.Type where

2

3

3import Data.Binary

4import Data.Binary

@@ -10,16 +11,15 @@ import Text.PrettyPrint as P

10data Type = Lambda Type Type

11data Type = Lambda Type Type

11 | Var String

12 | Var String

12 | Data String [Type]

13 | Data String [Type]

13− | EmptyRecord

14− | Record [(String,Type)] Type

14+ | Record [(String,Type)] (Maybe String)

15− deriving (Eq, Show)

15+ deriving (Eq)

16

17fieldMap :: [(String,a)] -> Map.Map String [a]

18fieldMap fields =

19 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

20

21recordOf :: [(String,Type)] -> Type

22−recordOf fields = Record fields EmptyRecord

22+recordOf fields = Record fields Nothing

23

24listOf :: Type -> Type

25listOf t = Data "_List" [t]

@@ -27,39 +27,39 @@ listOf t = Data "_List" [t]

27tupleOf :: [Type] -> Type

28tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

29

30+instance Show Type where

31+ show = render . pretty

30

32

31instance Pretty Type where

33instance Pretty Type where

32 pretty tipe =

34 pretty tipe =

33 case tipe of

35 case tipe of

34− Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

36+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

37+ where

35− where t:ts = collectLambdas tipe

38+ t:ts = map prettyLambda (collectLambdas tipe)

39+ prettyLambda t = case t of

40+ Lambda _ _ -> P.parens (pretty t)

41+ _ -> pretty t

42+

36 Var x -> P.text x

43 Var x -> P.text x

37 Data "_List" [t] -> P.brackets (pretty t)

44 Data "_List" [t] -> P.brackets (pretty t)

38 Data name tipes

45 Data name tipes

39 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

46 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

40 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

47 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

41− EmptyRecord -> P.braces P.empty

48+ Record fields ext ->

42− Record _ _ -> P.braces $ case ext of

49+ P.braces $ case ext of

43− EmptyRecord -> prettyFields

50+ Nothing -> prettyFields

44− _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields

51+ Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields

45 where

52 where

46− (fields, ext) = collectRecords tipe

47 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

53 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

48 prettyFields = commaSep . map prettyField $ fields

54 prettyFields = commaSep . map prettyField $ fields

49

55

56+collectLambdas :: Type -> [Type]

50collectLambdas tipe =

57collectLambdas tipe =

51 case tipe of

58 case tipe of

52− Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

53− Lambda arg body -> pretty arg : collectLambdas body

59+ Lambda arg body -> arg : collectLambdas body

54− _ -> [pretty tipe]

60+ _ -> [tipe]

55−

56−collectRecords = go []

57− where

58− go fields tipe =

59− case tipe of

60− Record fs ext -> go (fs ++ fields) ext

61− _ -> (fields, tipe)

62

61

62+prettyParens :: Type -> Doc

63prettyParens tipe = parensIf needed (pretty tipe)

64 where

65 needed =

@@ -79,10 +79,8 @@ instance Binary Type where

79 putWord8 1 >> put x

80 Data ctor tipes ->

81 putWord8 2 >> put ctor >> put tipes

82− EmptyRecord ->

83− putWord8 3

84 Record fs ext ->

82 Record fs ext ->

85− putWord8 4 >> put fs >> put ext

83+ putWord8 3 >> put fs >> put ext

86

84

87 get = do

85 get = do

88 n <- getWord8

86 n <- getWord8

@@ -90,6 +88,5 @@ instance Binary Type where

90 0 -> Lambda <$> get <*> get

88 0 -> Lambda <$> get <*> get

91 1 -> Var <$> get

89 1 -> Var <$> get

92 2 -> Data <$> get <*> get

90 2 -> Data <$> get <*> get

93− 3 -> return EmptyRecord

94− 4 -> Record <$> get <*> get

91+ 3 -> Record <$> get <*> get

95 _ -> error "Error reading a valid type from serialized string"

92 _ -> error "Error reading a valid type from serialized string"

compiler/SourceSyntax/Variable.hsdeleted−2

@@ -1,2 +0,0 @@

1−module SourceSyntax.Variable where

2−

compiler/Transform/Canonicalize.hs+74−80

@@ -1,7 +1,10 @@

1+{-# OPTIONS_GHC -W #-}

1module Transform.Canonicalize (interface, metadataModule) where

2module Transform.Canonicalize (interface, metadataModule) where

2

3

3import Control.Arrow ((***))

4import Control.Arrow ((***))

5+import Control.Applicative (Applicative,(<$>),(<*>))

4import Control.Monad.Identity

6import Control.Monad.Identity

7+import qualified Data.Traversable as T

5import qualified Data.Map as Map

8import qualified Data.Map as Map

6import qualified Data.Set as Set

9import qualified Data.Set as Set

7import qualified Data.List as List

10import qualified Data.List as List

@@ -9,10 +12,8 @@ import qualified Data.Either as Either

9import SourceSyntax.Module

12import SourceSyntax.Module

10import SourceSyntax.Expression

13import SourceSyntax.Expression

11import SourceSyntax.Location as Loc

14import SourceSyntax.Location as Loc

12−import SourceSyntax.Pattern

15+import qualified SourceSyntax.Pattern as P

13−import SourceSyntax.Helpers (isOp)

14import qualified SourceSyntax.Type as Type

16import qualified SourceSyntax.Type as Type

15−import qualified Transform.SortDefinitions as SD

16import Text.PrettyPrint as P

17import Text.PrettyPrint as P

17

18

18interface :: String -> ModuleInterface -> ModuleInterface

19interface :: String -> ModuleInterface -> ModuleInterface

@@ -26,11 +27,11 @@ interface moduleName iface =

26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

27 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

27 }

28 }

28 where

29 where

29− both f g (a,b,c) = (f a, b, g c)

30+ both f g (a,b,c,d) = (f a, b, g c, d)

30 prefix name = moduleName ++ "." ++ name

31 prefix name = moduleName ++ "." ++ name

31

32

32 pair name = (name, moduleName ++ "." ++ name)

33 pair name = (name, moduleName ++ "." ++ name)

33− canon (name,_,_) = pair name

34+ canon (name,_,_,_) = pair name

34 canons = Map.fromList $ concat

35 canons = Map.fromList $ concat

35 [ map canon (iAdts iface), map canon (iAliases iface) ]

36 [ map canon (iAdts iface), map canon (iAliases iface) ]

36

37

@@ -39,48 +40,40 @@ interface moduleName iface =

39 renameType' =

40 renameType' =

40 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

41 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

41

42

42−renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43−renameType rename tipe =

44+renameType renamer tipe =

44− let rnm = renameType rename in

45+ let rnm = renameType renamer in

45 case tipe of

46 case tipe of

46− Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

47+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

47− Type.Var x -> return tipe

48+ Type.Var _ -> return tipe

48− Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

49+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

49− Type.EmptyRecord -> return tipe

50− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

51− where rnm' (f,t) = (,) f `liftM` rnm t

51+ where rnm' (f,t) = (,) f <$> rnm t

52−

52+

53−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

53+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

54metadataModule ifaces modul =

55− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56− [] -> Right ()

56+ [] -> Right ()

57− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

58 program' <- rename initialEnv (program modul)

59− aliases' <- mapM (third renameType') (aliases modul)

59+ aliases' <- mapM (three4 renameType') (aliases modul)

60− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

60+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)

61− exports' <- mapM (third renameType') (foreignExports modul)

62− imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

63 return $ modul { program = program'

61 return $ modul { program = program'

64 , aliases = aliases'

62 , aliases = aliases'

65− , datatypes = datatypes'

63+ , datatypes = datatypes' }

66− , foreignExports = exports'

67− , foreignImports = imports' }

68 where

64 where

69− second f (a,b) = (,) a `fmap` f b

65+ two2 f (a,b) = (,) a <$> f b

70− third f (a,b,c) = (,,) a b `fmap` f c

71− twoAndFour f g (a,b,c,d) = do b' <- f b

72− d' <- g d

73− return (a,b',c,d')

66+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d

74 renameType' =

67 renameType' =

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

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

76

69

77− get1 (a,_,_) = a

70+ get1 (a,_,_,_) = a

78 canon (name, importMethod) =

71 canon (name, importMethod) =

79 let pair pre var = (pre ++ drop (length name + 1) var, var)

72 let pair pre var = (pre ++ drop (length name + 1) var, var)

80 iface = ifaces Map.! name

73 iface = ifaces Map.! name

81 allNames = concat [ Map.keys (iTypes iface)

74 allNames = concat [ Map.keys (iTypes iface)

82 , map get1 (iAliases iface)

75 , map get1 (iAliases iface)

83− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

76+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

84 in case importMethod of

77 in case importMethod of

85 As alias -> map (pair (alias ++ ".")) allNames

78 As alias -> map (pair (alias ++ ".")) allNames

86 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

79 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

@@ -88,18 +81,19 @@ metadataModule ifaces modul =

88 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

81 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

89 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

82 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

90

83

91− pair n = (n,n)

84+ two n = (n,n)

92− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))

85+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

86+ globalEnv =

93− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

87+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

94− map (\n -> "_Tuple" ++ show n) [0..9]

88+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

95 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

89 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

96 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

90 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

97

91

98type Env = Map.Map String String

92type Env = Map.Map String String

99

93

100−extend :: Env -> Pattern -> Env

94+extend :: Env -> P.Pattern -> Env

101extend env pattern = Map.union (Map.fromList (zip xs xs)) env

95extend env pattern = Map.union (Map.fromList (zip xs xs)) env

102− where xs = Set.toList (SD.boundVars pattern)

96+ where xs = Set.toList (P.boundVars pattern)

103

97

104

98

105replace :: String -> Env -> String -> Either String String

99replace :: String -> Env -> String -> Either String String

@@ -113,76 +107,76 @@ replace variable env v =

113 msg = if null matches then "" else

107 msg = if null matches then "" else

114 "\nClose matches include: " ++ List.intercalate ", " matches

108 "\nClose matches include: " ++ List.intercalate ", " matches

115

109

116−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

110+rename :: Env -> LExpr -> Either [Doc] LExpr

117−rename env lexpr@(L s expr) =

111+rename env (L s expr) =

118 let rnm = rename env

112 let rnm = rename env

119 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

113 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

120 format = Either.either throw return

114 format = Either.either throw return

115+ renameType' env = renameType (format . replace "variable" env)

121 in

116 in

122− L s `liftM`

117+ L s <$>

123 case expr of

118 case expr of

124− Literal lit -> return expr

119+ Literal _ -> return expr

125

120

126− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

121+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

127

122

128− Access e x -> Access `liftM` rnm e `ap` return x

123+ Access e x -> Access <$> rnm e <*> return x

129

124

130− Remove e x -> flip Remove x `liftM` rnm e

125+ Remove e x -> flip Remove x <$> rnm e

131

126

132− Insert e x v -> flip Insert x `liftM` rnm e `ap` rnm v

127+ Insert e x v -> flip Insert x <$> rnm e <*> rnm v

133

128

134 Modify e fs ->

129 Modify e fs ->

135− Modify `liftM` rnm e `ap` mapM (\(x,e) -> (,) x `liftM` rnm e) fs

130+ Modify <$> rnm e <*> mapM (\(k,v) -> (,) k <$> rnm v) fs

136

131

137− Record fs -> Record `liftM` mapM frnm fs

132+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

138− where

139− frnm (f,e) = (,) f `liftM` rename env e

140

133

141 Binop op e1 e2 ->

134 Binop op e1 e2 ->

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

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

143− Binop op' `liftM` rnm e1 `ap` rnm e2

136+ Binop op' <$> rnm e1 <*> rnm e2

144

137

145 Lambda pattern e ->

138 Lambda pattern e ->

146 let env' = extend env pattern in

139 let env' = extend env pattern in

147− Lambda `liftM` format (renamePattern env' pattern) `ap` rename env' e

140+ Lambda <$> format (renamePattern env' pattern) <*> rename env' e

148

141

149− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

142+ App e1 e2 -> App <$> rnm e1 <*> rnm e2

150

143

151− MultiIf ps -> MultiIf `liftM` mapM grnm ps

144+ MultiIf ps -> MultiIf <$> mapM grnm ps

152− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

145+ where grnm (b,e) = (,) <$> rnm b <*> rnm e

153

146

154− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

147+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e

155 where

148 where

156− env' = foldl extend env [ pattern | Def pattern _ <- defs ]

149+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

157− rename' def =

150+ rename' (Definition p body mtipe) =

158− case def of

159− Def p exp ->

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

151+ Definition <$> format (renamePattern env' p)

161− TypeAnnotation name tipe ->

152+ <*> rename env' body

162− TypeAnnotation name `liftM`

163− renameType (format . replace "variable" env') tipe

153+ <*> T.traverse (renameType' env') mtipe

164

154

165− Var x -> Var `liftM` format (replace "variable" env x)

155+ Var x -> Var <$> format (replace "variable" env x)

166

156

167− Data name es -> Data name `liftM` mapM rnm es

157+ Data name es -> Data name <$> mapM rnm es

168

158

169− ExplicitList es -> ExplicitList `liftM` mapM rnm es

159+ ExplicitList es -> ExplicitList <$> mapM rnm es

170

160

171− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

161+ Case e cases -> Case <$> rnm e <*> mapM branch cases

172 where

162 where

173− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

163+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)

174− `ap` rename (extend env pattern) e

164+ <*> rename (extend env pattern) b

165+

166+ Markdown uid md es -> Markdown uid md <$> mapM rnm es

167+

168+ PortIn name st -> PortIn name <$> renameType' env st

175

169

176− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es

170+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

177

171

178

172

179−renamePattern :: Env -> Pattern -> Either String Pattern

173+renamePattern :: Env -> P.Pattern -> Either String P.Pattern

180renamePattern env pattern =

174renamePattern env pattern =

181 case pattern of

175 case pattern of

182− PVar _ -> return pattern

176+ P.PVar _ -> return pattern

183− PLiteral _ -> return pattern

177+ P.PLiteral _ -> return pattern

184− PRecord _ -> return pattern

178+ P.PRecord _ -> return pattern

185− PAnything -> return pattern

179+ P.PAnything -> return pattern

186− PAlias x p -> PAlias x `liftM` renamePattern env p

180+ P.PAlias x p -> P.PAlias x <$> renamePattern env p

187− PData name ps -> PData `liftM` replace "pattern" env name

181+ P.PData name ps -> P.PData <$> replace "pattern" env name

188− `ap` mapM (renamePattern env) ps

182+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+86−90

@@ -1,114 +1,109 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Transform.Check (mistakes) where

2module Transform.Check (mistakes) where

2

3

3−import Transform.SortDefinitions (boundVars)

4+import qualified Control.Arrow as Arrow

4−import SourceSyntax.Declaration (Declaration(..))

5−import SourceSyntax.Expression

6−import SourceSyntax.Pattern

7−import SourceSyntax.Location

8−import SourceSyntax.PrettyPrint

9−import qualified SourceSyntax.Type as T

10−import Data.List as List

5+import qualified Data.List as List

11−import qualified Data.Map as Map

12import qualified Data.Maybe as Maybe

6import qualified Data.Maybe as Maybe

13import qualified Data.Set as Set

7import qualified Data.Set as Set

8+

9+import qualified SourceSyntax.Expression as E

10+import qualified SourceSyntax.Declaration as D

11+import qualified SourceSyntax.Pattern as Pattern

12+import qualified SourceSyntax.Type as T

13+import qualified Transform.Expression as Expr

14+

15+import SourceSyntax.PrettyPrint

14import Text.PrettyPrint as P

16import Text.PrettyPrint as P

15

17

16

18

17−mistakes :: [Declaration t v] -> [Doc]

19+mistakes :: [D.Declaration] -> [Doc]

18mistakes decls =

20mistakes decls =

19 concat [ infiniteTypeAliases decls

21 concat [ infiniteTypeAliases decls

20 , illFormedTypes decls

22 , illFormedTypes decls

21 , map P.text (duplicateConstructors decls)

23 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

24+ , map P.text (duplicates decls)

23− where

25+ , badDerivations decls ]

24− findErrors defs = duplicates defs ++ badOrder defs

25

26

26−getLets :: [Declaration t v] -> [[Def t v]]

27−getLets decls = defs : concatMap defLets defs

28− where

29− defs = [ d | Definition d <- decls ]

30−

31− defLets def =

32− case def of

33− TypeAnnotation _ _ -> []

34− Def _ expr -> exprLets expr

35−

36− exprLets (L _ expr) =

37− case expr of

38− Var _ -> []

39− Lambda p e -> exprLets e

40− Binop op e1 e2 -> exprLets e1 ++ exprLets e2

41− Case e cases -> exprLets e ++ concatMap (exprLets . snd) cases

42− Data name es -> concatMap exprLets es

43− Literal _ -> []

44− Range e1 e2 -> exprLets e1 ++ exprLets e2

45− ExplicitList es -> concatMap exprLets es

46− App e1 e2 -> exprLets e1 ++ exprLets e2

47− MultiIf branches -> concatMap (\(b,e) -> exprLets b ++ exprLets e) branches

48− Access e lbl -> exprLets e

49− Remove e lbl -> exprLets e

50− Insert e lbl v -> exprLets e ++ exprLets v

51− Modify e fields -> exprLets e ++ concatMap (exprLets . snd) fields

52− Record fields -> concatMap (exprLets . snd) fields

53− Markdown uid md es -> []

54− Let defs body -> [defs] ++ exprLets body

55−

56−dups :: Eq a => [a] -> [a]

27+dups :: Ord a => [a] -> [a]

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

28+dups = map head . filter ((>1) . length) . List.group . List.sort

58

29

59dupErr :: String -> String -> String

30dupErr :: String -> String -> String

60dupErr err x =

31dupErr err x =

61 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

32 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

62

33

63−duplicates :: [Def t v] -> [String]

34+duplicates :: [D.Declaration] -> [String]

64−duplicates defs =

35+duplicates decls =

65− map defMsg (dups definitions) ++ map annMsg (dups annotations)

36+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++

66− where

37+ case mapM exprDups (portExprs ++ defExprs) of

67− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]

38+ Left name -> [msg name]

68− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]

39+ Right _ -> []

69− defMsg = dupErr "definition of"

70− annMsg = dupErr "type annotation for"

71

40

72−duplicateConstructors :: [Declaration t v] -> [String]

73−duplicateConstructors decls =

74− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 where

41 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

42+ msg = dupErr "definition of"

77− dataCtors = List.sort . concat $

78− [ map fst patterns | Datatype _ _ patterns <- decls ]

79− dataMsg = dupErr "definition of data constructor"

80− typeMsg = dupErr "definition of type constructor"

81−

82−badOrder :: [Def t v] -> [String]

83−badOrder defs = go defs

84− where

85− msg x = "Syntax Error: The type annotation for '" ++ x ++

86− "' must be directly above its definition."

87

43

88− go defs =

44+ (defPatterns, defExprs) =

89− case defs of

45+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

90− TypeAnnotation name _ : Def (PVar name') _ : rest

91− | name == name' -> go rest

92

46

93− TypeAnnotation name _ : rest -> [msg name] ++ go rest

47+ (portNames, portExprs) =

48+ Arrow.second concat $ unzip $

49+ flip map [ port | D.Port port <- decls ] $ \port ->

50+ case port of

51+ D.Out name expr _ -> (name, [expr])

52+ D.In name _ -> (name, [])

94

53

95− _ : rest -> go rest

54+ getNames = Set.toList . Pattern.boundVars

96

55

56+ exprDups :: E.LExpr -> Either String E.LExpr

57+ exprDups expr = Expr.crawlLet defsDups expr

58+

59+ defsDups :: [E.Def] -> Either String [E.Def]

60+ defsDups defs =

61+ case dups $ concatMap (\(E.Definition name _ _) -> getNames name) defs of

62+ [] -> Right defs

63+ name:_ -> Left name

64+

65+duplicateConstructors :: [D.Declaration] -> [String]

66+duplicateConstructors decls =

67+ map (dupErr "definition of type constructor") (dups typeCtors) ++

68+ map (dupErr "definition of data constructor") (dups dataCtors)

69+ where

70+ typeCtors = [ name | D.Datatype name _ _ _ <- decls ]

71+ dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]

72+

73+badDerivations :: [D.Declaration] -> [Doc]

74+badDerivations decls = concatMap badDerivation derivations

75+ where

76+ derivations =

77+ [ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++

78+ [ (decl, tvars, derives) | decl@(D.Datatype _ tvars _ derives) <- decls ]

79+

80+ badDerivation (decl, tvars, derives) =

81+ case (tvars, derives) of

82+ (_:_, _)

83+ | D.Json `elem` derives -> [report decl D.Json]

84+ | D.Binary `elem` derives -> [report decl D.Binary]

97 _ -> []

85 _ -> []

98

86

87+ report decl derive =

88+ P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."

89+ , P.text "Make sure all type variables are replaced with concrete types:"

90+ , P.text "\n"

91+ , nest 4 (pretty decl)

92+ ]

93+

99−illFormedTypes :: [Declaration t v] -> [Doc]

94+illFormedTypes :: [D.Declaration] -> [Doc]

100illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

95illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

101 where

96 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

97+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

98+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

104

99

105 freeVars tipe =

100 freeVars tipe =

106 case tipe of

101 case tipe of

107 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

102 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

108 T.Var x -> Set.singleton x

103 T.Var x -> Set.singleton x

109 T.Data _ ts -> Set.unions (map freeVars ts)

104 T.Data _ ts -> Set.unions (map freeVars ts)

110− T.EmptyRecord -> Set.empty

111− T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)

105+ T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

106+ where ext' = maybe Set.empty Set.singleton ext

112

107

113 undeclared tvars tipes = Set.difference used declared

108 undeclared tvars tipes = Set.difference used declared

114 where

109 where

@@ -132,7 +127,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

132

127

133 addCommas xs

128 addCommas xs

134 | length xs < 3 = concat xs

129 | length xs < 3 = concat xs

135− | otherwise = intercalate "," xs

130+ | otherwise = List.intercalate "," xs

136

131

137 addAnd xs

132 addAnd xs

138 | length xs < 2 = xs

133 | length xs < 2 = xs

@@ -141,29 +136,30 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141 quote tvar = "'" ++ tvar ++ "'"

136 quote tvar = "'" ++ tvar ++ "'"

142

137

143

138

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

139+infiniteTypeAliases :: [D.Declaration] -> [Doc]

145infiniteTypeAliases decls =

140infiniteTypeAliases decls =

146− [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]

141+ [ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls

142+ , infiniteType name tipe ]

147 where

143 where

148− isInfinite name tipe =

144+ infiniteType name tipe =

149− let infinite = isInfinite name in

145+ let infinite = infiniteType name in

150 case tipe of

146 case tipe of

151 T.Lambda a b -> infinite a || infinite b

147 T.Lambda a b -> infinite a || infinite b

152 T.Var _ -> False

148 T.Var _ -> False

153 T.Data name' ts -> name == name' || any infinite ts

149 T.Data name' ts -> name == name' || any infinite ts

154− T.EmptyRecord -> False

155− T.Record fields ext -> infinite ext || any (infinite . snd) fields

150+ T.Record fields _ -> any (infinite . snd) fields

156

151

152+ indented :: D.Declaration -> Doc

153+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"

154+

157− report decl@(TypeAlias name args tipe) =

155+ report name args tipe derivations =

158 P.vcat [ P.text $ eightyCharLines 0 msg1

156 P.vcat [ P.text $ eightyCharLines 0 msg1

159− , indented decl

157+ , indented $ D.TypeAlias name args tipe derivations

160 , P.text $ eightyCharLines 0 msg2

158 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

159+ , indented $ D.Datatype name args [(name,[tipe])] derivations

162 , P.text $ eightyCharLines 0 msg3 ++ "\n"

160 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163 ]

161 ]

164 where

162 where

165− indented decl = P.text "\n " <> pretty decl <> P.text "\n"

166−

167 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

163 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

168 "Notice that it appears in its own definition, so when \

164 "Notice that it appears in its own definition, so when \

169 \you expand it, it just keeps getting bigger:"

165 \you expand it, it just keeps getting bigger:"

compiler/Transform/Declaration.hsnew file+63

@@ -0,0 +1,63 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Declaration where

3+

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

5+import qualified SourceSyntax.Pattern as P

6+import SourceSyntax.Expression as E

7+import SourceSyntax.Declaration as D

8+

9+import qualified Transform.Expression as Expr

10+import qualified Transform.Definition as Def

11+

12+

13+combineAnnotations :: [ParseDeclaration] -> Either String [Declaration]

14+combineAnnotations = go

15+ where

16+ msg x = "Syntax Error: The type annotation for '" ++ x ++

17+ "' must be directly above its definition."

18+

19+ exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations

20+

21+ go decls =

22+ case decls of

23+ -- simple cases, pass them through with no changes

24+ [] -> return []

25+

26+ Datatype name tvars ctors ds : rest ->

27+ (:) (Datatype name tvars ctors ds) <$> go rest

28+

29+ TypeAlias name tvars alias ds : rest ->

30+ (:) (TypeAlias name tvars alias ds) <$> go rest

31+

32+ Fixity assoc prec op : rest ->

33+ (:) (Fixity assoc prec op) <$> go rest

34+

35+ -- combine definitions

36+ D.Definition def : defRest ->

37+ case def of

38+ Def pat expr ->

39+ do expr' <- exprCombineAnnotations expr

40+ let def' = E.Definition pat expr' Nothing

41+ (:) (D.Definition def') <$> go defRest

42+

43+ TypeAnnotation name tipe ->

44+ case defRest of

45+ D.Definition (Def pat@(P.PVar name') expr) : rest | name == name' ->

46+ do expr' <- exprCombineAnnotations expr

47+ let def' = E.Definition pat expr' (Just tipe)

48+ (:) (D.Definition def') <$> go rest

49+

50+ _ -> Left (msg name)

51+

52+ -- combine ports

53+ Port port : portRest ->

54+ case port of

55+ PPDef name _ -> Left (msg name)

56+ PPAnnotation name tipe ->

57+ case portRest of

58+ Port (PPDef name' expr) : rest | name == name' ->

59+ do expr' <- exprCombineAnnotations expr

60+ (:) (Port (Out name expr' tipe)) <$> go rest

61+

62+ _ -> (:) (Port (In name tipe)) <$> go portRest

63+

compiler/Transform/Definition.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Definition where

3+

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

5+import qualified SourceSyntax.Pattern as P

6+import SourceSyntax.Expression

7+import qualified Transform.Expression as Expr

8+

9+combineAnnotations :: [ParseDef] -> Either String [Def]

10+combineAnnotations = go

11+ where

12+ msg x = "Syntax Error: The type annotation for '" ++ x ++

13+ "' must be directly above its definition."

14+

15+ exprCombineAnnotations = Expr.crawlLet combineAnnotations

16+

17+ go defs =

18+ case defs of

19+ TypeAnnotation name tipe : Def pat@(P.PVar name') expr : rest | name == name' ->

20+ do expr' <- exprCombineAnnotations expr

21+ let def = Definition pat expr' (Just tipe)

22+ (:) def <$> go rest

23+

24+ TypeAnnotation name _ : _ -> Left (msg name)

25+

26+ Def pat expr : rest ->

27+ do expr' <- exprCombineAnnotations expr

28+ let def = Definition pat expr' Nothing

29+ (:) def <$> go rest

30+

31+ [] -> return []

compiler/Transform/Expression.hsnew file+55

@@ -0,0 +1,55 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.Expression (crawlLet, checkPorts) where

3+

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

5+import SourceSyntax.Expression

6+import SourceSyntax.Location

7+import qualified SourceSyntax.Type as ST

8+

9+crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

10+crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

11+

12+checkPorts :: (String -> ST.Type -> Either a ())

13+ -> (String -> ST.Type -> Either a ())

14+ -> LExpr

15+ -> Either a LExpr

16+checkPorts inCheck outCheck expr =

17+ crawl inCheck outCheck (mapM checkDef) expr

18+ where

19+ checkDef def@(Definition _ body _) =

20+ do _ <- checkPorts inCheck outCheck body

21+ return def

22+

23+crawl :: (String -> ST.Type -> Either a ())

24+ -> (String -> ST.Type -> Either a ())

25+ -> ([def] -> Either a [def'])

26+ -> LExpr' def

27+ -> Either a (LExpr' def')

28+crawl portInCheck portOutCheck defsTransform = go

29+ where

30+ go (L srcSpan expr) =

31+ L srcSpan <$>

32+ case expr of

33+ Var x -> return (Var x)

34+ Lambda p e -> Lambda p <$> go e

35+ Binop op e1 e2 -> Binop op <$> go e1 <*> go e2

36+ Case e cases -> Case <$> go e <*> mapM (\(p,b) -> (,) p <$> go b) cases

37+ Data name es -> Data name <$> mapM go es

38+ Literal lit -> return (Literal lit)

39+ Range e1 e2 -> Range <$> go e1 <*> go e2

40+ ExplicitList es -> ExplicitList <$> mapM go es

41+ App e1 e2 -> App <$> go e1 <*> go e2

42+ MultiIf branches -> MultiIf <$> mapM (\(b,e) -> (,) <$> go b <*> go e) branches

43+ Access e lbl -> Access <$> go e <*> return lbl

44+ Remove e lbl -> Remove <$> go e <*> return lbl

45+ Insert e lbl v -> Insert <$> go e <*> return lbl <*> go v

46+ Modify e fields -> Modify <$> go e <*> mapM (\(k,v) -> (,) k <$> go v) fields

47+ Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

48+ Markdown uid md es -> Markdown uid md <$> mapM go es

49+ Let defs body -> Let <$> defsTransform defs <*> go body

50+ PortIn name st ->

51+ do portInCheck name st

52+ return $ PortIn name st

53+ PortOut name st signal ->

54+ do portOutCheck name st

55+ PortOut name st <$> go signal

compiler/Transform/Optimize.hsdeleted−136

@@ -1,136 +0,0 @@

1−module Transform.Optimize (optimize) where

2−

3−import SourceSyntax.Declaration (Declaration(..))

4−import SourceSyntax.Expression

5−import SourceSyntax.Literal

6−import SourceSyntax.Location

7−import SourceSyntax.Module

8−import Control.Arrow (second, (***))

9−import Data.Char (isAlpha)

10−

11−optimize (Module name ims exs stmts) =

12− Module name ims exs (map optimizeStmt stmts)

13−

14−optimizeStmt stmt = if stmt == stmt' then stmt' else optimizeStmt stmt'

15− where stmt' = simp stmt

16−

17−class Simplify a where

18− simp :: a -> a

19−

20−instance Simplify (Declaration t v) where

21− simp (Definition def) = Definition (simp def)

22− simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

23− simp stmt = stmt

24−

25−instance Simplify (Def t v) where

26− simp (Def name e) = Def name (simp e)

27− simp x = x

28−

29−instance Simplify e => Simplify (Located e) where

30− simp (L s e) = L s (simp e)

31−

32−instance Simplify (Expr t v) where

33− simp expr =

34− let f = simp in

35− case expr of

36− Range e1 e2 -> Range (f e1) (f e2)

37− Binop op e1 e2 -> binop op (f e1) (f e2)

38− Lambda x e -> Lambda x (f e)

39− Record fs -> Record (map (second simp) fs)

40− App e1 e2 -> App (f e1) (f e2)

41− Let defs e -> Let (map simp defs) (f e)

42− Data name es -> Data name (map f es)

43− MultiIf es -> MultiIf . clipBranches $ map (f *** f) es

44− Case e cases -> Case (f e) (map (second f) cases)

45− _ -> expr

46−

47−

48−clipBranches [] = []

49−clipBranches (e:es) =

50− case e of

51− (L _ (Literal (Boolean True)), _) -> [e]

52− _ -> e : clipBranches es

53−

54−

55−isValue e =

56− case e of

57− Literal _ -> True

58− Var _ -> True

59− Data _ _ -> True

60− _ -> False

61−

62−

63−binop op ce1@(L s1 e1) ce2@(L s2 e2) =

64− let c1 = L s1

65− c2 = L s2

66− int = Literal . IntNum

67− str = Literal . Str

68− bool = Literal . Boolean

69− in

70− case (op, e1, e2) of

71− (_, Literal (IntNum n), Literal (IntNum m)) ->

72− case op of

73− { "+" -> int $ (+) n m

74− ; "-" -> int $ (-) n m

75− ; "*" -> int $ (*) n m

76− ; "^" -> int $ n ^ m

77− ; "div" -> int $ div n m

78− ; "mod" -> int $ mod n m

79− ; "rem" -> int $ rem n m

80− ; "<" -> bool $ n < m

81− ; ">" -> bool $ n > m

82− ; "<=" -> bool $ n <= m

83− ; ">=" -> bool $ n >= m

84− ; "==" -> bool $ n == m

85− ; "/=" -> bool $ n /= m

86− ; _ -> Binop op ce1 ce2 }

87− {--

88− -- flip order to move lone integers to the left

89− ("+", _, IntNum n) -> binop "+" ce2 ce1

90− ("*", _, IntNum n) -> binop "*" ce2 ce1

91−

92− ("+", IntNum 0, _) -> e2

93− ("+", IntNum n, Binop "+" (L _ (IntNum m)) ce) ->

94− binop "+" (c1 $ IntNum (n+m)) ce

95− ("+", Binop "+" (L _ (IntNum n)) ce1'

96− , Binop "+" (L _ (IntNum m)) ce2') ->

97− binop "+" (none $ IntNum (n+m)) (none $ Binop "+" ce1' ce2')

98−

99− ("*", IntNum 0, _) -> e1

100− ("*", IntNum 1, _) -> e2

101− ("*", IntNum n, Binop "*" (L _ (IntNum m)) ce) ->

102− binop "*" (none $ IntNum (n*m)) ce

103− ("*", Binop "*" (L _ (IntNum n)) ce1'

104− , Binop "*" (L _ (IntNum m)) ce2') ->

105− binop "*" (none $ IntNum (n*m)) (none $ Binop "*" ce1' ce2')

106−

107− ("-", _, IntNum 0) -> e1

108− ("/", _, IntNum 1) -> e1

109− ("div", _, IntNum 1) -> e1

110−--}

111− (_, Literal (Boolean n), Literal (Boolean m)) ->

112− case op of

113− "&&" -> bool $ n && m

114− "||" -> bool $ n || m

115− _ -> Binop op ce1 ce2

116−

117− ("&&", Literal (Boolean True), _) -> e2

118− ("&&", Literal (Boolean False), _) -> bool False

119− ("||", Literal (Boolean True), _) -> bool True

120− ("||", Literal (Boolean False), _) -> e2

121−

122− ("::", _, _) -> Data "::" [ce1, ce2]

123−

124− ("++", Literal (Str s1), Literal (Str s2)) -> str $ s1 ++ s2

125− ("++", Literal (Str s1), Binop "++" (L _ (Literal (Str s2))) ce) ->

126− Binop "++" (c1 . str $ s1 ++ s2) ce

127− ("++", Binop "++" e (L _ (Literal (Str s1))), Literal (Str s2)) ->

128− Binop "++" e (c1 . str $ s1 ++ s2)

129−

130− ("++", Data "[]" [], _) -> e2

131− ("++", _, Data "[]" []) -> e1

132− ("++", Data "::" [h,t], _) -> Data "::" [h, none $ binop "++" t ce2]

133−

134− _ | isAlpha (head op) || '_' == head op ->

135− App (none $ App (none $ Var op) ce1) ce2

136− | otherwise -> Binop op ce1 ce2

compiler/Transform/SafeNames.hs+9−15

@@ -27,7 +27,7 @@ pattern pat =

27 PAlias x p -> PAlias (var x) (pattern p)

28 PData name ps -> PData name (map pattern ps)

29

30−expression :: LExpr t v -> LExpr t v

30+expression :: LExpr -> LExpr

31expression (L loc expr) =

32 let f = expression in

33 L loc $

@@ -49,14 +49,14 @@ expression (L loc expr) =

49 Modify r fs -> Modify (f r) (map (var *** f) fs)

50 Record fs -> Record (map (var *** f) fs)

51 Markdown uid md es -> Markdown uid md (map f es)

52+ PortIn name st -> PortIn name st

53+ PortOut name st signal -> PortOut name st (f signal)

52

54

53−definition :: Def t v -> Def t v

55+definition :: Def -> Def

54−definition def =

56+definition (Definition p e t) =

55− case def of

56− Def p e -> Def (pattern p) (expression e)

57+ Definition (pattern p) (expression e) t

57− TypeAnnotation name t -> TypeAnnotation (var name) t

58

59−metadataModule :: MetadataModule t v -> MetadataModule t v

59+metadataModule :: MetadataModule -> MetadataModule

60metadataModule modul =

61 modul

62 { names = map var (names modul)

@@ -64,15 +64,9 @@ metadataModule modul =

64 , imports = map (first var) (imports modul)

65 , program = expression (program modul)

66 , aliases =

67− let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)

67+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

68 in map makeSafe (aliases modul)

69 , datatypes =

70− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

70+ let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)

71 in map makeSafe (datatypes modul)

72− , foreignImports =

73− let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)

74− in map makeSafe (foreignImports modul)

75− , foreignExports =

76− let makeSafe (js,elm,tipe) = (js, var elm, tipe)

77− in map makeSafe (foreignExports modul)

78 }

72 }

compiler/Transform/SortDefinitions.hs+50−102

@@ -1,37 +1,25 @@

1−

1+{-# OPTIONS_GHC -Wall #-}

2−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where

2+module Transform.SortDefinitions (sortDefs) where

3

4import Control.Monad.State

5−import Control.Applicative ((<$>))

5+import Control.Applicative ((<$>),(<*>))

6−import qualified Data.Set as Set

7import qualified Data.Map as Map

6import qualified Data.Map as Map

8−import qualified SourceSyntax.Type as ST

9import SourceSyntax.Expression

7import SourceSyntax.Expression

10import SourceSyntax.Location

8import SourceSyntax.Location

11−import SourceSyntax.Pattern

9+import qualified SourceSyntax.Pattern as P

12import qualified Data.Graph as Graph

10import qualified Data.Graph as Graph

13−import qualified Data.Map as Map

11+import qualified Data.Set as Set

14import qualified Data.Maybe as Maybe

12import qualified Data.Maybe as Maybe

15

13

16−boundVars :: Pattern -> Set.Set String

17−boundVars pattern =

18− case pattern of

19− PVar x -> Set.singleton x

20− PAlias x p -> Set.insert x (boundVars p)

21− PData _ ps -> Set.unions (map boundVars ps)

22− PRecord fields -> Set.fromList fields

23− PAnything -> Set.empty

24− PLiteral _ -> Set.empty

25−

26−ctors :: Pattern -> [String]

14+ctors :: P.Pattern -> [String]

27ctors pattern =

15ctors pattern =

28 case pattern of

16 case pattern of

29− PVar x -> []

17+ P.PVar _ -> []

30− PAlias x p -> ctors p

18+ P.PAlias _ p -> ctors p

31− PData ctor ps -> ctor : concatMap ctors ps

19+ P.PData ctor ps -> ctor : concatMap ctors ps

32− PRecord fields -> []

20+ P.PRecord _ -> []

33− PAnything -> []

21+ P.PAnything -> []

34− PLiteral _ -> []

22+ P.PLiteral _ -> []

35

23

36free :: String -> State (Set.Set String) ()

24free :: String -> State (Set.Set String) ()

37free x = modify (Set.insert x)

25free x = modify (Set.insert x)

@@ -39,68 +27,66 @@ free x = modify (Set.insert x)

39bound :: Set.Set String -> State (Set.Set String) ()

27bound :: Set.Set String -> State (Set.Set String) ()

40bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

28bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

41

29

42−sortDefs :: LExpr t v -> LExpr t v

30+sortDefs :: LExpr -> LExpr

43sortDefs expr = evalState (reorder expr) Set.empty

31sortDefs expr = evalState (reorder expr) Set.empty

44

32

45−flattenLets defs lexpr@(L _ expr) =

46− case expr of

47− Let ds body -> flattenLets (defs ++ ds) body

48− _ -> (defs, lexpr)

49−

50−

51−reorder :: LExpr t v -> State (Set.Set String) (LExpr t v)

33+reorder :: LExpr -> State (Set.Set String) LExpr

52−reorder lexpr@(L s expr) =

34+reorder (L s expr) =

53− L s `liftM`

35+ L s <$>

54 case expr of

36 case expr of

55 -- Be careful adding and restricting freeVars

37 -- Be careful adding and restricting freeVars

56 Var x -> free x >> return expr

38 Var x -> free x >> return expr

57

39

58 Lambda p e ->

40 Lambda p e ->

59− uncurry Lambda `liftM` bindingReorder (p,e)

41+ uncurry Lambda <$> bindingReorder (p,e)

60

42

61 Binop op e1 e2 ->

43 Binop op e1 e2 ->

62 do free op

44 do free op

63− Binop op `liftM` reorder e1 `ap` reorder e2

45+ Binop op <$> reorder e1 <*> reorder e2

64

46

65 Case e cases ->

47 Case e cases ->

66− Case `liftM` reorder e `ap` mapM bindingReorder cases

48+ Case <$> reorder e <*> mapM bindingReorder cases

67

49

68 Data name es ->

50 Data name es ->

69 do free name

51 do free name

70− Data name `liftM` mapM reorder es

52+ Data name <$> mapM reorder es

71

53

72 -- Just pipe the reorder though

54 -- Just pipe the reorder though

73 Literal _ -> return expr

55 Literal _ -> return expr

74

56

75 Range e1 e2 ->

57 Range e1 e2 ->

76− Range `liftM` reorder e1 `ap` reorder e2

58+ Range <$> reorder e1 <*> reorder e2

77

59

78 ExplicitList es ->

60 ExplicitList es ->

79− ExplicitList `liftM` mapM reorder es

61+ ExplicitList <$> mapM reorder es

80

62

81 App e1 e2 ->

63 App e1 e2 ->

82− App `liftM` reorder e1 `ap` reorder e2

64+ App <$> reorder e1 <*> reorder e2

83

65

84 MultiIf branches ->

66 MultiIf branches ->

85− MultiIf `liftM` mapM reorderPair branches

67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches

86

68

87 Access e lbl ->

69 Access e lbl ->

88− Access `liftM` reorder e `ap` return lbl

70+ Access <$> reorder e <*> return lbl

89

71

90 Remove e lbl ->

72 Remove e lbl ->

91− Remove `liftM` reorder e `ap` return lbl

73+ Remove <$> reorder e <*> return lbl

92

74

93 Insert e lbl v ->

75 Insert e lbl v ->

94− Insert `liftM` reorder e `ap` return lbl `ap` reorder v

76+ Insert <$> reorder e <*> return lbl <*> reorder v

95

77

96 Modify e fields ->

78 Modify e fields ->

97− Modify `liftM` reorder e `ap` mapM reorderField fields

79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields

98

80

99 Record fields ->

81 Record fields ->

100− Record `liftM` mapM reorderField fields

82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

101

83

102 Markdown uid md es -> Markdown uid md <$> mapM reorder es

84 Markdown uid md es -> Markdown uid md <$> mapM reorder es

103

85

86+ PortOut name st signal -> PortOut name st <$> reorder signal

87+

88+ PortIn name st -> return $ PortIn name st

89+

104 -- Actually do some reordering

90 -- Actually do some reordering

105 Let defs body ->

91 Let defs body ->

106 do body' <- reorder body

92 do body' <- reorder body

@@ -113,48 +99,24 @@ reorder lexpr@(L s expr) =

113 let defss = map Graph.flattenSCC sccs

99 let defss = map Graph.flattenSCC sccs

114

100

115 -- remove let-bound variables from the context

101 -- remove let-bound variables from the context

116− let getPatterns def =

117− case def of

118− Def pattern _ -> pattern

119− TypeAnnotation name _ -> PVar name

120− forM (map getPatterns defs) $ \pattern -> do

102+ forM_ defs $ \(Definition pattern _ _) -> do

121− bound (boundVars pattern)

103+ bound (P.boundVars pattern)

122 mapM free (ctors pattern)

104 mapM free (ctors pattern)

123

105

124− let addDefs ds bod = L s (Let (concatMap toDefs ds) bod)

125− L _ let' = foldr addDefs body' defss

106+ let L _ let' = foldr (\ds bod -> L s (Let ds bod)) body' defss

126

107

127 return let'

108 return let'

128

109

129− where

130− toDefs def =

131− case def of

132− (pattern, expr, Nothing) -> [ Def pattern expr ]

133− (PVar name, expr, Just tipe) ->

134− [ TypeAnnotation name tipe, Def (PVar name) expr ]

135− _ -> error $ unlines

136− [ "The impossible occurred."

137− , "Please report an issue at <https://github.com/evancz/Elm/issues>."

138− , "Be very descriptive because something quite weird probably happened." ]

139−

140−reorderField (label, expr) =

141− (,) label `liftM` reorder expr

142−

143−reorderPair (e1,e2) =

144− (,) `liftM` reorder e1 `ap` reorder e2

145−

146−bindingReorder :: (Pattern, LExpr t v) -> State (Set.Set String) (Pattern, LExpr t v)

110+bindingReorder :: (P.Pattern, LExpr) -> State (Set.Set String) (P.Pattern, LExpr)

147bindingReorder (pattern,expr) =

111bindingReorder (pattern,expr) =

148 do expr' <- reorder expr

112 do expr' <- reorder expr

149− bound (boundVars pattern)

113+ bound (P.boundVars pattern)

150− mapM free (ctors pattern)

114+ mapM_ free (ctors pattern)

151 return (pattern, expr')

115 return (pattern, expr')

152

116

153

117

154−type PDef t v = (Pattern, LExpr t v, Maybe ST.Type)

155−

156−reorderAndGetDependencies :: PDef t v -> State (Set.Set String) (PDef t v, [String])

118+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

157−reorderAndGetDependencies (pattern, expr, mType) =

119+reorderAndGetDependencies (Definition pattern expr mType) =

158 do globalFrees <- get

120 do globalFrees <- get

159 -- work in a fresh environment

121 -- work in a fresh environment

160 put Set.empty

122 put Set.empty

@@ -162,44 +124,30 @@ reorderAndGetDependencies (pattern, expr, mType) =

162 localFrees <- get

124 localFrees <- get

163 -- merge with global frees

125 -- merge with global frees

164 modify (Set.union globalFrees)

126 modify (Set.union globalFrees)

165− return ((pattern, expr', mType), Set.toList localFrees)

127+ return (Definition pattern expr' mType, Set.toList localFrees)

166

128

167

129

168-- This also reorders the all of the sub-expressions in the Def list.

130-- This also reorders the all of the sub-expressions in the Def list.

169−buildDefDict :: [Def t v] -> State (Set.Set String) [(PDef t v, Int, [Int])]

131+buildDefDict :: [Def] -> State (Set.Set String) [(Def, Int, [Int])]

170buildDefDict defs =

132buildDefDict defs =

171− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)

133+ do pdefsDeps <- mapM reorderAndGetDependencies defs

172 return $ realDeps (addKey pdefsDeps)

134 return $ realDeps (addKey pdefsDeps)

173

135

174 where

136 where

175− getPDefs :: [Def t v] -> [PDef t v]

176− getPDefs defs = map (\(p,(e,t)) -> (p,e,t)) $

177− Map.toList $ go defs Map.empty Map.empty

178− where

179− go [] ds ts =

180− Map.unions [ Map.difference ds ts

181− , Map.intersectionWith (\(e,_) t -> (e,Just t)) ds ts ]

182−

183− go (def:defs) ds ts =

184− case def of

185− Def p e -> go defs (Map.insert p (e, Nothing) ds) ts

186− TypeAnnotation name tipe -> go defs ds (Map.insert (PVar name) tipe ts)

187−

188− addKey :: [(PDef t v, [String])] -> [(PDef t v, Int, [String])]

137+ addKey :: [(Def, [String])] -> [(Def, Int, [String])]

189 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

138 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

190

139

191− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]

140+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]

192− variableToKey ((pattern, _, _), key, _) =

141+ variableToKey (Definition pattern _ _, key, _) =

193− [ (var, key) | var <- Set.toList (boundVars pattern) ]

142+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

194

143

195− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int

144+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

196 variableToKeyMap pdefsDeps =

145 variableToKeyMap pdefsDeps =

197 Map.fromList (concatMap variableToKey pdefsDeps)

146 Map.fromList (concatMap variableToKey pdefsDeps)

198

147

199− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]

148+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

200 realDeps pdefsDeps = map convert pdefsDeps

149 realDeps pdefsDeps = map convert pdefsDeps

201 where

150 where

202 varDict = variableToKeyMap pdefsDeps

151 varDict = variableToKeyMap pdefsDeps

203 convert (pdef, key, deps) =

152 convert (pdef, key, deps) =

204 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

153 (pdef, key, Maybe.mapMaybe (flip Map.lookup varDict) deps)

205−

compiler/Transform/Substitute.hs+8−9

@@ -4,10 +4,10 @@ module Transform.Substitute (subst) where

4import Control.Arrow (second, (***))

5import SourceSyntax.Expression

6import SourceSyntax.Location

7+import qualified SourceSyntax.Pattern as Pattern

7import qualified Data.Set as Set

8import qualified Data.Set as Set

8−import qualified Transform.SortDefinitions as SD

9

10−subst :: String -> Expr t v -> Expr t v -> Expr t v

10+subst :: String -> Expr -> Expr -> Expr

11subst old new expr =

12 let f (L s e) = L s (subst old new e) in

13 case expr of

@@ -15,7 +15,7 @@ subst old new expr =

15 ExplicitList es -> ExplicitList (map f es)

16 Binop op e1 e2 -> Binop op (f e1) (f e2)

17 Lambda p e

18− | Set.member old (SD.boundVars p) -> expr

18+ | Set.member old (Pattern.boundVars p) -> expr

19 | otherwise -> Lambda p (f e)

20 App e1 e2 -> App (f e1) (f e2)

21 MultiIf ps -> MultiIf (map (f *** f) ps)

@@ -24,12 +24,9 @@ subst old new expr =

24 | anyShadow -> expr

25 | otherwise -> Let (map substDef defs) (f body)

26 where

27+ substDef (Definition p e t) = Definition p (f e) t

27 anyShadow =

28 anyShadow =

28− any (Set.member old . SD.boundVars) [ p | Def p _ <- defs ]

29+ any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

29− substDef def =

30− case def of

31− TypeAnnotation _ _ -> def

32− Def p e -> Def p (f e)

33

30

34 Var x -> if x == old then new else expr

31 Var x -> if x == old then new else expr

35 Case e cases -> Case (f e) $ map (second f) cases

32 Case e cases -> Case (f e) $ map (second f) cases

@@ -40,4 +37,6 @@ subst old new expr =

40 Modify r fs -> Modify (f r) (map (second f) fs)

37 Modify r fs -> Modify (f r) (map (second f) fs)

41 Record fs -> Record (map (second f) fs)

38 Record fs -> Record (map (second f) fs)

42 Literal _ -> expr

39 Literal _ -> expr

43− Markdown uid md es -> Markdown uid md (map f es)

40+ Markdown uid md es -> Markdown uid md (map f es)

41+ PortIn name st -> PortIn name st

42+ PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Alias.hs+18−18

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Alias (realias, rules, canonicalRealias, Rules) where

2module Type.Alias (realias, rules, canonicalRealias, Rules) where

2

3

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

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

@@ -9,7 +10,7 @@ import qualified Data.List as List

9import SourceSyntax.Type

10import SourceSyntax.Type

10import SourceSyntax.Module

11import SourceSyntax.Module

11

12

12−type Rules = ([(String,[String],Type)], Type -> Type)

13+type Rules = ([Alias], Type -> Type)

13

14

14rules interfaces moduleAliases moduleImports =

15rules interfaces moduleAliases moduleImports =

15 (collect interfaces moduleAliases, localizer moduleImports)

16 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +21,7 @@ collect interfaces moduleAliases =

20 rawAliases =

21 rawAliases =

21 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

22 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

22

23

23− isPrimitive (_,_,tipe) =

24+ isPrimitive (_,_,tipe,_) =

24 case tipe of

25 case tipe of

25 Data _ [] -> True

26 Data _ [] -> True

26 _ -> False

27 _ -> False

@@ -30,10 +31,9 @@ localizer moduleImports = go

30 go tipe =

31 go tipe =

31 case tipe of

32 case tipe of

32 Var _ -> tipe

33 Var _ -> tipe

33− EmptyRecord -> tipe

34 Lambda t1 t2 -> Lambda (go t1) (go t2)

35 Data name ts -> Data (localize name) (map go ts)

36− Record fs ext -> Record (map (second go) fs) (go ext)

36+ Record fs ext -> Record (map (second go) fs) ext

37

38 byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

39 Map.empty moduleImports

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62

63-- Realias using canonical aliases, so results will have aliases

64-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

66canonicalRealias aliases tipe =

67 case concatMap tryRealias aliases of

68 [] -> if tipe == tipe' then tipe else f tipe'

69 tipes -> f (bestType tipes)

70 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

72 case diff aliasTipe tipe of

73 Nothing -> []

74 Just kvs ->

@@ -83,10 +83,9 @@ canonicalRealias aliases tipe =

83 tipe' =

84 case tipe of

85 Var _ -> tipe

86− EmptyRecord -> tipe

87 Lambda t1 t2 -> Lambda (f t1) (f t2)

86 Lambda t1 t2 -> Lambda (f t1) (f t2)

88 Data name ts -> Data name (map f ts)

87 Data name ts -> Data name (map f ts)

89− Record fs ext -> Record (map (second f) fs) (f ext)

88+ Record fs ext -> Record (map (second f) fs) ext

90

89

91allEqual [] = True

90allEqual [] = True

92allEqual (x:xs) = all (==x) xs

91allEqual (x:xs) = all (==x) xs

@@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

102 Lambda t1 t2 -> numFields t1 + numFields t2

101 Lambda t1 t2 -> numFields t1 + numFields t2

103 Var _ -> 0

102 Var _ -> 0

104 Data _ ts -> sum (map numFields ts)

103 Data _ ts -> sum (map numFields ts)

105− EmptyRecord -> 0

106− Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext

104+ Record fields _ -> length fields + sum (map (numFields . snd) fields)

107

105

108diff :: Type -> Type -> Maybe [(String,Type)]

106diff :: Type -> Type -> Maybe [(String,Type)]

109diff general specific =

107diff general specific =

@@ -113,11 +111,11 @@ diff general specific =

113 (Data gname gts, Data sname sts)

111 (Data gname gts, Data sname sts)

114 | gname == sname && length gts == length sts ->

112 | gname == sname && length gts == length sts ->

115 concat <$> zipWithM diff gts sts

113 concat <$> zipWithM diff gts sts

116− (EmptyRecord, EmptyRecord) -> Just []

114+ (Record [] Nothing, Record [] Nothing) -> Just []

117− (Record _ _, Record _ _) ->

115+ (Record _ _, Record [] Nothing) -> Nothing

118− let (gfs,gext) = collectRecords general

116+ (Record [] Nothing, Record _ _) -> Nothing

119− (sfs,sext) = collectRecords specific

117+ (Record gfs gext, Record sfs sext) ->

120− gfields = collectFields gfs

118+ let gfields = collectFields gfs

121 sfields = collectFields sfs

119 sfields = collectFields sfs

122

120

123 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

121 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

@@ -126,10 +124,12 @@ diff general specific =

126 case isAligned of

124 case isAligned of

127 False -> Nothing

125 False -> Nothing

128 True -> let remaining = Map.difference sfields gfields

126 True -> let remaining = Map.difference sfields gfields

127+ sext' = case sext of

129− sext' = if Map.null remaining then sext else

128+ Just x | Map.null remaining -> Var x

130− Record (flattenFields remaining) sext

129+ _ -> Record (flattenFields remaining) sext

130+ gext' = maybe (Record [] Nothing) Var gext

131 matchMap = Map.intersectionWith (zipWith diff) gfields sfields

132− in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))

132+ in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))

133 (_,_) -> Nothing

134

135collectFields fields =

compiler/Type/Constrain/Declaration.hs+30−37

@@ -1,70 +1,63 @@

1+{-# OPTIONS_GHC -Wall #-}

1module Type.Constrain.Declaration where

2module Type.Constrain.Declaration where

2

3

3−import Control.Monad

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

5−

6−import qualified Data.Map as Map

7−

8−import qualified Type.Constrain.Expression as TcExpr

9−import qualified Type.Environment as Env

10−

11import SourceSyntax.Declaration

4import SourceSyntax.Declaration

12−import qualified SourceSyntax.Expression as Src

5+import qualified SourceSyntax.Expression as E

13import qualified SourceSyntax.Location as L

6import qualified SourceSyntax.Location as L

14import qualified SourceSyntax.Pattern as P

7import qualified SourceSyntax.Pattern as P

15−import qualified SourceSyntax.Type as Type

8+import qualified SourceSyntax.Type as T

16

9

17−toExpr :: [Declaration t v] -> [Src.Def t v]

10+toExpr :: [Declaration] -> [E.Def]

18toExpr = concatMap toDefs

11toExpr = concatMap toDefs

19

12

20−toDefs :: Declaration t v -> [Src.Def t v]

13+toDefs :: Declaration -> [E.Def]

21toDefs decl =

14toDefs decl =

22 case decl of

15 case decl of

23 Definition def -> [def]

16 Definition def -> [def]

24

17

25− Datatype name tvars constructors -> concatMap toDefs constructors

18+ Datatype name tvars constructors _ -> concatMap toDefs' constructors

26 where

19 where

27− toDefs (ctor, tipes) =

20+ toDefs' (ctor, tipes) =

28 let vars = take (length tipes) arguments

21 let vars = take (length tipes) arguments

29− tbody = Type.Data name $ map Type.Var tvars

22+ tbody = T.Data name $ map T.Var tvars

30− body = L.none . Src.Data ctor $ map (L.none . Src.Var) vars

23+ body = L.none . E.Data ctor $ map (L.none . E.Var) vars

31− in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

24+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

32− , Src.Def (P.PVar ctor) $ buildFunction body vars

33− ]

34

25

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

26+ TypeAlias name _ tipe@(T.Record fields ext) _ ->

36− [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37− , Src.Def (P.PVar name) $ buildFunction record vars ]

27+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

38 where

28 where

39− args = case ext of

29+ args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

40− Type.EmptyRecord -> map snd fields

41− _ -> map snd fields ++ [ext]

42

30

43− var = L.none . Src.Var

31+ var = L.none . E.Var

44 vars = take (length args) arguments

32 vars = take (length args) arguments

45

33

46 efields = zip (map fst fields) (map var vars)

34 efields = zip (map fst fields) (map var vars)

47 record = case ext of

35 record = case ext of

48− Type.EmptyRecord -> L.none $ Src.Record efields

36+ Nothing -> L.none $ E.Record efields

49− _ -> foldl (\r (f,v) -> L.none $ Src.Insert r f v) (var $ last vars) efields

37+ Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

50

38

51 -- Type aliases must be added to an extended equality dictionary,

39 -- Type aliases must be added to an extended equality dictionary,

52 -- but they do not require any basic constraints.

40 -- but they do not require any basic constraints.

41+ -- TODO: with the ability to derive code, you may need to generate stuff!

53− TypeAlias _ _ _ -> []

42+ TypeAlias _ _ _ _ -> []

54

43

44+ Port port ->

45+ case port of

55− ImportEvent _ expr@(L.L s _) name tipe ->

46+ Out name expr@(L.L s _) tipe ->

56− [ Src.TypeAnnotation name tipe

47+ [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

57− , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]

58−

59− ExportEvent _ name tipe ->

48+ In name tipe ->

60− [ Src.TypeAnnotation name tipe ]

49+ [ definition name (L.none $ E.PortIn name tipe) tipe ]

61

50

62 -- no constraints are needed for fixity declarations

51 -- no constraints are needed for fixity declarations

63 Fixity _ _ _ -> []

52 Fixity _ _ _ -> []

64

53

65

54

66arguments :: [String]

55arguments :: [String]

67−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

56+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

68

57

58+buildFunction :: E.LExpr -> [String] -> E.LExpr

69buildFunction body@(L.L s _) vars =

59buildFunction body@(L.L s _) vars =

70− foldr (\p e -> L.L s (Src.Lambda p e)) body (map P.PVar vars)

60+ foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)

61+

62+definition :: String -> E.LExpr -> T.Type -> E.Def

63+definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)

compiler/Type/Constrain/Expression.hs+19−34

@@ -1,18 +1,16 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.Constrain.Expression where

2module Type.Constrain.Expression where

2

3

3import qualified Data.List as List

4import qualified Data.List as List

4import qualified Data.Map as Map

5import qualified Data.Map as Map

5import qualified Data.Set as Set

6import qualified Data.Set as Set

6−import Control.Arrow (second)

7+import Control.Applicative ((<$>))

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

8import qualified Control.Monad as Monad

9import Control.Monad.Error

10−import Control.Monad.State

11−import Data.Traversable (traverse)

12import qualified Text.PrettyPrint as PP

10import qualified Text.PrettyPrint as PP

13

11

14import SourceSyntax.Location as Loc

12import SourceSyntax.Location as Loc

15−import SourceSyntax.Pattern (Pattern(PVar))

13+import SourceSyntax.Pattern (Pattern(PVar), boundVars)

16import SourceSyntax.Expression

14import SourceSyntax.Expression

17import qualified SourceSyntax.Type as SrcT

15import qualified SourceSyntax.Type as SrcT

18import Type.Type hiding (Descriptor(..))

16import Type.Type hiding (Descriptor(..))

@@ -20,10 +18,8 @@ import Type.Fragment

20import qualified Type.Environment as Env

18import qualified Type.Environment as Env

21import qualified Type.Constrain.Literal as Literal

19import qualified Type.Constrain.Literal as Literal

22import qualified Type.Constrain.Pattern as Pattern

20import qualified Type.Constrain.Pattern as Pattern

23−import qualified Transform.SortDefinitions as SD

24

21

25−

26−constrain :: Env.Environment -> LExpr a b -> Type -> ErrorT [PP.Doc] IO TypeConstraint

22+constrain :: Env.Environment -> LExpr -> Type -> ErrorT [PP.Doc] IO TypeConstraint

27constrain env (L span expr) tipe =

23constrain env (L span expr) tipe =

28 let list t = Env.get env Env.types "_List" <| t

24 let list t = Env.get env Env.types "_List" <| t

29 and = L span . CAnd

25 and = L span . CAnd

@@ -145,13 +141,17 @@ constrain env (L span expr) tipe =

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

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

146 Monad.foldM (constrainDef env)

142 Monad.foldM (constrainDef env)

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

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

148− (collapseDefs defs)

144+ (concatMap expandPattern defs)

149 return $ clet schemes

145 return $ clet schemes

150 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

151 (c1 /\ c))

147 (c1 /\ c))

152

148

149+ PortIn _ _ -> return true

150+

151+ PortOut _ _ signal ->

152+ constrain env signal tipe

153

154−constrainDef env info (pattern, expr, maybeTipe) =

154+constrainDef env info (Definition pattern expr maybeTipe) =

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

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

157 in

@@ -188,33 +188,18 @@ constrainDef env info (pattern, expr, maybeTipe) =

188 , c /\ c2

189 , c1 )

190

191+ _ -> error (show pattern)

192+

191−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

193+expandPattern :: Def -> [Def]

192− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

193−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

194+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

194 case pattern of

195 case pattern of

195− PVar _ -> [triple]

196+ PVar _ -> [def]

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

197+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars

197 where

198 where

198− vars = Set.toList $ SD.boundVars pattern

199+ vars = Set.toList $ boundVars pattern

199 x = "$" ++ concat vars

200 x = "$" ++ concat vars

200− var = L s . Var

201+ mkVar = L s . Var

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

202+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

202−

203−collapseDefs :: [Def t v] -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

204−collapseDefs = concatMap expandPattern . go [] Map.empty Map.empty

205− where

206− go output defs typs [] =

207− output ++ concatMap Map.elems [

208− Map.intersectionWithKey (\k v t -> (PVar k, v, Just t)) defs typs,

209− Map.mapWithKey (\k v -> (PVar k, v, Nothing)) (Map.difference defs typs) ]

210− go output defs typs (d:ds) =

211− case d of

212− Def (PVar name) body ->

213− go output (Map.insert name body defs) typs ds

214− Def pattern body ->

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

216− TypeAnnotation name typ ->

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

218

203

219try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

204try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

220try span computation = do

205try span computation = do

compiler/Type/Constrain/Pattern.hs−2

@@ -5,8 +5,6 @@ import Control.Arrow (second)

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

6import qualified Control.Monad as Monad

7import Control.Monad.Error

8−import qualified Data.List as List

9−import qualified Data.Maybe as Maybe

10import qualified Data.Map as Map

8import qualified Data.Map as Map

11import qualified Text.PrettyPrint as PP

9import qualified Text.PrettyPrint as PP

12

10

compiler/Type/Environment.hs+14−12

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Environment where

2module Type.Environment where

2

3

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

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

@@ -9,11 +10,10 @@ import qualified Control.Monad.State as State

9import qualified Data.Traversable as Traverse

10import qualified Data.Traversable as Traverse

10import qualified Data.Map as Map

11import qualified Data.Map as Map

11import Data.List (isPrefixOf)

12import Data.List (isPrefixOf)

12−import qualified Data.UnionFind.IO as UF

13import qualified Text.PrettyPrint as PP

14

15import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

17import Type.Type

18

19type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

26 value :: TypeDict

27}

28

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30initialEnvironment datatypes aliases = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

32+ let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases

33 env = Environment {

34 constructor = Map.empty,

35 value = Map.empty,

@@ -42,9 +42,9 @@ makeTypes :: [ADT] -> IO TypeDict

42makeTypes datatypes =

43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

44 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

46

47− makeCtor (name, kind) = do

47+ makeCtor (name, _) = do

48 ctor <- VarN <$> namedVar Constant name

49 return (name, ctor)

50

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

84

85

86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, _) =

88 zip (map fst ctors) (map inst ctors)

89 where

90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

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

94

95

96 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

97− go (ctor, args) = do

97+ go (_, args) = do

98 types <- mapM (instantiator env) args

99 returnType <- instantiator env (Src.Data name (map Src.Var tvars))

100 return (types, returnType)

@@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType

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

163 name ++ "' while checking types."

164

165− Src.EmptyRecord -> return (TermN EmptyRecord1)

166−

167− Src.Record fields ext ->

165+ Src.Record fields ext -> do

168− TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)

166+ fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

167+ ext' <- case ext of

168+ Nothing -> return $ TermN EmptyRecord1

169+ Just x -> go (Src.Var x)

170+ return $ TermN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+103−28

@@ -1,10 +1,12 @@

1+{-# OPTIONS_GHC -W #-}

2+module Type.ExtraChecks (mainType, occurs, portTypes) where

1-- This module contains checks to be run *after* type inference has

3-- This module contains checks to be run *after* type inference has

2-- completed successfully. At that point we still need to do occurs

4-- completed successfully. At that point we still need to do occurs

3-- checks and ensure that `main` has an acceptable type.

5-- checks and ensure that `main` has an acceptable type.

4−module Type.ExtraChecks (extraChecks, occursCheck) where

5

6

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

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

7import Control.Monad.State

8import Control.Monad.State

9+import qualified Data.List as List

8import qualified Data.Map as Map

10import qualified Data.Map as Map

9import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

10import Type.Type ( Variable, structure, Term1(..), toSrcType )

12import Type.Type ( Variable, structure, Term1(..), toSrcType )

@@ -12,33 +14,106 @@ import qualified Type.State as TS

12import qualified Type.Alias as Alias

14import qualified Type.Alias as Alias

13import Text.PrettyPrint as P

15import Text.PrettyPrint as P

14import SourceSyntax.PrettyPrint (pretty)

16import SourceSyntax.PrettyPrint (pretty)

17+import qualified SourceSyntax.Helpers as Help

15−import SourceSyntax.Type (Type)

18+import qualified SourceSyntax.Type as T

19+import qualified SourceSyntax.Expression as E

16−import qualified SourceSyntax.Location as Location

20+import qualified SourceSyntax.Location as L

17−import qualified SourceSyntax.Expression as Expr

21+import qualified Transform.Expression as Expr

18import qualified Data.Traversable as Traverse

22import qualified Data.Traversable as Traverse

19

23

24+throw err = Left [ P.vcat err ]

25+

20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))

26+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

21−extraChecks rules env =

22− mainCheck rules <$> Traverse.traverse toSrcType env

27+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

23−

28+ where

24−mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)

25−mainCheck rules env =

30+ mainCheck rules env =

26− let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in

27− case Map.lookup "main" env of

31+ case Map.lookup "main" env of

28− Nothing -> Right env

32+ Nothing -> Right env

29− Just tipe

33+ Just mainType

34+ | tipe `elem` acceptable -> Right env

35+ | otherwise -> throw err

36+ where

37+ acceptable = [ "Graphics.Element.Element"

38+ , "Signal.Signal Graphics.Element.Element" ]

39+

30− | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->

40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

31− Right env

32− | otherwise ->

33− Left [ P.vcat [ P.text "Type Error:"

34− , P.text "Bad type for 'main'. It must have type Element or a (Signal Element)"

41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

35− , P.text "Instead 'main' has type:\n"

42+ , P.text "Instead 'main' has type:\n"

36− , P.nest 4 . pretty $ Alias.realias rules tipe

43+ , P.nest 4 . pretty $ Alias.realias rules mainType

44+ , P.text " " ]

45+

46+data Direction = In | Out

47+

48+portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

49+portTypes rules expr =

50+ const () <$> Expr.checkPorts (check In) (check Out) expr

51+ where

52+ check = isValid True False False

53+ isValid isTopLevel seenFunc seenSignal direction name tipe =

54+ case tipe of

55+ T.Data ctor ts

56+ | isJs ctor || isElm ctor -> mapM_ valid ts

57+ | ctor == "Signal.Signal" -> handleSignal ts

58+ | otherwise -> err' True "an unsupported type"

59+

60+ T.Var _ -> err "free type variables"

61+

62+ T.Lambda _ _ ->

63+ case direction of

64+ In -> err "functions"

65+ Out | seenFunc -> err "higher-order functions"

66+ | seenSignal -> err "signals that contain functions"

67+ | otherwise ->

68+ forM_ (T.collectLambdas tipe)

69+ (isValid' True seenSignal direction name)

70+

71+ T.Record _ (Just _) -> err "extended records with free type variables"

72+

73+ T.Record fields Nothing ->

74+ mapM_ (\(k,v) -> (,) k <$> valid v) fields

75+

76+ where

77+ isValid' = isValid False

78+ valid = isValid' seenFunc seenSignal direction name

79+

80+ isJs ctor =

81+ List.isPrefixOf "JavaScript." ctor

82+ && length (filter (=='.') ctor) == 1

83+

84+ isElm ctor =

85+ ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]

86+ || Help.isTuple ctor

87+

88+ handleSignal ts

89+ | seenFunc = err "functions that involve signals"

90+ | seenSignal = err "signals-of-signals"

91+ | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

92+ | otherwise = err "a signal within a data stucture"

93+

94+ dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

37− , P.text " " ]

95+ txt = P.text . concat

38− ]

96+

39−

97+ err = err' False

98+ err' couldBeAlias kind =

99+ throw $

100+ [ txt [ "Type Error: the value ", dir "coming in" "sent out"

101+ , " through port '", name, "' is invalid." ]

102+ , txt [ "It contains ", kind, ":\n" ]

103+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

104+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"

105+ , " ports include JavaScript values and" ]

106+ , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]

107+ , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]

108+ ] ++ if couldBeAlias then aliasWarning else []

109+

110+ aliasWarning =

111+ [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]

112+ , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

113+ ]

114+

40−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()

115+occurs :: (String, Variable) -> StateT TS.SolverState IO ()

41−occursCheck (name, variable) =

116+occurs (name, variable) =

42 do vars <- liftIO $ infiniteVars [] variable

117 do vars <- liftIO $ infiniteVars [] variable

43 case vars of

118 case vars of

44 [] -> return ()

119 [] -> return ()

@@ -47,10 +122,10 @@ occursCheck (name, variable) =

47 case structure desc of

122 case structure desc of

48 Nothing ->

123 Nothing ->

49 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

124 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

50− Just struct ->

125+ Just _ ->

51 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

126 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

52 var' <- liftIO $ UF.fresh desc

127 var' <- liftIO $ UF.fresh desc

53− TS.addError (Location.NoSpan name) (Just msg) var var'

128+ TS.addError (L.NoSpan name) (Just msg) var var'

54 where

129 where

55 msg = "Infinite types are not allowed"

130 msg = "Infinite types are not allowed"

56 fallback _ = return $ P.text msg

131 fallback _ = return $ P.text msg

compiler/Type/Inference.hs+7−8

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Inference where

2module Type.Inference where

2

3

3import qualified Data.Map as Map

4import qualified Data.Map as Map

@@ -5,27 +6,23 @@ import qualified Data.Map as Map

5import qualified Type.Type as T

6import qualified Type.Type as T

6import qualified Type.Environment as Env

7import qualified Type.Environment as Env

7import qualified Type.Constrain.Expression as TcExpr

8import qualified Type.Constrain.Expression as TcExpr

8−import qualified Type.Constrain.Declaration as TcDecl

9import qualified Type.Solve as Solve

10

11import SourceSyntax.Module as Module

12−import qualified SourceSyntax.Expression as Expr

13−import SourceSyntax.Location (Located, noneNoDocs)

12+import SourceSyntax.Location (noneNoDocs)

14−import SourceSyntax.PrettyPrint

15import SourceSyntax.Type (Type)

13import SourceSyntax.Type (Type)

16import Text.PrettyPrint

14import Text.PrettyPrint

17import qualified Type.State as TS

15import qualified Type.State as TS

18−import Type.ExtraChecks (extraChecks)

16+import qualified Type.ExtraChecks as Check

19import Control.Monad.State (execStateT, forM)

17import Control.Monad.State (execStateT, forM)

20import Control.Monad.Error (runErrorT, liftIO)

18import Control.Monad.Error (runErrorT, liftIO)

21−import Control.Arrow (second)

22import qualified Type.Alias as Alias

19import qualified Type.Alias as Alias

23

20

24import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

21import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

25 -- the IO monad. I don't think that'd be worthwhile.

22 -- the IO monad. I don't think that'd be worthwhile.

26

23

27

24

28−infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

25+infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

29infer interfaces modul = unsafePerformIO $ do

26infer interfaces modul = unsafePerformIO $ do

30 env <- Env.initialEnvironment

27 env <- Env.initialEnvironment

31 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

28 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

@@ -55,4 +52,6 @@ infer interfaces modul = unsafePerformIO $ do

55 let rules = Alias.rules interfaces (aliases modul) (imports modul)

52 let rules = Alias.rules interfaces (aliases modul) (imports modul)

56 case TS.sErrors state of

53 case TS.sErrors state of

57 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

54 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

55+ [] -> case Check.portTypes rules (program modul) of

58− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

56+ Right () -> Check.mainType rules (Map.difference (TS.sSavedEnv state) header)

57+ Left err -> return (Left err)

compiler/Type/Solve.hs+3−5

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Solve (solve) where

2module Type.Solve (solve) where

2

3

3import Control.Monad

4import Control.Monad

@@ -5,14 +6,11 @@ import Control.Monad.State

5import qualified Data.UnionFind.IO as UF

6import qualified Data.UnionFind.IO as UF

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Traversable as Traversable

8import qualified Data.Traversable as Traversable

8−import qualified Data.Maybe as Maybe

9import qualified Data.List as List

10import Type.Type

11import Type.Unify

12−import qualified Type.ExtraChecks as EC

12+import qualified Type.ExtraChecks as Check

13−import qualified Type.Environment as Env

14import qualified Type.State as TS

13import qualified Type.State as TS

15−import qualified Text.PrettyPrint as P

16import SourceSyntax.Location (Located(L), SrcSpan)

14import SourceSyntax.Location (Located(L), SrcSpan)

17

15

18

16

@@ -122,7 +120,7 @@ solve (L span constraint) =

122 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

120 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

123 TS.modifyEnv $ \env -> Map.union headers env

121 TS.modifyEnv $ \env -> Map.union headers env

124 solve constraint'

122 solve constraint'

125− mapM EC.occursCheck $ Map.toList headers

123+ mapM Check.occurs $ Map.toList headers

126 TS.modifyEnv (\_ -> oldEnv)

124 TS.modifyEnv (\_ -> oldEnv)

127

125

128 CInstance name term -> do

126 CInstance name term -> do

compiler/Type/State.hs+3−5

@@ -1,9 +1,8 @@

1+{-# OPTIONS_GHC -W #-}

1module Type.State where

2module Type.State where

2

3

3import Type.Type

4import Type.Type

4import qualified Data.Map as Map

5import qualified Data.Map as Map

5−import qualified Data.List as List

6−import qualified Type.Environment as Env

7import qualified Data.UnionFind.IO as UF

6import qualified Data.UnionFind.IO as UF

8import Control.Monad.State

7import Control.Monad.State

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

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

@@ -11,7 +10,6 @@ import qualified Data.Traversable as Traversable

11import Text.PrettyPrint as P

10import Text.PrettyPrint as P

12import SourceSyntax.PrettyPrint

11import SourceSyntax.PrettyPrint

13import SourceSyntax.Location

12import SourceSyntax.Location

14−import qualified SourceSyntax.Type as Src

15import qualified Type.Alias as Alias

13import qualified Type.Alias as Alias

16

14

17-- Pool

15-- Pool

@@ -64,8 +62,8 @@ addError span hint t1 t2 =

64 ]

62 ]

65

63

66 location = case span of

64 location = case span of

67− NoSpan msg -> ""

65+ NoSpan _ -> ""

68− Span p1 p2 msg ->

66+ Span p1 p2 _ ->

69 if line p1 == line p2 then " on line " ++ show (line p1)

67 if line p1 == line p2 then " on line " ++ show (line p1)

70 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

68 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

71

69

compiler/Type/Type.hs+20−13

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

62infixl 8 /\

63

64(/\) :: Constraint a b -> Constraint a b -> Constraint a b

65−a@(L s1 c1) /\ b@(L s2 c2) =

65+a@(L _ c1) /\ b@(L _ c2) =

66 case (c1, c2) of

67 (CTrue, _) -> b

68 (_, CTrue) -> a

@@ -95,6 +95,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

95data SuperType = Number | Comparable | Appendable

96 deriving (Show, Eq)

97

98+namedVar :: Flex -> String -> IO Variable

98namedVar flex name = UF.fresh $ Descriptor {

99namedVar flex name = UF.fresh $ Descriptor {

99 structure = Nothing,

100 structure = Nothing,

100 rank = noRank,

101 rank = noRank,

@@ -104,6 +105,7 @@ namedVar flex name = UF.fresh $ Descriptor {

104 mark = noMark

105 mark = noMark

105 }

106 }

106

107

108+var :: Flex -> IO Variable

107var flex = UF.fresh $ Descriptor {

109var flex = UF.fresh $ Descriptor {

108 structure = Nothing,

110 structure = Nothing,

109 rank = noRank,

111 rank = noRank,

@@ -113,6 +115,7 @@ var flex = UF.fresh $ Descriptor {

113 mark = noMark

115 mark = noMark

114 }

116 }

115

117

118+structuredVar :: Term1 Variable -> IO Variable

116structuredVar structure = UF.fresh $ Descriptor {

119structuredVar structure = UF.fresh $ Descriptor {

117 structure = Just structure,

120 structure = Just structure,

118 rank = noRank,

121 rank = noRank,

@@ -361,15 +364,19 @@ toSrcType variable = do

361 return (Src.Data name (ts ++ [b']))

364 return (Src.Data name (ts ++ [b']))

362 Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

365 Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

363 Var1 a -> toSrcType a

366 Var1 a -> toSrcType a

364− EmptyRecord1 -> return Src.EmptyRecord

367+ EmptyRecord1 -> return $ Src.Record [] Nothing

365− Record1 fs ext -> do

368+ Record1 tfields extension -> do

366− fs' <- traverse (mapM toSrcType) fs

369+ fields' <- traverse (mapM toSrcType) tfields

367− let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]

370+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

368− Src.Record fs'' <$> toSrcType ext

371+ ext' <- toSrcType extension

372+ return $ case ext' of

373+ Src.Record fs ext -> Src.Record (fs ++ fields) ext

374+ Src.Var x -> Src.Record fields (Just x)

375+ _ -> error "Used toSrcType on a type that is not well-formed"

369 Nothing ->

376 Nothing ->

370 case name desc of

377 case name desc of

371− Just x@(c:cs) | Char.isLower c -> return (Src.Var x)

378+ Just x@(c:_) | Char.isLower c -> return (Src.Var x)

372− | otherwise -> return (Src.Data x [])

379+ | otherwise -> return (Src.Data x [])

373 _ -> error $ concat

380 _ -> error $ concat

374 [ "Problem converting the following type "

381 [ "Problem converting the following type "

375 , "from a type-checker type to a source-syntax type:"

382 , "from a type-checker type to a source-syntax type:"

@@ -383,12 +390,12 @@ collectApps variable = go [] variable

383 go vars variable = do

390 go vars variable = do

384 desc <- UF.descriptor variable

391 desc <- UF.descriptor variable

385 case (structure desc, vars) of

392 case (structure desc, vars) of

386− (Nothing, [v] ) -> case name desc of

393+ (Nothing, [v]) -> case name desc of

387 Just "_List" -> return (List v)

394 Just "_List" -> return (List v)

388 _ -> return Other

395 _ -> return Other

389− (Nothing, vs ) -> case name desc of

396+ (Nothing, vs) -> case name desc of

390 Just ctor | isTuple ctor -> return (Tuple vs)

397 Just ctor | isTuple ctor -> return (Tuple vs)

391 _ -> return Other

398 _ -> return Other

392− (Just term, vs) -> case term of

399+ (Just term, _) -> case term of

393− App1 a b -> go (vars ++ [b]) a

400+ App1 a b -> go (vars ++ [b]) a

394− _ -> return Other

401+ _ -> return Other

compiler/Type/Unify.hs+3−3

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Unify (unify) where

2module Type.Unify (unify) where

2

3

3import Type.Type

4import Type.Type

@@ -5,7 +6,6 @@ import qualified Data.UnionFind.IO as UF

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6import qualified Data.Maybe as Maybe

7import qualified Data.Maybe as Maybe

7import qualified Type.State as TS

8import qualified Type.State as TS

8−import Control.Arrow (first,second)

9import Control.Monad.State

10import SourceSyntax.Location

11import Type.PrettyPrint

@@ -193,8 +193,8 @@ actuallyUnify span variable1 variable2 = do

193

194 unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a

195

196− eat (x:xs) (y:ys) = eat xs ys

196+ eat (_:xs) (_:ys) = eat xs ys

197− eat xs ys = xs

197+ eat xs _ = xs

198

199 _ -> TS.addError span Nothing variable1 variable2

200

libraries/Basics.elm+17−1

@@ -43,7 +43,7 @@ which happen to be radians.

43@docs fst, snd

44

45# Higher-Order Helpers

46−@docs id, (<|), (|>), (.), flip, curry, uncurry

46+@docs id, (<|), (|>), (.), always, flip, curry, uncurry

47

48-}

49

@@ -313,6 +313,22 @@ infixl 0 |>

313id : a -> a

314id x = x

315

316+{-| Creates a [constant function](http://en.wikipedia.org/wiki/Constant_function),

317+a function that *always* returns the same value regardless of what input you give.

318+It is defined as:

319+

320+ always a b = a

321+

322+It totally ignores the second argument, so `always 42` is a function that always

323+returns in 42. When you are dealing with higher-order functions, this comes in

324+handy more often than you might expect. For example, creating a zeroed out list

325+of length ten would be:

326+

327+ map (always 0) [0..9]

328+-}

329+always : a -> b -> a

330+always a _ = a

331+

316{-| Given a 2-tuple, returns the first value. -}

332{-| Given a 2-tuple, returns the first value. -}

317fst : (a,b) -> a

333fst : (a,b) -> a

318fst (a,_) = a

334fst (a,_) = a

libraries/Dict.elm+82−88

@@ -34,15 +34,35 @@ Insert, remove, and query operations all take *O(log n)* time.

34import open Basics

35import open Maybe

36import Native.Error

37−import List as List

37+import List

38+import String

38import Native.Utils

39import Native.Utils

39

40

40-- BBlack and NBlack should only be used during the deletion

41-- BBlack and NBlack should only be used during the deletion

41-- algorithm. Any other occurrence is a bug and should fail an assert.

42-- algorithm. Any other occurrence is a bug and should fail an assert.

42−data NColor = Red | Black

43+data NColor = Red

44+ | Black

45+ -- ^ Double Black, counts as 2 blacks for the invariant

43− | BBlack | NBlack

46+ | BBlack

44−

47+ -- ^ Negative Black, counts as -1 blacks for the invariant

48+ | NBlack

49+

50+

51+showNColor : NColor -> String

52+showNColor c = case c of

53+ Red -> "Red"

54+ Black -> "Black"

55+ BBlack -> "BBlack"

56+ NBlack -> "NBlack"

57+

45−data LeafColor = LBlack | LBBlack

58+data LeafColor = LBlack

59+ -- ^ Double Black, counts as 2

60+ | LBBlack

61+

62+showLColor : LeafColor -> String

63+showLColor c = case c of

64+ LBlack -> "LBlack"

65+ LBBlack -> "LBBlack"

46

66

47data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

67data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

48 | RBEmpty LeafColor

68 | RBEmpty LeafColor

@@ -93,51 +113,6 @@ member : comparable -> Dict comparable v -> Bool

93-- Does t contain k?

113-- Does t contain k?

94member k t = isJust <| lookup k t

114member k t = isJust <| lookup k t

95

115

96−rotateLeft : Dict k v -> Dict k v

97−rotateLeft t =

98− case t of

99− RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c

100− _ -> Native.Error.raise "rotateLeft of a node without enough children"

101−

102−-- rotateRight -- the reverse, and

103−-- makes Y have Z's color, and makes Z Red.

104−rotateRight : Dict k v -> Dict k v

105−rotateRight t =

106− case t of

107− RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)

108− _ -> Native.Error.raise "rotateRight of a node without enough children"

109−

110−rotateLeftIfNeeded : Dict k v -> Dict k v

111−rotateLeftIfNeeded t =

112− case t of

113− RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t

114− _ -> t

115−

116−rotateRightIfNeeded : Dict k v -> Dict k v

117−rotateRightIfNeeded t =

118− case t of

119− RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t

120− _ -> t

121−

122−otherColor c = case c of { Red -> Black ; Black -> Red }

123−

124−color_flip : Dict k v -> Dict k v

125−color_flip t =

126− case t of

127− RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->

128− RBNode (otherColor c1) bk bv

129− (RBNode (otherColor c2) ak av la ra)

130− (RBNode (otherColor c3) ck cv lc rc)

131− _ -> Native.Error.raise "color_flip called on a Empty or Node with a Empty child"

132−

133−color_flipIfNeeded : Dict k v -> Dict k v

134−color_flipIfNeeded t =

135− case t of

136− RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t

137− _ -> t

138−

139−fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))

140−

141ensureBlackRoot : Dict k v -> Dict k v

116ensureBlackRoot : Dict k v -> Dict k v

142ensureBlackRoot t =

117ensureBlackRoot t =

143 case t of

118 case t of

@@ -158,6 +133,11 @@ remove k t = let u _ = Nothing in

158 update k u t

133 update k u t

159

134

160data Flag = Insert | Remove | Same

135data Flag = Insert | Remove | Same

136+showFlag : Flag -> String

137+showFlag f = case f of

138+ Insert -> "Insert"

139+ Remove -> "Remove"

140+ Same -> "Same"

161

141

162{-| Update the value of a dictionary for a specific key with a given function. -}

142{-| Update the value of a dictionary for a specific key with a given function. -}

163update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v

143update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v

@@ -168,76 +148,87 @@ update k u t =

168 Just v -> (Insert, RBNode Red k v empty empty)

148 Just v -> (Insert, RBNode Red k v empty empty)

169 RBNode c k' v l r -> case Native.Utils.compare k k' of

149 RBNode c k' v l r -> case Native.Utils.compare k k' of

170 EQ -> case u (Just v) of

150 EQ -> case u (Just v) of

171− Nothing -> (Remove, rem t)

151+ Nothing -> (Remove, rem c l r)

172 Just v' -> (Same, RBNode c k' v' l r)

152 Just v' -> (Same, RBNode c k' v' l r)

173 LT -> let (fl, l') = up l in

153 LT -> let (fl, l') = up l in

174 case fl of

154 case fl of

175 Same -> (Same, RBNode c k' v l' r)

155 Same -> (Same, RBNode c k' v l' r)

176− Insert -> (Insert, fixUp <| RBNode c k' v l' r)

156+ Insert -> (Insert, balance c k' v l' r)

177 Remove -> (Remove, bubble c k' v l' r)

157 Remove -> (Remove, bubble c k' v l' r)

178 GT -> let (fl, r') = up r in

158 GT -> let (fl, r') = up r in

179 case fl of

159 case fl of

180 Same -> (Same, RBNode c k' v l r')

160 Same -> (Same, RBNode c k' v l r')

181− Insert -> (Insert, fixUp <| RBNode c k' v l r')

161+ Insert -> (Insert, balance c k' v l r')

182 Remove -> (Remove, bubble c k' v l r')

162 Remove -> (Remove, bubble c k' v l r')

183 (fl, t') = up t

163 (fl, t') = up t

184 in case fl of

164 in case fl of

185 Same -> t'

165 Same -> t'

186 Insert -> ensureBlackRoot t'

166 Insert -> ensureBlackRoot t'

187 Remove -> blacken t'

167 Remove -> blacken t'

188−

168+

189{-| Create a dictionary with one key-value pair. -}

169{-| Create a dictionary with one key-value pair. -}

190singleton : comparable -> v -> Dict comparable v

170singleton : comparable -> v -> Dict comparable v

191singleton k v = insert k v (RBEmpty LBlack)

171singleton k v = insert k v (RBEmpty LBlack)

192

172

193−{- Remove helpers: everything from here to remove should only be used

194− internally by remove as they would otherwise break rb-invariants -}

195−

196isBBlack : Dict k v -> Bool

173isBBlack : Dict k v -> Bool

197isBBlack t = case t of

174isBBlack t = case t of

198− RBNode c _ _ _ _ -> case c of

199− BBlack -> True

175+ RBNode BBlack _ _ _ _ -> True

200− _ -> False

201 RBEmpty LBBlack -> True

176 RBEmpty LBBlack -> True

202 _ -> False

177 _ -> False

203

178

204moreBlack : NColor -> NColor

179moreBlack : NColor -> NColor

205moreBlack c = case c of

180moreBlack c = case c of

206− BBlack -> BBlack

207 Black -> BBlack

181 Black -> BBlack

208 Red -> Black

182 Red -> Black

209 NBlack -> Red

183 NBlack -> Red

184+ BBlack -> Native.Error.raise "Can't make a double black node more black!"

185+

210lessBlack : NColor -> NColor

186lessBlack : NColor -> NColor

211lessBlack c = case c of

187lessBlack c = case c of

212 BBlack -> Black

188 BBlack -> Black

213 Black -> Red

189 Black -> Red

214 Red -> NBlack

190 Red -> NBlack

215− NBlack -> NBlack

191+ NBlack -> Native.Error.raise "Can't make a negative black node less black!"

216−

217−moreBlackTree : Dict k v -> Dict k v

218−moreBlackTree t = case t of

219− RBNode c k v l r -> RBNode (moreBlack c) k v l r

220− RBEmpty _ -> RBEmpty LBBlack

221

192

222lessBlackTree : Dict k v -> Dict k v

193lessBlackTree : Dict k v -> Dict k v

223lessBlackTree t = case t of

194lessBlackTree t = case t of

224 RBNode c k v l r -> RBNode (lessBlack c) k v l r

195 RBNode c k v l r -> RBNode (lessBlack c) k v l r

225− RBEmpty _ -> RBEmpty LBlack

196+ RBEmpty LBBlack -> RBEmpty LBlack

197+

198+reportRemBug : String -> NColor -> String -> String -> a

199+reportRemBug msg c lgot rgot =

200+ Native.Error.raise . String.concat <| [

201+ "Internal red-black tree invariant violated, expected ",

202+ msg,

203+ "and got",

204+ showNColor c,

205+ " ",

206+ lgot,

207+ " ",

208+ rgot,

209+ "\nPlease report this bug to https://github.com/evancz/Elm/issues"

210+ ]

226

211

227-- Remove the top node from the tree, may leave behind BBlacks

212-- Remove the top node from the tree, may leave behind BBlacks

228−rem : Dict k v -> Dict k v

213+rem : NColor -> Dict k v -> Dict k v -> Dict k v

229−rem t = case t of

214+rem c l r = case (l, r) of

230− RBNode c k v (RBEmpty _) (RBEmpty _) -> case c of

215+ ((RBEmpty _), (RBEmpty _)) -> case c of

231− Red -> RBEmpty LBlack

216+ Red -> RBEmpty LBlack

232 Black -> RBEmpty LBBlack

217 Black -> RBEmpty LBBlack

233− RBNode Black _ _ (RBEmpty _) (RBNode _ k v l r) ->

218+ ((RBEmpty cl), (RBNode cr k' v' l' r')) ->

219+ case (c, cl, cr) of

234− RBNode Black k v l r

220+ (Black, LBlack, Red) -> RBNode Black k' v' l' r'

221+ _ -> reportRemBug "Black, LBlack, Red" c (showLColor cl) (showNColor cr)

235− RBNode Black _ _ (RBNode _ k v l r) (RBEmpty _) ->

222+ ((RBNode cl k' v' l' r'), (RBEmpty cr)) ->

223+ case (c, cl, cr) of

236− RBNode Black k v l r

224+ (Black, Red, LBlack) -> RBNode Black k' v' l' r'

225+ _ -> reportRemBug "Black, Red, LBlack" c (showNColor cl) (showLColor cr)

237 -- l and r are both RBNodes

226 -- l and r are both RBNodes

238− RBNode c _ _ l r ->

227+ ((RBNode cl kl vl ll rl), (RBNode cr kr vr lr rr)) ->

228+ let l = RBNode cl kl vl ll rl

229+ r = RBNode cr kr vr lr rr

239− let (k, v) = max l

230+ (k, v) = max l

240− l' = remove_max l

231+ l' = remove_max cl kl vl ll rl

241 in bubble c k v l' r

232 in bubble c k v l' r

242

233

243-- Kills a BBlack or moves it upward, may leave behind NBlack

234-- Kills a BBlack or moves it upward, may leave behind NBlack

@@ -245,19 +236,24 @@ bubble : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

245bubble c k v l r = if isBBlack l || isBBlack r

236bubble c k v l r = if isBBlack l || isBBlack r

246 then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)

237 then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)

247 else RBNode c k v l r

238 else RBNode c k v l r

248−

239+

249-- Removes rightmost node, may leave root as BBlack

240-- Removes rightmost node, may leave root as BBlack

250−remove_max : Dict k v -> Dict k v

241+remove_max : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

251−remove_max t = case t of

242+remove_max c k v l r = case r of

252− RBNode c k v l (RBEmpty _) -> rem t

243+ RBEmpty _ -> rem c l r

244+ RBNode cr kr vr lr rr

253− RBNode c k v l r -> bubble c k v l (remove_max r)

245+ -> bubble c k v l (remove_max cr kr vr lr rr)

254

246

255-- generalized tree balancing act

247-- generalized tree balancing act

256balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

248balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

249+balance c k v l r =

250+

257−balance c k v l r = balance_node (RBNode c k v l r)

251+ balance_node (RBNode c k v l r)

258

252

259blackish : Dict k v -> Bool

253blackish : Dict k v -> Bool

254+blackish t = case t of

260−blackish (RBNode c _ _ _ _) = c == Black || c == BBlack

255+ RBNode c _ _ _ _ -> c == Black || c == BBlack

256+ RBEmpty _ -> True

261

257

262balance_node : Dict k v -> Dict k v

258balance_node : Dict k v -> Dict k v

263balance_node t =

259balance_node t =

@@ -286,9 +282,7 @@ balance_node t =

286 (RBNode Black _ _ _ _) ->

282 (RBNode Black _ _ _ _) ->

287 RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)

283 RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)

288 _ -> t

284 _ -> t

289−

290 _ -> t

285 _ -> t

291−

292 else t

286 else t

293

287

294-- make the top node black

288-- make the top node black

libraries/Native/JavaScript.js+1−1

@@ -34,7 +34,7 @@ Elm.Native.JavaScript.make = function(elm) {

34

35 function toJS(v) {

36 var type = typeof v;

37− if (type === 'number' || type === 'boolean') return v;

37+ if (type === 'number' || type === 'boolean' || type === 'string') return v;

38 if (type === 'object' && '_' in v) {

39 var obj = {};

40 for (var k in v) {

libraries/Native/Ports.jsnew file+83

@@ -0,0 +1,83 @@

1+Elm.Native.Ports = {};

2+Elm.Native.Ports.make = function(elm) {

3+ elm.Native = elm.Native || {};

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

5+ if (elm.Native.Ports.values) return elm.Native.Ports.values;

6+

7+ var Signal = Elm.Signal.make(elm);

8+

9+ function incomingSignal(converter) {

10+ converter.isSignal = true;

11+ return converter;

12+ }

13+

14+ function outgoingSignal(converter) {

15+ return function(signal) {

16+ var subscribers = []

17+ function subscribe(handler) {

18+ subscribers.push(handler);

19+ }

20+ function unsubscribe(handler) {

21+ subscribers.pop(subscribers.indexOf(handler));

22+ }

23+ A2( Signal.lift, function(value) {

24+ var val = converter(value);

25+ var len = subscribers.length;

26+ for (var i = 0; i < len; ++i) {

27+ subscribers[i](val);

28+ }

29+ }, signal);

30+ return { subscribe:subscribe, unsubscribe:unsubscribe };

31+ }

32+ }

33+

34+ function portIn(name, converter) {

35+ var jsValue = elm.ports.incoming[name];

36+ if (jsValue === undefined) {

37+ throw new Error("Initialization Error: port '" + name +

38+ "' was not given an input!");

39+ }

40+ elm.ports.uses[name] += 1;

41+ try {

42+ var elmValue = converter(jsValue);

43+ } catch(e) {

44+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

45+ }

46+

47+ // just return a static value if it is not a signal

48+ if (!converter.isSignal) {

49+ return elmValue;

50+ }

51+

52+ // create a signal if necessary

53+ var signal = Signal.constant(elmValue);

54+ function send(jsValue) {

55+ try {

56+ var elmValue = converter(jsValue);

57+ } catch(e) {

58+ throw new Error("Error sending to port '" + name + "': \n" + e.message);

59+ }

60+ setTimeout(function() {

61+ elm.notify(signal.id, elmValue);

62+ }, 0);

63+ }

64+ elm.ports.outgoing[name] = { send:send };

65+ return signal;

66+ }

67+

68+ function portOut(name, converter, value) {

69+ try {

70+ elm.ports.outgoing[name] = converter(value);

71+ } catch(e) {

72+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

73+ }

74+ return value;

75+ }

76+

77+ return elm.Native.Ports.values = {

78+ incomingSignal: incomingSignal,

79+ outgoingSignal: outgoingSignal,

80+ portOut: portOut,

81+ portIn: portIn

82+ };

83+};

runtime/Init.js+86−30

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

2(function() {

3'use strict';

4

5−Elm.fullscreen = function(module) {

5+Elm.fullscreen = function(module, ports) {

6 var style = document.createElement('style');

7 style.type = 'text/css';

8 style.innerHTML = "html,head,body { padding:0; margin:0; }" +

@@ -10,24 +10,24 @@ Elm.fullscreen = function(module) {

10 document.head.appendChild(style);

11 var container = document.createElement('div');

12 document.body.appendChild(container);

13− return init(ElmRuntime.Display.FULLSCREEN, container, module);

13+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports || {});

14};

15

16−Elm.embed = function(module, container) {

16+Elm.embed = function(module, container, ports) {

17 var tag = container.tagName;

18 if (tag !== 'DIV') {

19 throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');

20 } else if (container.hasChildNodes()) {

21 throw new Error('Elm.node must be given an empty DIV. No children allowed!');

22 }

23− return init(ElmRuntime.Display.COMPONENT, container, module);

23+ return init(ElmRuntime.Display.COMPONENT, container, module, ports || {});

24};

25

26−Elm.worker = function(module) {

26+Elm.worker = function(module, ports) {

27− return init(ElmRuntime.Display.NONE, {}, module);

27+ return init(ElmRuntime.Display.NONE, {}, module, ports || {});

28};

29

30−function init(display, container, module, moduleToReplace) {

30+function init(display, container, module, ports, moduleToReplace) {

31 // defining state needed for an instance of the Elm RTS

32 var inputs = [];

33

@@ -59,6 +59,10 @@ function init(display, container, module, moduleToReplace) {

59 listeners.push(listener);

60 }

61

62+ var portUses = {}

63+ for (var key in ports) {

64+ portUses[key] = 0;

65+ }

62 // create the actual RTS. Any impure modules will attach themselves to this

66 // create the actual RTS. Any impure modules will attach themselves to this

63 // object. This permits many Elm programs to be embedded per document.

67 // object. This permits many Elm programs to be embedded per document.

64 var elm = {

68 var elm = {

@@ -67,34 +71,15 @@ function init(display, container, module, moduleToReplace) {

67 display:display,

71 display:display,

68 id:ElmRuntime.guid(),

72 id:ElmRuntime.guid(),

69 addListener:addListener,

73 addListener:addListener,

70− inputs:inputs

74+ inputs:inputs,

75+ ports: { incoming:ports, outgoing:{}, uses:portUses }

71 };

76 };

72

77

73− // Set up methods to communicate with Elm program from JS.

74− function send(name, value) {

75− if (typeof value === 'undefined') return function(v) { return send(name,v); };

76− var e = document.createEvent('Event');

77− e.initEvent(name + '_' + elm.id, true, true);

78− e.value = value;

79− document.dispatchEvent(e);

80− }

81− function recv(name, handler) {

82− document.addEventListener(name + '_' + elm.id, handler);

83− }

84−

85− recv('log', function(e) {console.log(e.value)});

86− recv('title', function(e) {document.title = e.value});

87− recv('redirect', function(e) {

88− if (e.value.length > 0) { window.location = e.value; }

89− });

90−

91 function swap(newModule) {

78 function swap(newModule) {

92 removeListeners(listeners);

79 removeListeners(listeners);

93 var div = document.createElement('div');

80 var div = document.createElement('div');

94− var newElm = init(display, div, newModule, elm);

81+ var newElm = init(display, div, newModule, ports, elm);

95 inputs = [];

82 inputs = [];

96− // elm.send = newElm.send;

97− // elm.recv = newElm.recv;

98 // elm.swap = newElm.swap;

83 // elm.swap = newElm.swap;

99 return newElm;

84 return newElm;

100 }

85 }

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

103 var reportAnyErrors = function() {};

88 var reportAnyErrors = function() {};

104 try {

89 try {

105 Module = module.make(elm);

90 Module = module.make(elm);

91+ checkPorts(elm);

106 } catch(e) {

92 } catch(e) {

107 var directions = "<br/>    Open the developer console for more details."

93 var directions = "<br/>    Open the developer console for more details."

108 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

94 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

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

110 }

96 }

111 inputs = ElmRuntime.filterDeadInputs(inputs);

97 inputs = ElmRuntime.filterDeadInputs(inputs);

112 filterListeners(inputs, listeners);

98 filterListeners(inputs, listeners);

99+ addReceivers(elm.ports.outgoing);

113 if (display !== ElmRuntime.Display.NONE) {

100 if (display !== ElmRuntime.Display.NONE) {

114 var graphicsNode = initGraphics(elm, Module);

101 var graphicsNode = initGraphics(elm, Module);

115 }

102 }

@@ -123,9 +110,27 @@ function init(display, container, module, moduleToReplace) {

123 }

110 }

124

111

125 reportAnyErrors();

112 reportAnyErrors();

126− return { send:send, recv:recv, swap:swap };

113+ return { swap:swap, ports:elm.ports.outgoing };

127};

114};

128

115

116+function checkPorts(elm) {

117+ var portUses = elm.ports.uses;

118+ for (var key in portUses) {

119+ var uses = portUses[key]

120+ if (uses === 0) {

121+ throw new Error(

122+ "Initialization Error: provided port '" + key +

123+ "' to a module that does not take it as in input.\n" +

124+ "Remove '" + key + "' from the module initialization code.");

125+ } else if (uses > 1) {

126+ throw new Error(

127+ "Initialization Error: port '" + key +

128+ "' has been declared multiple times in the Elm code.\n" +

129+ "Remove declarations until there is exactly one.");

130+ }

131+ }

132+}

133+

129function filterListeners(inputs, listeners) {

134function filterListeners(inputs, listeners) {

130 loop:

135 loop:

131 for (var i = listeners.length; i--; ) {

136 for (var i = listeners.length; i--; ) {

@@ -146,6 +151,57 @@ function removeListeners(listeners) {

146 }

151 }

147}

152}

148

153

154+// add receivers for built-in ports if they are defined

155+function addReceivers(ports) {

156+ if ('log' in ports) {

157+ ports.log.subscribe(function(v) { console.log(v) });

158+ }

159+ if ('stdout' in ports) {

160+ var process = process || {};

161+ var handler = process.stdout

162+ ? function(v) { process.stdout.write(v); }

163+ : function(v) { console.log(v); };

164+ ports.stdout.subscribe(handler);

165+ }

166+ if ('stderr' in ports) {

167+ var process = process || {};

168+ var handler = process.stderr

169+ ? function(v) { process.stderr.write(v); }

170+ : function(v) { console.log('Error:' + v); };

171+ ports.stderr.subscribe(handler);

172+ }

173+ if ('title' in ports) {

174+ if (typeof ports.title === 'string') {

175+ document.title = ports.title;

176+ } else {

177+ ports.title.subscribe(function(v) { document.title = v; });

178+ }

179+ }

180+ if ('redirect' in ports) {

181+ ports.redirect.subscribe(function(v) {

182+ if (v.length > 0) window.location = v;

183+ });

184+ }

185+ if ('favicon' in ports) {

186+ if (typeof ports.favicon === 'string') {

187+ changeFavicon(ports.favicon);

188+ } else {

189+ ports.favicon.subscribe(changeFavicon);

190+ }

191+ }

192+ function changeFavicon(src) {

193+ var link = document.createElement('link');

194+ var oldLink = document.getElementById('elm-favicon');

195+ link.id = 'elm-favicon';

196+ link.rel = 'shortcut icon';

197+ link.href = src;

198+ if (oldLink) {

199+ document.head.removeChild(oldLink);

200+ }

201+ document.head.appendChild(link);

202+ }

203+}

204+

149function initGraphics(elm, Module) {

205function initGraphics(elm, Module) {

150 if (!('main' in Module))

206 if (!('main' in Module))

151 throw new Error("'main' is missing! What do I display?!");

207 throw new Error("'main' is missing! What do I display?!");

runtime/Utils.js+8−8

@@ -34,18 +34,18 @@ ElmRuntime.filterDeadInputs = function(inputs) {

34

35// define the draw function

36var vendors = ['ms', 'moz', 'webkit', 'o'];

37−var window = window || {};

37+var win = window || {};

38−for (var i = 0; i < vendors.length && !window.requestAnimationFrame; ++i) {

38+for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

39− window.requestAnimationFrame = window[vendors[i]+'RequestAnimationFrame'];

39+ win.requestAnimationFrame = win[vendors[i]+'RequestAnimationFrame'];

40− window.cancelAnimationFrame = window[vendors[i]+'CancelAnimationFrame'] ||

40+ win.cancelAnimationFrame = win[vendors[i]+'CancelAnimationFrame'] ||

41− window[vendors[i]+'CancelRequestAnimationFrame'];

41+ win[vendors[i]+'CancelRequestAnimationFrame'];

42}

43

44−if (window.requestAnimationFrame && window.cancelAnimationFrame) {

44+if (win.requestAnimationFrame && win.cancelAnimationFrame) {

45 var previous = 0;

46 ElmRuntime.draw = function(callback) {

47− window.cancelAnimationFrame(previous);

47+ win.cancelAnimationFrame(previous);

48− previous = window.requestAnimationFrame(callback);

48+ previous = win.requestAnimationFrame(callback);

49 };

50} else {

51 ElmRuntime.draw = function(callback) { callback(); };

tests/Main.hs+7−18

@@ -1,22 +1,11 @@

1module 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

3+import Test.Framework

8

4

9−main :: IO ()

5+import Tests.Compiler

10−main = do

6+import Tests.Property

11− args <- getArgs

12− tests <- blackBoxTests "tests" "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

7

21−ignoreDiff :: Diff

8+main :: IO ()

22−ignoreDiff _ _ = return Nothing

9+main = defaultMain [ compilerTests

10+ , propertyTests

11+ ]

tests/Tests/Compiler.hsnew file+45

@@ -0,0 +1,45 @@

1+module Tests.Compiler (compilerTests)

2+ where

3+

4+import Data.Functor ((<$>))

5+import Data.Traversable (traverse)

6+import System.FilePath ((</>))

7+import System.FilePath.Find (find, (==?), extension)

8+import Test.Framework

9+import Test.Framework.Providers.HUnit (testCase)

10+import Test.HUnit (Assertion, assertFailure, assertBool)

11+import Text.Parsec (ParseError)

12+

13+import Elm.Internal.Utils as Elm

14+

15+compilerTests :: Test

16+compilerTests = buildTest $ do

17+ goods <- mkTests goodCompile =<< getElms "good"

18+ bads <- mkTests badCompile =<< getElms "bad"

19+ return $ testGroup "Compile Tests"

20+ [

21+ testGroup "Good Tests" goods

22+ , testGroup "Bad Tests" bads

23+ ]

24+

25+ where getElms :: FilePath -> IO [FilePath]

26+ getElms fname = find (return True) (extension ==? ".elm") (testsDir </> fname)

27+

28+ mkTests :: (Either String String -> Assertion) -> [FilePath] -> IO [Test]

29+ mkTests h = traverse setupTest

30+ where setupTest f = testCase f . mkCompileTest h <$> readFile f

31+

32+ testsDir = "tests" </> "test-files"

33+

34+goodCompile :: Either String String -> Assertion

35+goodCompile (Left err) = assertFailure err

36+goodCompile (Right _) = assertBool "" True

37+

38+badCompile :: Either String String -> Assertion

39+badCompile (Left _) = assertBool "" True

40+badCompile (Right _) = assertFailure "Compilation succeeded but should have failed"

41+

42+mkCompileTest :: ((Either String String) -> Assertion) -- ^ Handler

43+ -> String -- ^ File Contents

44+ -> Assertion

45+mkCompileTest handle = handle . Elm.compile

tests/Tests/Property.hsnew file+54

@@ -0,0 +1,54 @@

1+module Tests.Property where

2+

3+import Control.Applicative ((<*))

4+import Test.Framework

5+import Test.Framework.Providers.HUnit

6+import Test.Framework.Providers.QuickCheck2

7+import Test.HUnit (assert)

8+import Test.QuickCheck

9+import Text.Parsec.Combinator (eof)

10+import Text.PrettyPrint as P

11+

12+import SourceSyntax.Literal as Lit

13+import SourceSyntax.Pattern as Pat

14+import SourceSyntax.PrettyPrint (Pretty, pretty)

15+import Parse.Helpers (IParser, iParse)

16+import Parse.Literal (literal)

17+import qualified Parse.Pattern as Pat (expr)

18+import qualified Parse.Type as Type (expr)

19+import Tests.Property.Arbitrary

20+

21+propertyTests :: Test

22+propertyTests =

23+ testGroup "Parse/Print Agreement Tests"

24+ [

25+ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

26+ , testProperty "Literal test" $ prop_parse_print literal

27+ , testProperty "Pattern test" $ prop_parse_print Pat.expr

28+ , testProperty "Type test" $ prop_parse_print Type.expr

29+ ]

30+

31+ where

32+ -- This test was autogenerated from the Pattern test and should be

33+ -- left in all its ugly glory.

34+ longPat = Pat.PData "I" [ Pat.PLiteral (Lit.Chr '+')

35+ , Pat.PRecord [

36+ "q7yclkcm7k_ikstrczv_"

37+ , "wQRv6gKsvvkjw4b5F"

38+ ,"c9'eFfhk9FTvsMnwF_D"

39+ ,"yqxhEkHvRFwZ"

40+ ,"o"

41+ ,"nbUlCn3y3NnkVoxhW"

42+ ,"iJ0MNy3KZ_lrs"

43+ ,"ug"

44+ ,"sHHsX"

45+ ,"mRKs9d"

46+ ,"o2KiCX5'ZRzHJfRi8" ]

47+ , Pat.PVar "su'BrrbPUK6I33Eq" ]

48+

49+prop_parse_print :: (Pretty a, Arbitrary a, Eq a) => IParser a -> a -> Bool

50+prop_parse_print p x =

51+ either (const False) (== x) . parse_print p $ x

52+

53+parse_print :: (Pretty a) => IParser a -> a -> Either String a

54+parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty

tests/Tests/Property/Arbitrary.hsnew file+113

@@ -0,0 +1,113 @@

1+{-# OPTIONS_GHC -W -fno-warn-orphans #-}

2+module Tests.Property.Arbitrary where

3+

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

5+import Test.QuickCheck.Arbitrary

6+import Test.QuickCheck.Gen

7+

8+import qualified Data.Set as Set

9+import qualified Parse.Helpers (reserveds)

10+

11+import SourceSyntax.Literal

12+import SourceSyntax.Pattern

13+import SourceSyntax.Type hiding (listOf)

14+

15+instance Arbitrary Literal where

16+ arbitrary = oneof [ IntNum <$> arbitrary

17+ , FloatNum <$> (arbitrary `suchThat` noE)

18+ , Chr <$> arbitrary

19+ -- This is too permissive

20+ , Str <$> arbitrary

21+ -- Booleans aren't actually source syntax

22+ -- , Boolean <$> arbitrary

23+ ]

24+ shrink l = case l of

25+ IntNum n -> IntNum <$> shrink n

26+ FloatNum f -> FloatNum <$> (filter noE . shrink $ f)

27+ Chr c -> Chr <$> shrink c

28+ Str s -> Str <$> shrink s

29+ Boolean b -> Boolean <$> shrink b

30+

31+noE :: Double -> Bool

32+noE = notElem 'e' . show

33+

34+

35+instance Arbitrary Pattern where

36+ arbitrary = sized pat

37+ where pat :: Int -> Gen Pattern

38+ pat n = oneof [ pure PAnything

39+ , PVar <$> lowVar

40+ , PRecord <$> (listOf1 lowVar)

41+ , PLiteral <$> arbitrary

42+ , PAlias <$> lowVar <*> pat (n-1)

43+ , PData <$> capVar <*> sizedPats

44+ ]

45+ where sizedPats = do

46+ len <- choose (0,n)

47+ let m = n `div` (len + 1)

48+ vectorOf len $ pat m

49+

50+ shrink pat = case pat of

51+ PAnything -> []

52+ PVar v -> PVar <$> shrinkWHead v

53+ PRecord fs -> PRecord <$> (filter (all $ not . null) . filter (not . null) $ shrink fs)

54+ PLiteral l -> PLiteral <$> shrink l

55+ PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)

56+ PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)

57+

58+shrinkWHead :: Arbitrary a => [a] -> [[a]]

59+shrinkWHead [] = error "Should be nonempty"

60+shrinkWHead (x:xs) = (x:) <$> shrink xs

61+

62+instance Arbitrary Type where

63+ arbitrary = sized tipe

64+ where tipe :: Int -> Gen Type

65+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe

66+ , Var <$> lowVar

67+ , Data <$> capVar <*> depthTipes

68+ , Record <$> fields <*> pure Nothing

69+ , Record <$> fields1 <*> (Just <$> lowVar)

70+ ]

71+ where depthTipe = choose (0,n) >>= tipe

72+ depthTipes = do

73+ len <- choose (0,n)

74+ let m = n `div` (len + 1)

75+ vectorOf len $ tipe m

76+

77+ field = (,) <$> lowVar <*> depthTipe

78+ fields = do

79+ len <- choose (0,n)

80+ let m = n `div` (len + 1)

81+ vectorOf len $ (,) <$> lowVar <*> tipe m

82+ fields1 = (:) <$> field <*> fields

83+

84+ shrink tipe = case tipe of

85+ Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)

86+ Var _ -> []

87+ Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)

88+ Record fs t -> map snd fs ++ case t of

89+ Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing

90+ Just _ ->

91+ do

92+ fields <- filter (not . null) $ shrinkList shrinkField fs

93+ return $ Record fields t

94+ where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

95+

96+lowVar :: Gen String

97+lowVar = notReserved $ (:) <$> lower <*> listOf varLetter

98+ where lower = elements ['a'..'z']

99+

100+capVar :: Gen String

101+capVar = notReserved $ (:) <$> upper <*> listOf varLetter

102+ where upper = elements ['A'..'Z']

103+

104+varLetter :: Gen Char

105+varLetter = elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['\'', '_']

106+

107+notReserved :: Gen String -> Gen String

108+notReserved = flip exceptFor Parse.Helpers.reserveds

109+

110+exceptFor :: (Ord a) => Gen a -> [a] -> Gen a

111+exceptFor g xs = g `suchThat` notAnX

112+ where notAnX = flip Set.notMember xset

113+ xset = Set.fromList xs

tests/bad/BBTArgs → tests/test-files/bad/BBTArgsrenamed

The content is the same.

tests/bad/InfiniteType.elm → tests/test-files/bad/InfiniteType.elmrenamed

The content is the same.

tests/bad/NonElementMain.elm → tests/test-files/bad/NonElementMain.elmrenamed

The content is the same.

tests/test-files/bad/Strings/ExtraClose.elmnew file+4

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

1+

2+s = " " "

3+

4+main = plainText s

tests/good/AliasSubstitution.elm → tests/test-files/good/AliasSubstitution.elmrenamed

The content is the same.

tests/good/NoExpressions.elm → tests/test-files/good/NoExpressions.elmrenamed

The content is the same.

tests/good/Otherwise.elm → tests/test-files/good/Otherwise.elmrenamed

The content is the same.

tests/test-files/good/Ports.elmnew file+17

@@ -0,0 +1,17 @@

1+

2+-- incoming

3+port userID : String

4+port signal : Signal Int

5+port tuple : (Float,Bool)

6+port array : [Int]

7+port record : { x:Float, y:Float }

8+

9+-- outgoing

10+port fortyTwo : Int

11+port fortyTwo = 42

12+

13+port time : Signal Float

14+port time = every second

15+

16+port students : Signal [{name:String, age:Int}]

17+port students = constant []

tests/good/QuotesAndComments.elm → tests/test-files/good/QuotesAndComments.elmrenamed

The content is the same.

tests/good/Soundness/Apply.elm → tests/test-files/good/Soundness/Apply.elmrenamed

The content is the same.

tests/good/Soundness/ApplyAnnotated.elm → tests/test-files/good/Soundness/ApplyAnnotated.elmrenamed

The content is the same.

tests/good/Soundness/Id.elm → tests/test-files/good/Soundness/Id.elmrenamed

The content is the same.

tests/good/Soundness/IdAnnotated.elm → tests/test-files/good/Soundness/IdAnnotated.elmrenamed

The content is the same.

tests/good/Soundness/TrickyId.elm → tests/test-files/good/Soundness/TrickyId.elmrenamed

The content is the same.

tests/good/Soundness/TrickyIdAnnotated.elm → tests/test-files/good/Soundness/TrickyIdAnnotated.elmrenamed

The content is the same.

tests/test-files/good/Strings/Multiline.elmnew file+6

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

1+s = """

2+here's a quote: "

3+

4+"""

5+

6+main = plainText s

tests/test-files/good/Strings/MultilineNormal.elmnew file+6

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

1+s = "

2+here's a quote: \"

3+

4+"

5+

6+main = plainText s

tests/good/Unify/LockedVars.elm → tests/test-files/good/Unify/LockedVars.elmrenamed

The content is the same.

tests/good/Unify/NonHomogeneousRecords.elm → tests/test-files/good/Unify/NonHomogeneousRecords.elmrenamed

The content is the same.