be9baab · elk · git.iko.soy

Elm.cabal+4

compare with master

unifiedsplit

@@ -47,6 +47,8 @@ Library

47 SourceSyntax.PrettyPrint,

48 SourceSyntax.Type,

49 Generate.JavaScript,

50+ Generate.JavaScript.Helpers,

51+ Generate.JavaScript.Ports,

50 Generate.Noscript,

52 Generate.Noscript,

51 Generate.Markdown,

53 Generate.Markdown,

52 Generate.Html,

54 Generate.Html,

@@ -128,6 +130,8 @@ Executable elm

128 SourceSyntax.PrettyPrint,

130 SourceSyntax.PrettyPrint,

129 SourceSyntax.Type,

131 SourceSyntax.Type,

130 Generate.JavaScript,

132 Generate.JavaScript,

133+ Generate.JavaScript.Helpers,

134+ Generate.JavaScript.Ports,

131 Generate.Noscript,

135 Generate.Noscript,

132 Generate.Markdown,

136 Generate.Markdown,

133 Generate.Html,

137 Generate.Html,

compiler/Build/Dependencies.hs+46−42

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

1{-# OPTIONS_GHC -W #-}

2−module Build.Dependencies (getSortedDependencies) where

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

3

4import Control.Applicative

5import Control.Monad.Error

@@ -12,9 +12,9 @@ import qualified Data.Map as Map

12import qualified Data.Maybe as Maybe

13import qualified Data.Set as Set

14import System.Directory

15−import System.Exit

16import System.FilePath as FP

15import System.FilePath as FP

17−import System.IO

16+

17+import Build.Print (failure)

18

19import qualified SourceSyntax.Module as Module

20import qualified Parse.Parse as Parse

@@ -26,7 +26,7 @@ getSortedDependencies :: [FilePath] -> Module.Interfaces -> FilePath -> IO [Stri

26getSortedDependencies srcDirs builtIns root =

27 do extras <- extraDependencies

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

29− result <- runErrorT $ readDeps allSrcDirs builtIns root

29+ result <- runErrorT $ readAllDeps allSrcDirs builtIns root

30 case result of

31 Right deps -> sortDeps deps

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

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

34 Path.dependencyFile ++

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

36

37−failure msg = hPutStrLn stderr msg >> exitFailure

38−

39extraDependencies :: IO (Maybe [FilePath])

37extraDependencies :: IO (Maybe [FilePath])

40extraDependencies =

38extraDependencies =

41 do exists <- doesFileExist Path.dependencyFile

39 do exists <- doesFileExist Path.dependencyFile

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

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

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

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

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

78

76

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

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

80−readDeps srcDirs builtIns root = do

78+readAllDeps srcDirs builtIns root =

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

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

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

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

83 where

81 where

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

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

85 go builtIns root = do

83 go builtIns root = do

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

84+ root' <- lift $ findSrcFile srcDirs root

87− case Parse.dependencies txt of

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

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

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

90−

91− Right (name,deps) ->

92− do seen <- State.get

86+ seen <- State.get

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

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

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

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

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

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

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

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

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

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

98−

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+

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

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

100−getFile [] path =

102+findSrcFile dirs path = foldr tryDir notFound dirs

103+ where

101− throwError $ unlines

104+ notFound = throwError $ unlines

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

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

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

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

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

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

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

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

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

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

107−

110+ tryDir dir next = do

108−getFile (dir:dirs) path = do

109− let path' = dir </> path

111+ let path' = dir </> path

110− exists <- liftIO $ doesFileExist path'

112+ exists <- liftIO $ doesFileExist path'

111− case exists of

113+ if exists

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

114+ then return path'

113− False -> getFile dirs path

115+ else next

114−

116+

117+isNative :: String -> Bool

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

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

116

119

117toFilePath :: String -> FilePath

120toFilePath :: String -> FilePath

118toFilePath name = map swapDots name ++ ext

121toFilePath name = map swapDots name ++ ext

122+ where

119− where swapDots '.' = '/'

123+ swapDots '.' = '/'

120− swapDots c = c

124+ swapDots c = c

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

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

compiler/Build/File.hs+129−78

@@ -1,92 +1,137 @@

1{-# OPTIONS_GHC -W #-}

2module Build.File (build) where

3

4−import Control.Monad (when)

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

5−import qualified Data.Binary as Binary

5+import Control.Monad.Error (runErrorT)

6−import qualified Data.Map as Map

6+import Control.Monad.RWS.Strict

7import System.Directory

8import System.Exit

9import System.FilePath

10import System.IO

11

12+import qualified Data.Binary as Binary

13+import qualified Data.Maybe as Maybe

14+import qualified Data.Map as Map

15+import qualified Data.ByteString.Lazy as L

16+

17+import qualified Build.Dependencies as Deps

18+import qualified Build.Flags as Flag

19+import qualified Build.Interface as Interface

20+import qualified Build.Print as Print

21+import qualified Build.Source as Source

22+import qualified Build.Utils as Utils

23+import qualified Generate.JavaScript as JS

24+import qualified Parse.Module as Parser

25+import qualified SourceSyntax.Module as M

12import qualified Transform.Canonicalize as Canonical

26import qualified Transform.Canonicalize as Canonical

13

27

14−import qualified Data.ByteString.Lazy as L

28+-- Reader: Runtime flags, always accessible

15−

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

16−import qualified Build.Utils as Utils

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

17−import qualified Build.Flags as Flag

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

18−import qualified Build.Interface as Interface

32+type Build a = BuildT IO a

19−import qualified Build.Print as Print

33+

20−import qualified Build.Source as Source

34+-- Interfaces, remembering if something was recompiled

21−import qualified Generate.JavaScript as JS

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

22−import qualified Parse.Module as Parser

36+

23−import qualified SourceSyntax.Module as M

24−

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

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

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

38+evalBuild flags interfaces b = do

27−build _ _ interfaces moduleName [] =

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

28− return (moduleName, interfaces)

40+ return . getLast $ s

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

41+ where

30− do (name,interface) <-

42+ notUpdated i = (False, i)

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

43+

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

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

33− build flags numModules interfaces' name rest

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

34−

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

35−

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

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

48+

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

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

38−build1 flags moduleNum numModules interfaces filePath =

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

39− do compiled <- alreadyCompiled flags filePath

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

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

40− case compiled of

77+ case eDeps of

41− False -> compile flags number interfaces filePath

78+ -- Should never actually reach here

42− True -> retrieve flags interfaces filePath

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

43− where

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

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

81+

45−

82+

46−

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

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

84+

48−alreadyCompiled flags filePath = do

85+wasCompiled :: String -> Build Bool

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

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

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

87+

51− if not existsi || not existso

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

52− then return False

89+infixr 2 `orM`

53− else do tsrc <- getModificationTime filePath

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

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

91+orM m1 m2 = do b1 <- m1

55− return (tsrc <= tint)

92+ if b1

56−

93+ then return b1

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

94+ else m2

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

95+

59−retrieve flags interfaces filePath = do

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

60− iface <- Interface.load (Utils.elmi flags filePath)

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

61 case Interface.isValid filePath iface of

103 case Interface.isValid filePath iface of

62 Right (name, interface) ->

104 Right (name, interface) ->

105+ do binterfaces <- get

106+ let interfaces = snd <$> binterfaces

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

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

64− return (name, interface)

108+ update name interface False

109+

65− Left err ->

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

66− do hPutStrLn stderr err

111+

67− exitFailure

68−

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

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

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

71−compile flags number interfaces filePath =

113+compile number filePath =

114+ do flags <- ask

115+ binterfaces <- get

72− do source <- readFile filePath

116+ source <- liftIO $ readFile filePath

117+ let interfaces = snd <$> binterfaces

73− let name = getName source

118+ name = getName source

119+ liftIO $ do

74− printStatus name

120+ printStatus name

75−

76− createDirectoryIfMissing True (Flag.cache_dir flags)

121+ createDirectoryIfMissing True (Flag.cache_dir flags)

77− createDirectoryIfMissing True (Flag.build_dir flags)

122+ createDirectoryIfMissing True (Flag.build_dir flags)

78−

123+

79− metaModule <-

124+ metaModule <-

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

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

81 Right modul -> return modul

126 Right modul -> return modul

82 Left errors -> do Print.errors errors

127 Left errors -> do Print.errors errors

83 exitFailure

128 exitFailure

84

129

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

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

86−

131+

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

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

88− generateCache intermediate metaModule

133+ generateCache name newInters metaModule

89− return intermediate

134+ update name newInters True

90

135

91 where

136 where

92 getName source = case Parser.getModuleName source of

137 getName source = case Parser.getModuleName source of

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

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

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

99 , "( " ++ filePath ++ " )" ]

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

100

145

101− generateCache intermediate metaModule = do

146+ generateCache name interfs metaModule = do

147+ flags <- ask

148+ liftIO $ do

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

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

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

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

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

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

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

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

153+

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

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

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

compiler/Build/Print.hs+7−1

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

1module Build.Print where

2

3+import System.IO (hPutStrLn, stderr)

4+import System.Exit (exitFailure)

5+

3import qualified Data.Map as Map

6import qualified Data.Map as Map

4import qualified Data.List as List

7import qualified Data.List as List

5import qualified SourceSyntax.Module as M

8import qualified SourceSyntax.Module as M

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

29

32

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

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

31errors errs =

34errors errs =

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

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

36+

37+failure :: String -> IO a

38+failure msg = hPutStrLn stderr msg >> exitFailure

compiler/Compiler.hs+1−2

@@ -37,8 +37,7 @@ build flags rootFile =

37 then getSortedDependencies (Flag.src_dir flags) builtIns rootFile

38 else return [rootFile]

39

40− (moduleName, _) <-

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

40+ moduleName <- File.build flags builtIns files

42

41

43 js <- foldM appendToOutput BS.empty files

42 js <- foldM appendToOutput BS.empty files

44

43

compiler/Docs.hs+3−4

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

7import System.Exit

8import System.IO

9

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

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

11import Data.Aeson

12import Data.Aeson.Encode.Pretty

13import qualified Data.List as List

@@ -154,11 +154,10 @@ instance ToJSON Type where

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

155 Var x -> toJSON x

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

157− EmptyRecord -> object []

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

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

159 where fields' = case ext of

158 where fields' = case ext of

160− EmptyRecord -> fields

159+ Nothing -> fields

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

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

162

161

163ctorToJson tipe (ctor, tipes) =

162ctorToJson tipe (ctor, tipes) =

164 object [ "name" .= ctor

163 object [ "name" .= ctor

compiler/Generate/JavaScript.hs+18−36

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

8import qualified Data.Map as Map

9import qualified Data.Set as Set

10

11+import Generate.JavaScript.Helpers

11import qualified Generate.Cases as Case

12import qualified Generate.Cases as Case

13+import qualified Generate.JavaScript.Ports as Port

12import qualified Generate.Markdown as MD

14import qualified Generate.Markdown as MD

13import qualified SourceSyntax.Helpers as Help

15import qualified SourceSyntax.Helpers as Help

14import SourceSyntax.Literal

16import SourceSyntax.Literal

@@ -20,38 +22,15 @@ import Language.ECMAScript3.Syntax

20import Language.ECMAScript3.PrettyPrint

22import Language.ECMAScript3.PrettyPrint

21import qualified Transform.SafeNames as MakeSafe

23import qualified Transform.SafeNames as MakeSafe

22

24

23−split :: String -> [String]

24−split = go []

25− where

26− go vars str =

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

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

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

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

31−

32−var name = Id () name

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

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

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

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

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

38−call = CallExpr ()

39−string = StringLit ()

40−

41−dotSep vars =

42− case vars of

43− x:xs -> foldl (DotRef ()) (ref x) (map var xs)

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

45−

46−obj = dotSep . split

47−

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

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

49varDecl x expr =

26varDecl x expr =

50 VarDecl () (var x) (Just expr)

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

51

28

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

52include alias moduleName =

30include alias moduleName =

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

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

54

32

33+internalImports :: String -> Statement ()

55internalImports name =

34internalImports name =

56 VarDeclStmt ()

35 VarDeclStmt ()

57 [ varDecl "_N" (obj "Elm.Native")

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

@@ -155,7 +134,7 @@ expression (L span expr) =

155 do let (defs',e') = flattenLets defs e

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

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

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

157 exp <- expression e'

136 exp <- expression e'

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

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

159

138

160 MultiIf branches ->

139 MultiIf branches ->

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

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

@@ -199,13 +178,13 @@ expression (L span expr) =

199 GLShader _uid src _tipe ->

178 GLShader _uid src _tipe ->

200 return . literal $ Str src

179 return . literal $ Str src

201

180

202− PortIn name _ _ handler ->

181+ PortIn name tipe ->

203− do handler' <- expression handler

204− return $ obj "Native.Ports.portIn" `call` [ string name, handler' ]

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

205

183

206− PortOut name _ signal ->

184+ PortOut name tipe value ->

207− do signal' <- expression signal

185+ do value' <- expression value

208− return $ obj "Native.Ports.portOut" `call` [ string name, signal' ]

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

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

209

188

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

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

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

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

@@ -251,7 +230,7 @@ definition (Definition pattern expr@(L span _) _) = do

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

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

252 in definition $ Definition (PVar y) expr Nothing

231 in definition $ Definition (PVar y) expr Nothing

253

232

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

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

255match span mtch =

234match span mtch =

256 case mtch of

235 case mtch of

257 Case.Match name clauses mtch' ->

236 Case.Match name clauses mtch' ->

@@ -273,7 +252,7 @@ match span mtch =

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

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

274 Case.Other e ->

253 Case.Other e ->

275 do e' <- expression e

254 do e' <- expression e

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

255+ return [ ret e' ]

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

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

278 where

257 where

279 dropEnd acc [] = acc

258 dropEnd acc [] = acc

@@ -282,6 +261,7 @@ match span mtch =

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

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

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

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

284

263

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

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

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

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

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

287 where

267 where

@@ -296,6 +276,7 @@ clause span variable (Case.Clause value vars mtch) =

296 [] -> name

276 [] -> name

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

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

298

278

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

299flattenLets defs lexpr@(L _ expr) =

280flattenLets defs lexpr@(L _ expr) =

300 case expr of

281 case expr of

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

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

@@ -311,13 +292,13 @@ generate unsafeModule =

311 programStmts =

292 programStmts =

312 concat

293 concat

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

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

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

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

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

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

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

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

317 , [ assign ["_op"] (ObjectLit () []) ]

298 , [ assign ["_op"] (ObjectLit () []) ]

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

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

319 , [ jsExports ]

300 , [ jsExports ]

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

301+ , [ ret thisModule ]

321 ]

302 ]

322

303

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

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

@@ -343,6 +324,7 @@ generate unsafeModule =

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

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

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

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

345

326

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

346binop span op e1 e2 =

328binop span op e1 e2 =

347 case op of

329 case op of

348 "Basics.." ->

330 "Basics.." ->

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/Parse/Declaration.hs+2−3

@@ -59,6 +59,5 @@ port =

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.PortAnnotation Type.expr

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

63− , port' (string "<-") D.SendDefinition Expr.expr

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

64− , port' (string "->") D.RecvDefinition Expr.expr ]

compiler/Parse/Helpers.hs−1

@@ -7,7 +7,6 @@ import Control.Monad

7import Control.Monad.State

8import Data.Char (isUpper)

9import qualified Data.Set as Set

10−import Data.Map (Map)

11import qualified Data.Map as Map

10import qualified Data.Map as Map

12import qualified Language.GLSL.Parser as GLP

11import qualified Language.GLSL.Parser as GLP

13import Language.GLSL.Syntax

12import Language.GLSL.Syntax

compiler/Parse/Type.hs+7−7

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

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

2module Parse.Type where

3

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

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

5import Data.List (intercalate)

6import Text.Parsec

7

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

23record :: IParser T.Type

24record =

25 do char '{' ; whitespace

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

26+ rcrd <- extended <|> normal

27 dumbWhitespace ; char '}'

28− return (T.Record fs ext)

28+ return rcrd

29 where

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

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

31

32 -- extended record types require at least one field

33 extended = do

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

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

35 whitespace

36− (,) ext <$> commaSep1 fields

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

37

38− fields = do

38+ field = do

39 lbl <- rLabel

40 whitespace >> hasType >> whitespace

41 (,) lbl <$> expr

compiler/SourceSyntax/Declaration.hs+10−14

@@ -22,14 +22,13 @@ data Derivation = Json | JS | Binary | New

22 deriving (Eq, Show)

23

24data ParsePort

25− = PortAnnotation String T.Type

25+ = PPAnnotation String T.Type

26− | SendDefinition String Expr.LParseExpr

27− | RecvDefinition String Expr.LParseExpr

26+ | PPDef String Expr.LParseExpr

28 deriving (Show)

27 deriving (Show)

29

28

30data Port

29data Port

31− = Send String Expr.LExpr T.Type

30+ = Out String Expr.LExpr T.Type

32− | Recv String Expr.LExpr T.Type

31+ | In String T.Type

33 deriving (Show)

32 deriving (Show)

34

33

35type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

34type ParseDeclaration = Declaration' ParsePort Expr.ParseDef

@@ -100,19 +99,16 @@ instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where

100instance Pretty ParsePort where

99instance Pretty ParsePort where

101 pretty port =

100 pretty port =

102 case port of

101 case port of

103− PortAnnotation name tipe -> prettyPort name ":" tipe

102+ PPAnnotation name tipe -> prettyPort name ":" tipe

104− SendDefinition name expr -> prettyPort name "<-" expr

105− RecvDefinition name expr -> prettyPort name "->" expr

103+ PPDef name expr -> prettyPort name "=" expr

106

104

107instance Pretty Port where

105instance Pretty Port where

108 pretty port =

106 pretty port =

109 case port of

107 case port of

110− Send name expr tipe -> mkPort "<-" name expr tipe

108+ In name tipe -> prettyPort name ":" tipe

111− Recv name expr tipe -> mkPort "->" name expr tipe

112− where

113− mkPort arrow name expr tipe =

114− P.vcat [ prettyPort name ":" tipe

109+ Out name expr tipe -> P.vcat [ prettyPort name ":" tipe

115− , prettyPort name arrow expr ]

110+ , prettyPort name "=" expr ]

111+

116

112

117prettyPort :: (Pretty a) => String -> String -> a -> Doc

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

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

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

compiler/SourceSyntax/Expression.hs+46−29

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

1{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Expression where

3+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.

4+The first is the fully general version and is labeled with a prime (Expr').

5+The others are specialized versions of the AST that represent specific phases

6+of the compilation process. I expect there to be more phases as we begin to

7+enrich the AST with more information.

8+-}

9+

3

10

4import SourceSyntax.PrettyPrint

11import SourceSyntax.PrettyPrint

5import Text.PrettyPrint as P

12import Text.PrettyPrint as P

@@ -8,25 +15,23 @@ import qualified SourceSyntax.Location as Location

8import qualified SourceSyntax.Pattern as Pattern

15import qualified SourceSyntax.Pattern as Pattern

9import qualified SourceSyntax.Type as SrcType

16import qualified SourceSyntax.Type as SrcType

10import qualified SourceSyntax.Literal as Literal

17import qualified SourceSyntax.Literal as Literal

11−import qualified Type.Type as Type

12

18

19+---- GENERAL AST ----

20+

13−{-| This is a located expression. -}

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

14type LExpr' def = Location.Located (Expr' def)

25type LExpr' def = Location.Located (Expr' def)

15

26

16−{-| This is a fully general expression. The compilation process will enrich

27+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has

17−this data structure with additional information after the initial parse.

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

18−The type holes let us reflect these structural changes in the types.

30+structural changes in the types. The only type hole right now is:

19

31

20 def: Parsing allows two kinds of definitions (type annotations or definitions),

32 def: Parsing allows two kinds of definitions (type annotations or definitions),

21 but later checks will see that they are well formed and combine them.

33 but later checks will see that they are well formed and combine them.

22

34

23− t: for adding type information, currently unused

24−

25− v: for enriching variables with information like provenonce, currently unused

26−

27−Please don't get on my case to take the unused ones out. I have considered it.

28−It's a huge pain to add and remove, it will get used eventually, and it's not

29−hurting anything as it is.

30-}

35-}

31data Expr' def

36data Expr' def

32 = Literal Literal.Literal

37 = Literal Literal.Literal

@@ -47,29 +52,38 @@ data Expr' def

47 | Record [(String, LExpr' def)]

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

48 | Markdown String String [LExpr' def]

53 | Markdown String String [LExpr' def]

49 -- for type checking and code gen only

54 -- for type checking and code gen only

50− | PortIn String SrcType.Type Type.Variable (LExpr' def)

55+ | PortIn String SrcType.Type

51 | PortOut String SrcType.Type (LExpr' def)

56 | PortOut String SrcType.Type (LExpr' def)

52 | GLShader String String Literal.GLShaderTipe

57 | GLShader String String Literal.GLShaderTipe

53

58

59+

60+---- SPECIALIZED ASTs ----

61+

62+{-| Expressions created by the parser. These use a split representation of type

63+annotations and definitions, which is how they appear in source code and how

64+they are parsed.

65+-}

54type ParseExpr = Expr' ParseDef

66type ParseExpr = Expr' ParseDef

55type LParseExpr = LExpr' ParseDef

67type LParseExpr = LExpr' ParseDef

56−type LExpr = LExpr' Def

57−type Expr = Expr' Def

58

68

59−{-| Style of definitions as they are parsed. Users specify them

60−separately, and other checks will make sure they can be combined.

61−-}

62data ParseDef

69data ParseDef

63 = Def Pattern.Pattern LParseExpr

70 = Def Pattern.Pattern LParseExpr

64 | TypeAnnotation String SrcType.Type

71 | TypeAnnotation String SrcType.Type

65 deriving (Show)

72 deriving (Show)

66

73

67−{-| After checking that type annotations and definitions are all

74+{-| "Normal" expressions. When the compiler checks that type annotations and

68−valid, they can be combined.

75+ports are all paired with definitions in the appropriate order, it collapses

76+them into a Def that is easier to work with in later phases of compilation.

69-}

77-}

78+type LExpr = LExpr' Def

79+type Expr = Expr' Def

80+

70−data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)

81+data Def = Definition Pattern.Pattern LExpr (Maybe SrcType.Type)

71 deriving (Show)

82 deriving (Show)

72

83

84+

85+---- UTILITIES ----

86+

73tuple :: [LExpr' def] -> Expr' def

87tuple :: [LExpr' def] -> Expr' def

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

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

75

89

@@ -98,8 +112,10 @@ instance Pretty def => Pretty (Expr' def) where

98 P.text "-" <> prettyParens e

112 P.text "-" <> prettyParens e

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

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

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

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

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

116+ where

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

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

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

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

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

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

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

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

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

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

@@ -115,7 +131,9 @@ instance Pretty def => Pretty (Expr' def) where

115 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

131 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

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

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

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

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

134+ Data name es

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

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

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

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

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

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

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

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

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

@@ -139,7 +157,7 @@ instance Pretty def => Pretty (Expr' def) where

139

157

140 GLShader _ _ _ -> P.text "[glShader| ... |]"

158 GLShader _ _ _ -> P.text "[glShader| ... |]"

141

159

142− PortIn _ _ _ handler -> pretty handler

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

143

161

144 PortOut _ _ signal -> pretty signal

162 PortOut _ _ signal -> pretty signal

145

163

@@ -166,12 +184,11 @@ collectApps lexpr@(Location.L _ expr) =

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

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

167 _ -> [lexpr]

185 _ -> [lexpr]

168

186

169−collectLambdas :: LExpr' def -> ([Doc], LExpr' def)

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

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

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

171 case expr of

189 case expr of

172− Lambda pattern body ->

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

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

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

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

175 _ -> ([], lexpr)

192 _ -> ([], lexpr)

176

193

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

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

compiler/SourceSyntax/Pattern.hs+3−3

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

1{-# OPTIONS_GHC -Wall #-}

2module SourceSyntax.Pattern where

3

4−import SourceSyntax.Helpers as Help

4+import qualified SourceSyntax.Helpers as Help

5import SourceSyntax.PrettyPrint

6import Text.PrettyPrint as PP

7import qualified Data.Set as Set

@@ -51,7 +51,7 @@ instance Pretty Pattern where

51 PData "::" _ -> True

52 _ -> False

53 PData name ps ->

54− if isTuple name then

54+ if Help.isTuple name then

55 PP.parens . commaCat $ map pretty ps

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

57

@@ -60,6 +60,6 @@ prettyParens pattern = parensIf needsThem (pretty pattern)

60 where

61 needsThem =

62 case pattern of

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

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

64 PAlias _ _ -> True

65 _ -> False

compiler/SourceSyntax/Type.hs+18−27

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

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2module SourceSyntax.Type where

3

4import Data.Binary

@@ -11,8 +11,7 @@ import Text.PrettyPrint as P

11data Type = Lambda Type Type

12 | Var String

13 | Data String [Type]

14− | EmptyRecord

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

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

16 deriving (Eq, Show)

15 deriving (Eq, Show)

17

16

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

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

@@ -20,7 +19,7 @@ fieldMap fields =

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

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

21

20

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

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

23−recordOf fields = Record fields EmptyRecord

22+recordOf fields = Record fields Nothing

24

23

25listOf :: Type -> Type

24listOf :: Type -> Type

26listOf t = Data "_List" [t]

25listOf t = Data "_List" [t]

@@ -33,35 +32,30 @@ instance Pretty Type where

33 pretty tipe =

32 pretty tipe =

34 case tipe of

33 case tipe of

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

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

35+ where

36− where t:ts = collectLambdas tipe

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

37+ prettyLambda t = case t of

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

39+ _ -> pretty t

40+

37 Var x -> P.text x

41 Var x -> P.text x

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

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

39 Data name tipes

43 Data name tipes

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

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

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

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

42− EmptyRecord -> P.braces P.empty

46+ Record fields ext ->

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

47+ P.braces $ case ext of

44− EmptyRecord -> prettyFields

48+ Nothing -> prettyFields

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

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

46 where

50 where

47− (fields, ext) = collectRecords tipe

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

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

49 prettyFields = commaSep . map prettyField $ fields

52 prettyFields = commaSep . map prettyField $ fields

50

53

51−collectLambdas :: Type -> [Doc]

54+collectLambdas :: Type -> [Type]

52collectLambdas tipe =

55collectLambdas tipe =

53 case tipe of

56 case tipe of

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

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

57+ Lambda arg body -> arg : collectLambdas body

56− _ -> [pretty tipe]

58+ _ -> [tipe]

57−

58−collectRecords :: Type -> ([(String,Type)], Type)

59−collectRecords = go []

60− where

61− go fields tipe =

62− case tipe of

63− Record fs ext -> go (fs ++ fields) ext

64− _ -> (fields, tipe)

65

59

66prettyParens :: Type -> Doc

60prettyParens :: Type -> Doc

67prettyParens tipe = parensIf needed (pretty tipe)

61prettyParens tipe = parensIf needed (pretty tipe)

@@ -83,10 +77,8 @@ instance Binary Type where

83 putWord8 1 >> put x

77 putWord8 1 >> put x

84 Data ctor tipes ->

78 Data ctor tipes ->

85 putWord8 2 >> put ctor >> put tipes

79 putWord8 2 >> put ctor >> put tipes

86− EmptyRecord ->

87− putWord8 3

88 Record fs ext ->

80 Record fs ext ->

89− putWord8 4 >> put fs >> put ext

81+ putWord8 3 >> put fs >> put ext

90

82

91 get = do

83 get = do

92 n <- getWord8

84 n <- getWord8

@@ -94,6 +86,5 @@ instance Binary Type where

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

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

95 1 -> Var <$> get

87 1 -> Var <$> get

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

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

97− 3 -> return EmptyRecord

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

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

99 _ -> error "Error reading a valid type from serialized string"

90 _ -> error "Error reading a valid type from serialized string"

compiler/Transform/Canonicalize.hs+4−9

@@ -4,6 +4,7 @@ module Transform.Canonicalize (interface, metadataModule) where

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

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

6import Control.Monad.Identity

7+import qualified Data.Traversable as T

7import qualified Data.Map as Map

8import qualified Data.Map as Map

8import qualified Data.Set as Set

9import qualified Data.Set as Set

9import qualified Data.List as List

10import qualified Data.List as List

@@ -46,8 +47,7 @@ renameType renamer tipe =

46 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

47 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

47 Type.Var _ -> return tipe

48 Type.Var _ -> return tipe

48 Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

49 Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

49− Type.EmptyRecord -> return tipe

50− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

51 where rnm' (f,t) = (,) f <$> rnm t

52

53metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

@@ -150,9 +150,7 @@ rename env (L s expr) =

150 rename' (Definition p body mtipe) =

151 Definition <$> format (renamePattern env' p)

152 <*> rename env' body

153− <*> case mtipe of

154− Nothing -> return Nothing

155− Just tipe -> Just <$> renameType' env' tipe

153+ <*> T.traverse (renameType' env') mtipe

156

154

157 Var x -> Var <$> format (replace "variable" env x)

155 Var x -> Var <$> format (replace "variable" env x)

158

156

@@ -167,10 +165,7 @@ rename env (L s expr) =

167

165

168 Markdown uid md es -> Markdown uid md <$> mapM rnm es

166 Markdown uid md es -> Markdown uid md <$> mapM rnm es

169

167

170− PortIn name st tt handler ->

171− do st' <- renameType' env st

168+ PortIn name st -> PortIn name <$> renameType' env st

172− handler' <- rnm handler

173− return $ PortIn name st' tt handler'

174

169

175 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

170 PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

176

171

compiler/Transform/Check.hs+8−7

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

1{-# OPTIONS_GHC -Wall #-}

2module Transform.Check (mistakes) where

3

4+import qualified Control.Arrow as Arrow

4import qualified Data.List as List

5import qualified Data.List as List

5import qualified Data.Maybe as Maybe

6import qualified Data.Maybe as Maybe

6import qualified Data.Set as Set

7import qualified Data.Set as Set

@@ -44,10 +45,11 @@ duplicates decls =

44 unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45 unzip [ (pat,expr) | D.Definition (E.Definition pat expr _) <- decls ]

45

46

46 (portNames, portExprs) =

47 (portNames, portExprs) =

48+ Arrow.second concat $ unzip $

47− unzip $ flip map [ port | D.Port port <- decls ] $ \port ->

49+ flip map [ port | D.Port port <- decls ] $ \port ->

48 case port of

50 case port of

49− D.Send name expr _ -> (name,expr)

51+ D.Out name expr _ -> (name, [expr])

50− D.Recv name expr _ -> (name,expr)

52+ D.In name _ -> (name, [])

51

53

52 getNames = Set.toList . Pattern.boundVars

54 getNames = Set.toList . Pattern.boundVars

53

55

@@ -100,8 +102,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

100 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

102 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

101 T.Var x -> Set.singleton x

103 T.Var x -> Set.singleton x

102 T.Data _ ts -> Set.unions (map freeVars ts)

104 T.Data _ ts -> Set.unions (map freeVars ts)

103− T.EmptyRecord -> Set.empty

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

105

107

106 undeclared tvars tipes = Set.difference used declared

108 undeclared tvars tipes = Set.difference used declared

107 where

109 where

@@ -145,8 +147,7 @@ infiniteTypeAliases decls =

145 T.Lambda a b -> infinite a || infinite b

147 T.Lambda a b -> infinite a || infinite b

146 T.Var _ -> False

148 T.Var _ -> False

147 T.Data name' ts -> name == name' || any infinite ts

149 T.Data name' ts -> name == name' || any infinite ts

148− T.EmptyRecord -> False

149− T.Record fields ext -> infinite ext || any (infinite . snd) fields

150+ T.Record fields _ -> any (infinite . snd) fields

150

151

151 indented :: D.Declaration -> Doc

152 indented :: D.Declaration -> Doc

152 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

153 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

compiler/Transform/Declaration.hs+5−9

@@ -52,16 +52,12 @@ combineAnnotations = go

52 -- combine ports

53 Port port : portRest ->

54 case port of

55− SendDefinition name _ -> Left (msg name)

56− RecvDefinition name _ -> Left (msg name)

55+ PPDef name _ -> Left (msg name)

57− PortAnnotation name tipe ->

56+ PPAnnotation name tipe ->

58 case portRest of

57 case portRest of

59− Port (SendDefinition name' expr) : rest | name == name' ->

58+ Port (PPDef name' expr) : rest | name == name' ->

60 do expr' <- exprCombineAnnotations expr

59 do expr' <- exprCombineAnnotations expr

61− (:) (Port (Send name expr' tipe)) <$> go rest

60+ (:) (Port (Out name expr' tipe)) <$> go rest

62

61

63− Port (RecvDefinition name' expr) : rest | name == name' ->

64− do expr' <- exprCombineAnnotations expr

65− (:) (Port (Recv name expr' tipe)) <$> go rest

62+ _ -> (:) (Port (In name tipe)) <$> go portRest

66

63

67− _ -> Left (msg name)

compiler/Transform/Expression.hs+6−7

@@ -5,12 +5,11 @@ import Control.Applicative ((<$>),(<*>))

5import SourceSyntax.Expression

6import SourceSyntax.Location

7import qualified SourceSyntax.Type as ST

8−import qualified Type.Type as TT

9

8

10crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

9crawlLet :: ([def] -> Either a [def']) -> LExpr' def -> Either a (LExpr' def')

11−crawlLet = crawl (\_ _ _ -> return ()) (\_ _ -> return ())

10+crawlLet = crawl (\_ _ -> return ()) (\_ _ -> return ())

12

11

13−checkPorts :: (String -> ST.Type -> TT.Variable -> Either a ())

12+checkPorts :: (String -> ST.Type -> Either a ())

14 -> (String -> ST.Type -> Either a ())

13 -> (String -> ST.Type -> Either a ())

15 -> LExpr

14 -> LExpr

16 -> Either a LExpr

15 -> Either a LExpr

@@ -21,7 +20,7 @@ checkPorts inCheck outCheck expr =

21 do _ <- checkPorts inCheck outCheck body

20 do _ <- checkPorts inCheck outCheck body

22 return def

21 return def

23

22

24−crawl :: (String -> ST.Type -> TT.Variable -> Either a ())

23+crawl :: (String -> ST.Type -> Either a ())

25 -> (String -> ST.Type -> Either a ())

24 -> (String -> ST.Type -> Either a ())

26 -> ([def] -> Either a [def'])

25 -> ([def] -> Either a [def'])

27 -> LExpr' def

26 -> LExpr' def

@@ -49,9 +48,9 @@ crawl portInCheck portOutCheck defsTransform = go

49 Markdown uid md es -> Markdown uid md <$> mapM go es

48 Markdown uid md es -> Markdown uid md <$> mapM go es

50 Let defs body -> Let <$> defsTransform defs <*> go body

49 Let defs body -> Let <$> defsTransform defs <*> go body

51 GLShader uid src gltipe -> return $ GLShader uid src gltipe

50 GLShader uid src gltipe -> return $ GLShader uid src gltipe

52− PortIn name st tt handler ->

51+ PortIn name st ->

53− do portInCheck name st tt

52+ do portInCheck name st

54− PortIn name st tt <$> go handler

53+ return $ PortIn name st

55 PortOut name st signal ->

54 PortOut name st signal ->

56 do portOutCheck name st

55 do portOutCheck name st

57 PortOut name st <$> go signal

56 PortOut name st <$> go signal

compiler/Transform/SafeNames.hs+1−1

@@ -50,7 +50,7 @@ expression (L loc expr) =

50 Record fs -> Record (map (var *** f) fs)

51 Markdown uid md es -> Markdown uid md (map f es)

52 GLShader _ _ _ -> expr

53− PortIn name st tt handler -> PortIn name st tt (f handler)

53+ PortIn name st -> PortIn name st

54 PortOut name st signal -> PortOut name st (f signal)

55

56definition :: Def -> Def

compiler/Transform/SortDefinitions.hs+1−1

@@ -87,7 +87,7 @@ reorder (L s expr) =

87

88 PortOut name st signal -> PortOut name st <$> reorder signal

89

90− PortIn name st tt handler -> PortIn name st tt <$> reorder handler

90+ PortIn name st -> return $ PortIn name st

91

92 -- Actually do some reordering

93 Let defs body ->

compiler/Transform/Substitute.hs+1−1

@@ -39,5 +39,5 @@ subst old new expr =

39 Literal _ -> expr

40 Markdown uid md es -> Markdown uid md (map f es)

41 GLShader _ _ _ -> expr

42− PortIn name st tt handler -> PortIn name st tt (f handler)

42+ PortIn name st -> PortIn name st

43 PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Alias.hs+14−14

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Alias (realias, rules, canonicalRealias, Rules) where

2module Type.Alias (realias, rules, canonicalRealias, Rules) where

2

3

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

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

@@ -30,10 +31,9 @@ localizer moduleImports = go

30 go tipe =

31 go tipe =

31 case tipe of

32 case tipe of

32 Var _ -> tipe

33 Var _ -> tipe

33− EmptyRecord -> tipe

34 Lambda t1 t2 -> Lambda (go t1) (go t2)

35 Data name ts -> Data (localize name) (map go ts)

36− Record fs ext -> Record (map (second go) fs) (go ext)

36+ Record fs ext -> Record (map (second go) fs) ext

37

38 byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

39 Map.empty moduleImports

@@ -83,10 +83,9 @@ canonicalRealias aliases tipe =

83 tipe' =

84 case tipe of

85 Var _ -> tipe

86− EmptyRecord -> tipe

87 Lambda t1 t2 -> Lambda (f t1) (f t2)

86 Lambda t1 t2 -> Lambda (f t1) (f t2)

88 Data name ts -> Data name (map f ts)

87 Data name ts -> Data name (map f ts)

89− Record fs ext -> Record (map (second f) fs) (f ext)

88+ Record fs ext -> Record (map (second f) fs) ext

90

89

91allEqual [] = True

90allEqual [] = True

92allEqual (x:xs) = all (==x) xs

91allEqual (x:xs) = all (==x) xs

@@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

102 Lambda t1 t2 -> numFields t1 + numFields t2

101 Lambda t1 t2 -> numFields t1 + numFields t2

103 Var _ -> 0

102 Var _ -> 0

104 Data _ ts -> sum (map numFields ts)

103 Data _ ts -> sum (map numFields ts)

105− EmptyRecord -> 0

106− Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext

104+ Record fields _ -> length fields + sum (map (numFields . snd) fields)

107

105

108diff :: Type -> Type -> Maybe [(String,Type)]

106diff :: Type -> Type -> Maybe [(String,Type)]

109diff general specific =

107diff general specific =

@@ -113,11 +111,11 @@ diff general specific =

113 (Data gname gts, Data sname sts)

111 (Data gname gts, Data sname sts)

114 | gname == sname && length gts == length sts ->

112 | gname == sname && length gts == length sts ->

115 concat <$> zipWithM diff gts sts

113 concat <$> zipWithM diff gts sts

116− (EmptyRecord, EmptyRecord) -> Just []

114+ (Record [] Nothing, Record [] Nothing) -> Just []

117− (Record _ _, Record _ _) ->

115+ (Record _ _, Record [] Nothing) -> Nothing

118− let (gfs,gext) = collectRecords general

116+ (Record [] Nothing, Record _ _) -> Nothing

119− (sfs,sext) = collectRecords specific

117+ (Record gfs gext, Record sfs sext) ->

120− gfields = collectFields gfs

118+ let gfields = collectFields gfs

121 sfields = collectFields sfs

119 sfields = collectFields sfs

122

120

123 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

121 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

@@ -126,10 +124,12 @@ diff general specific =

126 case isAligned of

124 case isAligned of

127 False -> Nothing

125 False -> Nothing

128 True -> let remaining = Map.difference sfields gfields

126 True -> let remaining = Map.difference sfields gfields

127+ sext' = case sext of

129− sext' = if Map.null remaining then sext else

128+ Just x | Map.null remaining -> Var x

130− Record (flattenFields remaining) sext

129+ _ -> Record (flattenFields remaining) sext

130+ gext' = maybe (Record [] Nothing) Var gext

131 matchMap = Map.intersectionWith (zipWith diff) gfields sfields

132− in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))

132+ in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))

133 (_,_) -> Nothing

134

135collectFields fields =

compiler/Type/Constrain/Declaration.hs+6−12

@@ -6,8 +6,6 @@ import qualified SourceSyntax.Expression as E

6import qualified SourceSyntax.Location as L

7import qualified SourceSyntax.Pattern as P

8import qualified SourceSyntax.Type as T

9−import qualified Type.Type as Type

10−import System.IO.Unsafe

11

9

12toExpr :: [Declaration] -> [E.Def]

10toExpr :: [Declaration] -> [E.Def]

13toExpr = concatMap toDefs

11toExpr = concatMap toDefs

@@ -28,17 +26,15 @@ toDefs decl =

28 TypeAlias name _ tipe@(T.Record fields ext) _ ->

26 TypeAlias name _ tipe@(T.Record fields ext) _ ->

29 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

27 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

30 where

28 where

31− args = case ext of

29+ args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

32− T.EmptyRecord -> map snd fields

33− _ -> map snd fields ++ [ext]

34

30

35 var = L.none . E.Var

31 var = L.none . E.Var

36 vars = take (length args) arguments

32 vars = take (length args) arguments

37

33

38 efields = zip (map fst fields) (map var vars)

34 efields = zip (map fst fields) (map var vars)

39 record = case ext of

35 record = case ext of

40− T.EmptyRecord -> L.none $ E.Record efields

36+ Nothing -> L.none $ E.Record efields

41− _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

37+ Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

42

38

43 -- Type aliases must be added to an extended equality dictionary,

39 -- Type aliases must be added to an extended equality dictionary,

44 -- but they do not require any basic constraints.

40 -- but they do not require any basic constraints.

@@ -47,12 +43,10 @@ toDefs decl =

47

43

48 Port port ->

44 Port port ->

49 case port of

45 case port of

50− Send name expr@(L.L s _) tipe ->

46+ Out name expr@(L.L s _) tipe ->

51 [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

47 [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

52− Recv name expr@(L.L s _) tipe ->

48+ In name tipe ->

53− unsafePerformIO $ do

54− tvar <- Type.var Type.Flexible

55− return $ [ definition name (L.L s $ E.PortIn name tipe tvar expr) tipe ]

49+ [ definition name (L.none $ E.PortIn name tipe) tipe ]

56

50

57 -- no constraints are needed for fixity declarations

51 -- no constraints are needed for fixity declarations

58 Fixity _ _ _ -> []

52 Fixity _ _ _ -> []

compiler/Type/Constrain/Expression.hs+1−2

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

156 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

157 (c1 /\ c))

158

159− PortIn _ _ tt handler ->

159+ PortIn _ _ -> return true

160− constrain env handler (VarN tt)

161

160

162 PortOut _ _ signal ->

161 PortOut _ _ signal ->

163 constrain env signal tipe

162 constrain env signal tipe

compiler/Type/Environment.hs+6−4

@@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType

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

163 name ++ "' while checking types."

164

165− Src.EmptyRecord -> return (TermN EmptyRecord1)

166−

167− Src.Record fields ext ->

165+ Src.Record fields ext -> do

168− TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)

166+ fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

167+ ext' <- case ext of

168+ Nothing -> return $ TermN EmptyRecord1

169+ Just x -> go (Src.Var x)

170+ return $ TermN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs+59−60

@@ -14,12 +14,12 @@ import qualified Type.State as TS

14import qualified Type.Alias as Alias

15import Text.PrettyPrint as P

16import SourceSyntax.PrettyPrint (pretty)

17+import qualified SourceSyntax.Helpers as Help

17import qualified SourceSyntax.Type as T

18import qualified SourceSyntax.Type as T

18import qualified SourceSyntax.Expression as E

19import qualified SourceSyntax.Expression as E

19import qualified SourceSyntax.Location as L

20import qualified SourceSyntax.Location as L

20import qualified Transform.Expression as Expr

21import qualified Transform.Expression as Expr

21import qualified Data.Traversable as Traverse

22import qualified Data.Traversable as Traverse

22−import System.IO.Unsafe

23

24throw err = Left [ P.vcat err ]

25

@@ -43,70 +43,69 @@ mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env

43 , P.nest 4 . pretty $ Alias.realias rules mainType

44 , P.text " " ]

45

46+data Direction = In | Out

47+

46portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

48portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

47portTypes rules expr =

49portTypes rules expr =

48− const () <$> Expr.checkPorts checkIn checkOut expr

50+ const () <$> Expr.checkPorts (check In) (check Out) expr

49 where

51 where

50− showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

52+ check = isValid False False

51−

53+ isValid seenFunc seenSignal direction name tipe =

52− checkIn name st tt =

54+ let valid = isValid seenFunc seenSignal direction name in

53− do t <- getSignal name st

54− case unsafePerformIO (toSrcType tt) of

55− T.Lambda a b ->

56− do isJsType "coming in" name a

57− if b `elem` okayTypes then return () else throw msg

58− where

59− okayTypes = [ t

60− , T.Data "Maybe.Maybe" [t]

61− , T.Data "Either.Either" [T.Data "String.String" [], t]

62− ]

63− msg = [ P.text $ "Type Error: the handler for port '" ++ name ++

64− "' returns values of type:\n"

65− , showType b

66− , P.text $ "but the port's type annotation requires that the handler returns values"

67− , P.text $ "with one of the following types:\n"

68− ] ++ map showType okayTypes ++

69− [ P.text "If the handler returns a Maybe or Either, invalid values will cause an"

70− , P.text "error to be thrown to the JS error handler associated with this port." ]

71−

72− tipe ->

73− throw [ P.text $ "Type Error: the handler for port '" ++ name ++

74− "' must be a function!"

75− , P.text "Instead it was given a value of type:\n"

76− , showType tipe

77− ]

78−

79− checkOut name st =

80− do t <- getSignal name st

81− isJsType "sent out" name t

82−

83− getSignal name tipe =

84− case tipe of

85− T.Data "Signal.Signal" [t] -> return t

86− _ -> throw [ P.text $ "Type Error: port '" ++ name ++ "' must be a Signal,"

87− , P.text $ "but the type annotation says it has non-Signal type:\n"

88− , showType tipe

89− , P.text $ "Maybe instead you want the following type?\n"

90− , showType (T.Data "Signal.Signal" [tipe])

91− ]

92−

93− isJsType msg name tipe =

94 case tipe of

55 case tipe of

95− T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts

56+ T.Data ctor ts

96− | otherwise -> throw $ err msg "Elm values"

57+ | isJs ctor || isElm ctor -> mapM_ valid ts

58+ | ctor == "Signal.Signal" -> handleSignal ts

59+ | otherwise -> err' True "an unsupported type"

60+

97− T.Var _ -> throw $ err msg "type variables"

61+ T.Var _ -> err "free type variables"

62+

98− T.Lambda _ _ -> throw $ err msg "Elm functions"

63+ T.Lambda _ _ ->

99− T.EmptyRecord -> throw $ err msg "Elm records"

64+ case direction of

100− T.Record _ _ -> throw $ err msg "Elm records"

65+ In -> err "functions"

66+ Out | seenFunc -> err "higher-order functions"

67+ | seenSignal -> err "signals that contain functions"

68+ | otherwise ->

69+ mapM_ (isValid True seenSignal direction name) (T.collectLambdas tipe)

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+

101 where

76 where

77+ isJs ctor =

102− okay ctor = and [ List.isPrefixOf "JavaScript." ctor

78+ List.isPrefixOf "JavaScript." ctor

103− , 1 == length (filter (=='.') ctor) ]

79+ && length (filter (=='.') ctor) == 1

104−

80+

105− err msg kind =

81+ isElm ctor =

106− [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++

82+ ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List"]

107− "' must be JavaScript values."

83+ || Help.isTuple ctor

108− , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"

84+

109− , showType tipe

85+ handleSignal ts

86+ | seenFunc = err "functions that involve signals"

87+ | seenSignal = err "signals-of-signals"

88+ | otherwise = mapM_ (isValid seenFunc True direction name) ts

89+

90+ dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

91+ txt = P.text . concat

92+

93+ err = err' False

94+ err' couldBeAlias kind =

95+ throw $

96+ [ txt [ "Type Error: the value ", dir "coming in" "sent out"

97+ , " through port '", name, "' is invalid." ]

98+ , txt [ "It contains ", kind, ":\n" ]

99+ , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"

100+ , txt [ "Acceptable values for ", dir "incoming" "outgoing"

101+ , " ports include JavaScript values and" ]

102+ , txt [ "the following Elm values: Ints, Floats, Bools, Strings, Maybes," ]

103+ , txt [ "Lists, Tuples, ", dir "" "first-order functions, ", "and concrete records." ]

104+ ] ++ if couldBeAlias then aliasWarning else []

105+

106+ aliasWarning =

107+ [ txt [ "\nType aliases are not expanded for this check (yet) so you need to do that" ]

108+ , txt [ "manually for now (e.g. {x:Int,y:Int} instead of a type alias of that type)." ]

110 ]

109 ]

111

110

112occurs :: (String, Variable) -> StateT TS.SolverState IO ()

111occurs :: (String, Variable) -> StateT TS.SolverState IO ()

compiler/Type/Type.hs+9−5

@@ -364,11 +364,15 @@ toSrcType variable = do

364 return (Src.Data name (ts ++ [b']))

365 Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

366 Var1 a -> toSrcType a

367− EmptyRecord1 -> return Src.EmptyRecord

367+ EmptyRecord1 -> return $ Src.Record [] Nothing

368− Record1 fs ext -> do

368+ Record1 tfields extension -> do

369− fs' <- traverse (mapM toSrcType) fs

369+ fields' <- traverse (mapM toSrcType) tfields

370− let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]

370+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

371− Src.Record fs'' <$> toSrcType ext

371+ ext' <- toSrcType extension

372+ return $ case ext' of

373+ Src.Record fs ext -> Src.Record (fs ++ fields) ext

374+ Src.Var x -> Src.Record fields (Just x)

375+ _ -> error "Used toSrcType on a type that is not well-formed"

372 Nothing ->

376 Nothing ->

373 case name desc of

377 case name desc of

374 Just x@(c:_) | Char.isLower c -> return (Src.Var x)

378 Just x@(c:_) | Char.isLower c -> return (Src.Var x)

libraries/Dict.elm+82−88

@@ -34,15 +34,35 @@ Insert, remove, and query operations all take *O(log n)* time.

34import open Basics

35import open Maybe

36import Native.Error

37−import List as List

37+import List

38+import String

38import Native.Utils

39import Native.Utils

39

40

40-- BBlack and NBlack should only be used during the deletion

41-- BBlack and NBlack should only be used during the deletion

41-- algorithm. Any other occurrence is a bug and should fail an assert.

42-- algorithm. Any other occurrence is a bug and should fail an assert.

42−data NColor = Red | Black

43+data NColor = Red

44+ | Black

45+ -- ^ Double Black, counts as 2 blacks for the invariant

43− | BBlack | NBlack

46+ | BBlack

44−

47+ -- ^ Negative Black, counts as -1 blacks for the invariant

48+ | NBlack

49+

50+

51+showNColor : NColor -> String

52+showNColor c = case c of

53+ Red -> "Red"

54+ Black -> "Black"

55+ BBlack -> "BBlack"

56+ NBlack -> "NBlack"

57+

45−data LeafColor = LBlack | LBBlack

58+data LeafColor = LBlack

59+ -- ^ Double Black, counts as 2

60+ | LBBlack

61+

62+showLColor : LeafColor -> String

63+showLColor c = case c of

64+ LBlack -> "LBlack"

65+ LBBlack -> "LBBlack"

46

66

47data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

67data Dict k v = RBNode NColor k v (Dict k v) (Dict k v)

48 | RBEmpty LeafColor

68 | RBEmpty LeafColor

@@ -93,51 +113,6 @@ member : comparable -> Dict comparable v -> Bool

93-- Does t contain k?

113-- Does t contain k?

94member k t = isJust <| lookup k t

114member k t = isJust <| lookup k t

95

115

96−rotateLeft : Dict k v -> Dict k v

97−rotateLeft t =

98− case t of

99− RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c

100− _ -> Native.Error.raise "rotateLeft of a node without enough children"

101−

102−-- rotateRight -- the reverse, and

103−-- makes Y have Z's color, and makes Z Red.

104−rotateRight : Dict k v -> Dict k v

105−rotateRight t =

106− case t of

107− RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)

108− _ -> Native.Error.raise "rotateRight of a node without enough children"

109−

110−rotateLeftIfNeeded : Dict k v -> Dict k v

111−rotateLeftIfNeeded t =

112− case t of

113− RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t

114− _ -> t

115−

116−rotateRightIfNeeded : Dict k v -> Dict k v

117−rotateRightIfNeeded t =

118− case t of

119− RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t

120− _ -> t

121−

122−otherColor c = case c of { Red -> Black ; Black -> Red }

123−

124−color_flip : Dict k v -> Dict k v

125−color_flip t =

126− case t of

127− RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->

128− RBNode (otherColor c1) bk bv

129− (RBNode (otherColor c2) ak av la ra)

130− (RBNode (otherColor c3) ck cv lc rc)

131− _ -> Native.Error.raise "color_flip called on a Empty or Node with a Empty child"

132−

133−color_flipIfNeeded : Dict k v -> Dict k v

134−color_flipIfNeeded t =

135− case t of

136− RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t

137− _ -> t

138−

139−fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))

140−

141ensureBlackRoot : Dict k v -> Dict k v

116ensureBlackRoot : Dict k v -> Dict k v

142ensureBlackRoot t =

117ensureBlackRoot t =

143 case t of

118 case t of

@@ -158,6 +133,11 @@ remove k t = let u _ = Nothing in

158 update k u t

133 update k u t

159

134

160data Flag = Insert | Remove | Same

135data Flag = Insert | Remove | Same

136+showFlag : Flag -> String

137+showFlag f = case f of

138+ Insert -> "Insert"

139+ Remove -> "Remove"

140+ Same -> "Same"

161

141

162{-| Update the value of a dictionary for a specific key with a given function. -}

142{-| Update the value of a dictionary for a specific key with a given function. -}

163update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v

143update : comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v

@@ -168,76 +148,87 @@ update k u t =

168 Just v -> (Insert, RBNode Red k v empty empty)

148 Just v -> (Insert, RBNode Red k v empty empty)

169 RBNode c k' v l r -> case Native.Utils.compare k k' of

149 RBNode c k' v l r -> case Native.Utils.compare k k' of

170 EQ -> case u (Just v) of

150 EQ -> case u (Just v) of

171− Nothing -> (Remove, rem t)

151+ Nothing -> (Remove, rem c l r)

172 Just v' -> (Same, RBNode c k' v' l r)

152 Just v' -> (Same, RBNode c k' v' l r)

173 LT -> let (fl, l') = up l in

153 LT -> let (fl, l') = up l in

174 case fl of

154 case fl of

175 Same -> (Same, RBNode c k' v l' r)

155 Same -> (Same, RBNode c k' v l' r)

176− Insert -> (Insert, fixUp <| RBNode c k' v l' r)

156+ Insert -> (Insert, balance c k' v l' r)

177 Remove -> (Remove, bubble c k' v l' r)

157 Remove -> (Remove, bubble c k' v l' r)

178 GT -> let (fl, r') = up r in

158 GT -> let (fl, r') = up r in

179 case fl of

159 case fl of

180 Same -> (Same, RBNode c k' v l r')

160 Same -> (Same, RBNode c k' v l r')

181− Insert -> (Insert, fixUp <| RBNode c k' v l r')

161+ Insert -> (Insert, balance c k' v l r')

182 Remove -> (Remove, bubble c k' v l r')

162 Remove -> (Remove, bubble c k' v l r')

183 (fl, t') = up t

163 (fl, t') = up t

184 in case fl of

164 in case fl of

185 Same -> t'

165 Same -> t'

186 Insert -> ensureBlackRoot t'

166 Insert -> ensureBlackRoot t'

187 Remove -> blacken t'

167 Remove -> blacken t'

188−

168+

189{-| Create a dictionary with one key-value pair. -}

169{-| Create a dictionary with one key-value pair. -}

190singleton : comparable -> v -> Dict comparable v

170singleton : comparable -> v -> Dict comparable v

191singleton k v = insert k v (RBEmpty LBlack)

171singleton k v = insert k v (RBEmpty LBlack)

192

172

193−{- Remove helpers: everything from here to remove should only be used

194− internally by remove as they would otherwise break rb-invariants -}

195−

196isBBlack : Dict k v -> Bool

173isBBlack : Dict k v -> Bool

197isBBlack t = case t of

174isBBlack t = case t of

198− RBNode c _ _ _ _ -> case c of

199− BBlack -> True

175+ RBNode BBlack _ _ _ _ -> True

200− _ -> False

201 RBEmpty LBBlack -> True

176 RBEmpty LBBlack -> True

202 _ -> False

177 _ -> False

203

178

204moreBlack : NColor -> NColor

179moreBlack : NColor -> NColor

205moreBlack c = case c of

180moreBlack c = case c of

206− BBlack -> BBlack

207 Black -> BBlack

181 Black -> BBlack

208 Red -> Black

182 Red -> Black

209 NBlack -> Red

183 NBlack -> Red

184+ BBlack -> Native.Error.raise "Can't make a double black node more black!"

185+

210lessBlack : NColor -> NColor

186lessBlack : NColor -> NColor

211lessBlack c = case c of

187lessBlack c = case c of

212 BBlack -> Black

188 BBlack -> Black

213 Black -> Red

189 Black -> Red

214 Red -> NBlack

190 Red -> NBlack

215− NBlack -> NBlack

191+ NBlack -> Native.Error.raise "Can't make a negative black node less black!"

216−

217−moreBlackTree : Dict k v -> Dict k v

218−moreBlackTree t = case t of

219− RBNode c k v l r -> RBNode (moreBlack c) k v l r

220− RBEmpty _ -> RBEmpty LBBlack

221

192

222lessBlackTree : Dict k v -> Dict k v

193lessBlackTree : Dict k v -> Dict k v

223lessBlackTree t = case t of

194lessBlackTree t = case t of

224 RBNode c k v l r -> RBNode (lessBlack c) k v l r

195 RBNode c k v l r -> RBNode (lessBlack c) k v l r

225− RBEmpty _ -> RBEmpty LBlack

196+ RBEmpty LBBlack -> RBEmpty LBlack

197+

198+reportRemBug : String -> NColor -> String -> String -> a

199+reportRemBug msg c lgot rgot =

200+ Native.Error.raise . String.concat <| [

201+ "Internal red-black tree invariant violated, expected ",

202+ msg,

203+ "and got",

204+ showNColor c,

205+ " ",

206+ lgot,

207+ " ",

208+ rgot,

209+ "\nPlease report this bug to https://github.com/evancz/Elm/issues"

210+ ]

226

211

227-- Remove the top node from the tree, may leave behind BBlacks

212-- Remove the top node from the tree, may leave behind BBlacks

228−rem : Dict k v -> Dict k v

213+rem : NColor -> Dict k v -> Dict k v -> Dict k v

229−rem t = case t of

214+rem c l r = case (l, r) of

230− RBNode c k v (RBEmpty _) (RBEmpty _) -> case c of

215+ ((RBEmpty _), (RBEmpty _)) -> case c of

231− Red -> RBEmpty LBlack

216+ Red -> RBEmpty LBlack

232 Black -> RBEmpty LBBlack

217 Black -> RBEmpty LBBlack

233− RBNode Black _ _ (RBEmpty _) (RBNode _ k v l r) ->

218+ ((RBEmpty cl), (RBNode cr k' v' l' r')) ->

219+ case (c, cl, cr) of

234− RBNode Black k v l r

220+ (Black, LBlack, Red) -> RBNode Black k' v' l' r'

221+ _ -> reportRemBug "Black, LBlack, Red" c (showLColor cl) (showNColor cr)

235− RBNode Black _ _ (RBNode _ k v l r) (RBEmpty _) ->

222+ ((RBNode cl k' v' l' r'), (RBEmpty cr)) ->

223+ case (c, cl, cr) of

236− RBNode Black k v l r

224+ (Black, Red, LBlack) -> RBNode Black k' v' l' r'

225+ _ -> reportRemBug "Black, Red, LBlack" c (showNColor cl) (showLColor cr)

237 -- l and r are both RBNodes

226 -- l and r are both RBNodes

238− RBNode c _ _ l r ->

227+ ((RBNode cl kl vl ll rl), (RBNode cr kr vr lr rr)) ->

228+ let l = RBNode cl kl vl ll rl

229+ r = RBNode cr kr vr lr rr

239− let (k, v) = max l

230+ (k, v) = max l

240− l' = remove_max l

231+ l' = remove_max cl kl vl ll rl

241 in bubble c k v l' r

232 in bubble c k v l' r

242

233

243-- Kills a BBlack or moves it upward, may leave behind NBlack

234-- Kills a BBlack or moves it upward, may leave behind NBlack

@@ -245,19 +236,24 @@ bubble : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

245bubble c k v l r = if isBBlack l || isBBlack r

236bubble c k v l r = if isBBlack l || isBBlack r

246 then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)

237 then balance (moreBlack c) k v (lessBlackTree l) (lessBlackTree r)

247 else RBNode c k v l r

238 else RBNode c k v l r

248−

239+

249-- Removes rightmost node, may leave root as BBlack

240-- Removes rightmost node, may leave root as BBlack

250−remove_max : Dict k v -> Dict k v

241+remove_max : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

251−remove_max t = case t of

242+remove_max c k v l r = case r of

252− RBNode c k v l (RBEmpty _) -> rem t

243+ RBEmpty _ -> rem c l r

244+ RBNode cr kr vr lr rr

253− RBNode c k v l r -> bubble c k v l (remove_max r)

245+ -> bubble c k v l (remove_max cr kr vr lr rr)

254

246

255-- generalized tree balancing act

247-- generalized tree balancing act

256balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

248balance : NColor -> k -> v -> Dict k v -> Dict k v -> Dict k v

249+balance c k v l r =

250+

257−balance c k v l r = balance_node (RBNode c k v l r)

251+ balance_node (RBNode c k v l r)

258

252

259blackish : Dict k v -> Bool

253blackish : Dict k v -> Bool

254+blackish t = case t of

260−blackish (RBNode c _ _ _ _) = c == Black || c == BBlack

255+ RBNode c _ _ _ _ -> c == Black || c == BBlack

256+ RBEmpty _ -> True

261

257

262balance_node : Dict k v -> Dict k v

258balance_node : Dict k v -> Dict k v

263balance_node t =

259balance_node t =

@@ -286,9 +282,7 @@ balance_node t =

286 (RBNode Black _ _ _ _) ->

282 (RBNode Black _ _ _ _) ->

287 RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)

283 RBNode Black yk yv (balance Black xk xv (redden a) b) (RBNode Black zk zv c d)

288 _ -> t

284 _ -> t

289−

290 _ -> t

285 _ -> t

291−

292 else t

286 else t

293

287

294-- make the top node black

288-- make the top node black

libraries/Native/JavaScript.js+1−1

@@ -34,7 +34,7 @@ Elm.Native.JavaScript.make = function(elm) {

34

35 function toJS(v) {

36 var type = typeof v;

37− if (type === 'number' || type === 'boolean') return v;

37+ if (type === 'number' || type === 'boolean' || type === 'string') return v;

38 if (type === 'object' && '_' in v) {

39 var obj = {};

40 for (var k in v) {

libraries/Native/Ports.js+46−42

@@ -6,62 +6,66 @@ Elm.Native.Ports.make = function(elm) {

6

7 var Signal = Elm.Signal.make(elm);

8

9− // On failure, return message. On success, return the value in an array.

9+ function incomingSignal(converter) {

10− // Wrapping in an array allows the programmer to pass in a null value.

10+ return function(port) {

11− function processInput(converter, v) {

11+ var base = converter(port.internal.defaultValue);

12− try { var elmValue = converter(v); }

12+ var signal = Signal.constant(base);

13− catch(e) { return "The given value caused a runtime error!\n" + e.toString(); }

13+ port.internal.subscribe(function(v) {

14+ try {

15+ elm.notify(signal.id, converter(v));

16+ } catch(e) {

17+ port.internal.errorHandler(v);

18+ }

19+ });

20+ return signal;

21+ }

22+ }

14

23

15− var ctor = elmValue.ctor;

24+ function outgoingSignal(converter) {

16− if (ctor === 'Nothing' || ctor === 'Left') {

25+ return function(signal) {

17− return "The port's conversion function failed.";

26+ var subscribers = []

18− } else if (ctor === 'Just' || ctor === 'Right') {

27+ function subscribe(handler) {

19− return [elmValue._0];

28+ subscribers.push(handler);

29+ }

30+ function unsubscribe(handler) {

31+ subscribers.pop(subscribers.indexOf(handler));

32+ }

33+ A2( Signal.lift, function(value) {

34+ var val = converter(value);

35+ var len = subscribers.length;

36+ for (var i = 0; i < len; ++i) {

37+ subscribers[i](val);

38+ }

39+ }, signal);

40+ return { subscribe:subscribe, unsubscribe:unsubscribe };

20 }

41 }

21− return [elmValue];

22 }

42 }

43+

23 function portIn(name, converter) {

44 function portIn(name, converter) {

24− var port = elm.ports.incoming[name];

45+ var value = elm.ports.incoming[name];

25− if (!port) {

46+ if (!value) {

26 throw new Error("Initialization Error: port '" + name +

47 throw new Error("Initialization Error: port '" + name +

27 "' was not given an input!");

48 "' was not given an input!");

28 }

49 }

29 elm.ports.uses[name] += 1;

50 elm.ports.uses[name] += 1;

30− var result = processInput(converter, port.internal.defaultValue);

51+ try {

31− if (typeof result === 'string') {

52+ return converter(value);

53+ } catch(e) {

32− throw new Error("Initialization Error: The default value for port '" +

54+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

33− name + "' is invalid.\n" + result);

34 }

55 }

35− var signal = Signal.constant(result[0]);

36− port.internal.subscribe(function(v) {

37− var result = processInput(converter, v);

38− if (typeof result === 'string') {

39− port.internal.errorHandler(v)

40− } else {

41− elm.notify(signal.id, result[0]);

42− }

43− });

44− return signal;

45 }

56 }

46− function portOut(name, signal) {

57+ function portOut(name, converter, value) {

47− var subscribers = []

58+ try {

48− function subscribe(handler) {

59+ elm.ports.outgoing[name] = converter(value);

49− subscribers.push(handler);

60+ } catch(e) {

61+ throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

50 }

62 }

51− function unsubscribe(handler) {

52− subscribers.pop(subscribers.indexOf(handler));

53− }

54− A2( Signal.lift, function(value) {

55− var len = subscribers.length;

56− for (var i = 0; i < len; ++i) {

57− subscribers[i](value);

58− }

59− }, signal);

60− elm.ports.outgoing[name] = { subscribe:subscribe, unsubscribe:unsubscribe };

61− return signal;

63+ return value;

62 }

64 }

63

65

64 return elm.Native.Ports.values = {

66 return elm.Native.Ports.values = {

67+ incomingSignal: incomingSignal,

68+ outgoingSignal: outgoingSignal,

65 portOut: portOut,

69 portOut: portOut,

66 portIn: portIn

70 portIn: portIn

67 };

71 };

libraries/elm_dependencies.json+2

@@ -16,6 +16,7 @@

16 , "Graphics.Element"

17 , "Graphics.Collage"

18 , "Graphics.Input"

19+ , "Graphics.WebGL"

19 , "Http"

20 , "Http"

20 , "JavaScript"

21 , "JavaScript"

21 , "JavaScript.Experimental"

22 , "JavaScript.Experimental"

@@ -23,6 +24,7 @@

23 , "Keyboard"

24 , "Keyboard"

24 , "List"

25 , "List"

25 , "Maybe"

26 , "Maybe"

27+ , "MJS"

26 , "Mouse"

28 , "Mouse"

27 , "Random"

29 , "Random"

28 , "Regex"

30 , "Regex"

runtime/Init.js+34−7

@@ -27,7 +27,7 @@ Elm.worker = function(module, ports) {

27 return init(ElmRuntime.Display.NONE, {}, module, ports || {});

28};

29

30−Elm.input = function(defaultValue, errorHandler) {

30+Elm.signal = function(defaultValue, errorHandler) {

31 var subscribers = []

32 function subscribe(handler) {

33 subscribers.push(handler);

@@ -133,7 +133,7 @@ function init(display, container, module, ports, moduleToReplace) {

133 }

134

135 reportAnyErrors();

136− return { swap:swap, output:elm.ports.outgoing };

136+ return { swap:swap, ports:elm.ports.outgoing };

137};

138

139function checkPorts(elm) {

@@ -142,8 +142,9 @@ function checkPorts(elm) {

142 var uses = portUses[key]

143 if (uses === 0) {

144 throw new Error(

145− "Initialization Error: there is no port named '" + key + "'.\n" +

145+ "Initialization Error: provided port '" + key +

146+ "' to a module that does not take it as in input.\n" +

146− "You should probably remove that input from your initialization code.");

147+ "Remove '" + key + "' from the module initialization code.");

147 } else if (uses > 1) {

148 } else if (uses > 1) {

148 throw new Error(

149 throw new Error(

149 "Initialization Error: port '" + key +

150 "Initialization Error: port '" + key +

@@ -179,23 +180,49 @@ function addReceivers(ports) {

179 ports.log.subscribe(function(v) { console.log(v) });

180 ports.log.subscribe(function(v) { console.log(v) });

180 }

181 }

181 if ('stdout' in ports) {

182 if ('stdout' in ports) {

183+ var process = process || {};

184+ var handler = process.stdout

182− var handler = process ? function(v) { process.stdout.write(v); }

185+ ? function(v) { process.stdout.write(v); }

183 : function(v) { console.log(v); };

186 : function(v) { console.log(v); };

184 ports.stdout.subscribe(handler);

187 ports.stdout.subscribe(handler);

185 }

188 }

186 if ('stderr' in ports) {

189 if ('stderr' in ports) {

190+ var process = process || {};

191+ var handler = process.stderr

187− var handler = process ? function(v) { process.stderr.write(v); }

192+ ? function(v) { process.stderr.write(v); }

188 : function(v) { console.log('Error:' + v); };

193 : function(v) { console.log('Error:' + v); };

189 ports.stderr.subscribe(handler);

194 ports.stderr.subscribe(handler);

190 }

195 }

191 if ('title' in ports) {

196 if ('title' in ports) {

197+ if (typeof ports.title === 'string') {

198+ document.title = ports.title;

199+ } else {

192− ports.title.subscribe(function(v) { document.title = v; });

200+ ports.title.subscribe(function(v) { document.title = v; });

201+ }

193 }

202 }

194 if ('redirect' in ports) {

203 if ('redirect' in ports) {

195 ports.redirect.subscribe(function(v) {

204 ports.redirect.subscribe(function(v) {

196 if (v.length > 0) window.location = v;

205 if (v.length > 0) window.location = v;

197 });

206 });

198 }

207 }

208+ if ('favicon' in ports) {

209+ if (typeof ports.favicon === 'string') {

210+ changeFavicon(ports.favicon);

211+ } else {

212+ ports.favicon.subscribe(changeFavicon);

213+ }

214+ }

215+ function changeFavicon(src) {

216+ var link = document.createElement('link');

217+ var oldLink = document.getElementById('elm-favicon');

218+ link.id = 'elm-favicon';

219+ link.rel = 'shortcut icon';

220+ link.href = src;

221+ if (oldLink) {

222+ document.head.removeChild(oldLink);

223+ }

224+ document.head.appendChild(link);

225+ }

199}

226}

200

227

201function initGraphics(elm, Module) {

228function initGraphics(elm, Module) {

tests/test-files/good/Box.elm+2

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

1

2+module Box where

3+

2import MJS (V3,M4x4,v3,m4x4makeRotate,m4x4makePerspective,m4x4makeLookAt,m4x4mul)

4import MJS (V3,M4x4,v3,m4x4makeRotate,m4x4makePerspective,m4x4makeLookAt,m4x4mul)

3import Graphics.WebGL (Program, link, Triangle, zipTriangle, Buffer, bind, Model, encapsulate, webgl)

5import Graphics.WebGL (Program, link, Triangle, zipTriangle, Buffer, bind, Model, encapsulate, webgl)

4import Window(dimensions)

6import Window(dimensions)