892464e · elk · git.iko.soy

.gitignore+1

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

1010data

1111*/ElmFiles/*

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

4747 SourceSyntax.PrettyPrint,

4848 SourceSyntax.Type,

4949 Generate.JavaScript,

50+ Generate.JavaScript.Helpers,

51+ Generate.JavaScript.Ports,

5052 Generate.Noscript,

5153 Generate.Markdown,

5254 Generate.Html,

5355 Generate.Cases,

5456 Transform.Canonicalize,

5557 Transform.Check,

58+ Transform.Expression,

59+ Transform.Declaration,

60+ Transform.Definition,

5661 Transform.SafeNames,

5762 Transform.SortDefinitions,

5863 Transform.Substitute,

59− Transform.Optimize,

6064 Metadata.Prelude,

61− InterfaceSerialization,

6265 Parse.Binop,

6366 Parse.Declaration,

6467 Parse.Expression,

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

8588 Build.Dependencies,

8689 Build.File,

8790 Build.Flags,

91+ Build.Interface,

8892 Build.Print,

8993 Build.Source,

9094 Build.Utils,

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

125129 SourceSyntax.PrettyPrint,

126130 SourceSyntax.Type,

127131 Generate.JavaScript,

132+ Generate.JavaScript.Helpers,

133+ Generate.JavaScript.Ports,

128134 Generate.Noscript,

129135 Generate.Markdown,

130136 Generate.Html,

131137 Generate.Cases,

132138 Transform.Canonicalize,

133139 Transform.Check,

140+ Transform.Expression,

141+ Transform.Declaration,

142+ Transform.Definition,

134143 Transform.SafeNames,

135144 Transform.SortDefinitions,

136145 Transform.Substitute,

137− Transform.Optimize,

138146 Metadata.Prelude,

139− InterfaceSerialization,

140147 Parse.Binop,

141148 Parse.Declaration,

142149 Parse.Expression,

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

163170 Build.Dependencies,

164171 Build.File,

165172 Build.Flags,

173+ Build.Interface,

166174 Build.Print,

167175 Build.Source,

168176 Build.Utils,

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

224232 pandoc >= 1.10,

225233 parsec >= 3.1.1,

226234 pretty,

227− text

235+ text,

236+ union-find

228237

229238Test-Suite test-elm

230239 Type: exitcode-stdio-1.0

231− Hs-Source-Dirs: tests

240+ Hs-Source-Dirs: tests, compiler

232241 Main-is: Main.hs

233− build-depends: base, directory, HTF

242+ other-modules: Tests.Compiler

243+ Tests.Property

244+ Tests.Property.Arbitrary

245+ SourceSyntax.Helpers

246+ SourceSyntax.Literal

247+ SourceSyntax.PrettyPrint

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

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

22

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

34

45## Install

56

compiler/Build/Dependencies.hs+47−53

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

1−module Build.Dependencies (getSortedDependencies) where

1+{-# OPTIONS_GHC -W #-}

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

23

3−import Data.Data

44import Control.Applicative

55import Control.Monad.Error

66import qualified Control.Monad.State as State

77import qualified Data.Aeson as Json

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

9−import qualified Data.Char as Char

109import qualified Data.Graph as Graph

1110import qualified Data.List as List

1211import qualified Data.Map as Map

1312import qualified Data.Maybe as Maybe

1413import qualified Data.Set as Set

1514import System.Directory

16−import System.Exit

1715import System.FilePath as FP

18−import System.IO

19−import Text.PrettyPrint (Doc)

16+

17+import Build.Print (failure)

2018

2119import qualified SourceSyntax.Module as Module

22−import qualified SourceSyntax.Type as Type

2320import 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

3021import qualified Elm.Internal.Paths as Path

3122import qualified Elm.Internal.Name as N

32−import qualified Elm.Internal.Version as V

3323import qualified Elm.Internal.Dependencies as Deps

3424

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

3626getSortedDependencies srcDirs builtIns root =

3727 do extras <- extraDependencies

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

39− result <- runErrorT $ readDeps allSrcDirs builtIns root

29+ result <- runErrorT $ readAllDeps allSrcDirs builtIns root

4030 case result of

4131 Right deps -> sortDeps deps

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

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

4434 Path.dependencyFile ++

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

4636

47−failure msg = hPutStrLn stderr msg >> exitFailure

48−

4937extraDependencies :: IO (Maybe [FilePath])

5038extraDependencies =

5139 do exists <- doesFileExist Path.dependencyFile

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

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

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

8876

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

90−readDeps srcDirs builtIns root = do

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

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

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

78+readAllDeps srcDirs builtIns root =

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

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

9381 where

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

9583 go builtIns root = do

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

97− case Parse.dependencies txt of

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

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

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

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

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

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

108−

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

110−getFile [] path =

111− throwError $ unlines

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

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

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

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

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

117−

118−getFile (dir:dirs) path = do

119− let path' = dir </> path

120− exists <- liftIO $ doesFileExist path'

121− case exists of

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

123− False -> getFile dirs path

124−

84+ root' <- lift $ findSrcFile srcDirs root

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

86+ seen <- State.get

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

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

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

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

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

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+

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

102+findSrcFile dirs path = foldr tryDir notFound dirs

103+ where

104+ notFound = throwError $ unlines

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

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

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

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

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

110+ tryDir dir next = do

111+ let path' = dir </> path

112+ exists <- liftIO $ doesFileExist path'

113+ if exists

114+ then return path'

115+ else next

116+

117+isNative :: String -> Bool

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

126119

127120toFilePath :: String -> FilePath

128121toFilePath name = map swapDots name ++ ext

129− where swapDots '.' = '/'

130− swapDots c = c

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

122+ where

123+ swapDots '.' = '/'

124+ swapDots c = c

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

compiler/Build/File.hs+131−81

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

1+{-# OPTIONS_GHC -W #-}

12module Build.File (build) where

23

3−import Control.Monad (when)

4−import qualified Data.Binary as Binary

5−import qualified Data.List as List

6−import qualified Data.Map as Map

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

5+import Control.Monad.Error (runErrorT)

6+import Control.Monad.RWS.Strict

77import System.Directory

88import System.Exit

99import System.FilePath

1010import System.IO

1111

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

1226import qualified Transform.Canonicalize as Canonical

1327

14−import qualified Data.ByteString.Lazy as L

15−

16−import qualified Build.Utils as Utils

17−import qualified Build.Flags as Flag

18−import qualified Build.Source as Source

19−import qualified Build.Print as Print

20−import qualified Generate.JavaScript as JS

21−import qualified InterfaceSerialization as IS

22−import qualified Parse.Module as Parser

23−import qualified SourceSyntax.Module as M

24−

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

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

27−build _ _ interfaces moduleName [] =

28− return (moduleName, interfaces)

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

30− do (name,interface) <-

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

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

33− build flags numModules interfaces' name rest

34−

35−

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

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

38−build1 flags moduleNum numModules interfaces filePath =

39− do compiled <- alreadyCompiled flags filePath

40− case compiled of

41− False -> compile flags number interfaces filePath

42− True -> retrieve flags interfaces filePath

43− where

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

45−

46−

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

48−alreadyCompiled flags filePath = do

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

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

51− if not existsi || not existso

52− then return False

53− else do tsrc <- getModificationTime filePath

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

55− return (tsrc <= tint)

56−

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

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

59−retrieve flags interfaces filePath = do

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

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

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

28+-- Reader: Runtime flags, always accessible

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

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

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

32+type Build a = BuildT IO a

33+

34+-- Interfaces, remembering if something was recompiled

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

36+

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

38+evalBuild flags interfaces b = do

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

40+ return . getLast $ s

41+ where

42+ notUpdated i = (False, i)

43+

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

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

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

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

48+

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

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

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

52+ build1 num fname = do

53+ shouldCompile <- shouldBeCompiled fname

54+ if shouldCompile

55+ then compile number fname

56+ else retrieve fname

57+

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

59+

60+ total = length fs

61+

62+shouldBeCompiled :: FilePath -> Build Bool

63+shouldBeCompiled filePath = do

64+ flags <- ask

65+ let alreadyCompiled = liftIO $ do

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

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

68+ return $ existsi && existso

69+

70+ outDated = liftIO $ do

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

93+ then return b1

94+ else m2

95+

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

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

98+

99+retrieve :: FilePath -> Build ()

100+retrieve filePath = do

101+ flags <- ask

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

103+ case Interface.isValid filePath iface of

63104 Right (name, interface) ->

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

65− return (name, interface)

66− Left err ->

67− do hPutStrLn stderr err

68− exitFailure

69−

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

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

72−compile flags number interfaces filePath =

73− do source <- readFile filePath

74− let name = getName source

75− printStatus name

76−

77− createDirectoryIfMissing True (Flag.cache_dir flags)

78− createDirectoryIfMissing True (Flag.build_dir flags)

79−

80− metaModule <-

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

105+ do binterfaces <- get

106+ let interfaces = snd <$> binterfaces

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

108+ update name interface False

109+

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

111+

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

113+compile number filePath =

114+ do flags <- ask

115+ binterfaces <- get

116+ source <- liftIO $ readFile filePath

117+ let interfaces = snd <$> binterfaces

118+ name = getName source

119+ liftIO $ do

120+ printStatus name

121+ createDirectoryIfMissing True (Flag.cache_dir flags)

122+ createDirectoryIfMissing True (Flag.build_dir flags)

123+

124+ metaModule <-

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

82126 Right modul -> return modul

83127 Left errors -> do Print.errors errors

84128 exitFailure

85129

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

87−

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

89− generateCache intermediate metaModule

90− return intermediate

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

131+

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

133+ generateCache name newInters metaModule

134+ update name newInters True

91135

92136 where

93137 getName source = case Parser.getModuleName source of

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

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

100144 , "( " ++ filePath ++ " )" ]

101145

102− generateCache intermediate metaModule = do

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

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

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

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

146+ generateCache name interfs metaModule = do

147+ flags <- ask

148+ liftIO $ do

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

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

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

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

11module Build.Print where

22

3+import System.IO (hPutStrLn, stderr)

4+import System.Exit (exitFailure)

5+

36import qualified Data.Map as Map

47import qualified Data.List as List

58import qualified SourceSyntax.Module as M

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

710import qualified Type.Alias as Alias

811import qualified Text.PrettyPrint as P

912

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

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

1114metaTypes interfaces meta =

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

1316

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

2932

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

3134errors 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 #-}

12module Build.Source (build) where

23

3−import Data.Data

4−import Control.Monad.State

5−import qualified Data.Graph as Graph

6−import qualified Data.List as List

74import qualified Data.Map as Map

85import qualified Data.Set as Set

9−import System.Directory

10−import System.Exit

116import System.FilePath as FP

127import Text.PrettyPrint (Doc)

138

149import SourceSyntax.Declaration

1510import SourceSyntax.Module

1611import qualified SourceSyntax.Expression as Expr

12+import qualified SourceSyntax.Pattern as Pattern

1713import qualified SourceSyntax.Type as Type

1814import qualified Parse.Parse as Parse

1915import qualified Metadata.Prelude as Prelude

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

2319import qualified Type.Constrain.Declaration as TcDecl

2420import qualified Transform.Canonicalize as Canonical

2521

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

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

2723build noPrelude interfaces source =

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

24+ do let add = Prelude.add noPrelude

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

3026 . concatMap iFixities $ Map.elems interfaces

3127

32− 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

37− [] -> return modul

38− ms -> Left ms

28+ Module names exs ims decls <- do

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

30+ case Check.mistakes decls of

31+ [] -> return modul

32+ ms -> Left ms

3933

4034 let exports'

4135 | null exs =

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

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

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

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

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

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

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

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

4640 | otherwise = exs

4741

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

49− names = names,

50− path = FP.joinPath names,

51− exports = exports',

52− imports = ims,

42+ metaModule <- Canonical.metadataModule interfaces $

43+ MetadataModule

44+ { names = names

45+ , path = FP.joinPath names

46+ , exports = exports'

47+ , imports = ims

5348 -- reorder AST into strongly connected components

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

55− types = Map.empty,

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

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

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

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

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

61− }

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

50+ , types = Map.empty

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

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

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

54+ }

6255

6356 types <- TI.infer interfaces metaModule

6457

compiler/Build/Utils.hs+1

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

1+{-# OPTIONS_GHC -W #-}

12module Build.Utils where

23

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

compiler/Compiler.hs+3−4

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

1+{-# OPTIONS_GHC -W #-}

12module Main where

23

34import Control.Monad (foldM)

4−import qualified Data.Map as Map

55import qualified Data.Maybe as Maybe

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

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

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

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

3232build flags rootFile =

3333 do let noPrelude = Flag.no_prelude flags

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

34+ builtIns <- Prelude.interfaces noPrelude

3535

3636 files <- if Flag.make flags

3737 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile

3838 else return [rootFile]

3939

40− (moduleName, interfaces) <-

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

40+ moduleName <- File.build flags builtIns files

4241

4342 js <- foldM appendToOutput BS.empty files

4443

compiler/Docs.hs+21−17

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

77import System.Exit

88import System.IO

99

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

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

1111import Data.Aeson

1212import Data.Aeson.Encode.Pretty

1313import qualified Data.List as List

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

1717

1818import SourceSyntax.Helpers (isSymbol)

1919import SourceSyntax.Type (Type(..))

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

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

20+import qualified SourceSyntax.Expression as E

21+import qualified SourceSyntax.Declaration as D

2222

2323import Text.Parsec hiding (newline,spaces)

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

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

7777 structure <- docComment

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

7979

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

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

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

8282

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

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

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

8585 where

8686 uncommentable = do

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

9393 uncommented comment

9494

9595 uncommented comment = do

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

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

9797 return (comment, def, src)

9898

9999

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

121121 where

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

123123 addDefaultInfix name pairs

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

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

125125 | otherwise = pairs

126126

127127 customOps = Map.intersectionWith addInfix infixes types

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

130130

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

132132 case decl of

133− Fixity assoc prec name ->

133+ D.Fixity assoc prec name ->

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

135− Definition (TypeAnnotation name tipe) ->

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

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

137− TypeAlias name vars tipe ->

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

137+ D.TypeAlias name vars tipe derivations ->

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

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

140− Datatype name vars ctors ->

140+ D.Datatype name vars ctors derivations ->

141141 let tipe = Data name (map Var vars)

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

142+ fields = ["typeVariables" .= vars

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

144+ , "deriving" .= derivations ]

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

144146 where

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

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

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

153155 Var x -> toJSON x

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

155− EmptyRecord -> object []

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

157158 where fields' = case ext of

158− EmptyRecord -> fields

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

159+ Nothing -> fields

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

160161

161162ctorToJson tipe (ctor, tipes) =

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

2121

2222{-# NOINLINE interfaces #-}

2323interfaces :: M.Interfaces

24−interfaces = unsafePerformIO $ Prelude.interfaces

24+interfaces = unsafePerformIO $ Prelude.interfaces False

2525

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

2727moduleName :: String -> Maybe String

compiler/Generate/Cases.hs+21−21

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

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

22

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

4−import Control.Arrow (first,second)

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

4+import Control.Arrow (first)

55import Control.Monad.State

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

6+import Data.List (groupBy,sortBy)

77import Data.Maybe (fromMaybe)

88

99import SourceSyntax.Location

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

1313import Transform.Substitute

1414

1515

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

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

1717toMatch patterns = do

1818 v <- newVar

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

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

2323 modify (+1)

2424 return $ "_v" ++ show n

2525

26−data Match t v

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

26+data Match

27+ = Match String [Clause] Match

2828 | Break

2929 | Fail

30− | Other (LExpr t v)

31− | Seq [Match t v]

30+ | Other LExpr

31+ | Seq [Match]

3232 deriving Show

3333

34−data Clause t v =

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

34+data Clause =

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

3636 deriving Show

3737

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

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

3939matchSubst _ Break = Break

4040matchSubst _ Fail = Fail

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

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

4747 clauseSubst (Clause c vs m) =

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

4949

50−isCon (p:ps, e) =

50+isCon (p:_, _) =

5151 case p of

5252 PData _ _ -> True

5353 PLiteral _ -> True

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

5555

5656isVar p = not (isCon p)

5757

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

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

5959match [] [] def = return def

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

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

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

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

7373 _ -> c

7474

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

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

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

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

7979 where

8080 subOnePattern pattern e =

8181 case pattern of

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

8484 PRecord fs ->

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

8686

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

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

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

8989 where

9090 css = groupBy eq (sortBy cmp cs)

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

106106

107107matchClause :: Either String Literal

108108 -> [String]

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

110− -> Match t v

111− -> State Int (Clause t v)

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

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

110+ -> Match

111+ -> State Int Clause

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

113113 do vs' <- getVars

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

115115 where

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

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

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

126126

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

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

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

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

compiler/Generate/JavaScript.hs+94−131

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

1+{-# OPTIONS_GHC -W #-}

12module Generate.JavaScript (generate) where

23

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

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

78import qualified Data.Map as Map

89import qualified Data.Set as Set

910

11+import Generate.JavaScript.Helpers

1012import qualified Generate.Cases as Case

13+import qualified Generate.JavaScript.Ports as Port

1114import qualified Generate.Markdown as MD

1215import qualified SourceSyntax.Helpers as Help

1316import SourceSyntax.Literal

14−import SourceSyntax.Pattern

17+import SourceSyntax.Pattern as Pattern

1518import SourceSyntax.Location

1619import SourceSyntax.Expression

1720import SourceSyntax.Module

18−import qualified Transform.SortDefinitions as SD

1921import Language.ECMAScript3.Syntax

2022import Language.ECMAScript3.PrettyPrint

2123import qualified Transform.SafeNames as MakeSafe

2224

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−

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

4526varDecl x expr =

4627 VarDecl () (var x) (Just expr)

4728

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

4830include alias moduleName =

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

5032

33+internalImports :: String -> Statement ()

5134internalImports name =

5235 VarDeclStmt ()

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

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

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

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

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

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

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

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

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

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

5841 , varDecl "$moduleName" (string name)

5942 ]

6043

6144literal :: Literal -> Expression ()

6245literal lit =

6346 case lit of

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

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

6548 Str s -> string s

6649 IntNum n -> IntLit () n

6750 FloatNum n -> NumLit () n

6851 Boolean b -> BoolLit () b

6952

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

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

7154expression (L span expr) =

7255 case expr of

7356 Var x -> return $ ref x

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

8467

8568 Remove e x ->

8669 do e' <- expression e

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

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

8871

8972 Insert e x v ->

9073 do v' <- expression v

9174 e' <- expression e

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

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

9376

9477 Modify e fs ->

9578 do e' <- expression e

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

9780 v' <- expression v

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

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

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

10083

10184 Record fields ->

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

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

148131 _ -> (func, args)

149132

150133 Let defs e ->

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

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

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

153136 exp <- expression e'

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

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

155138

156139 MultiIf branches ->

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

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

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

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

194177

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

196−definition def =

197− case def of

198− TypeAnnotation _ _ -> return []

199−

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

201− expr' <- expression expr

202− let assign x = varDecl x expr'

203− case pattern of

204− PVar x

205− | Help.isOp x ->

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

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

208− | otherwise ->

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

210−

211− PRecord fields ->

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

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

214−

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

216− case vars of

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

218− where

219− vars = getVars patterns

220− getVars patterns =

221− case patterns of

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

223− [] -> Just []

224− _ -> Nothing

225−

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

227− setup vars

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

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

230−

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

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

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

234−

235− _ ->

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

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

238− where

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

240− mkVar = L span . Var

241− toDef y = definition $

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

243−

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

178+ PortIn name tipe ->

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

180+

181+ PortOut name tipe value ->

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

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

188+ expr' <- expression expr

189+ let assign x = varDecl x expr'

190+ case pattern of

191+ PVar x

192+ | Help.isOp x ->

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

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

195+ | otherwise ->

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

197+

198+ PRecord fields ->

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

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

201+

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

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

204+ where

205+ vars = getVars patterns

206+ getVars patterns =

207+ case patterns of

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

209+ [] -> Just []

210+ _ -> Nothing

211+

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

213+ setup vars

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

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

216+

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

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

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

220+

221+ _ ->

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

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

224+ where

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

226+ mkVar = L span . Var

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

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

229+

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

245231match span mtch =

246232 case mtch of

247233 Case.Match name clauses mtch' ->

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

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

264250 Case.Other e ->

265251 do e' <- expression e

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

252+ return [ ret e' ]

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

268254 where

269255 dropEnd acc [] = acc

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

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

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

274260

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

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

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

277264 where

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

286273 [] -> name

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

288275

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)

289281

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

282+generate :: MetadataModule -> String

291283generate unsafeModule =

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

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

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

295287 modul = MakeSafe.metadataModule unsafeModule

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

297289 programStmts =

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

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

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

301− , concatMap jsImport (imports modul)

302− , concatMap importEvent (foreignImports modul)

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

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

305− , map exportEvent $ foreignExports modul

306− , [ jsExports ]

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

308− ]

290+ concat

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

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

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

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

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

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

297+ , [ jsExports ]

298+ , [ ret thisModule ]

299+ ]

309300

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

311302 where

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

318309 _ -> ExprStmt () $

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

320311

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

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

322313 where

323314 path = split modul

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

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

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

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

332323

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

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−

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

359325binop span op e1 e2 =

360326 case op of

361327 "Basics.." ->

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

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

383349 _ -> es ++ [e]

384350

385− js1 = expression e1

386− js2 = expression e2

387−

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

389352 | otherwise = dotSep parts

390353 where

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

408371 specialOps = concat

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

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

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

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

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

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

413376 , specialOp "<" $ cmp OpLT 0

414377 , specialOp ">" $ cmp OpGT 0

415378 , specialOp "<=" $ cmp OpLT 1

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

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

418381 ]

419382

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

11module Generate.Noscript (noscript) where

22

33import Data.List (isInfixOf)

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

4+import qualified SourceSyntax.Declaration as D

55import SourceSyntax.Expression

66import SourceSyntax.Literal

77import SourceSyntax.Location

88import SourceSyntax.Module

99import qualified Generate.Markdown as MD

1010

11−noscript :: Module t v -> String

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

1212noscript modul = concat (extract modul)

1313

1414class Extract a where

1515 extract :: a -> [String]

1616

17−instance Extract (Module t v) where

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

1818 extract (Module _ _ _ stmts) =

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

2020

21−instance Extract (Declaration t v) where

22− extract (Definition d) = extract d

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

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

2323 extract _ = []

2424

25−instance Extract (Def t v) where

26− extract (Def _ e) = extract e

27− extract _ = []

25+instance Extract Def where

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

2827

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

3029 extract (L _ e) = extract e

3130

32−instance Extract (Expr t v) where

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

3332 extract expr =

3433 let f = extract in

3534 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 #-}

12module Metadata.Prelude (interfaces, add) where

23

34import qualified Data.Map as Map

45import qualified Control.Exception as E

56import qualified Paths_Elm as Path

6−import System.Directory

77import System.Exit

8−import System.FilePath

98import System.IO

109import SourceSyntax.Module

11−import qualified Data.Binary as Binary

12−import qualified Data.ByteString.Lazy as BS

10+import qualified Build.Interface as Interface

1311

14−import qualified InterfaceSerialization as IS

15−

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

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

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

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

1814 where

19− customIms = concatMap addModule prelude

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

2016

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

2218 Nothing -> [(n, method)]

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

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

2420 Just _ -> []

2521

2622prelude :: [(String, ImportMethod)]

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

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

2824 where

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

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

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

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

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

3229

33−interfaces :: IO Interfaces

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

30+interfaces :: Bool -> IO Interfaces

31+interfaces noPrelude =

32+ if noPrelude

33+ then return $ Map.empty

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

3535

3636safeReadDocs :: FilePath -> IO Interfaces

3737safeReadDocs name =

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

3939 let _ = err :: IOError

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

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

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

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

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

40+ hPutStrLn stderr $ unlines $

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

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

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

44+ , " Elm and your OS." ]

4545 exitFailure

4646

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−

5447readDocs :: FilePath -> IO Interfaces

5548readDocs filePath = do

56− bytes <- IS.loadInterface filePath

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

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

49+ interfaces <- Interface.load filePath

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

51+ Left err -> do

6752 hPutStrLn stderr err

6853 exitFailure

6954

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

55+ Right [] -> do

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

57+ exitFailure

58+

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

compiler/Parse/Binop.hs+15−16

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

11module Parse.Binop (binops, OpTable) where

22

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

4−import Control.Monad.Error

54import Data.List (intercalate)

65import qualified Data.Map as Map

76

87import SourceSyntax.Location (merge)

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

8+import qualified SourceSyntax.Expression as E

109import SourceSyntax.Declaration (Assoc(..))

1110import Text.Parsec

1211import Parse.Helpers

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

1716opAssoc :: OpTable -> String -> Assoc

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

1918

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

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

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

2221

23−binops :: IParser (LExpr t v)

24− -> IParser (LExpr t v)

22+binops :: IParser E.LParseExpr

23+ -> IParser E.LParseExpr

2524 -> IParser String

26− -> IParser (LExpr t v)

25+ -> IParser E.LParseExpr

2726binops term last anyOp =

2827 do e <- term

2928 table <- getState

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

3938

4039split :: OpTable

4140 -> Int

42− -> LExpr t v

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

44− -> IParser (LExpr t v)

41+ -> E.LParseExpr

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

43+ -> IParser E.LParseExpr

4544split _ _ e [] = return e

4645split table n e eops = do

4746 assoc <- getAssoc table n eops

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

5049 case assoc of R -> joinR es ops

5150 _ -> joinL es ops

5251

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

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

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

53+ -> [IParser E.LParseExpr]

5554splitLevel table n e eops =

5655 case break (hasLevel table n) eops of

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

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

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

6059

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

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

6261joinL [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

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

6564

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

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

6766joinR [e] [] = return e

6867joinR (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))

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

7170

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

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

7372getAssoc table n eops

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

7574 | 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 #-}

22module Parse.Declaration where

33

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

5−import qualified Data.List as List

6−import qualified Data.Set as Set

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

75import Text.Parsec hiding (newline,spaces)

8−import Text.Parsec.Indent

96

107import Parse.Helpers

118import qualified Parse.Expression as Expr

12−import qualified SourceSyntax.Type as T

139import qualified Parse.Type as Type

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

10+import qualified SourceSyntax.Declaration as D

1511

1612

17−declaration :: IParser (Declaration t v)

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

13+declaration :: IParser D.ParseDeclaration

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

1915

20−definition :: IParser (Declaration t v)

21−definition = Definition <$> Expr.def

16+definition :: IParser D.ParseDeclaration

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

2218

23−alias :: IParser (Declaration t v)

19+alias :: IParser D.ParseDeclaration

2420alias = do

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

2622 forcedWS

27− alias <- capVar

28− args <- spacePrefix lowVar

23+ name <- capVar

24+ args <- spacePrefix lowVar

2925 padded equals

3026 tipe <- Type.expr

31− return (TypeAlias alias args tipe)

27+ json <- option [] $ do

28+ try $ padded (reserved "deriving")

29+ string "Json"

30+ return [D.Json]

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

3232

33−datatype :: IParser (Declaration t v)

33+datatype :: IParser D.ParseDeclaration

3434datatype = do

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

3636 forcedWS

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

3838 args <- spacePrefix lowVar

3939 padded equals

4040 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

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

4242

4343

44−infixDecl :: IParser (Declaration t v)

44+infixDecl :: IParser D.ParseDeclaration

4545infixDecl = do

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

47− , reserved "infix" >> return N

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

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

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

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

4949 forcedWS

5050 n <- digit

5151 forcedWS

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

53−

54−

55−foreignDef :: IParser (Declaration t v)

56−foreignDef = do

57− try (reserved "foreign")

58− whitespace

59− importEvent <|> exportEvent

60−

61−exportEvent :: IParser (Declaration t v)

62−exportEvent = do

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

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

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

53+

54+

55+port :: IParser D.ParseDeclaration

56+port =

57+ do try (reserved "port")

58+ whitespace

59+ name <- lowVar

60+ whitespace

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

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

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

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

22

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

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

54import Data.List (foldl')

65import Text.Parsec hiding (newline,spaces)

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

1615import SourceSyntax.Pattern hiding (tuple,list)

1716import qualified SourceSyntax.Literal as Literal

1817import SourceSyntax.Expression

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

2018

2119

2220-------- Basic Terms --------

2321

24−varTerm :: IParser (Expr t v)

22+varTerm :: IParser ParseExpr

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

2624

27−toVar :: String -> Expr t v

25+toVar :: String -> ParseExpr

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

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

3028 _ -> Var v

3129

32−accessor :: IParser (Expr t v)

30+accessor :: IParser ParseExpr

3331accessor = do

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

3533 let loc e = Location.at start end e

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

3735

38−negative :: IParser (Expr t v)

36+negative :: IParser ParseExpr

3937negative = do

4038 (start, nTerm, end) <-

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

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

4543

4644-------- Complex Terms --------

4745

48−listTerm :: IParser (Expr t v)

46+listTerm :: IParser ParseExpr

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

5048 where

5149 range = do

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

6866 string "}}"

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

7068

71−parensTerm :: IParser (LExpr t v)

69+parensTerm :: IParser LParseExpr

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

7371 where

7472 opFn = do

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

9189 [e] -> e

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

9391

94−recordTerm :: IParser (LExpr t v)

92+recordTerm :: IParser LParseExpr

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

9694 where field = do

9795 label <- rLabel

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

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

125123

126124

127−term :: IParser (LExpr t v)

125+term :: IParser LParseExpr

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

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

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

131129

132130-------- Applications --------

133131

134−appExpr :: IParser (LExpr t v)

132+appExpr :: IParser LParseExpr

135133appExpr = do

136134 t <- term

137135 ts <- constrainedSpacePrefix term $ \str ->

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

142140

143141-------- Normal Expressions --------

144142

145−binaryExpr :: IParser (LExpr t v)

143+binaryExpr :: IParser LParseExpr

146144binaryExpr = binops appExpr lastExpr anyOp

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

148146 <|> lambdaExpr

149147

150−ifExpr :: IParser (Expr t v)

148+ifExpr :: IParser ParseExpr

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

152150 where

153151 normal = do

@@ -163,7 +161,7 @@ ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)

163161 b <- expr ; padded arrow

164162 (,) b <$> expr

165163

166−lambdaExpr :: IParser (LExpr t v)

164+lambdaExpr :: IParser LParseExpr

167165lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

168166 whitespace

169167 args <- spaceSep1 Pattern.term

@@ -171,17 +169,17 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

171169 body <- expr

172170 return (makeFunction args body)

173171

174−defSet :: IParser [Def t v]

172+defSet :: IParser [ParseDef]

175173defSet = block (do d <- def ; whitespace ; return d)

176174

177−letExpr :: IParser (Expr t v)

175+letExpr :: IParser ParseExpr

178176letExpr = do

179177 reserved "let" ; whitespace

180178 defs <- defSet

181179 padded (reserved "in")

182180 Let defs <$> expr

183181

184−caseExpr :: IParser (Expr t v)

182+caseExpr :: IParser ParseExpr

185183caseExpr = do

186184 reserved "case"; e <- padded expr; reserved "of"; whitespace

187185 Case e <$> (with <|> without)

@@ -191,6 +189,7 @@ caseExpr = do

191189 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

192190 without = block (do c <- case_ ; whitespace ; return c)

193191

192+expr :: IParser LParseExpr

194193expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

195194 <|> lambdaExpr

196195 <|> binaryExpr

@@ -206,7 +205,7 @@ defStart =

206205 where

207206 func pattern =

208207 case pattern of

209− PVar v -> (pattern:) <$> spacePrefix Pattern.term

208+ PVar _ -> (pattern:) <$> spacePrefix Pattern.term

210209 _ -> do try (lookAhead (whitespace >> string "="))

211210 return [pattern]

212211

@@ -216,18 +215,18 @@ defStart =

216215 return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]

217216 else [ PVar (o:p), p1, p2 ]

218217

219−makeFunction :: [Pattern] -> LExpr t v -> LExpr t v

218+makeFunction :: [Pattern] -> LParseExpr -> LParseExpr

220219makeFunction args body@(L s _) =

221220 foldr (\arg body' -> L s $ Lambda arg body') body args

222221

223−definition :: IParser (Def t v)

222+definition :: IParser ParseDef

224223definition = withPos $ do

225224 (name:args) <- defStart

226225 padded equals

227226 body <- expr

228227 return . Def name $ makeFunction args body

229228

230−typeAnnotation :: IParser (Def t v)

229+typeAnnotation :: IParser ParseDef

231230typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

232231 where

233232 start = do

@@ -235,5 +234,5 @@ typeAnnotation = TypeAnnotation <$> try start <*> Type.expr

235234 padded hasType

236235 return v

237236

238−def :: IParser (Def t v)

237+def :: IParser ParseDef

239238def = typeAnnotation <|> definition

compiler/Parse/Helpers.hs+77−41

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

1+{-# OPTIONS_GHC -W #-}

12module Parse.Helpers where

23

34import Prelude hiding (until)

@@ -7,13 +8,15 @@ import Control.Monad.State

78import Data.Char (isUpper)

89import qualified Data.Set as Set

910import 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+

1015import SourceSyntax.Helpers as Help

1116import SourceSyntax.Location as Location

1217import SourceSyntax.Expression

1318import SourceSyntax.PrettyPrint

1419import SourceSyntax.Declaration (Assoc)

15−import Text.Parsec hiding (newline,spaces,State)

16−import Text.Parsec.Indent

1720

1821reserveds = [ "if", "then", "else"

1922 , "case", "of"

@@ -22,7 +25,7 @@ reserveds = [ "if", "then", "else"

2225 , "module", "where"

2326 , "import", "as", "hiding", "open"

2427 , "export", "foreign"

25− , "deriving" ]

28+ , "deriving", "port" ]

2629

2730jsReserveds :: Set.Set String

2831jsReserveds = Set.fromList

@@ -45,7 +48,8 @@ jsReserveds = Set.fromList

4548expecting = flip (<?>)

4649

4750type OpTable = Map.Map String (Int, Assoc)

48−type IParser a = ParsecT String OpTable (State SourcePos) a

51+type SourceM = State SourcePos

52+type IParser a = ParsecT String OpTable SourceM a

4953

5054iParse :: IParser a -> String -> Either ParseError a

5155iParse = iParseWithTable "" Map.empty

@@ -54,23 +58,6 @@ iParseWithTable :: SourceName -> OpTable -> IParser a -> String -> Either ParseE

5458iParseWithTable sourceName table aParser input =

5559 runIndent sourceName $ runParserT aParser table sourceName input

5660

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−

7461var :: IParser String

7562var = makeVar (letter <|> char '_' <?> "variable")

7663

@@ -206,7 +193,7 @@ located p = do

206193 end <- getPosition

207194 return (start, e, end)

208195

209−accessible :: IParser (LExpr t v) -> IParser (LExpr t v)

196+accessible :: IParser LParseExpr -> IParser LParseExpr

210197accessible expr = do

211198 start <- getPosition

212199 ce@(L _ e) <- expr

@@ -325,24 +312,73 @@ markdown interpolation = try (string "[markdown|") >> closeMarkdown "" []

325312 closeMarkdown (md ++ [c]) stuff

326313 ]

327314

328−str :: IParser String

329−str = choice [ quote >> dewindows <$> manyTill (backslashed <|> anyChar) quote

330− , liftM dewindows . expecting "string" . betwixt '"' '"' . many $

331− backslashed <|> satisfy (/='"')

332− ]

333− where

334− quote = try (string "\"\"\"")

335−

336− -- Remove \r from strings to fix generated JavaScript

337− dewindows [] = []

338− dewindows cs =

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

340− in pre ++ case suf of

341− ('\r':'\n':rest) -> '\n' : dewindows rest

342− ('\n':rest) -> '\n' : dewindows rest

343− ('\r':rest) -> '\n' : dewindows rest

344− _ -> []

315+--str :: IParser String

316+str = expecting "String" $ do

317+ s <- choice [ multiStr, singleStr ]

318+ processAs T.stringLiteral . sandwich '\"' $ concat s

319+ where

320+ rawString quote insides =

321+ quote >> manyTill insides quote

322+

323+ multiStr = rawString (try (string "\"\"\"")) multilineStringChar

324+ singleStr = rawString (char '"') stringChar

325+

326+ stringChar :: IParser String

327+ stringChar = choice [ newlineChar, escaped '\"', (:[]) <$> satisfy (/= '\"') ]

328+

329+ multilineStringChar :: IParser String

330+ multilineStringChar =

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]

345350

346351chr :: IParser Char

347−chr = betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))

348− <?> "character"

352+chr = betwixt '\'' '\'' character <?> "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 #-}

12module Parse.Literal (literal) where

23

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

4−import Control.Monad

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

55import Text.Parsec hiding (newline,spaces)

6−import Text.Parsec.Indent

7−

86import Parse.Helpers

97import SourceSyntax.Literal

108

9+literal :: IParser Literal

1110literal = num <|> (Str <$> str) <|> (Chr <$> chr)

1211

1312num :: IParser Literal

compiler/Parse/Module.hs+1−2

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

1−

21module Parse.Module (moduleDef, getModuleName, imports) where

32

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

@@ -6,7 +5,7 @@ import Data.List (intercalate)

65import Text.Parsec hiding (newline,spaces)

76

87import Parse.Helpers

9−import SourceSyntax.Module (Module(..), ImportMethod(..), Imports)

8+import SourceSyntax.Module (ImportMethod(..), Imports)

109

1110varList :: IParser [String]

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

compiler/Parse/Parse.hs+23−20

@@ -1,22 +1,19 @@

1+{-# OPTIONS_GHC -W #-}

12module Parse.Parse (program, dependencies) where

23

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

4−import Control.Monad

5−import Data.Char (isSymbol, isDigit)

6−import Data.List (foldl',intercalate)

5+import qualified Data.List as List

76import qualified Data.Map as Map

87import Text.Parsec hiding (newline,spaces)

98import qualified Text.PrettyPrint as P

109

11−import qualified SourceSyntax.Module as S

12−import SourceSyntax.Declaration (Declaration(Fixity))

10+import qualified SourceSyntax.Declaration as D

11+import qualified SourceSyntax.Module as M

1312import Parse.Helpers

14−import Parse.Binop (OpTable)

15−import Parse.Expression

1613import Parse.Declaration (infixDecl)

17−import Parse.Type

1814import Parse.Module

1915import qualified Parse.Declaration as Decl

16+import Transform.Declaration (combineAnnotations)

2017

2118freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

2219 freshLine

@@ -25,19 +22,25 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

2522decls = do d <- Decl.declaration <?> "at least one datatype or variable definition"

2623 (d:) <$> many freshDef

2724

28−program :: OpTable -> String -> Either [P.Doc] (S.Module t v)

29−program table = setupParserWithTable table $ do

30− optional freshLine

31− (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

32− is <- (do try (lookAhead $ reserved "import")

33− imports `followedBy` freshLine) <|> return []

34− declarations <- decls

35− optional freshLine ; optional spaces ; eof

36− return $ S.Module names exports is declarations

25+program :: OpTable -> String -> Either [P.Doc] (M.Module D.Declaration)

26+program table src =

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 =

33+ do optional freshLine

34+ (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

35+ is <- (do try (lookAhead $ reserved "import")

36+ imports `followedBy` freshLine) <|> return []

37+ declarations <- decls

38+ optional freshLine ; optional spaces ; eof

39+ return $ M.Module names exports is declarations

3740

3841dependencies :: String -> Either [P.Doc] (String, [String])

3942dependencies =

40− let getName = intercalate "." . fst in

43+ let getName = List.intercalate "." . fst in

4144 setupParser $ do

4245 optional freshLine

4346 (,) <$> option "Main" (getName <$> moduleDef `followedBy` freshLine)

@@ -56,12 +59,12 @@ setupParserWithTable table p source =

5659 msg overlap =

5760 P.vcat [ P.text "Parse error:"

5861 , P.text $ "Overlapping definitions for infix operators: " ++

59− intercalate " " (Map.keys overlap)

62+ List.intercalate " " (Map.keys overlap)

6063 ]

6164

6265parseFixities = do

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

6568

6669setupParser :: IParser a -> String -> Either [P.Doc] a

6770setupParser p source =

compiler/Parse/Pattern.hs+6−8

@@ -1,13 +1,10 @@

1−

1+{-# OPTIONS_GHC -W #-}

22module Parse.Pattern (term, expr) where

33

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

5−import Control.Monad

6−import Control.Monad.State

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

75import Data.Char (isUpper)

86import Data.List (intercalate)

97import Text.Parsec hiding (newline,spaces,State)

10−import Text.Parsec.Indent

118

129import Parse.Helpers

1310import Parse.Literal

@@ -20,9 +17,10 @@ basic = choice

2017 [ char '_' >> return PAnything

2118 , do v <- var

2219 return $ case v of

23− "True" -> PLiteral (Boolean True)

24− "False" -> PLiteral (Boolean False)

25− c : _ -> if isUpper c then PData v [] else PVar v

20+ "True" -> PLiteral (Boolean True)

21+ "False" -> PLiteral (Boolean False)

22+ c:_ | isUpper c -> PData v []

23+ _ -> PVar v

2624 , PLiteral <$> literal

2725 ]

2826

compiler/Parse/Type.hs+10−11

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

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

12module Parse.Type where

23

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

4−import Control.Monad (liftM,mapM)

5−import Data.Char (isLower)

6−import Data.List (lookup,intercalate)

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

5+import Data.List (intercalate)

76import Text.Parsec

8−import Text.Parsec.Indent

97

108import SourceSyntax.Type as T

119import Parse.Helpers

@@ -25,23 +23,24 @@ tuple = do ts <- parens (commaSep expr)

2523record :: IParser T.Type

2624record =

2725 do char '{' ; whitespace

28− (ext,fs) <- extended <|> normal

26+ rcrd <- extended <|> normal

2927 dumbWhitespace ; char '}'

30− return (T.Record fs ext)

28+ return rcrd

3129 where

32− normal = (,) T.EmptyRecord <$> commaSep fields

30+ normal = flip T.Record Nothing <$> commaSep field

3331

3432 -- extended record types require at least one field

3533 extended = do

36− ext <- try (const <$> tvar <*> (whitespace >> string "|"))

34+ ext <- try (lowVar <* (whitespace >> string "|"))

3735 whitespace

38− (,) ext <$> commaSep1 fields

36+ flip T.Record (Just ext) <$> commaSep1 field

3937

40− fields = do

38+ field = do

4139 lbl <- rLabel

4240 whitespace >> hasType >> whitespace

4341 (,) lbl <$> expr

4442

43+capTypeVar :: IParser String

4544capTypeVar = intercalate "." <$> dotSep1 capVar

4645

4746constructor0 :: IParser T.Type

compiler/SourceSyntax/Declaration.hs+95−20

@@ -1,21 +1,55 @@

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Declaration where

23

4+import Data.Binary

35import qualified SourceSyntax.Expression as Expr

4−import SourceSyntax.Type

6+import qualified SourceSyntax.Type as T

57import SourceSyntax.PrettyPrint

68import Text.PrettyPrint as P

79

8−data Declaration tipe var

9− = Definition (Expr.Def tipe var)

10− | Datatype String [String] [(String,[Type])]

11− | TypeAlias String [String] Type

12− | ImportEvent String (Expr.LExpr tipe var) String Type

13− | ExportEvent String String Type

10+data Declaration' port def

11+ = Definition def

12+ | Datatype String [String] [(String,[T.Type])] [Derivation]

13+ | TypeAlias String [String] T.Type [Derivation]

14+ | Port port

1415 | Fixity Assoc Int String

15− deriving (Eq, Show)

16+ deriving (Show)

1617

1718data 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

1953

2054instance Show Assoc where

2155 show assoc =

@@ -24,24 +58,65 @@ instance Show Assoc where

2458 N -> "non"

2559 R -> "right"

2660

27−instance Pretty (Declaration t v) where

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+

71+instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

2872 pretty decl =

2973 case decl of

3074 Definition def -> pretty def

3175

32− Datatype tipe tvars ctors ->

76+ Datatype tipe tvars ctors deriveables ->

3377 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

3579 where

3680 join c ctor = P.text c <+> prettyCtor ctor

3781 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+

39112

40− TypeAlias name tvars tipe ->

41− let alias = P.text name <+> P.hsep (map P.text tvars) in

42− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)

113+prettyPort :: (Pretty a) => String -> String -> a -> Doc

114+prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e

43115

44− -- TODO: Actually write out the contained data in these cases.

45− ImportEvent _ _ _ _ -> P.text (show decl)

46− ExportEvent _ _ _ -> P.text (show decl)

47− Fixity _ _ _ -> P.text (show decl)

116+prettyDeriving :: [Derivation] -> Doc

117+prettyDeriving deriveables =

118+ case deriveables of

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 #-}

12module 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+

210

3−import Data.List (intercalate)

411import SourceSyntax.PrettyPrint

512import Text.PrettyPrint as P

613import qualified SourceSyntax.Helpers as Help

714import qualified SourceSyntax.Location as Location

815import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

16+import qualified SourceSyntax.Type as SrcType

1017import qualified SourceSyntax.Literal as Literal

1118

12−type LExpr tipe var = Location.Located (Expr tipe var)

13−data Expr t v

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+-}

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+-}

36+data Expr' def

1437 = Literal Literal.Literal

1538 | Var String

16− | Range (LExpr t v) (LExpr t v)

17− | ExplicitList [LExpr t v]

18− | Binop String (LExpr t v) (LExpr t v)

19− | Lambda Pattern.Pattern (LExpr t v)

20− | App (LExpr t v) (LExpr t v)

21− | MultiIf [(LExpr t v,LExpr t v)]

22− | Let [Def t v] (LExpr t v)

23− | Case (LExpr t v) [(Pattern.Pattern, LExpr t v)]

24− | Data String [LExpr t v]

25− | Access (LExpr t v) String

26− | Remove (LExpr t v) String

27− | Insert (LExpr t v) String (LExpr t v)

28− | Modify (LExpr t v) [(String, LExpr t v)]

29− | Record [(String, LExpr t v)]

30− | Markdown String String [LExpr t v]

31− deriving (Eq)

32−

33−data Def tipe var

34− = Def Pattern.Pattern (LExpr tipe var)

35− | TypeAnnotation String Type.Type

36− deriving (Eq, Show)

37−

39+ | Range (LExpr' def) (LExpr' def)

40+ | ExplicitList [LExpr' def]

41+ | Binop String (LExpr' def) (LExpr' def)

42+ | Lambda Pattern.Pattern (LExpr' def)

43+ | App (LExpr' def) (LExpr' def)

44+ | MultiIf [(LExpr' def,LExpr' def)]

45+ | Let [def] (LExpr' def)

46+ | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]

47+ | Data String [LExpr' def]

48+ | Access (LExpr' def) String

49+ | Remove (LExpr' def) String

50+ | Insert (LExpr' def) String (LExpr' def)

51+ | Modify (LExpr' def) [(String, LExpr' def)]

52+ | Record [(String, LExpr' def)]

53+ | Markdown String String [LExpr' def]

54+ -- for type checking and code gen only

55+ | PortIn String SrcType.Type

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

69+ = Def Pattern.Pattern LParseExpr

70+ | TypeAnnotation String SrcType.Type

71+ deriving (Show)

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

3887tuple es = Data ("_Tuple" ++ show (length es)) es

3988

89+delist :: LExpr' def -> [LExpr' def]

4090delist (Location.L _ (Data "::" [h,t])) = h : delist t

4191delist _ = []

4292

93+saveEnvName :: String

4394saveEnvName = "_save_the_environment!!!"

4495

96+dummyLet :: Pretty def => [def] -> LExpr' def

4597dummyLet defs =

4698 Location.none $ Let defs (Location.none $ Var saveEnvName)

4799

48−instance Show (Expr t v) where

100+instance Pretty def => Show (Expr' def) where

49101 show = render . pretty

50102

51−instance Pretty (Expr t v) where

103+instance Pretty def => Pretty (Expr' def) where

52104 pretty expr =

53105 case expr of

54106 Literal lit -> pretty lit

@@ -59,8 +111,10 @@ instance Pretty (Expr t v) where

59111 P.text "-" <> prettyParens e

60112 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]

61113 where op' = if Help.isOp op then op else "`" ++ op ++ "`"

62− Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)

63− in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body

114+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body

115+ where

116+ (ps,body) = collectLambdas (Location.none $ Lambda p e)

117+ args = P.sep (map Pattern.prettyParens ps)

64118 App _ _ -> P.hang func 2 (P.sep args)

65119 where func:args = map prettyParens (collectApps (Location.none expr))

66120 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)

@@ -73,51 +127,68 @@ instance Pretty (Expr t v) where

73127 P.hang pexpr 2 (P.vcat (map pretty' pats))

74128 where

75129 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

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

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

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

133+ Data name es

134+ | Help.isTuple name -> P.parens (commaCat (map pretty es))

135+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

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

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

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

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

86142

87143 Modify e fs ->

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

89145 4

90146 (commaSep $ map field fs)

91147 where

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

148+ field (k,v) = variable k <+> P.text "<-" <+> pretty v

93149

94150 Record fs ->

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

96152 where

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

153+ field (x,e) = variable x <+> P.equals <+> pretty e

98154

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

100156

101−instance Pretty (Def t v) where

157+ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"

158+

159+ PortOut _ _ signal -> pretty signal

160+

161+instance Pretty ParseDef where

102162 pretty def =

103163 case def of

104164 TypeAnnotation name tipe ->

105− variable name <+> P.text ":" <+> pretty tipe

165+ variable name <+> P.colon <+> pretty tipe

106166 Def pattern expr ->

107− pretty pattern <+> P.text "=" <+> pretty expr

108−

167+ pretty pattern <+> P.equals <+> pretty expr

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]

109179collectApps lexpr@(Location.L _ expr) =

110180 case expr of

111181 App a b -> collectApps a ++ [b]

112182 _ -> [lexpr]

113183

184+collectLambdas :: LExpr' def -> ([Pattern.Pattern], LExpr' def)

114185collectLambdas lexpr@(Location.L _ expr) =

115186 case expr of

116− Lambda pattern body ->

117− let (ps, body') = collectLambdas body

118− in (pretty pattern : ps, body')

187+ Lambda pattern body -> (pattern : ps, body')

188+ where (ps, body') = collectLambdas body

119189 _ -> ([], lexpr)

120190

191+prettyParens :: (Pretty def) => LExpr' def -> Doc

121192prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

122193 where

123194 needed =

@@ -128,5 +199,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

128199 MultiIf _ -> True

129200 Let _ _ -> True

130201 Case _ _ -> True

131− Data name (x:xs) -> name /= "::"

202+ Data name (_:_) -> name /= "::"

132203 _ -> False

compiler/SourceSyntax/Helpers.hs+1−1

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

1−

1+{-# OPTIONS_GHC -Wall #-}

22module SourceSyntax.Helpers where

33

44import qualified Data.Char as Char

compiler/SourceSyntax/Literal.hs+5−4

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

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Literal where

23

34import SourceSyntax.PrettyPrint

@@ -8,13 +9,13 @@ data Literal = IntNum Int

89 | Chr Char

910 | Str String

1011 | Boolean Bool

11− deriving (Eq, Ord, Show)

12+ deriving (Eq, Ord, Show)

1213

1314instance Pretty Literal where

1415 pretty literal =

1516 case literal of

1617 IntNum n -> PP.int n

1718 FloatNum n -> PP.double n

18− Chr c -> PP.quotes (PP.char c)

19− Str s -> PP.text (show s)

20− Boolean bool -> PP.text (show bool)

19+ Chr c -> PP.text . show $ c

20+ Str s -> PP.text . show $ s

21+ Boolean bool -> PP.text (show bool)

compiler/SourceSyntax/Module.hs+28−43

@@ -1,21 +1,18 @@

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Module where

23

34import Data.Binary

4−import Data.List (intercalate)

55import qualified Data.Map as Map

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

7−import Control.Arrow (second)

87

98import SourceSyntax.Expression (LExpr)

109import SourceSyntax.Declaration

1110import SourceSyntax.Type

12−import System.FilePath (joinPath)

13−import Control.Monad (liftM)

1411

1512import qualified Elm.Internal.Version as Version

1613

17−data Module tipe var =

18− Module [String] Exports Imports [Declaration tipe var]

14+data Module def =

15+ Module [String] Exports Imports [def]

1916 deriving (Show)

2017

2118type Exports = [String]

@@ -25,48 +22,47 @@ data ImportMethod = As String | Importing [String] | Hiding [String]

2522 deriving (Eq, Ord, Show)

2623

2724instance Binary ImportMethod where

28− put (As s) = do put (0 :: Word8)

29− put s

30−

31− put (Importing ss) = do put (1 :: Word8)

32− put ss

33−

34− put (Hiding ss) = do put (2 :: Word8)

35− put ss

25+ put method =

26+ let put' n info = putWord8 n >> put info in

27+ case method of

28+ As s -> put' 0 s

29+ Importing ss -> put' 1 ss

30+ Hiding ss -> put' 2 ss

3631

3732 get = do tag <- getWord8

3833 case tag of

39− 0 -> liftM As get

40− 1 -> liftM Importing get

41− 2 -> liftM Hiding get

34+ 0 -> As <$> get

35+ 1 -> Importing <$> get

36+ 2 -> Hiding <$> get

4237 _ -> error "Error reading valid ImportMethod type from serialized string"

4338

44−data MetadataModule t v = MetadataModule {

45− names :: [String],

46− path :: FilePath,

47− exports :: [String],

48− imports :: [(String, ImportMethod)],

49− program :: LExpr t v,

50− types :: Map.Map String Type,

51− fixities :: [(Assoc, Int, String)],

52− aliases :: [(String, [String], Type)],

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

54− foreignImports :: [(String, LExpr t v, String, Type)],

55− foreignExports :: [(String, String, Type)]

56−} deriving Show

39+data MetadataModule =

40+ MetadataModule

41+ { names :: [String]

42+ , path :: FilePath

43+ , exports :: [String]

44+ , imports :: [(String, ImportMethod)]

45+ , program :: LExpr

46+ , types :: Map.Map String Type

47+ , fixities :: [(Assoc, Int, String)]

48+ , aliases :: [Alias]

49+ , datatypes :: [ADT]

50+ } deriving Show

5751

5852type 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])

6055

6156data ModuleInterface = ModuleInterface {

6257 iVersion :: Version.Version,

6358 iTypes :: Map.Map String Type,

6459 iImports :: [(String, ImportMethod)],

6560 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

61+ iAliases :: [Alias],

6762 iFixities :: [(Assoc, Int, String)]

6863} deriving Show

6964

65+metaToInterface :: MetadataModule -> ModuleInterface

7066metaToInterface metaModule =

7167 ModuleInterface

7268 { iVersion = Version.elmVersion

@@ -86,14 +82,3 @@ instance Binary ModuleInterface where

8682 put (iAdts modul)

8783 put (iAliases modul)

8884 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 #-}

12module SourceSyntax.Pattern where

23

3−import Data.List (intercalate)

4−import SourceSyntax.Helpers as Help

4+import qualified SourceSyntax.Helpers as Help

55import SourceSyntax.PrettyPrint

66import Text.PrettyPrint as PP

7+import qualified Data.Set as Set

78import SourceSyntax.Literal as Literal

89

910data Pattern = PData String [Pattern]

@@ -14,11 +15,28 @@ data Pattern = PData String [Pattern]

1415 | PLiteral Literal.Literal

1516 deriving (Eq, Ord, Show)

1617

18+cons :: Pattern -> Pattern -> Pattern

1719cons h t = PData "::" [h,t]

18−nil = PData "[]" []

20+

21+nil :: Pattern

22+nil = PData "[]" []

23+

24+list :: [Pattern] -> Pattern

1925list = foldr cons nil

26+

27+tuple :: [Pattern] -> Pattern

2028tuple es = PData ("_Tuple" ++ show (length es)) es

2129

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+

2240

2341instance Pretty Pattern where

2442 pretty pattern =

@@ -33,14 +51,15 @@ instance Pretty Pattern where

3351 PData "::" _ -> True

3452 _ -> False

3553 PData name ps ->

36− if isTuple name then

54+ if Help.isTuple name then

3755 PP.parens . commaCat $ map pretty ps

38− else sep (PP.text name : map prettyParens ps)

56+ else hsep (PP.text name : map prettyParens ps)

3957

58+prettyParens :: Pattern -> Doc

4059prettyParens pattern = parensIf needsThem (pretty pattern)

4160 where

4261 needsThem =

4362 case pattern of

44− PData name (_:_) | not (isTuple name) -> True

63+ PData name (_:_) | not (Help.isTuple name) -> True

4564 PAlias _ _ -> True

46− _ -> False

65+ _ -> False

compiler/SourceSyntax/Type.hs+23−26

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

1+{-# OPTIONS_GHC -W #-}

12module SourceSyntax.Type where

23

34import Data.Binary

@@ -10,16 +11,15 @@ import Text.PrettyPrint as P

1011data Type = Lambda Type Type

1112 | Var String

1213 | Data String [Type]

13− | EmptyRecord

14− | Record [(String,Type)] Type

15− deriving (Eq, Show)

14+ | Record [(String,Type)] (Maybe String)

15+ deriving (Eq)

1616

1717fieldMap :: [(String,a)] -> Map.Map String [a]

1818fieldMap fields =

1919 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

2020

2121recordOf :: [(String,Type)] -> Type

22−recordOf fields = Record fields EmptyRecord

22+recordOf fields = Record fields Nothing

2323

2424listOf :: Type -> Type

2525listOf t = Data "_List" [t]

@@ -27,39 +27,39 @@ listOf t = Data "_List" [t]

2727tupleOf :: [Type] -> Type

2828tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

2929

30+instance Show Type where

31+ show = render . pretty

3032

3133instance Pretty Type where

3234 pretty tipe =

3335 case tipe of

34− Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

35− where t:ts = collectLambdas tipe

36+ Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]

37+ where

38+ t:ts = map prettyLambda (collectLambdas tipe)

39+ prettyLambda t = case t of

40+ Lambda _ _ -> P.parens (pretty t)

41+ _ -> pretty t

42+

3643 Var x -> P.text x

3744 Data "_List" [t] -> P.brackets (pretty t)

3845 Data name tipes

3946 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

4047 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

41− EmptyRecord -> P.braces P.empty

42− Record _ _ -> P.braces $ case ext of

43− EmptyRecord -> prettyFields

44− _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields

48+ Record fields ext ->

49+ P.braces $ case ext of

50+ Nothing -> prettyFields

51+ Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields

4552 where

46− (fields, ext) = collectRecords tipe

4753 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

4854 prettyFields = commaSep . map prettyField $ fields

4955

56+collectLambdas :: Type -> [Type]

5057collectLambdas tipe =

5158 case tipe of

52− Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body

53− Lambda arg body -> pretty arg : collectLambdas body

54− _ -> [pretty 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)

59+ Lambda arg body -> arg : collectLambdas body

60+ _ -> [tipe]

6261

62+prettyParens :: Type -> Doc

6363prettyParens tipe = parensIf needed (pretty tipe)

6464 where

6565 needed =

@@ -79,10 +79,8 @@ instance Binary Type where

7979 putWord8 1 >> put x

8080 Data ctor tipes ->

8181 putWord8 2 >> put ctor >> put tipes

82− EmptyRecord ->

83− putWord8 3

8482 Record fs ext ->

85− putWord8 4 >> put fs >> put ext

83+ putWord8 3 >> put fs >> put ext

8684

8785 get = do

8886 n <- getWord8

@@ -90,6 +88,5 @@ instance Binary Type where

9088 0 -> Lambda <$> get <*> get

9189 1 -> Var <$> get

9290 2 -> Data <$> get <*> get

93− 3 -> return EmptyRecord

94− 4 -> Record <$> get <*> get

91+ 3 -> Record <$> get <*> get

9592 _ -> 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 #-}

12module Transform.Canonicalize (interface, metadataModule) where

23

34import Control.Arrow ((***))

5+import Control.Applicative (Applicative,(<$>),(<*>))

46import Control.Monad.Identity

7+import qualified Data.Traversable as T

58import qualified Data.Map as Map

69import qualified Data.Set as Set

710import qualified Data.List as List

@@ -9,10 +12,8 @@ import qualified Data.Either as Either

912import SourceSyntax.Module

1013import SourceSyntax.Expression

1114import SourceSyntax.Location as Loc

12−import SourceSyntax.Pattern

13−import SourceSyntax.Helpers (isOp)

15+import qualified SourceSyntax.Pattern as P

1416import qualified SourceSyntax.Type as Type

15−import qualified Transform.SortDefinitions as SD

1617import Text.PrettyPrint as P

1718

1819interface :: String -> ModuleInterface -> ModuleInterface

@@ -26,11 +27,11 @@ interface moduleName iface =

2627 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

2728 }

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

3031 prefix name = moduleName ++ "." ++ name

3132

3233 pair name = (name, moduleName ++ "." ++ name)

33− canon (name,_,_) = pair name

34+ canon (name,_,_,_) = pair name

3435 canons = Map.fromList $ concat

3536 [ map canon (iAdts iface), map canon (iAliases iface) ]

3637

@@ -39,48 +40,40 @@ interface moduleName iface =

3940 renameType' =

4041 runIdentity . renameType (\name -> return $ Map.findWithDefault name name canons)

4142

42−renameType :: (Monad m) => (String -> m String) -> Type.Type -> m Type.Type

43−renameType rename tipe =

44− let rnm = renameType rename in

43+renameType :: (Applicative m, Monad m) => (String -> m String) -> Type.Type -> m Type.Type

44+renameType renamer tipe =

45+ let rnm = renameType renamer in

4546 case tipe of

46− Type.Lambda a b -> Type.Lambda `liftM` rnm a `ap` rnm b

47− Type.Var x -> return tipe

48− Type.Data name ts -> Type.Data `liftM` rename name `ap` mapM rnm ts

49− Type.EmptyRecord -> return tipe

50− Type.Record fields ext -> Type.Record `liftM` mapM rnm' fields `ap` rnm ext

51− where rnm' (f,t) = (,) f `liftM` rnm t

52−

53−metadataModule :: Interfaces -> MetadataModule t v -> Either [Doc] (MetadataModule t v)

47+ Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

48+ Type.Var _ -> return tipe

49+ Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

51+ where rnm' (f,t) = (,) f <$> rnm t

52+

53+metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

5454metadataModule ifaces modul =

55− do _ <- case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56− [] -> Right ()

57− missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

55+ do case filter (\m -> Map.notMember m ifaces) (map fst realImports) of

56+ [] -> Right ()

57+ missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

5858 program' <- rename initialEnv (program modul)

59− aliases' <- mapM (third renameType') (aliases modul)

60− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

61− exports' <- mapM (third renameType') (foreignExports modul)

62− imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

59+ aliases' <- mapM (three4 renameType') (aliases modul)

60+ datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)

6361 return $ modul { program = program'

6462 , aliases = aliases'

65− , datatypes = datatypes'

66− , foreignExports = exports'

67− , foreignImports = imports' }

63+ , datatypes = datatypes' }

6864 where

69− second f (a,b) = (,) a `fmap` 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')

65+ two2 f (a,b) = (,) a <$> f b

66+ three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d

7467 renameType' =

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

7669

77− get1 (a,_,_) = a

70+ get1 (a,_,_,_) = a

7871 canon (name, importMethod) =

7972 let pair pre var = (pre ++ drop (length name + 1) var, var)

8073 iface = ifaces Map.! name

8174 allNames = concat [ Map.keys (iTypes iface)

8275 , map get1 (iAliases iface)

83− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

76+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

8477 in case importMethod of

8578 As alias -> map (pair (alias ++ ".")) allNames

8679 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

@@ -88,18 +81,19 @@ metadataModule ifaces modul =

8881 Importing vars -> map (pair "") $ filter (flip Set.member vs) allNames

8982 where vs = Set.fromList $ map (\v -> name ++ "." ++ v) vars

9083

91− pair n = (n,n)

92− localEnv = map pair (map get1 (aliases modul) ++ map get1 (datatypes modul))

93− globalEnv = map pair $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

94− map (\n -> "_Tuple" ++ show n) [0..9]

84+ two n = (n,n)

85+ localEnv = map two (map get1 (aliases modul) ++ map get1 (datatypes modul))

86+ globalEnv =

87+ map two $ ["_List",saveEnvName,"::","[]","Int","Float","Char","Bool","String"] ++

88+ map (\n -> "_Tuple" ++ show (n :: Int)) [0..9]

9589 realImports = filter (not . List.isPrefixOf "Native." . fst) (imports modul)

9690 initialEnv = Map.fromList (concatMap canon realImports ++ localEnv ++ globalEnv)

9791

9892type Env = Map.Map String String

9993

100−extend :: Env -> Pattern -> Env

94+extend :: Env -> P.Pattern -> Env

10195extend 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)

10397

10498

10599replace :: String -> Env -> String -> Either String String

@@ -113,76 +107,76 @@ replace variable env v =

113107 msg = if null matches then "" else

114108 "\nClose matches include: " ++ List.intercalate ", " matches

115109

116−rename :: Env -> LExpr t v -> Either [Doc] (LExpr t v)

117−rename env lexpr@(L s expr) =

110+rename :: Env -> LExpr -> Either [Doc] LExpr

111+rename env (L s expr) =

118112 let rnm = rename env

119113 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

120114 format = Either.either throw return

115+ renameType' env = renameType (format . replace "variable" env)

121116 in

122− L s `liftM`

117+ L s <$>

123118 case expr of

124− Literal lit -> return expr

119+ Literal _ -> return expr

125120

126− Range e1 e2 -> Range `liftM` rnm e1 `ap` rnm e2

121+ Range e1 e2 -> Range <$> rnm e1 <*> rnm e2

127122

128− Access e x -> Access `liftM` rnm e `ap` return x

123+ Access e x -> Access <$> rnm e <*> return x

129124

130− Remove e x -> flip Remove x `liftM` rnm e

125+ Remove e x -> flip Remove x <$> rnm e

131126

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

133128

134129 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

136131

137− Record fs -> Record `liftM` mapM frnm fs

138− where

139− frnm (f,e) = (,) f `liftM` rename env e

132+ Record fs -> Record <$> mapM (\(k,v) -> (,) k <$> rnm v) fs

140133

141134 Binop op e1 e2 ->

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

143− Binop op' `liftM` rnm e1 `ap` rnm e2

136+ Binop op' <$> rnm e1 <*> rnm e2

144137

145138 Lambda pattern e ->

146139 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

148141

149− App e1 e2 -> App `liftM` rnm e1 `ap` rnm e2

142+ App e1 e2 -> App <$> rnm e1 <*> rnm e2

150143

151− MultiIf ps -> MultiIf `liftM` mapM grnm ps

152− where grnm (b,e) = (,) `liftM` rnm b `ap` rnm e

144+ MultiIf ps -> MultiIf <$> mapM grnm ps

145+ where grnm (b,e) = (,) <$> rnm b <*> rnm e

153146

154− Let defs e -> Let `liftM` mapM rename' defs `ap` rename env' e

147+ Let defs e -> Let <$> mapM rename' defs <*> rename env' e

155148 where

156− env' = foldl extend env [ pattern | Def pattern _ <- defs ]

157− rename' def =

158− case def of

159− Def p exp ->

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

161− TypeAnnotation name tipe ->

162− TypeAnnotation name `liftM`

163− renameType (format . replace "variable" env') tipe

149+ env' = foldl extend env $ map (\(Definition p _ _) -> p) defs

150+ rename' (Definition p body mtipe) =

151+ Definition <$> format (renamePattern env' p)

152+ <*> rename env' body

153+ <*> T.traverse (renameType' env') mtipe

164154

165− Var x -> Var `liftM` format (replace "variable" env x)

155+ Var x -> Var <$> format (replace "variable" env x)

166156

167− Data name es -> Data name `liftM` mapM rnm es

157+ Data name es -> Data name <$> mapM rnm es

168158

169− ExplicitList es -> ExplicitList `liftM` mapM rnm es

159+ ExplicitList es -> ExplicitList <$> mapM rnm es

170160

171− Case e cases -> Case `liftM` rnm e `ap` mapM branch cases

161+ Case e cases -> Case <$> rnm e <*> mapM branch cases

172162 where

173− branch (pattern,e) = (,) `liftM` format (renamePattern env pattern)

174− `ap` rename (extend env pattern) e

163+ branch (pattern,b) = (,) <$> format (renamePattern env pattern)

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

175169

176− Markdown uid md es -> Markdown uid md `liftM` mapM rnm es

170+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

177171

178172

179−renamePattern :: Env -> Pattern -> Either String Pattern

173+renamePattern :: Env -> P.Pattern -> Either String P.Pattern

180174renamePattern env pattern =

181175 case pattern of

182− PVar _ -> return pattern

183− PLiteral _ -> return pattern

184− PRecord _ -> return pattern

185− PAnything -> return pattern

186− PAlias x p -> PAlias x `liftM` renamePattern env p

187− PData name ps -> PData `liftM` replace "pattern" env name

188− `ap` mapM (renamePattern env) ps

176+ P.PVar _ -> return pattern

177+ P.PLiteral _ -> return pattern

178+ P.PRecord _ -> return pattern

179+ P.PAnything -> return pattern

180+ P.PAlias x p -> P.PAlias x <$> renamePattern env p

181+ P.PData name ps -> P.PData <$> replace "pattern" env name

182+ <*> mapM (renamePattern env) ps

compiler/Transform/Check.hs+86−90

@@ -1,114 +1,109 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Transform.Check (mistakes) where

23

3−import Transform.SortDefinitions (boundVars)

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

11−import qualified Data.Map as Map

4+import qualified Control.Arrow as Arrow

5+import qualified Data.List as List

126import qualified Data.Maybe as Maybe

137import 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

1416import Text.PrettyPrint as P

1517

1618

17−mistakes :: [Declaration t v] -> [Doc]

19+mistakes :: [D.Declaration] -> [Doc]

1820mistakes decls =

1921 concat [ infiniteTypeAliases decls

2022 , illFormedTypes decls

2123 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

23− where

24− findErrors defs = duplicates defs ++ badOrder defs

24+ , map P.text (duplicates decls)

25+ , badDerivations decls ]

2526

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]

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

27+dups :: Ord a => [a] -> [a]

28+dups = map head . filter ((>1) . length) . List.group . List.sort

5829

5930dupErr :: String -> String -> String

6031dupErr err x =

6132 "Syntax Error: There can only be one " ++ err ++ " '" ++ x ++ "'."

6233

63−duplicates :: [Def t v] -> [String]

64−duplicates defs =

65− map defMsg (dups definitions) ++ map annMsg (dups annotations)

66− where

67− annotations = List.sort [ name | TypeAnnotation name _ <- defs ]

68− definitions = List.sort $ concatMap Set.toList [ boundVars pattern | Def pattern _ <- defs ]

69− defMsg = dupErr "definition of"

70− annMsg = dupErr "type annotation for"

34+duplicates :: [D.Declaration] -> [String]

35+duplicates decls =

36+ map msg (dups (portNames ++ concatMap getNames defPatterns)) ++

37+ case mapM exprDups (portExprs ++ defExprs) of

38+ Left name -> [msg name]

39+ Right _ -> []

7140

72−duplicateConstructors :: [Declaration t v] -> [String]

73−duplicateConstructors decls =

74− map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

7541 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

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

42+ msg = dupErr "definition of"

8743

88− go defs =

89− case defs of

90− TypeAnnotation name _ : Def (PVar name') _ : rest

91− | name == name' -> go rest

44+ (defPatterns, defExprs) =

45+ unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

9246

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, [])

9453

95− _ : rest -> go rest

54+ getNames = Set.toList . Pattern.boundVars

9655

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]

9785 _ -> []

9886

99−illFormedTypes :: [Declaration t v] -> [Doc]

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+

94+illFormedTypes :: [D.Declaration] -> [Doc]

10095illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

10196 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

97+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

98+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

10499

105100 freeVars tipe =

106101 case tipe of

107102 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

108103 T.Var x -> Set.singleton x

109104 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

112107

113108 undeclared tvars tipes = Set.difference used declared

114109 where

@@ -132,7 +127,7 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

132127

133128 addCommas xs

134129 | length xs < 3 = concat xs

135− | otherwise = intercalate "," xs

130+ | otherwise = List.intercalate "," xs

136131

137132 addAnd xs

138133 | length xs < 2 = xs

@@ -141,29 +136,30 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141136 quote tvar = "'" ++ tvar ++ "'"

142137

143138

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

139+infiniteTypeAliases :: [D.Declaration] -> [Doc]

145140infiniteTypeAliases 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 ]

147143 where

148− isInfinite name tipe =

149− let infinite = isInfinite name in

144+ infiniteType name tipe =

145+ let infinite = infiniteType name in

150146 case tipe of

151147 T.Lambda a b -> infinite a || infinite b

152148 T.Var _ -> False

153149 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

156151

157− report decl@(TypeAlias name args tipe) =

152+ indented :: D.Declaration -> Doc

153+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"

154+

155+ report name args tipe derivations =

158156 P.vcat [ P.text $ eightyCharLines 0 msg1

159− , indented decl

157+ , indented $ D.TypeAlias name args tipe derivations

160158 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

159+ , indented $ D.Datatype name args [(name,[tipe])] derivations

162160 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163161 ]

164162 where

165− indented decl = P.text "\n " <> pretty decl <> P.text "\n"

166−

167163 msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

168164 "Notice that it appears in its own definition, so when \

169165 \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 =

2727 PAlias x p -> PAlias (var x) (pattern p)

2828 PData name ps -> PData name (map pattern ps)

2929

30−expression :: LExpr t v -> LExpr t v

30+expression :: LExpr -> LExpr

3131expression (L loc expr) =

3232 let f = expression in

3333 L loc $

@@ -49,14 +49,14 @@ expression (L loc expr) =

4949 Modify r fs -> Modify (f r) (map (var *** f) fs)

5050 Record fs -> Record (map (var *** f) fs)

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

5254

53−definition :: Def t v -> Def t v

54−definition def =

55− case def of

56− Def p e -> Def (pattern p) (expression e)

57− TypeAnnotation name t -> TypeAnnotation (var name) t

55+definition :: Def -> Def

56+definition (Definition p e t) =

57+ Definition (pattern p) (expression e) t

5858

59−metadataModule :: MetadataModule t v -> MetadataModule t v

59+metadataModule :: MetadataModule -> MetadataModule

6060metadataModule modul =

6161 modul

6262 { names = map var (names modul)

@@ -64,15 +64,9 @@ metadataModule modul =

6464 , imports = map (first var) (imports modul)

6565 , program = expression (program modul)

6666 , aliases =

67− let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)

67+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

6868 in map makeSafe (aliases modul)

6969 , 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)

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

7872 }

compiler/Transform/SortDefinitions.hs+50−102

@@ -1,37 +1,25 @@

1−

2−module Transform.SortDefinitions (sortDefs, boundVars, flattenLets) where

1+{-# OPTIONS_GHC -Wall #-}

2+module Transform.SortDefinitions (sortDefs) where

33

44import Control.Monad.State

5−import Control.Applicative ((<$>))

6−import qualified Data.Set as Set

5+import Control.Applicative ((<$>),(<*>))

76import qualified Data.Map as Map

8−import qualified SourceSyntax.Type as ST

97import SourceSyntax.Expression

108import SourceSyntax.Location

11−import SourceSyntax.Pattern

9+import qualified SourceSyntax.Pattern as P

1210import qualified Data.Graph as Graph

13−import qualified Data.Map as Map

11+import qualified Data.Set as Set

1412import qualified Data.Maybe as Maybe

1513

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]

2715ctors pattern =

2816 case pattern of

29− PVar x -> []

30− PAlias x p -> ctors p

31− PData ctor ps -> ctor : concatMap ctors ps

32− PRecord fields -> []

33− PAnything -> []

34− PLiteral _ -> []

17+ P.PVar _ -> []

18+ P.PAlias _ p -> ctors p

19+ P.PData ctor ps -> ctor : concatMap ctors ps

20+ P.PRecord _ -> []

21+ P.PAnything -> []

22+ P.PLiteral _ -> []

3523

3624free :: String -> State (Set.Set String) ()

3725free x = modify (Set.insert x)

@@ -39,68 +27,66 @@ free x = modify (Set.insert x)

3927bound :: Set.Set String -> State (Set.Set String) ()

4028bound boundVars = modify (\freeVars -> Set.difference freeVars boundVars)

4129

42−sortDefs :: LExpr t v -> LExpr t v

30+sortDefs :: LExpr -> LExpr

4331sortDefs expr = evalState (reorder expr) Set.empty

4432

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)

52−reorder lexpr@(L s expr) =

53− L s `liftM`

33+reorder :: LExpr -> State (Set.Set String) LExpr

34+reorder (L s expr) =

35+ L s <$>

5436 case expr of

5537 -- Be careful adding and restricting freeVars

5638 Var x -> free x >> return expr

5739

5840 Lambda p e ->

59− uncurry Lambda `liftM` bindingReorder (p,e)

41+ uncurry Lambda <$> bindingReorder (p,e)

6042

6143 Binop op e1 e2 ->

6244 do free op

63− Binop op `liftM` reorder e1 `ap` reorder e2

45+ Binop op <$> reorder e1 <*> reorder e2

6446

6547 Case e cases ->

66− Case `liftM` reorder e `ap` mapM bindingReorder cases

48+ Case <$> reorder e <*> mapM bindingReorder cases

6749

6850 Data name es ->

6951 do free name

70− Data name `liftM` mapM reorder es

52+ Data name <$> mapM reorder es

7153

7254 -- Just pipe the reorder though

7355 Literal _ -> return expr

7456

7557 Range e1 e2 ->

76− Range `liftM` reorder e1 `ap` reorder e2

58+ Range <$> reorder e1 <*> reorder e2

7759

7860 ExplicitList es ->

79− ExplicitList `liftM` mapM reorder es

61+ ExplicitList <$> mapM reorder es

8062

8163 App e1 e2 ->

82− App `liftM` reorder e1 `ap` reorder e2

64+ App <$> reorder e1 <*> reorder e2

8365

8466 MultiIf branches ->

85− MultiIf `liftM` mapM reorderPair branches

67+ MultiIf <$> mapM (\(e1,e2) -> (,) <$> reorder e1 <*> reorder e2) branches

8668

8769 Access e lbl ->

88− Access `liftM` reorder e `ap` return lbl

70+ Access <$> reorder e <*> return lbl

8971

9072 Remove e lbl ->

91− Remove `liftM` reorder e `ap` return lbl

73+ Remove <$> reorder e <*> return lbl

9274

9375 Insert e lbl v ->

94− Insert `liftM` reorder e `ap` return lbl `ap` reorder v

76+ Insert <$> reorder e <*> return lbl <*> reorder v

9577

9678 Modify e fields ->

97− Modify `liftM` reorder e `ap` mapM reorderField fields

79+ Modify <$> reorder e <*> mapM (\(k,v) -> (,) k <$> reorder v) fields

9880

9981 Record fields ->

100− Record `liftM` mapM reorderField fields

82+ Record <$> mapM (\(k,v) -> (,) k <$> reorder v) fields

10183

10284 Markdown uid md es -> Markdown uid md <$> mapM reorder es

10385

86+ PortOut name st signal -> PortOut name st <$> reorder signal

87+

88+ PortIn name st -> return $ PortIn name st

89+

10490 -- Actually do some reordering

10591 Let defs body ->

10692 do body' <- reorder body

@@ -113,48 +99,24 @@ reorder lexpr@(L s expr) =

11399 let defss = map Graph.flattenSCC sccs

114100

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

121− bound (boundVars pattern)

102+ forM_ defs $ \(Definition pattern _ _) -> do

103+ bound (P.boundVars pattern)

122104 mapM free (ctors pattern)

123105

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

126107

127108 return let'

128109

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)

147111bindingReorder (pattern,expr) =

148112 do expr' <- reorder expr

149− bound (boundVars pattern)

150− mapM free (ctors pattern)

113+ bound (P.boundVars pattern)

114+ mapM_ free (ctors pattern)

151115 return (pattern, expr')

152116

153117

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

157−reorderAndGetDependencies (pattern, expr, mType) =

118+reorderAndGetDependencies :: Def -> State (Set.Set String) (Def, [String])

119+reorderAndGetDependencies (Definition pattern expr mType) =

158120 do globalFrees <- get

159121 -- work in a fresh environment

160122 put Set.empty

@@ -162,44 +124,30 @@ reorderAndGetDependencies (pattern, expr, mType) =

162124 localFrees <- get

163125 -- merge with global frees

164126 modify (Set.union globalFrees)

165− return ((pattern, expr', mType), Set.toList localFrees)

127+ return (Definition pattern expr' mType, Set.toList localFrees)

166128

167129

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

170132buildDefDict defs =

171− do pdefsDeps <- mapM reorderAndGetDependencies (getPDefs defs)

133+ do pdefsDeps <- mapM reorderAndGetDependencies defs

172134 return $ realDeps (addKey pdefsDeps)

173135

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

189138 addKey = zipWith (\n (pdef,deps) -> (pdef,n,deps)) [0..]

190139

191− variableToKey :: (PDef t v, Int, [String]) -> [(String, Int)]

192− variableToKey ((pattern, _, _), key, _) =

193− [ (var, key) | var <- Set.toList (boundVars pattern) ]

140+ variableToKey :: (Def, Int, [String]) -> [(String, Int)]

141+ variableToKey (Definition pattern _ _, key, _) =

142+ [ (var, key) | var <- Set.toList (P.boundVars pattern) ]

194143

195− variableToKeyMap :: [(PDef t v, Int, [String])] -> Map.Map String Int

144+ variableToKeyMap :: [(Def, Int, [String])] -> Map.Map String Int

196145 variableToKeyMap pdefsDeps =

197146 Map.fromList (concatMap variableToKey pdefsDeps)

198147

199− realDeps :: [(PDef t v, Int, [String])] -> [(PDef t v, Int, [Int])]

148+ realDeps :: [(Def, Int, [String])] -> [(Def, Int, [Int])]

200149 realDeps pdefsDeps = map convert pdefsDeps

201150 where

202151 varDict = variableToKeyMap pdefsDeps

203152 convert (pdef, key, deps) =

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

44import Control.Arrow (second, (***))

55import SourceSyntax.Expression

66import SourceSyntax.Location

7+import qualified SourceSyntax.Pattern as Pattern

78import qualified Data.Set as Set

8−import qualified Transform.SortDefinitions as SD

99

10−subst :: String -> Expr t v -> Expr t v -> Expr t v

10+subst :: String -> Expr -> Expr -> Expr

1111subst old new expr =

1212 let f (L s e) = L s (subst old new e) in

1313 case expr of

@@ -15,7 +15,7 @@ subst old new expr =

1515 ExplicitList es -> ExplicitList (map f es)

1616 Binop op e1 e2 -> Binop op (f e1) (f e2)

1717 Lambda p e

18− | Set.member old (SD.boundVars p) -> expr

18+ | Set.member old (Pattern.boundVars p) -> expr

1919 | otherwise -> Lambda p (f e)

2020 App e1 e2 -> App (f e1) (f e2)

2121 MultiIf ps -> MultiIf (map (f *** f) ps)

@@ -24,12 +24,9 @@ subst old new expr =

2424 | anyShadow -> expr

2525 | otherwise -> Let (map substDef defs) (f body)

2626 where

27+ substDef (Definition p e t) = Definition p (f e) t

2728 anyShadow =

28− any (Set.member old . SD.boundVars) [ p | Def p _ <- defs ]

29− substDef def =

30− case def of

31− TypeAnnotation _ _ -> def

32− Def p e -> Def p (f e)

29+ any (Set.member old . Pattern.boundVars) [ p | Definition p _ _ <- defs ]

3330

3431 Var x -> if x == old then new else expr

3532 Case e cases -> Case (f e) $ map (second f) cases

@@ -40,4 +37,6 @@ subst old new expr =

4037 Modify r fs -> Modify (f r) (map (second f) fs)

4138 Record fs -> Record (map (second f) fs)

4239 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 #-}

12module Type.Alias (realias, rules, canonicalRealias, Rules) where

23

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

@@ -9,7 +10,7 @@ import qualified Data.List as List

910import SourceSyntax.Type

1011import SourceSyntax.Module

1112

12−type Rules = ([(String,[String],Type)], Type -> Type)

13+type Rules = ([Alias], Type -> Type)

1314

1415rules interfaces moduleAliases moduleImports =

1516 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +21,7 @@ collect interfaces moduleAliases =

2021 rawAliases =

2122 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

2223

23− isPrimitive (_,_,tipe) =

24+ isPrimitive (_,_,tipe,_) =

2425 case tipe of

2526 Data _ [] -> True

2627 _ -> False

@@ -30,10 +31,9 @@ localizer moduleImports = go

3031 go tipe =

3132 case tipe of

3233 Var _ -> tipe

33− EmptyRecord -> tipe

3434 Lambda t1 t2 -> Lambda (go t1) (go t2)

3535 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

3737

3838 byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

3939 Map.empty moduleImports

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

6262

6363-- Realias using canonical aliases, so results will have aliases

6464-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

6666canonicalRealias aliases tipe =

6767 case concatMap tryRealias aliases of

6868 [] -> if tipe == tipe' then tipe else f tipe'

6969 tipes -> f (bestType tipes)

7070 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

7272 case diff aliasTipe tipe of

7373 Nothing -> []

7474 Just kvs ->

@@ -83,10 +83,9 @@ canonicalRealias aliases tipe =

8383 tipe' =

8484 case tipe of

8585 Var _ -> tipe

86− EmptyRecord -> tipe

8786 Lambda t1 t2 -> Lambda (f t1) (f t2)

8887 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

9089

9190allEqual [] = True

9291allEqual (x:xs) = all (==x) xs

@@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

102101 Lambda t1 t2 -> numFields t1 + numFields t2

103102 Var _ -> 0

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

107105

108106diff :: Type -> Type -> Maybe [(String,Type)]

109107diff general specific =

@@ -113,11 +111,11 @@ diff general specific =

113111 (Data gname gts, Data sname sts)

114112 | gname == sname && length gts == length sts ->

115113 concat <$> zipWithM diff gts sts

116− (EmptyRecord, EmptyRecord) -> Just []

117− (Record _ _, Record _ _) ->

118− let (gfs,gext) = collectRecords general

119− (sfs,sext) = collectRecords specific

120− gfields = collectFields gfs

114+ (Record [] Nothing, Record [] Nothing) -> Just []

115+ (Record _ _, Record [] Nothing) -> Nothing

116+ (Record [] Nothing, Record _ _) -> Nothing

117+ (Record gfs gext, Record sfs sext) ->

118+ let gfields = collectFields gfs

121119 sfields = collectFields sfs

122120

123121 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

@@ -126,10 +124,12 @@ diff general specific =

126124 case isAligned of

127125 False -> Nothing

128126 True -> let remaining = Map.difference sfields gfields

129− sext' = if Map.null remaining then sext else

130− Record (flattenFields remaining) sext

127+ sext' = case sext of

128+ Just x | Map.null remaining -> Var x

129+ _ -> Record (flattenFields remaining) sext

130+ gext' = maybe (Record [] Nothing) Var gext

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

133133 (_,_) -> Nothing

134134

135135collectFields fields =

compiler/Type/Constrain/Declaration.hs+30−37

@@ -1,70 +1,63 @@

1+{-# OPTIONS_GHC -Wall #-}

12module Type.Constrain.Declaration where

23

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−

114import SourceSyntax.Declaration

12−import qualified SourceSyntax.Expression as Src

5+import qualified SourceSyntax.Expression as E

136import qualified SourceSyntax.Location as L

147import qualified SourceSyntax.Pattern as P

15−import qualified SourceSyntax.Type as Type

8+import qualified SourceSyntax.Type as T

169

17−toExpr :: [Declaration t v] -> [Src.Def t v]

10+toExpr :: [Declaration] -> [E.Def]

1811toExpr = concatMap toDefs

1912

20−toDefs :: Declaration t v -> [Src.Def t v]

13+toDefs :: Declaration -> [E.Def]

2114toDefs decl =

2215 case decl of

2316 Definition def -> [def]

2417

25− Datatype name tvars constructors -> concatMap toDefs constructors

18+ Datatype name tvars constructors _ -> concatMap toDefs' constructors

2619 where

27− toDefs (ctor, tipes) =

20+ toDefs' (ctor, tipes) =

2821 let vars = take (length tipes) arguments

29− tbody = Type.Data name $ map Type.Var tvars

30− body = L.none . Src.Data ctor $ map (L.none . Src.Var) vars

31− in [ Src.TypeAnnotation ctor $ foldr Type.Lambda tbody tipes

32− , Src.Def (P.PVar ctor) $ buildFunction body vars

33− ]

22+ tbody = T.Data name $ map T.Var tvars

23+ body = L.none . E.Data ctor $ map (L.none . E.Var) vars

24+ in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

3425

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

36− [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37− , Src.Def (P.PVar name) $ buildFunction record vars ]

26+ TypeAlias name _ tipe@(T.Record fields ext) _ ->

27+ [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

3828 where

39− args = case ext of

40− Type.EmptyRecord -> map snd fields

41− _ -> map snd fields ++ [ext]

29+ args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

4230

43− var = L.none . Src.Var

31+ var = L.none . E.Var

4432 vars = take (length args) arguments

4533

4634 efields = zip (map fst fields) (map var vars)

4735 record = case ext of

48− Type.EmptyRecord -> L.none $ Src.Record efields

49− _ -> foldl (\r (f,v) -> L.none $ Src.Insert r f v) (var $ last vars) efields

36+ Nothing -> L.none $ E.Record efields

37+ Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

5038

5139 -- Type aliases must be added to an extended equality dictionary,

5240 -- but they do not require any basic constraints.

53− TypeAlias _ _ _ -> []

41+ -- TODO: with the ability to derive code, you may need to generate stuff!

42+ TypeAlias _ _ _ _ -> []

5443

55− ImportEvent _ expr@(L.L s _) name tipe ->

56− [ Src.TypeAnnotation name tipe

57− , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]

58−

59− ExportEvent _ name tipe ->

60− [ Src.TypeAnnotation name tipe ]

44+ Port port ->

45+ case port of

46+ Out name expr@(L.L s _) tipe ->

47+ [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

48+ In name tipe ->

49+ [ definition name (L.none $ E.PortIn name tipe) tipe ]

6150

6251 -- no constraints are needed for fixity declarations

6352 Fixity _ _ _ -> []

6453

6554

6655arguments :: [String]

67−arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show n) [1..]

56+arguments = map (:[]) ['a'..'z'] ++ map (\n -> "_" ++ show (n :: Int)) [1..]

6857

58+buildFunction :: E.LExpr -> [String] -> E.LExpr

6959buildFunction 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 #-}

12module Type.Constrain.Expression where

23

34import qualified Data.List as List

45import qualified Data.Map as Map

56import qualified Data.Set as Set

6−import Control.Arrow (second)

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

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

88import qualified Control.Monad as Monad

99import Control.Monad.Error

10−import Control.Monad.State

11−import Data.Traversable (traverse)

1210import qualified Text.PrettyPrint as PP

1311

1412import SourceSyntax.Location as Loc

15−import SourceSyntax.Pattern (Pattern(PVar))

13+import SourceSyntax.Pattern (Pattern(PVar), boundVars)

1614import SourceSyntax.Expression

1715import qualified SourceSyntax.Type as SrcT

1816import Type.Type hiding (Descriptor(..))

@@ -20,10 +18,8 @@ import Type.Fragment

2018import qualified Type.Environment as Env

2119import qualified Type.Constrain.Literal as Literal

2220import qualified Type.Constrain.Pattern as Pattern

23−import qualified Transform.SortDefinitions as SD

2421

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

2723constrain env (L span expr) tipe =

2824 let list t = Env.get env Env.types "_List" <| t

2925 and = L span . CAnd

@@ -145,13 +141,17 @@ constrain env (L span expr) tipe =

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

146142 Monad.foldM (constrainDef env)

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

148− (collapseDefs defs)

144+ (concatMap expandPattern defs)

149145 return $ clet schemes

150146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

151147 (c1 /\ c))

152148

149+ PortIn _ _ -> return true

150+

151+ PortOut _ _ signal ->

152+ constrain env signal tipe

153153

154−constrainDef env info (pattern, expr, maybeTipe) =

154+constrainDef env info (Definition pattern expr maybeTipe) =

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

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

157157 in

@@ -188,33 +188,18 @@ constrainDef env info (pattern, expr, maybeTipe) =

188188 , c /\ c2

189189 , c1 )

190190

191−expandPattern :: (Pattern, LExpr t v, Maybe SrcT.Type)

192− -> [(Pattern, LExpr t v, Maybe SrcT.Type)]

193−expandPattern triple@(pattern, lexpr@(L s _), maybeType) =

191+ _ -> error (show pattern)

192+

193+expandPattern :: Def -> [Def]

194+expandPattern def@(Definition pattern lexpr@(L s _) maybeType) =

194195 case pattern of

195− PVar _ -> [triple]

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

196+ PVar _ -> [def]

197+ _ -> Definition (PVar x) lexpr maybeType : map toDef vars

197198 where

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

199+ vars = Set.toList $ boundVars pattern

199200 x = "$" ++ concat vars

200− var = L s . Var

201− toDef y = (PVar y, L s $ Case (var x) [(pattern, var 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

201+ mkVar = L s . Var

202+ toDef y = Definition (PVar y) (L s $ Case (mkVar x) [(pattern, mkVar y)]) Nothing

218203

219204try :: SrcSpan -> ErrorT (SrcSpan -> PP.Doc) IO a -> ErrorT [PP.Doc] IO a

220205try span computation = do

compiler/Type/Constrain/Pattern.hs−2

@@ -5,8 +5,6 @@ import Control.Arrow (second)

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

66import qualified Control.Monad as Monad

77import Control.Monad.Error

8−import qualified Data.List as List

9−import qualified Data.Maybe as Maybe

108import qualified Data.Map as Map

119import qualified Text.PrettyPrint as PP

1210

compiler/Type/Environment.hs+14−12

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Environment where

23

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

@@ -9,11 +10,10 @@ import qualified Control.Monad.State as State

910import qualified Data.Traversable as Traverse

1011import qualified Data.Map as Map

1112import Data.List (isPrefixOf)

12−import qualified Data.UnionFind.IO as UF

1313import qualified Text.PrettyPrint as PP

1414

1515import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

2626 value :: TypeDict

2727}

2828

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

3030initialEnvironment datatypes aliases = do

3131 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

3333 env = Environment {

3434 constructor = Map.empty,

3535 value = Map.empty,

@@ -42,9 +42,9 @@ makeTypes :: [ADT] -> IO TypeDict

4242makeTypes datatypes =

4343 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

4444 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

4646

47− makeCtor (name, kind) = do

47+ makeCtor (name, _) = do

4848 ctor <- VarN <$> namedVar Constant name

4949 return (name, ctor)

5050

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

8484

8585

8686ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, _) =

8888 zip (map fst ctors) (map inst ctors)

8989 where

9090 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

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

9494

9595

9696 go :: (String, [Src.Type]) -> State.StateT (VarDict, TypeDict) IO ([Type], Type)

97− go (ctor, args) = do

97+ go (_, args) = do

9898 types <- mapM (instantiator env) args

9999 returnType <- instantiator env (Src.Data name (map Src.Var tvars))

100100 return (types, returnType)

@@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType

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

163163 name ++ "' while checking types."

164164

165− Src.EmptyRecord -> return (TermN EmptyRecord1)

166−

167− Src.Record fields ext ->

168− TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)

165+ Src.Record fields ext -> do

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

13-- This module contains checks to be run *after* type inference has

24-- completed successfully. At that point we still need to do occurs

35-- checks and ensure that `main` has an acceptable type.

4−module Type.ExtraChecks (extraChecks, occursCheck) where

56

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

78import Control.Monad.State

9+import qualified Data.List as List

810import qualified Data.Map as Map

911import qualified Data.UnionFind.IO as UF

1012import Type.Type ( Variable, structure, Term1(..), toSrcType )

@@ -12,33 +14,106 @@ import qualified Type.State as TS

1214import qualified Type.Alias as Alias

1315import Text.PrettyPrint as P

1416import SourceSyntax.PrettyPrint (pretty)

15−import SourceSyntax.Type (Type)

16−import qualified SourceSyntax.Location as Location

17−import qualified SourceSyntax.Expression as Expr

17+import qualified SourceSyntax.Helpers as Help

18+import qualified SourceSyntax.Type as T

19+import qualified SourceSyntax.Expression as E

20+import qualified SourceSyntax.Location as L

21+import qualified Transform.Expression as Expr

1822import qualified Data.Traversable as Traverse

1923

20−extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))

21−extraChecks rules env =

22− mainCheck rules <$> Traverse.traverse toSrcType env

23−

24−mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

25−mainCheck rules env =

26− let acceptable = ["Graphics.Element.Element","Signal.Signal Graphics.Element.Element"] in

27− case Map.lookup "main" env of

28− Nothing -> Right env

29− Just tipe

30− | P.render (pretty (Alias.canonicalRealias (fst rules) tipe)) `elem` acceptable ->

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

35− , P.text "Instead 'main' has type:\n"

36− , P.nest 4 . pretty $ Alias.realias rules tipe

37− , P.text " " ]

38− ]

39−

40−occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()

41−occursCheck (name, variable) =

24+throw err = Left [ P.vcat err ]

25+

26+mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))

27+mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

28+ where

29+ mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)

30+ mainCheck rules env =

31+ case Map.lookup "main" env of

32+ Nothing -> Right env

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+

40+ tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType

41+ err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

42+ , P.text "Instead 'main' has type:\n"

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 }

95+ txt = P.text . concat

96+

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+

115+occurs :: (String, Variable) -> StateT TS.SolverState IO ()

116+occurs (name, variable) =

42117 do vars <- liftIO $ infiniteVars [] variable

43118 case vars of

44119 [] -> return ()

@@ -47,10 +122,10 @@ occursCheck (name, variable) =

47122 case structure desc of

48123 Nothing ->

49124 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

50− Just struct ->

125+ Just _ ->

51126 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

52127 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'

54129 where

55130 msg = "Infinite types are not allowed"

56131 fallback _ = return $ P.text msg

compiler/Type/Inference.hs+7−8

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Inference where

23

34import qualified Data.Map as Map

@@ -5,27 +6,23 @@ import qualified Data.Map as Map

56import qualified Type.Type as T

67import qualified Type.Environment as Env

78import qualified Type.Constrain.Expression as TcExpr

8−import qualified Type.Constrain.Declaration as TcDecl

99import qualified Type.Solve as Solve

1010

1111import SourceSyntax.Module as Module

12−import qualified SourceSyntax.Expression as Expr

13−import SourceSyntax.Location (Located, noneNoDocs)

14−import SourceSyntax.PrettyPrint

12+import SourceSyntax.Location (noneNoDocs)

1513import SourceSyntax.Type (Type)

1614import Text.PrettyPrint

1715import qualified Type.State as TS

18−import Type.ExtraChecks (extraChecks)

16+import qualified Type.ExtraChecks as Check

1917import Control.Monad.State (execStateT, forM)

2018import Control.Monad.Error (runErrorT, liftIO)

21−import Control.Arrow (second)

2219import qualified Type.Alias as Alias

2320

2421import System.IO.Unsafe -- Possible to switch over to the ST monad instead of

2522 -- the IO monad. I don't think that'd be worthwhile.

2623

2724

28−infer :: Interfaces -> MetadataModule t v -> Either [Doc] (Map.Map String Type)

25+infer :: Interfaces -> MetadataModule -> Either [Doc] (Map.Map String Type)

2926infer interfaces modul = unsafePerformIO $ do

3027 env <- Env.initialEnvironment

3128 (datatypes modul ++ concatMap iAdts (Map.elems interfaces))

@@ -55,4 +52,6 @@ infer interfaces modul = unsafePerformIO $ do

5552 let rules = Alias.rules interfaces (aliases modul) (imports modul)

5653 case TS.sErrors state of

5754 errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))

58− [] -> extraChecks rules (Map.difference (TS.sSavedEnv state) header)

55+ [] -> case Check.portTypes rules (program modul) of

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 #-}

12module Type.Solve (solve) where

23

34import Control.Monad

@@ -5,14 +6,11 @@ import Control.Monad.State

56import qualified Data.UnionFind.IO as UF

67import qualified Data.Map as Map

78import qualified Data.Traversable as Traversable

8−import qualified Data.Maybe as Maybe

99import qualified Data.List as List

1010import Type.Type

1111import Type.Unify

12−import qualified Type.ExtraChecks as EC

13−import qualified Type.Environment as Env

12+import qualified Type.ExtraChecks as Check

1413import qualified Type.State as TS

15−import qualified Text.PrettyPrint as P

1614import SourceSyntax.Location (Located(L), SrcSpan)

1715

1816

@@ -122,7 +120,7 @@ solve (L span constraint) =

122120 headers <- Map.unions `fmap` mapM (solveScheme span) schemes

123121 TS.modifyEnv $ \env -> Map.union headers env

124122 solve constraint'

125− mapM EC.occursCheck $ Map.toList headers

123+ mapM Check.occurs $ Map.toList headers

126124 TS.modifyEnv (\_ -> oldEnv)

127125

128126 CInstance name term -> do

compiler/Type/State.hs+3−5

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

1+{-# OPTIONS_GHC -W #-}

12module Type.State where

23

34import Type.Type

45import qualified Data.Map as Map

5−import qualified Data.List as List

6−import qualified Type.Environment as Env

76import qualified Data.UnionFind.IO as UF

87import Control.Monad.State

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

@@ -11,7 +10,6 @@ import qualified Data.Traversable as Traversable

1110import Text.PrettyPrint as P

1211import SourceSyntax.PrettyPrint

1312import SourceSyntax.Location

14−import qualified SourceSyntax.Type as Src

1513import qualified Type.Alias as Alias

1614

1715-- Pool

@@ -64,8 +62,8 @@ addError span hint t1 t2 =

6462 ]

6563

6664 location = case span of

67− NoSpan msg -> ""

68− Span p1 p2 msg ->

65+ NoSpan _ -> ""

66+ Span p1 p2 _ ->

6967 if line p1 == line p2 then " on line " ++ show (line p1)

7068 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

7169

compiler/Type/Type.hs+20−13

@@ -62,7 +62,7 @@ monoscheme headers = Scheme [] [] (noneNoDocs CTrue) headers

6262infixl 8 /\

6363

6464(/\) :: 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) =

6666 case (c1, c2) of

6767 (CTrue, _) -> b

6868 (_, CTrue) -> a

@@ -95,6 +95,7 @@ data Flex = Rigid | Flexible | Constant | Is SuperType

9595data SuperType = Number | Comparable | Appendable

9696 deriving (Show, Eq)

9797

98+namedVar :: Flex -> String -> IO Variable

9899namedVar flex name = UF.fresh $ Descriptor {

99100 structure = Nothing,

100101 rank = noRank,

@@ -104,6 +105,7 @@ namedVar flex name = UF.fresh $ Descriptor {

104105 mark = noMark

105106 }

106107

108+var :: Flex -> IO Variable

107109var flex = UF.fresh $ Descriptor {

108110 structure = Nothing,

109111 rank = noRank,

@@ -113,6 +115,7 @@ var flex = UF.fresh $ Descriptor {

113115 mark = noMark

114116 }

115117

118+structuredVar :: Term1 Variable -> IO Variable

116119structuredVar structure = UF.fresh $ Descriptor {

117120 structure = Just structure,

118121 rank = noRank,

@@ -361,15 +364,19 @@ toSrcType variable = do

361364 return (Src.Data name (ts ++ [b']))

362365 Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

363366 Var1 a -> toSrcType a

364− EmptyRecord1 -> return Src.EmptyRecord

365− Record1 fs ext -> do

366− fs' <- traverse (mapM toSrcType) fs

367− let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]

368− Src.Record fs'' <$> toSrcType ext

367+ EmptyRecord1 -> return $ Src.Record [] Nothing

368+ Record1 tfields extension -> do

369+ fields' <- traverse (mapM toSrcType) tfields

370+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

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"

369376 Nothing ->

370377 case name desc of

371− Just x@(c:cs) | Char.isLower c -> return (Src.Var x)

372− | otherwise -> return (Src.Data x [])

378+ Just x@(c:_) | Char.isLower c -> return (Src.Var x)

379+ | otherwise -> return (Src.Data x [])

373380 _ -> error $ concat

374381 [ "Problem converting the following type "

375382 , "from a type-checker type to a source-syntax type:"

@@ -383,12 +390,12 @@ collectApps variable = go [] variable

383390 go vars variable = do

384391 desc <- UF.descriptor variable

385392 case (structure desc, vars) of

386− (Nothing, [v] ) -> case name desc of

393+ (Nothing, [v]) -> case name desc of

387394 Just "_List" -> return (List v)

388395 _ -> return Other

389− (Nothing, vs ) -> case name desc of

396+ (Nothing, vs) -> case name desc of

390397 Just ctor | isTuple ctor -> return (Tuple vs)

391398 _ -> return Other

392− (Just term, vs) -> case term of

393− App1 a b -> go (vars ++ [b]) a

394− _ -> return Other

399+ (Just term, _) -> case term of

400+ App1 a b -> go (vars ++ [b]) a

401+ _ -> return Other

compiler/Type/Unify.hs+3−3

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Unify (unify) where

23

34import Type.Type

@@ -5,7 +6,6 @@ import qualified Data.UnionFind.IO as UF

56import qualified Data.Map as Map

67import qualified Data.Maybe as Maybe

78import qualified Type.State as TS

8−import Control.Arrow (first,second)

99import Control.Monad.State

1010import SourceSyntax.Location

1111import Type.PrettyPrint

@@ -193,8 +193,8 @@ actuallyUnify span variable1 variable2 = do

193193

194194 unmerged a b = Map.filter (not . null) $ Map.union (Map.intersectionWith eat a b) a

195195

196− eat (x:xs) (y:ys) = eat xs ys

197− eat xs ys = xs

196+ eat (_:xs) (_:ys) = eat xs ys

197+ eat xs _ = xs

198198

199199 _ -> TS.addError span Nothing variable1 variable2

200200

libraries/Basics.elm+17−1

@@ -43,7 +43,7 @@ which happen to be radians.

4343@docs fst, snd

4444

4545# Higher-Order Helpers

46−@docs id, (<|), (|>), (.), flip, curry, uncurry

46+@docs id, (<|), (|>), (.), always, flip, curry, uncurry

4747

4848-}

4949

@@ -313,6 +313,22 @@ infixl 0 |>

313313id : a -> a

314314id x = x

315315

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+

316332{-| Given a 2-tuple, returns the first value. -}

317333fst : (a,b) -> a

318334fst (a,_) = a

libraries/Dict.elm+82−88

@@ -34,15 +34,35 @@ Insert, remove, and query operations all take *O(log n)* time.

3434import open Basics

3535import open Maybe

3636import Native.Error

37−import List as List

37+import List

38+import String

3839import Native.Utils

3940

4041-- BBlack and NBlack should only be used during the deletion

4142-- algorithm. Any other occurrence is a bug and should fail an assert.

42−data NColor = Red | Black

43− | BBlack | NBlack

44−

45−data LeafColor = LBlack | LBBlack

43+data NColor = Red

44+ | Black

45+ -- ^ Double Black, counts as 2 blacks for the invariant

46+ | BBlack

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+

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"

4666

4767data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

4868 | RBEmpty LeafColor

@@ -93,51 +113,6 @@ member : comparable -> Dict comparable v -> Bool

93113-- Does t contain k?

94114member k t = isJust <| lookup k t

95115

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−

141116ensureBlackRoot : Dict k v -> Dict k v

142117ensureBlackRoot t =

143118 case t of

@@ -158,6 +133,11 @@ remove k t = let u _ = Nothing in

158133 update k u t

159134

160135data Flag = Insert | Remove | Same

136+showFlag : Flag -> String

137+showFlag f = case f of

138+ Insert -> "Insert"

139+ Remove -> "Remove"

140+ Same -> "Same"

161141

162142{-| Update the value of a dictionary for a specific key with a given function. -}

163143update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v

@@ -168,76 +148,87 @@ update k u t =

168148 Just v -> (Insert, RBNode Red k v empty empty)

169149 RBNode c k' v l r -> case Native.Utils.compare k k' of

170150 EQ -> case u (Just v) of

171− Nothing -> (Remove, rem t)

151+ Nothing -> (Remove, rem c l r)

172152 Just v' -> (Same, RBNode c k' v' l r)

173153 LT -> let (fl, l') = up l in

174154 case fl of

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

177157 Remove -> (Remove, bubble c k' v l' r)

178158 GT -> let (fl, r') = up r in

179159 case fl of

180160 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')

182162 Remove -> (Remove, bubble c k' v l r')

183163 (fl, t') = up t

184164 in case fl of

185165 Same -> t'

186166 Insert -> ensureBlackRoot t'

187167 Remove -> blacken t'

188−

168+

189169{-| Create a dictionary with one key-value pair. -}

190170singleton : comparable -> v -> Dict comparable v

191171singleton k v = insert k v (RBEmpty LBlack)

192172

193−{- Remove helpers: everything from here to remove should only be used

194− internally by remove as they would otherwise break rb-invariants -}

195−

196173isBBlack : Dict k v -> Bool

197174isBBlack t = case t of

198− RBNode c _ _ _ _ -> case c of

199− BBlack -> True

200− _ -> False

175+ RBNode BBlack _ _ _ _ -> True

201176 RBEmpty LBBlack -> True

202177 _ -> False

203178

204179moreBlack : NColor -> NColor

205180moreBlack c = case c of

206− BBlack -> BBlack

207181 Black -> BBlack

208182 Red -> Black

209183 NBlack -> Red

184+ BBlack -> Native.Error.raise "Can't make a double black node more black!"

185+

210186lessBlack : NColor -> NColor

211187lessBlack c = case c of

212188 BBlack -> Black

213189 Black -> Red

214190 Red -> NBlack

215− NBlack -> NBlack

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

191+ NBlack -> Native.Error.raise "Can't make a negative black node less black!"

221192

222193lessBlackTree : Dict k v -> Dict k v

223194lessBlackTree t = case t of

224195 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+ ]

226211

227212-- Remove the top node from the tree, may leave behind BBlacks

228−rem : Dict k v -> Dict k v

229−rem t = case t of

230− RBNode c k v (RBEmpty _) (RBEmpty _) -> case c of

231− Red -> RBEmpty LBlack

213+rem : NColor -> Dict k v -> Dict k v -> Dict k v

214+rem c l r = case (l, r) of

215+ ((RBEmpty _), (RBEmpty _)) -> case c of

216+ Red -> RBEmpty LBlack

232217 Black -> RBEmpty LBBlack

233− RBNode Black _ _ (RBEmpty _) (RBNode _ k v l r) ->

234− RBNode Black k v l r

235− RBNode Black _ _ (RBNode _ k v l r) (RBEmpty _) ->

236− RBNode Black k v l r

218+ ((RBEmpty cl), (RBNode cr k' v' l' r')) ->

219+ case (c, cl, cr) of

220+ (Black, LBlack, Red) -> RBNode Black k' v' l' r'

221+ _ -> reportRemBug "Black, LBlack, Red" c (showLColor cl) (showNColor cr)

222+ ((RBNode cl k' v' l' r'), (RBEmpty cr)) ->

223+ case (c, cl, cr) of

224+ (Black, Red, LBlack) -> RBNode Black k' v' l' r'

225+ _ -> reportRemBug "Black, Red, LBlack" c (showNColor cl) (showLColor cr)

237226 -- l and r are both RBNodes

238− RBNode c _ _ l r ->

239− let (k, v) = max l

240− l' = remove_max l

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

230+ (k, v) = max l

231+ l' = remove_max cl kl vl ll rl

241232 in bubble c k v l' r

242233

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

245236bubble c k v l r = if isBBlack l || isBBlack r

246237 then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)

247238 else RBNode c k v l r

248−

239+

249240-- Removes rightmost node, may leave root as BBlack

250−remove_max : Dict k v -> Dict k v

251−remove_max t = case t of

252− RBNode c k v l (RBEmpty _) -> rem t

253− RBNode c k v l r -> bubble c k v l (remove_max r)

241+remove_max : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

242+remove_max c k v l r = case r of

243+ RBEmpty _ -> rem c l r

244+ RBNode cr kr vr lr rr

245+ -> bubble c k v l (remove_max cr kr vr lr rr)

254246

255247-- generalized tree balancing act

256248balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

257−balance c k v l r = balance_node (RBNode c k v l r)

249+balance c k v l r =

250+

251+ balance_node (RBNode c k v l r)

258252

259253blackish : Dict k v -> Bool

260−blackish (RBNode c _ _ _ _) = c == Black || c == BBlack

254+blackish t = case t of

255+ RBNode c _ _ _ _ -> c == Black || c == BBlack

256+ RBEmpty _ -> True

261257

262258balance_node : Dict k v -> Dict k v

263259balance_node t =

@@ -286,9 +282,7 @@ balance_node t =

286282 (RBNode Black _ _ _ _) ->

287283 RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)

288284 _ -> t

289−

290285 _ -> t

291−

292286 else t

293287

294288-- make the top node black

libraries/Native/JavaScript.js+1−1

@@ -34,7 +34,7 @@ Elm.Native.JavaScript.make = function(elm) {

3434

3535 function toJS(v) {

3636 var type = typeof v;

37− if (type === 'number' || type === 'boolean') return v;

37+ if (type === 'number' || type === 'boolean' || type === 'string') return v;

3838 if (type === 'object' && '_' in v) {

3939 var obj = {};

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

22(function() {

33'use strict';

44

5−Elm.fullscreen = function(module) {

5+Elm.fullscreen = function(module, ports) {

66 var style = document.createElement('style');

77 style.type = 'text/css';

88 style.innerHTML = "html,head,body { padding:0; margin:0; }" +

@@ -10,24 +10,24 @@ Elm.fullscreen = function(module) {

1010 document.head.appendChild(style);

1111 var container = document.createElement('div');

1212 document.body.appendChild(container);

13− return init(ElmRuntime.Display.FULLSCREEN, container, module);

13+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports || {});

1414};

1515

16−Elm.embed = function(module, container) {

16+Elm.embed = function(module, container, ports) {

1717 var tag = container.tagName;

1818 if (tag !== 'DIV') {

1919 throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');

2020 } else if (container.hasChildNodes()) {

2121 throw new Error('Elm.node must be given an empty DIV. No children allowed!');

2222 }

23− return init(ElmRuntime.Display.COMPONENT, container, module);

23+ return init(ElmRuntime.Display.COMPONENT, container, module, ports || {});

2424};

2525

26−Elm.worker = function(module) {

27− return init(ElmRuntime.Display.NONE, {}, module);

26+Elm.worker = function(module, ports) {

27+ return init(ElmRuntime.Display.NONE, {}, module, ports || {});

2828};

2929

30−function init(display, container, module, moduleToReplace) {

30+function init(display, container, module, ports, moduleToReplace) {

3131 // defining state needed for an instance of the Elm RTS

3232 var inputs = [];

3333

@@ -59,6 +59,10 @@ function init(display, container, module, moduleToReplace) {

5959 listeners.push(listener);

6060 }

6161

62+ var portUses = {}

63+ for (var key in ports) {

64+ portUses[key] = 0;

65+ }

6266 // create the actual RTS. Any impure modules will attach themselves to this

6367 // object. This permits many Elm programs to be embedded per document.

6468 var elm = {

@@ -67,34 +71,15 @@ function init(display, container, module, moduleToReplace) {

6771 display:display,

6872 id:ElmRuntime.guid(),

6973 addListener:addListener,

70− inputs:inputs

74+ inputs:inputs,

75+ ports: { incoming:ports, outgoing:{}, uses:portUses }

7176 };

7277

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−

9178 function swap(newModule) {

9279 removeListeners(listeners);

9380 var div = document.createElement('div');

94− var newElm = init(display, div, newModule, elm);

81+ var newElm = init(display, div, newModule, ports, elm);

9582 inputs = [];

96− // elm.send = newElm.send;

97− // elm.recv = newElm.recv;

9883 // elm.swap = newElm.swap;

9984 return newElm;

10085 }

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

10388 var reportAnyErrors = function() {};

10489 try {

10590 Module = module.make(elm);

91+ checkPorts(elm);

10692 } catch(e) {

10793 var directions = "<br/>    Open the developer console for more details."

10894 Module.main = Elm.Text.make(elm).text('<code>' + e.message + directions + '</code>');

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

11096 }

11197 inputs = ElmRuntime.filterDeadInputs(inputs);

11298 filterListeners(inputs, listeners);

99+ addReceivers(elm.ports.outgoing);

113100 if (display !== ElmRuntime.Display.NONE) {

114101 var graphicsNode = initGraphics(elm, Module);

115102 }

@@ -123,9 +110,27 @@ function init(display, container, module, moduleToReplace) {

123110 }

124111

125112 reportAnyErrors();

126− return { send:send, recv:recv, swap:swap };

113+ return { swap:swap, ports:elm.ports.outgoing };

127114};

128115

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+

129134function filterListeners(inputs, listeners) {

130135 loop:

131136 for (var i = listeners.length; i--; ) {

@@ -146,6 +151,57 @@ function removeListeners(listeners) {

146151 }

147152}

148153

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+

149205function initGraphics(elm, Module) {

150206 if (!('main' in Module))

151207 throw new Error("'main' is missing! What do I display?!");

runtime/Utils.js+8−8

@@ -34,18 +34,18 @@ ElmRuntime.filterDeadInputs = function(inputs) {

3434

3535// define the draw function

3636var vendors = ['ms', 'moz', 'webkit', 'o'];

37−var window = window || {};

38−for (var i = 0; i < vendors.length && !window.requestAnimationFrame; ++i) {

39− window.requestAnimationFrame = window[vendors[i]+'RequestAnimationFrame'];

40− window.cancelAnimationFrame = window[vendors[i]+'CancelAnimationFrame'] ||

41− window[vendors[i]+'CancelRequestAnimationFrame'];

37+var win = window || {};

38+for (var i = 0; i < vendors.length && !win.requestAnimationFrame; ++i) {

39+ win.requestAnimationFrame = win[vendors[i]+'RequestAnimationFrame'];

40+ win.cancelAnimationFrame = win[vendors[i]+'CancelAnimationFrame'] ||

41+ win[vendors[i]+'CancelRequestAnimationFrame'];

4242}

4343

44−if (window.requestAnimationFrame && window.cancelAnimationFrame) {

44+if (win.requestAnimationFrame && win.cancelAnimationFrame) {

4545 var previous = 0;

4646 ElmRuntime.draw = function(callback) {

47− window.cancelAnimationFrame(previous);

48− previous = window.requestAnimationFrame(callback);

47+ win.cancelAnimationFrame(previous);

48+ previous = win.requestAnimationFrame(callback);

4949 };

5050} else {

5151 ElmRuntime.draw = function(callback) { callback(); };

tests/Main.hs+7−18

@@ -1,22 +1,11 @@

11module Main where

22

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

84

9−main :: IO ()

10−main = do

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 }

5+import Tests.Compiler

6+import Tests.Property

207

21−ignoreDiff :: Diff

22−ignoreDiff _ _ = return Nothing

8+main :: IO ()

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.