513ded4 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Merge @garyb's core functional AST changes, fixes #710

513ded4Phil Freeman12 years ago

examples/manual/passing/TransitiveImport.pursnew file+21

compare with golang

unifiedsplit

@@ -0,0 +1,21 @@

1+module Test where

3+ class TestCls a where

4+ test :: a -> a

6+ instance unitTestCls :: TestCls Unit where

7+ test _ = unit

9+module Middle where

10+

11+ middle = Test.test

12+

13+module Main where

14+

15+ import Middle

16+ import Debug.Trace

17+

18+ main = do

19+ print (middle unit)

20+ trace "Done"

21+ return unit

examples/passing/ForeignInstance.purs+4

@@ -9,6 +9,10 @@ foreign import instance fooNumber :: Foo Number

10foreign import instance fooString :: Foo String

12+foreign import fooString "var fooString = {};" :: Unit

13+foreign import fooNumber "var fooNumber = {};" :: Unit

14+foreign import fooArray "var fooArray = {};" :: Unit

15+

12test1 _ = foo [1, 2, 3]

16test1 _ = foo [1, 2, 3]

14test2 _ = foo "Test"

18test2 _ = foo "Test"

purescript.cabal+23−14

@@ -45,24 +45,33 @@ library

45 Language.PureScript.AST.SourcePos

46 Language.PureScript.AST.Traversals

47 Language.PureScript.CodeGen

48− Language.PureScript.CodeGen.Common

49 Language.PureScript.CodeGen.Externs

48 Language.PureScript.CodeGen.Externs

50 Language.PureScript.CodeGen.JS

49 Language.PureScript.CodeGen.JS

51 Language.PureScript.CodeGen.JS.AST

50 Language.PureScript.CodeGen.JS.AST

51+ Language.PureScript.CodeGen.JS.Common

52+ Language.PureScript.CodeGen.JS.Optimizer

53+ Language.PureScript.CodeGen.JS.Optimizer.Blocks

54+ Language.PureScript.CodeGen.JS.Optimizer.Common

55+ Language.PureScript.CodeGen.JS.Optimizer.Inliner

56+ Language.PureScript.CodeGen.JS.Optimizer.MagicDo

57+ Language.PureScript.CodeGen.JS.Optimizer.TCO

58+ Language.PureScript.CodeGen.JS.Optimizer.Unused

52 Language.PureScript.Constants

59 Language.PureScript.Constants

60+ Language.PureScript.CoreFn

61+ Language.PureScript.CoreFn.Ann

62+ Language.PureScript.CoreFn.Binders

63+ Language.PureScript.CoreFn.Desugar

64+ Language.PureScript.CoreFn.Expr

65+ Language.PureScript.CoreFn.Literals

66+ Language.PureScript.CoreFn.Meta

67+ Language.PureScript.CoreFn.Module

68+ Language.PureScript.CoreFn.Traversals

53 Language.PureScript.DeadCodeElimination

69 Language.PureScript.DeadCodeElimination

54 Language.PureScript.Environment

70 Language.PureScript.Environment

55 Language.PureScript.Errors

71 Language.PureScript.Errors

56 Language.PureScript.Kinds

72 Language.PureScript.Kinds

57 Language.PureScript.ModuleDependencies

73 Language.PureScript.ModuleDependencies

58 Language.PureScript.Names

74 Language.PureScript.Names

59− Language.PureScript.Optimizer

60− Language.PureScript.Optimizer.Blocks

61− Language.PureScript.Optimizer.Common

62− Language.PureScript.Optimizer.Inliner

63− Language.PureScript.Optimizer.MagicDo

64− Language.PureScript.Optimizer.TCO

65− Language.PureScript.Optimizer.Unused

66 Language.PureScript.Options

75 Language.PureScript.Options

67 Language.PureScript.Parser

76 Language.PureScript.Parser

68 Language.PureScript.Parser.Common

77 Language.PureScript.Parser.Common

@@ -106,7 +115,7 @@ library

106 ghc-options: -Wall -O2

115 ghc-options: -Wall -O2

107

116

108executable psc

117executable psc

109− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

118+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

110 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

119 mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

111 transformers -any, utf8-string -any

120 transformers -any, utf8-string -any

112 main-is: Main.hs

121 main-is: Main.hs

@@ -116,8 +125,8 @@ executable psc

116 ghc-options: -Wall -O2 -fno-warn-unused-do-bind

125 ghc-options: -Wall -O2 -fno-warn-unused-do-bind

117

126

118executable psc-make

127executable psc-make

119− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

128+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

120− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

129+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

121 transformers -any, utf8-string -any

130 transformers -any, utf8-string -any

122 main-is: Main.hs

131 main-is: Main.hs

123 buildable: True

132 buildable: True

@@ -127,10 +136,10 @@ executable psc-make

127

136

128executable psci

137executable psci

129 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

138 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

130− mtl -any, optparse-applicative >= 0.10.0, parsec -any,

139+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,

131− haskeline >= 0.7.0.0, purescript -any, transformers -any,

140+ haskeline >= 0.7.0.0, purescript -any, transformers -any,

132 utf8-string -any, process -any

141 utf8-string -any, process -any

133−

142+

134 main-is: Main.hs

143 main-is: Main.hs

135 buildable: True

144 buildable: True

136 hs-source-dirs: psci

145 hs-source-dirs: psci

src/Language/PureScript.hs+38−38

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

1-----------------------------------------------------------------------------

2--

3-- Module : Language.PureScript

4−-- Copyright : (c) Phil Freeman 2013

5-- License : MIT

6--

7-- Maintainer : Phil Freeman <paf31@cantab.net>

@@ -17,42 +17,40 @@

18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where

20−import Language.PureScript.Types as P

20+import Data.FileEmbed (embedFile)

21−import Language.PureScript.Kinds as P

21+import Data.Function (on)

22+import Data.List (sortBy, groupBy, intercalate)

23+import Data.Maybe (fromMaybe)

24+import Data.Time.Clock

25+import qualified Data.ByteString.UTF8 as BU

26+import qualified Data.Map as M

27+import qualified Data.Set as S

28+

29+import Control.Applicative

30+import Control.Arrow ((&&&))

31+import Control.Monad.Error

32+

33+import System.FilePath ((</>))

34+

22import Language.PureScript.AST as P

35import Language.PureScript.AST as P

36+import Language.PureScript.CodeGen as P

37+import Language.PureScript.DeadCodeElimination as P

38+import Language.PureScript.Environment as P

39+import Language.PureScript.Errors as P

40+import Language.PureScript.Kinds as P

41+import Language.PureScript.ModuleDependencies as P

23import Language.PureScript.Names as P

42import Language.PureScript.Names as P

43+import Language.PureScript.Options as P

24import Language.PureScript.Parser as P

44import Language.PureScript.Parser as P

25−import Language.PureScript.CodeGen as P

26−import Language.PureScript.CodeGen.Common as P

27−import Language.PureScript.TypeChecker as P

28import Language.PureScript.Pretty as P

45import Language.PureScript.Pretty as P

46+import Language.PureScript.Renamer as P

29import Language.PureScript.Sugar as P

47import Language.PureScript.Sugar as P

30−import Language.PureScript.Options as P

31−import Language.PureScript.ModuleDependencies as P

32−import Language.PureScript.Environment as P

33−import Language.PureScript.Errors as P

34−import Language.PureScript.DeadCodeElimination as P

35import Language.PureScript.Supply as P

48import Language.PureScript.Supply as P

36−import Language.PureScript.Renamer as P

49+import Language.PureScript.TypeChecker as P

37−

50+import Language.PureScript.Types as P

51+import qualified Language.PureScript.CoreFn as CoreFn

38import qualified Language.PureScript.Constants as C

52import qualified Language.PureScript.Constants as C

40−import Data.List (sortBy, groupBy, intercalate)

41−import Data.Time.Clock

42−import Data.Function (on)

43−import Data.Maybe (fromMaybe)

44−import Data.FileEmbed (embedFile)

45−

46−import Control.Monad.Error

47−import Control.Arrow ((&&&))

48−import Control.Applicative

49−

50−import qualified Data.Map as M

51−import qualified Data.Set as S

52−import qualified Data.ByteString.UTF8 as BU

53−

54−import System.FilePath ((</>))

55−

56-- |

54-- |

57-- Compile a collection of modules

55-- Compile a collection of modules

58--

56--

@@ -77,17 +75,18 @@ compile = compile' initEnvironment

78compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

76compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

79compile' env opts ms prefix = do

77compile' env opts ms prefix = do

80− (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else (map importPrelude ms)

78+ (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms

81 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

79 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted

82 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

80 (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent

83 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

81 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

82+ let corefn = map (CoreFn.moduleToCoreFn env') regrouped

84 let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)

83 let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)

85− let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped

84+ let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

86 let renamed = renameInModules elim

85 let renamed = renameInModules elim

87 let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)

86 let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)

88− let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(Module mn _ _) -> mn `elem` codeGenModuleNames) renamed

87+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

89− let js = evalSupply nextVar $ concat <$> mapM (\m -> moduleToJs opts m env') modulesToCodeGen

88+ let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen

90− let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen

89+ let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

91 js' <- generateMain env' opts js

90 js' <- generateMain env' opts js

92 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

91 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

93 return (pjs, exts, env')

92 return (pjs, exts, env')

@@ -156,7 +155,7 @@ make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options

156make outputDir opts ms prefix = do

155make outputDir opts ms prefix = do

157 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

156 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

158

157

159− (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)

158+ (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms

160

159

161 toRebuild <- foldM (\s (Module moduleName' _ _) -> do

160 toRebuild <- foldM (\s (Module moduleName' _ _) -> do

162 let filePath = runModuleName moduleName'

161 let filePath = runModuleName moduleName'

@@ -199,11 +198,12 @@ make outputDir opts ms prefix = do

199 regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

198 regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

200

199

201 let mod' = Module moduleName' regrouped exps

200 let mod' = Module moduleName' regrouped exps

201+ let corefn = CoreFn.moduleToCoreFn env' mod'

202− let [renamed] = renameInModules [mod']

202+ let [renamed] = renameInModules [corefn]

203

204− pjs <- prettyPrintJS <$> moduleToJs opts renamed env'

204+ pjs <- prettyPrintJS <$> moduleToJs opts renamed

205 let js = unlines $ map ("// " ++) prefix ++ [pjs]

206− let exts = unlines $ map ("-- " ++ ) prefix ++ [moduleToPs renamed env']

206+ let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

207

208 lift $ writeTextFile jsFile js

209 lift $ writeTextFile externsFile exts

src/Language/PureScript/AST/Declarations.hs+4−4

@@ -171,7 +171,7 @@ data Declaration

171 -- |

172 -- A type class instance foreign import

173 --

174− | ExternInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type]

174+ | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]

175 -- |

176 -- A fixity declaration (fixity data, operator name)

177 --

@@ -183,12 +183,12 @@ data Declaration

183 -- |

184 -- A type class declaration (name, argument, implies, member declarations)

185 --

186− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]

186+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]

187 -- |

188 -- A type instance declaration (name, dependencies, class name, instance types, member

189 -- declarations)

190 --

191− | TypeInstanceDeclaration Ident [(Qualified ProperName, [Type])] (Qualified ProperName) [Type] [Declaration]

191+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]

192 -- |

193 -- A declaration with source position information

194 --

@@ -361,7 +361,7 @@ data Expr

361 -- at superclass implementations when searching for a dictionary, the type class name and

362 -- instance type, and the type class dictionaries in scope.

363 --

364− | TypeClassDictionary Bool (Qualified ProperName, [Type]) [TypeClassDictionaryInScope]

364+ | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]

365 -- |

366 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

367 --

src/Language/PureScript/CodeGen/Externs.hs+5−8

@@ -17,21 +17,19 @@ module Language.PureScript.CodeGen.Externs (

17 moduleToPs

18) where

20−import Data.Maybe (fromMaybe, mapMaybe)

21import Data.List (intercalate, find)

20import Data.List (intercalate, find)

22−

21+import Data.Maybe (fromMaybe, mapMaybe)

23import qualified Data.Map as M

22import qualified Data.Map as M

25import Control.Monad.Writer

24import Control.Monad.Writer

27−import Language.PureScript.CodeGen.Common

28−import Language.PureScript.TypeClassDictionaries

29import Language.PureScript.AST

26import Language.PureScript.AST

30−import Language.PureScript.Pretty

27+import Language.PureScript.Environment

31−import Language.PureScript.Names

32import Language.PureScript.Kinds

28import Language.PureScript.Kinds

29+import Language.PureScript.Names

30+import Language.PureScript.Pretty

31+import Language.PureScript.TypeClassDictionaries

33import Language.PureScript.Types

32import Language.PureScript.Types

34−import Language.PureScript.Environment

36-- |

34-- |

37-- Generate foreign imports for all declarations in a module

35-- Generate foreign imports for all declarations in a module

@@ -109,4 +107,3 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite

109

107

110 isValueExported :: Ident -> Bool

108 isValueExported :: Ident -> Bool

111 isValueExported ident = ValueRef ident `elem` exts

109 isValueExported ident = ValueRef ident `elem` exts

112−

src/Language/PureScript/CodeGen/JS.hs+175−215

@@ -13,32 +13,29 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE GADTs, DoAndIfThenElse #-}

16+{-# LANGUAGE GADTs #-}

18module Language.PureScript.CodeGen.JS (

19 module AST,

20− declToJs,

20+ module Common,

21+ bindToJs,

21− moduleToJs,

22+ moduleToJs

22− identNeedsEscaping

23) where

25−import Data.Maybe (catMaybes)

26import Data.Function (on)

25import Data.Function (on)

27−import Data.List (nub, (\\), delete, sortBy)

26+import Data.List ((\\), delete, sortBy)

27+import Data.Maybe (catMaybes, mapMaybe)

29−import qualified Data.Map as M

30−

31−import Control.Monad (foldM, replicateM, forM)

32import Control.Applicative

29import Control.Applicative

33−import Control.Arrow (second)

30+import Control.Arrow ((&&&))

31+import Control.Monad (foldM, replicateM, forM)

33+import Language.PureScript.CodeGen.JS.AST as AST

34+import Language.PureScript.CodeGen.JS.Common as Common

35+import Language.PureScript.CoreFn

35import Language.PureScript.Names

36import Language.PureScript.Names

36−import Language.PureScript.AST

37+import Language.PureScript.CodeGen.JS.Optimizer

37import Language.PureScript.Options

38import Language.PureScript.Options

38−import Language.PureScript.CodeGen.JS.AST as AST

39−import Language.PureScript.Optimizer

40−import Language.PureScript.CodeGen.Common

41−import Language.PureScript.Environment

42import Language.PureScript.Supply

39import Language.PureScript.Supply

43import Language.PureScript.Traversals (sndM)

40import Language.PureScript.Traversals (sndM)

44import qualified Language.PureScript.Constants as C

41import qualified Language.PureScript.Constants as C

@@ -47,25 +44,28 @@ import qualified Language.PureScript.Constants as C

47-- Generate code in the simplified Javascript intermediate representation for all declarations in a

44-- Generate code in the simplified Javascript intermediate representation for all declarations in a

48-- module.

45-- module.

49--

46--

50−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module -> Environment -> SupplyT m [JS]

47+moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]

51−moduleToJs opts (Module name decls (Just exps)) env = do

48+moduleToJs opts (Module name imps exps foreigns decls) = do

52− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) . nub $ concatMap imports decls

49+ let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

50+ let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

53− jsDecls <- mapM (\decl -> declToJs opts name decl env) decls

51+ jsDecls <- mapM (bindToJs name) decls

54− let optimized = concat $ map (map $ optimize opts) $ catMaybes jsDecls

52+ let optimized = concatMap (map $ optimize opts) $ catMaybes jsDecls

55 let isModuleEmpty = null exps

53 let isModuleEmpty = null exps

56− let moduleBody = JSStringLiteral "use strict" : jsImports ++ optimized

54+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized

57− let moduleExports = JSObjectLiteral . map (second var) . M.toList . M.unions $ map exportToJs exps

55+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps

58 return $ case optionsAdditional opts of

56 return $ case optionsAdditional opts of

59− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]

57+ MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']

60 CompileOptions ns _ _ | not isModuleEmpty ->

58 CompileOptions ns _ _ | not isModuleEmpty ->

61 [ JSVariableIntroduction ns

59 [ JSVariableIntroduction ns

62 (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )

60 (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )

63 , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))

61 , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))

64− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])

62+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])

65 ]

63 ]

66 _ -> []

64 _ -> []

67−moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"

66+-- |

67+-- Generates Javascript code for a module import.

68+--

69importToJs :: Options mode -> ModuleName -> JS

70importToJs opts mn =

71 JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

@@ -74,95 +74,18 @@ importToJs opts mn =

74 MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

75 CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)

77−imports :: Declaration -> [ModuleName]

78−imports (ImportDeclaration mn _ _) = [mn]

79−imports other =

80− let (f, _, _, _, _) = everythingOnValues (++) (const []) collectV collectB (const []) (const [])

81− in f other

82− where

83− collectV :: Expr -> [ModuleName]

84− collectV (Var (Qualified (Just mn) _)) = [mn]

85− collectV (Constructor (Qualified (Just mn) _)) = [mn]

86− collectV (TypeClassDictionaryConstructorApp (Qualified (Just mn) _) _) = [mn]

87− collectV _ = []

88− collectB :: Binder -> [ModuleName]

89− collectB (ConstructorBinder (Qualified (Just mn) _) _) = [mn]

90− collectB _ = []

91−

92-- |

77-- |

93-- Generate code in the simplified Javascript intermediate representation for a declaration

78-- Generate code in the simplified Javascript intermediate representation for a declaration

94--

79--

95−declToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Declaration -> Environment -> SupplyT m (Maybe [JS])

80+bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m (Maybe [JS])

96−declToJs opts mp (ValueDeclaration ident _ _ (Right val)) e = do

81+bindToJs mp (NonRec ident val) = do

97− js <- valueToJs opts mp e val

82+ js <- valueToJs mp val

98 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

83 return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]

99−declToJs opts mp (BindingGroupDeclaration vals) e = do

84+bindToJs mp (Rec vals) = do

100− jss <- forM vals $ \(ident, _, val) -> do

85+ jss <- forM vals $ \(ident, val) -> do

101− js <- valueToJs opts mp e val

86+ js <- valueToJs mp val

102 return $ JSVariableIntroduction (identToJs ident) (Just js)

87 return $ JSVariableIntroduction (identToJs ident) (Just js)

103 return $ Just jss

88 return $ Just jss

104−declToJs _ _ (DataDeclaration Newtype _ _ [((ProperName ctor), _)]) _ =

105− return $ Just $ [JSVariableIntroduction ctor (Just $

106− JSObjectLiteral [("create",

107− JSFunction Nothing ["value"]

108− (JSBlock [JSReturn $ JSVar "value"]))])]

109−declToJs _ _ (DataDeclaration Newtype _ _ _) _ =

110− error "newtype has multiple constructors"

111−declToJs _ mp (DataDeclaration Data _ _ ctors) e = do

112− return $ Just $ flip concatMap ctors $ \(pn@(ProperName ctor), tys) ->

113− let propName = if isNullaryConstructor e (Qualified (Just mp) pn) then "value" else "create"

114− in [ makeConstructor ctor (length tys)

115− , JSAssignment (JSAccessor propName (JSVar ctor)) (go pn 0 (length tys) [])

116− ]

117− where

118− makeConstructor :: String -> Int -> JS

119− makeConstructor ctorName n =

120− let

121− args = [ "value" ++ show index | index <- [0..n-1] ]

122− body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]

123− in JSFunction (Just ctorName) args (JSBlock body)

124− go :: ProperName -> Int -> Int -> [JS] -> JS

125− go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar $ runProperName pn) (reverse values)

126− go pn index n values =

127− JSFunction Nothing ["value" ++ show index]

128− (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])

129−declToJs opts mp (DataBindingGroupDeclaration ds) e = do

130− jss <- mapM (\decl -> declToJs opts mp decl e) ds

131− return $ Just $ concat $ catMaybes jss

132−declToJs _ _ (TypeClassDeclaration name _ supers members) _ =

133− return $ Just $ [

134− JSFunction (Just $ runProperName name) (identToJs `map` args)

135− (JSBlock $ assn `map` args)]

136− where

137− assn :: Ident -> JS

138− assn arg = JSAssignment (accessor arg (JSVar "this")) (var arg)

139− args :: [Ident]

140− args = sortBy (compare `on` runIdent) $ memberNames ++ superNames

141− memberNames :: [Ident]

142− memberNames = memberToName `map` members

143− superNames :: [Ident]

144− superNames = [ toSuperName superclass index

145− | (index, (superclass, _)) <- zip [0..] supers

146− ]

147− toSuperName :: Qualified ProperName -> Integer -> Ident

148− toSuperName pn index = Ident $ C.__superclass_ ++ show pn ++ "_" ++ show index

149− memberToName :: Declaration -> Ident

150− memberToName (TypeDeclaration ident _) = ident

151− memberToName (PositionedDeclaration _ d) = memberToName d

152− memberToName _ = error "Invalid declaration in type class definition"

153−declToJs _ _ (ExternDeclaration _ _ (Just js) _) _ = return $ Just [js]

154−declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e

155−declToJs _ _ _ _ = return Nothing

156−

157−-- |

158−-- Generate key//value pairs for an object literal exporting values from a module.

159−--

160−exportToJs :: DeclarationRef -> M.Map String Ident

161−exportToJs (TypeRef _ (Just dctors)) = M.fromList [ (n, Ident n) | (ProperName n) <- dctors ]

162−exportToJs (ValueRef name) = M.singleton (runIdent name) name

163−exportToJs (TypeInstanceRef name) = M.singleton (runIdent name) name

164−exportToJs (TypeClassRef name) = M.singleton (runProperName name) (Ident $ runProperName name)

165−exportToJs _ = M.empty

166

167-- |

90-- |

168-- Generate code in the simplified Javascript intermediate representation for a variable based on a

91-- Generate code in the simplified Javascript intermediate representation for a variable based on a

@@ -187,54 +110,89 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

187-- |

110-- |

188-- Generate code in the simplified Javascript intermediate representation for a value or expression.

111-- Generate code in the simplified Javascript intermediate representation for a value or expression.

189--

112--

190−valueToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> Expr -> SupplyT m JS

113+valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS

191−valueToJs _ _ _ (NumericLiteral n) = return $ JSNumericLiteral n

114+valueToJs m (Literal _ l) =

192−valueToJs _ _ _ (StringLiteral s) = return $ JSStringLiteral s

115+ literalToValueJS m l

193−valueToJs _ _ _ (BooleanLiteral b) = return $ JSBooleanLiteral b

116+valueToJs m (Var (_, _, Just (IsConstructor _ 0)) name) =

194−valueToJs opts m e (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs opts m e) xs

117+ return $ JSAccessor "value" $ qualifiedToJS m id name

195−valueToJs opts m e (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs opts m e)) ps

118+valueToJs m (Var (_, _, Just (IsConstructor _ _)) name) =

196−valueToJs opts m e (TypeClassDictionaryConstructorApp name (TypedValue _ (ObjectLiteral ps) _)) =

119+ return $ JSAccessor "create" $ qualifiedToJS m id name

197− JSUnary JSNew . JSApp (qualifiedToJS m (Ident . runProperName) name) <$> mapM (valueToJs opts m e . snd) (sortBy (compare `on` fst) ps)

120+valueToJs m (Accessor _ prop val) =

198−valueToJs _ _ _ TypeClassDictionaryConstructorApp{} =

121+ accessorString prop <$> valueToJs m val

199− error "TypeClassDictionaryConstructorApp did not contain object literal"

200−valueToJs opts m e (ObjectUpdate o ps) = do

122+valueToJs m (ObjectUpdate _ o ps) = do

201− obj <- valueToJs opts m e o

123+ obj <- valueToJs m o

202− sts <- mapM (sndM (valueToJs opts m e)) ps

124+ sts <- mapM (sndM (valueToJs m)) ps

203 extendObj obj sts

125 extendObj obj sts

204−valueToJs _ m e (Constructor name) =

126+valueToJs _ e@(Abs (_, _, Just IsTypeClassConstructor) _ val) =

205− let propName = if isNullaryConstructor e name then "value" else "create"

127+ let args = unAbs e

206− in return $ JSAccessor propName $ qualifiedToJS m (Ident . runProperName) name

128+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)

207−valueToJs opts m e (Case values binders) = do

129+ where

208− vals <- mapM (valueToJs opts m e) values

130+ unAbs :: Expr Ann -> [Ident]

209− bindersToJs opts m e binders vals

131+ unAbs (Abs _ arg val) = arg : unAbs val

210−valueToJs opts m e (IfThenElse cond th el) = JSConditional <$> valueToJs opts m e cond <*> valueToJs opts m e th <*> valueToJs opts m e el

132+ unAbs _ = []

211−valueToJs opts m e (Accessor prop val) = accessorString prop <$> valueToJs opts m e val

133+ assign :: Ident -> JS

134+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))

135+ (var name)

136+valueToJs m (Abs _ arg val) = do

212−valueToJs opts m e v@App{} = do

137+ ret <- valueToJs m val

138+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

139+valueToJs m e@App{} = do

213− let (f, args) = unApp v []

140+ let (f, args) = unApp e []

214− args' <- mapM (valueToJs opts m e) args

141+ args' <- mapM (valueToJs m) args

215 case f of

142 case f of

216− Constructor name | isNewtypeConstructor e name && length args == 1 -> return (head args')

143+ Var (_, _, Just IsNewtype) _ -> return (head args')

217− Constructor name | getConstructorArity e name == length args ->

144+ Var (_, _, Just (IsConstructor _ arity)) name | arity == length args ->

218− return $ JSUnary JSNew $ JSApp (qualifiedToJS m (Ident . runProperName) name) args'

145+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

146+ Var (_, _, Just IsTypeClassConstructor) name ->

147+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

219− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs opts m e f

148+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f

220 where

149 where

221− unApp :: Expr -> [Expr] -> (Expr, [Expr])

150+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

222− unApp (App val arg) args = unApp val (arg : args)

151+ unApp (App _ val arg) args = unApp val (arg : args)

223− unApp (PositionedValue _ val) args = unApp val args

224− unApp (TypedValue _ val _) args = unApp val args

225 unApp other args = (other, args)

152 unApp other args = (other, args)

153+valueToJs m (Var _ ident) =

154+ return $ varToJs m ident

155+valueToJs m (Case _ values binders) = do

156+ vals <- mapM (valueToJs m) values

157+ bindersToJs m binders vals

226−valueToJs opts m e (Let ds val) = do

158+valueToJs m (Let _ ds val) = do

227− decls <- concat . catMaybes <$> mapM (flip (declToJs opts m) e) ds

159+ decls <- concat . catMaybes <$> mapM (bindToJs m) ds

228− ret <- valueToJs opts m e val

160+ ret <- valueToJs m val

229 return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []

161 return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []

230−valueToJs opts m e (Abs (Left arg) val) = do

162+valueToJs _ (Constructor (_, _, Just IsNewtype) _ (ProperName ctor) _) =

231− ret <- valueToJs opts m e val

163+ return $ JSVariableIntroduction ctor (Just $

164+ JSObjectLiteral [("create",

165+ JSFunction Nothing ["value"]

166+ (JSBlock [JSReturn $ JSVar "value"]))])

167+valueToJs _ (Constructor _ _ (ProperName ctor) 0) =

168+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])

169+ , JSAssignment (JSAccessor "value" (JSVar ctor))

170+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]

171+valueToJs _ (Constructor _ _ (ProperName ctor) arity) =

172+ return $ iife ctor [ makeConstructor ctor arity

173+ , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])

174+ ]

175+ where

176+ makeConstructor :: String -> Int -> JS

177+ makeConstructor ctorName n =

178+ let args = [ "value" ++ show index | index <- [0..n-1] ]

179+ body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]

180+ in JSFunction (Just ctorName) args (JSBlock body)

181+ go :: String -> Int -> Int -> [JS] -> JS

182+ go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)

183+ go pn index n values =

184+ JSFunction Nothing ["value" ++ show index]

185+ (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])

186+

187+iife :: String -> [JS] -> JS

232− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

188+iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

233−valueToJs _ m _ (Var ident) = return $ varToJs m ident

189+

234−valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val

190+literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

235−valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val

191+literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

236−valueToJs _ _ _ (TypeClassDictionary _ _ _) = error "Type class dictionary was not replaced"

192+literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

237−valueToJs _ _ _ _ = error "Invalid argument to valueToJs"

193+literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

194+literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs

195+literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps

238

196

239-- |

197-- |

240-- Shallow copy an object.

198-- Shallow copy an object.

@@ -276,109 +234,111 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

276-- Generate code in the simplified Javascript intermediate representation for pattern match binders

234-- Generate code in the simplified Javascript intermediate representation for pattern match binders

277-- and guards.

235-- and guards.

278--

236--

279−bindersToJs :: (Functor m, Applicative m, Monad m) => Options mode -> ModuleName -> Environment -> [CaseAlternative] -> [JS] -> SupplyT m JS

237+bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

280−bindersToJs opts m e binders vals = do

238+bindersToJs m binders vals = do

281 valNames <- replicateM (length vals) freshName

239 valNames <- replicateM (length vals) freshName

282 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

240 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

283 jss <- forM binders $ \(CaseAlternative bs result) -> do

241 jss <- forM binders $ \(CaseAlternative bs result) -> do

284 ret <- guardsToJs result

242 ret <- guardsToJs result

285 go valNames ret bs

243 go valNames ret bs

286− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") $ [JSStringLiteral "Failed pattern match"]])))

244+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

287 []

245 []

288 where

246 where

289− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder] -> SupplyT m [JS]

247+ go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

290 go _ done [] = return done

248 go _ done [] = return done

291 go (v:vs) done' (b:bs) = do

249 go (v:vs) done' (b:bs) = do

292 done'' <- go vs done' bs

250 done'' <- go vs done' bs

293− binderToJs m e v done'' b

251+ binderToJs m v done'' b

294 go _ _ _ = error "Invalid arguments to bindersToJs"

252 go _ _ _ = error "Invalid arguments to bindersToJs"

295

253

296− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard, Expr)] Expr -> SupplyT m [JS]

254+ guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

297 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

255 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

298− cond' <- valueToJs opts m e cond

256+ cond' <- valueToJs m cond

299− done <- valueToJs opts m e val

257+ done <- valueToJs m val

300 return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

258 return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

301− guardsToJs (Right v) = return . JSReturn <$> valueToJs opts m e v

259+ guardsToJs (Right v) = return . JSReturn <$> valueToJs m v

302

260

303-- |

261-- |

304-- Generate code in the simplified Javascript intermediate representation for a pattern match

262-- Generate code in the simplified Javascript intermediate representation for a pattern match

305-- binder.

263-- binder.

306--

264--

307−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Environment -> String -> [JS] -> Binder -> SupplyT m [JS]

265+binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

308−binderToJs _ _ _ done NullBinder = return done

266+binderToJs _ _ done (NullBinder{}) = return done

309−binderToJs _ _ varName done (StringBinder str) =

310− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

311−binderToJs _ _ varName done (NumberBinder num) =

312− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

313−binderToJs _ _ varName done (BooleanBinder True) =

267+binderToJs m varName done (LiteralBinder _ l) =

314− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

268+ literalToBinderJS m varName done l

315−binderToJs _ _ varName done (BooleanBinder False) =

316− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

317−binderToJs _ _ varName done (VarBinder ident) =

269+binderToJs _ varName done (VarBinder _ ident) =

318 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

270 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

319−binderToJs m e varName done (ConstructorBinder ctor bs) | isNewtypeConstructor e ctor =

271+binderToJs m varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) =

320− case bs of

321− [b] -> binderToJs m e varName done b

272+ binderToJs m varName done b

322− _ -> error "binder for newtype constructor should have a single argument"

273+binderToJs m varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType _)) _ ctor bs) = do

323−binderToJs m e varName done (ConstructorBinder ctor bs) = do

324 js <- go 0 done bs

274 js <- go 0 done bs

325− if isOnlyConstructor e ctor

275+ return $ case ctorType of

326− then

276+ ProductType -> js

327− return js

277+ SumType ->

328− else

329− return [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))

278+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))

330− (JSBlock js)

279+ (JSBlock js)

331− Nothing]

280+ Nothing]

332 where

281 where

333− go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder] -> SupplyT m [JS]

282+ go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]

334 go _ done' [] = return done'

283 go _ done' [] = return done'

335 go index done' (binder:bs') = do

284 go index done' (binder:bs') = do

336 argVar <- freshName

285 argVar <- freshName

337 done'' <- go (index + 1) done' bs'

286 done'' <- go (index + 1) done' bs'

338− js <- binderToJs m e argVar done'' binder

287+ js <- binderToJs m argVar done'' binder

339 return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)

288 return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)

340−binderToJs m e varName done (ObjectBinder bs) = go done bs

289+binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do

341− where

342− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder)] -> SupplyT m [JS]

343− go done' [] = return done'

344− go done' ((prop, binder):bs') = do

345− propVar <- freshName

346− done'' <- go done' bs'

347− js <- binderToJs m e propVar done'' binder

348− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

349−binderToJs m e varName done (ArrayBinder bs) = do

350− js <- go done 0 bs

351− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

352− where

353− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder] -> SupplyT m [JS]

354− go done' _ [] = return done'

355− go done' index (binder:bs') = do

356− elVar <- freshName

357− done'' <- go done' (index + 1) bs'

358− js <- binderToJs m e elVar done'' binder

359− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

360−binderToJs m e varName done binder@(ConsBinder _ _) = do

361 let (headBinders, tailBinder) = uncons [] binder

290 let (headBinders, tailBinder) = uncons [] binder

362 numberOfHeadBinders = fromIntegral $ length headBinders

291 numberOfHeadBinders = fromIntegral $ length headBinders

363 js1 <- foldM (\done' (headBinder, index) -> do

292 js1 <- foldM (\done' (headBinder, index) -> do

364 headVar <- freshName

293 headVar <- freshName

365− jss <- binderToJs m e headVar done' headBinder

294+ jss <- binderToJs m headVar done' headBinder

366 return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])

295 return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])

367 tailVar <- freshName

296 tailVar <- freshName

368− js2 <- binderToJs m e tailVar js1 tailBinder

297+ js2 <- binderToJs m tailVar js1 tailBinder

369 return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock

298 return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock

370 ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :

299 ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :

371 js2

300 js2

372 )) Nothing]

301 )) Nothing]

373 where

302 where

374− uncons :: [Binder] -> Binder -> ([Binder], Binder)

303+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)

375− uncons acc (ConsBinder h t) = uncons (h : acc) t

304+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t

376− uncons acc (PositionedBinder _ b) = uncons acc b

377 uncons acc tailBinder = (reverse acc, tailBinder)

305 uncons acc tailBinder = (reverse acc, tailBinder)

306+binderToJs _ _ _ b@(ConstructorBinder{}) =

307+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b

378−binderToJs m e varName done (NamedBinder ident binder) = do

308+binderToJs m varName done (NamedBinder _ ident binder) = do

379− js <- binderToJs m e varName done binder

309+ js <- binderToJs m varName done binder

380 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

310 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

381−binderToJs m e varName done (PositionedBinder _ binder) =

382− binderToJs m e varName done binder

383

311

312+literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

313+literalToBinderJS _ varName done (NumericLiteral num) =

314+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

315+literalToBinderJS _ varName done (StringLiteral str) =

316+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

317+literalToBinderJS _ varName done (BooleanLiteral True) =

318+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

319+literalToBinderJS _ varName done (BooleanLiteral False) =

320+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

321+literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

322+ where

323+ go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

324+ go done' [] = return done'

325+ go done' ((prop, binder):bs') = do

326+ propVar <- freshName

327+ done'' <- go done' bs'

328+ js <- binderToJs m propVar done'' binder

329+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

330+literalToBinderJS m varName done (ArrayLiteral bs) = do

331+ js <- go done 0 bs

332+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

333+ where

334+ go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

335+ go done' _ [] = return done'

336+ go done' index (binder:bs') = do

337+ elVar <- freshName

338+ done'' <- go done' (index + 1) bs'

339+ js <- binderToJs m elVar done'' binder

340+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

384

341

342+isCons :: Qualified ProperName -> Bool

343+isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"

344+isCons name = error $ "Unexpected argument in isCons: " ++ show name

src/Language/PureScript/CodeGen/Common.hs → src/Language/PureScript/CodeGen/JS/Common.hsrenamed+1−53

@@ -13,18 +13,12 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.CodeGen.Common where

16+module Language.PureScript.CodeGen.JS.Common where

18import Data.Char

19import Data.List (intercalate)

20−import Data.Maybe (fromMaybe)

21−import Data.Function (on)

22−

23−import qualified Data.Map as M

25import Language.PureScript.Names

21import Language.PureScript.Names

26−import Language.PureScript.Environment

27−import Language.PureScript.Types

29-- |

23-- |

30-- Convert an Ident into a valid Javascript identifier:

24-- Convert an Ident into a valid Javascript identifier:

@@ -145,49 +139,3 @@ nameIsJsReserved name =

145

139

146moduleNameToJs :: ModuleName -> String

140moduleNameToJs :: ModuleName -> String

147moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

141moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)

148−

149−-- |

150−-- Finds the value stored for a data constructor in the current environment.

151−-- This is a partial function, but if an invalid type has reached this far then

152−-- something has gone wrong in typechecking.

153−--

154−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

155−lookupConstructor e ctor = fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors e

156−

157−-- |

158−-- Checks whether a data constructor is the only constructor for that type, used

159−-- to simplify the check when generating code for binders.

160−--

161−isOnlyConstructor :: Environment -> Qualified ProperName -> Bool

162−isOnlyConstructor e ctor = numConstructors (ctor, lookupConstructor e ctor) == 1

163− where

164− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

165− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e

166− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

167− typeConstructor (Qualified (Just moduleName) _, (_, tyCtor, _)) = (moduleName, tyCtor)

168− typeConstructor _ = error "Invalid argument to isOnlyConstructor"

169−

170−-- |

171−-- Checks whether a data constructor is for a newtype.

172−--

173−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

174−isNewtypeConstructor e ctor = case lookupConstructor e ctor of

175− (Newtype, _, _) -> True

176− (Data, _, _) -> False

177−

178−-- |

179−-- Checks the number of arguments a data constructor accepts.

180−--

181−getConstructorArity :: Environment -> Qualified ProperName -> Int

182−getConstructorArity e = go . (\(_, _, ctors) -> ctors) . lookupConstructor e

183− where

184− go :: Type -> Int

185− go (TypeApp (TypeApp f _) t) | f == tyFunction = go t + 1

186− go (ForAll _ ty _) = go ty

187− go _ = 0

188−

189−-- |

190−-- Checks whether a data constructor has no arguments, for example, `Nothing`.

191−--

192−isNullaryConstructor :: Environment -> Qualified ProperName -> Bool

193−isNullaryConstructor e = (== 0) . getConstructorArity e

src/Language/PureScript/Optimizer.hs → src/Language/PureScript/CodeGen/JS/Optimizer.hsrenamed+8−8

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer

4-- Copyright : (c) Phil Freeman 2013

5-- License : MIT

6--

@@ -31,7 +31,7 @@

31--

32-----------------------------------------------------------------------------

34−module Language.PureScript.Optimizer (

34+module Language.PureScript.CodeGen.JS.Optimizer (

35 optimize

36) where

@@ -39,12 +39,12 @@ import Language.PureScript.CodeGen.JS.AST

39import Language.PureScript.Options

40import qualified Language.PureScript.Constants as C

42−import Language.PureScript.Optimizer.Common

42+import Language.PureScript.CodeGen.JS.Optimizer.Common

43−import Language.PureScript.Optimizer.TCO

43+import Language.PureScript.CodeGen.JS.Optimizer.TCO

44−import Language.PureScript.Optimizer.MagicDo

44+import Language.PureScript.CodeGen.JS.Optimizer.MagicDo

45−import Language.PureScript.Optimizer.Inliner

45+import Language.PureScript.CodeGen.JS.Optimizer.Inliner

46−import Language.PureScript.Optimizer.Unused

46+import Language.PureScript.CodeGen.JS.Optimizer.Unused

47−import Language.PureScript.Optimizer.Blocks

47+import Language.PureScript.CodeGen.JS.Optimizer.Blocks

49-- |

50-- Apply a series of optimizer passes to simplified Javascript code

src/Language/PureScript/Optimizer/Blocks.hs → src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hsrenamed+2−2

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.Blocks

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.Optimizer.Blocks

16+module Language.PureScript.CodeGen.JS.Optimizer.Blocks

17 ( collapseNestedBlocks

18 , collapseNestedIfs

19 ) where

src/Language/PureScript/Optimizer/Common.hs → src/Language/PureScript/CodeGen/JS/Optimizer/Common.hsrenamed+2−2

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.Common

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.Optimizer.Common where

16+module Language.PureScript.CodeGen.JS.Optimizer.Common where

18import Data.Maybe (fromMaybe)

src/Language/PureScript/Optimizer/Inliner.hs → src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hsrenamed+4−5

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.Inliner

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.Optimizer.Inliner (

16+module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

17 inlineVariables,

18 inlineOperator,

19 inlineCommonOperators,

@@ -25,10 +25,9 @@ module Language.PureScript.Optimizer.Inliner (

25import Data.Maybe (fromMaybe)

27import Language.PureScript.CodeGen.JS.AST

28−import Language.PureScript.CodeGen.Common (identToJs)

28+import Language.PureScript.CodeGen.JS.Common

29−import Language.PureScript.Optimizer.Common

30import Language.PureScript.Names

29import Language.PureScript.Names

31−

30+import Language.PureScript.CodeGen.JS.Optimizer.Common

32import qualified Language.PureScript.Constants as C

31import qualified Language.PureScript.Constants as C

34shouldInline :: JS -> Bool

33shouldInline :: JS -> Bool

src/Language/PureScript/Optimizer/MagicDo.hs → src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hsrenamed+5−6

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.MagicDo

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -14,18 +14,17 @@

14--

15-----------------------------------------------------------------------------

17−module Language.PureScript.Optimizer.MagicDo (

17+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (

18 magicDo

19) where

21import Data.List (nub)

22import Data.Maybe (fromJust, isJust)

24−import Language.PureScript.Options

25import Language.PureScript.CodeGen.JS.AST

24import Language.PureScript.CodeGen.JS.AST

26−import Language.PureScript.CodeGen.Common (identToJs)

25+import Language.PureScript.CodeGen.JS.Common

27import Language.PureScript.Names

26import Language.PureScript.Names

28−

27+import Language.PureScript.Options

29import qualified Language.PureScript.Constants as C

28import qualified Language.PureScript.Constants as C

31magicDo :: Options mode -> JS -> JS

30magicDo :: Options mode -> JS -> JS

@@ -104,7 +103,7 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

104 undo :: JS -> JS

103 undo :: JS -> JS

105 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

104 undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body

106 undo other = other

105 undo other = other

107−

106+

108 applyReturns :: JS -> JS

107 applyReturns :: JS -> JS

109 applyReturns (JSReturn ret) = JSReturn (JSApp ret [])

108 applyReturns (JSReturn ret) = JSReturn (JSApp ret [])

110 applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)

109 applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)

src/Language/PureScript/Optimizer/TCO.hs → src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hsrenamed+2−2

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.TCO

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.Optimizer.TCO (tco) where

16+module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where

18import Language.PureScript.Options

19import Language.PureScript.CodeGen.JS.AST

src/Language/PureScript/Optimizer/Unused.hs → src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hsrenamed+3−3

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

1-----------------------------------------------------------------------------

2--

3−-- Module : Language.PureScript.Optimizer.Unused

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused

4-- Copyright : (c) Phil Freeman 2013-14

5-- License : MIT

6--

@@ -13,14 +13,14 @@

13--

14-----------------------------------------------------------------------------

16−module Language.PureScript.Optimizer.Unused

16+module Language.PureScript.CodeGen.JS.Optimizer.Unused

17 ( removeCodeAfterReturnStatements

18 , removeUnusedArg

19 , removeUndefinedApp

20 ) where

22import Language.PureScript.CodeGen.JS.AST

23−import Language.PureScript.Optimizer.Common

23+import Language.PureScript.CodeGen.JS.Optimizer.Common

25import qualified Language.PureScript.Constants as C

src/Language/PureScript/CoreFn.hsnew file+26

@@ -0,0 +1,26 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn (

16+ module C

17+) where

18+

19+import Language.PureScript.CoreFn.Ann as C

20+import Language.PureScript.CoreFn.Binders as C

21+import Language.PureScript.CoreFn.Desugar as C

22+import Language.PureScript.CoreFn.Expr as C

23+import Language.PureScript.CoreFn.Literals as C

24+import Language.PureScript.CoreFn.Meta as C

25+import Language.PureScript.CoreFn.Module as C

26+import Language.PureScript.CoreFn.Traversals as C

src/Language/PureScript/CoreFn/Ann.hsnew file+30

@@ -0,0 +1,30 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Ann

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Type alias for basic annotations

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Ann where

16+

17+import Language.PureScript.AST.SourcePos

18+import Language.PureScript.CoreFn.Meta

19+import Language.PureScript.Types

20+

21+-- |

22+-- Type alias for basic annotations

23+--

24+type Ann = (Maybe SourceSpan, Maybe Type, Maybe Meta)

25+

26+-- |

27+-- Initial annotation with no metadata

28+--

29+nullAnn :: Ann

30+nullAnn = (Nothing, Nothing, Nothing)

src/Language/PureScript/CoreFn/Binders.hsnew file+47

@@ -0,0 +1,47 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Binders

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation for binders

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.CoreFn.Binders where

18+

19+import qualified Data.Data as D

20+

21+import Language.PureScript.CoreFn.Literals

22+import Language.PureScript.Names

23+

24+-- |

25+-- Data type for binders

26+--

27+data Binder a

28+ -- |

29+ -- Wildcard binder

30+ --

31+ = NullBinder a

32+ -- |

33+ -- A binder which matches a literal value

34+ --

35+ | LiteralBinder a (Literal (Binder a))

36+ -- |

37+ -- A binder which binds an identifier

38+ --

39+ | VarBinder a Ident

40+ -- |

41+ -- A binder which matches a data constructor (type name, constructor name, binders)

42+ --

43+ | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]

44+ -- |

45+ -- A binder which binds its input to an identifier

46+ --

47+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/CoreFn/Desugar.hsnew file+242

@@ -0,0 +1,242 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Desugar

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The AST -> CoreFn desugaring step

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

16+

17+import Data.Function (on)

18+import Data.List (sort, sortBy, nub)

19+import Data.Maybe (mapMaybe)

20+import qualified Data.Map as M

21+

22+import Control.Arrow (second, (***))

23+

24+import Language.PureScript.AST.SourcePos

25+import Language.PureScript.AST.Traversals

26+import Language.PureScript.CoreFn.Ann

27+import Language.PureScript.CoreFn.Binders

28+import Language.PureScript.CoreFn.Expr

29+import Language.PureScript.CoreFn.Literals

30+import Language.PureScript.CoreFn.Meta

31+import Language.PureScript.CoreFn.Module

32+import Language.PureScript.Environment

33+import Language.PureScript.Names

34+import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)

35+import Language.PureScript.Types

36+import qualified Language.PureScript.AST as A

37+import qualified Language.PureScript.Constants as C

38+

39+-- |

40+-- Desugars a module from AST to CoreFn representation.

41+--

42+moduleToCoreFn :: Environment -> A.Module -> Module Ann

43+moduleToCoreFn env (A.Module mn decls (Just exps)) =

44+ let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

45+ exps' = nub $ concatMap exportToCoreFn exps

46+ externs = nub $ mapMaybe externToCoreFn decls

47+ decls' = concatMap (declToCoreFn env Nothing) decls

48+ in Module mn imports exps' externs decls'

49+moduleToCoreFn _ (A.Module{}) =

50+ error "Module exports were not elaborated before moduleToCoreFn"

51+

52+findQualModules :: [A.Declaration] -> [ModuleName]

53+findQualModules decls =

54+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])

55+ in f `concatMap` decls

56+ where

57+ fqValues :: A.Expr -> [ModuleName]

58+ fqValues (A.Var (Qualified (Just mn) _)) = [mn]

59+ fqValues _ = []

60+

61+-- |

62+-- Desugars import declarations from AST to CoreFn representation.

63+--

64+importToCoreFn :: A.Declaration -> Maybe ModuleName

65+importToCoreFn (A.ImportDeclaration name _ _) = Just name

66+importToCoreFn (A.PositionedDeclaration _ d) = importToCoreFn d

67+importToCoreFn _ = Nothing

68+

69+-- |

70+-- Desugars foreign declarations from AST to CoreFn representation.

71+--

72+externToCoreFn :: A.Declaration -> Maybe ForeignDecl

73+externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)

74+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)

75+externToCoreFn (A.PositionedDeclaration _ d) = externToCoreFn d

76+externToCoreFn _ = Nothing

77+

78+-- |

79+-- Desugars export declarations references from AST to CoreFn representation.

80+-- CoreFn modules only export values, so all data constructors, class

81+-- constructor, instances and values are flattened into one list.

82+--

83+exportToCoreFn :: A.DeclarationRef -> [Ident]

84+exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors

85+exportToCoreFn (A.ValueRef name) = [name]

86+exportToCoreFn (A.TypeClassRef name) = [properToIdent name]

87+exportToCoreFn (A.TypeInstanceRef name) = [name]

88+exportToCoreFn (A.PositionedDeclarationRef _ d) = exportToCoreFn d

89+exportToCoreFn _ = []

90+

91+-- |

92+-- Desugars member declarations from AST to CoreFn representation.

93+--

94+declToCoreFn :: Environment -> Maybe SourceSpan -> A.Declaration -> [Bind Ann]

95+declToCoreFn _ ss (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

96+ [NonRec (properToIdent ctor) $

97+ Abs (ss, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

98+declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

99+ error $ "Found newtype with multiple constructors: " ++ show d

100+declToCoreFn _ ss (A.DataDeclaration Data tyName _ ctors) =

101+ flip map ctors $ \(ctor, tys) ->

102+ NonRec (properToIdent ctor) $ Constructor (ss, Nothing, Nothing) tyName ctor (length tys)

103+declToCoreFn env ss (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss) ds

104+declToCoreFn env ss (A.ValueDeclaration name _ _ (Right e)) =

105+ [NonRec name (exprToCoreFn env ss Nothing e)]

106+declToCoreFn env ss (A.BindingGroupDeclaration ds) =

107+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss Nothing e)) ds]

108+declToCoreFn _ ss (A.TypeClassDeclaration name _ supers members) =

109+ [NonRec (properToIdent name) $ mkTypeClassConstructor ss supers members]

110+declToCoreFn env _ (A.PositionedDeclaration ss d) =

111+ declToCoreFn env (Just ss) d

112+declToCoreFn _ _ _ = []

113+

114+-- |

115+-- Makes a typeclass dictionary constructor function. The returned expression

116+-- is a function that accepts the superclass instances and member

117+-- implementations and returns a record for the instance dictionary.

118+--

119+mkTypeClassConstructor :: Maybe SourceSpan -> [Constraint] -> [A.Declaration] -> Expr Ann

120+mkTypeClassConstructor ss [] [] = Literal (ss, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])

121+mkTypeClassConstructor ss supers members =

122+ let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers

123+ props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]

124+ dict = Literal nullAnn (ObjectLiteral props)

125+ in Abs (ss, Nothing, Just IsTypeClassConstructor)

126+ (Ident a)

127+ (foldr (Abs nullAnn . Ident) dict as)

128+

129+-- |

130+-- Desugars expressions from AST to CoreFn representation.

131+--

132+exprToCoreFn :: Environment -> Maybe SourceSpan -> Maybe Type -> A.Expr -> Expr Ann

133+exprToCoreFn _ ss ty (A.NumericLiteral v) =

134+ Literal (ss, ty, Nothing) (NumericLiteral v)

135+exprToCoreFn _ ss ty (A.StringLiteral v) =

136+ Literal (ss, ty, Nothing) (StringLiteral v)

137+exprToCoreFn _ ss ty (A.BooleanLiteral v) =

138+ Literal (ss, ty, Nothing) (BooleanLiteral v)

139+exprToCoreFn env ss ty (A.ArrayLiteral vs) =

140+ Literal (ss, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss Nothing) vs)

141+exprToCoreFn env ss ty (A.ObjectLiteral vs) =

142+ Literal (ss, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss Nothing)) vs)

143+exprToCoreFn env ss ty (A.Accessor name v) =

144+ Accessor (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)

145+exprToCoreFn env ss ty (A.ObjectUpdate obj vs) =

146+ ObjectUpdate (ss, ty, Nothing) (exprToCoreFn env ss Nothing obj) $ map (second (exprToCoreFn env ss Nothing)) vs

147+exprToCoreFn env ss ty (A.Abs (Left name) v) =

148+ Abs (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)

149+exprToCoreFn _ _ _ (A.Abs _ _) =

150+ error "Abs with Binder argument was not desugared before exprToCoreFn"

151+exprToCoreFn env ss ty (A.App v1 v2) =

152+ App (ss, ty, Nothing) (exprToCoreFn env ss Nothing v1) (exprToCoreFn env ss Nothing v2)

153+exprToCoreFn _ ss ty (A.Var ident) =

154+ Var (ss, ty, Nothing) ident

155+exprToCoreFn env ss ty (A.IfThenElse v1 v2 v3) =

156+ Case (ss, ty, Nothing) [exprToCoreFn env ss Nothing v1]

157+ [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

158+ (Right $ exprToCoreFn env Nothing Nothing v2)

159+ , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]

160+ (Right $ exprToCoreFn env Nothing Nothing v3) ]

161+exprToCoreFn env ss ty (A.Constructor name) =

162+ Var (ss, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name

163+exprToCoreFn env ss ty (A.Case vs alts) =

164+ Case (ss, ty, Nothing) (map (exprToCoreFn env ss Nothing) vs) (map (altToCoreFn env ss) alts)

165+exprToCoreFn env ss _ (A.TypedValue _ v ty) =

166+ exprToCoreFn env ss (Just ty) v

167+exprToCoreFn env ss ty (A.Let ds v) =

168+ Let (ss, ty, Nothing) (concatMap (declToCoreFn env ss) ds) (exprToCoreFn env ss Nothing v)

169+exprToCoreFn env ss ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

170+ let args = map (exprToCoreFn env ss Nothing . snd) $ sortBy (compare `on` fst) vs

171+ ctor = Var (ss, Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

172+ in foldl (App (ss, Nothing, Nothing)) ctor args

173+exprToCoreFn env _ ty (A.PositionedValue ss v) =

174+ exprToCoreFn env (Just ss) ty v

175+exprToCoreFn _ _ _ e =

176+ error $ "Unexpected value in exprToCoreFn: " ++ show e

177+

178+-- |

179+-- Desugars case alternatives from AST to CoreFn representation.

180+--

181+altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann

182+altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss) bs) (go vs)

183+ where

184+ go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)

185+ go (Left ges) = Left $ map (exprToCoreFn env ss Nothing *** exprToCoreFn env ss Nothing) ges

186+ go (Right e) = Right (exprToCoreFn env ss Nothing e)

187+

188+-- |

189+-- Desugars case binders from AST to CoreFn representation.

190+--

191+binderToCoreFn :: Environment -> Maybe SourceSpan -> A.Binder -> Binder Ann

192+binderToCoreFn _ ss (A.NullBinder) =

193+ NullBinder (ss, Nothing, Nothing)

194+binderToCoreFn _ ss (A.BooleanBinder b) =

195+ LiteralBinder (ss, Nothing, Nothing) (BooleanLiteral b)

196+binderToCoreFn _ ss (A.StringBinder s) =

197+ LiteralBinder (ss, Nothing, Nothing) (StringLiteral s)

198+binderToCoreFn _ ss (A.NumberBinder n) =

199+ LiteralBinder (ss, Nothing, Nothing) (NumericLiteral n)

200+binderToCoreFn _ ss (A.VarBinder name) =

201+ VarBinder (ss, Nothing, Nothing) name

202+binderToCoreFn env ss (A.ConstructorBinder dctor@(Qualified mn _) bs) =

203+ let (_, tctor, _) = lookupConstructor env dctor

204+ in ConstructorBinder (ss, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss) bs)

205+binderToCoreFn env ss (A.ObjectBinder bs) =

206+ LiteralBinder (ss, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss)) bs)

207+binderToCoreFn env ss (A.ArrayBinder bs) =

208+ LiteralBinder (ss, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss) bs)

209+binderToCoreFn env ss (A.ConsBinder b1 b2) =

210+ let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

211+ in ConstructorBinder (ss, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss) [b1, b2]

212+binderToCoreFn env ss (A.NamedBinder name b) =

213+ NamedBinder (ss, Nothing, Nothing) name (binderToCoreFn env ss b)

214+binderToCoreFn env _ (A.PositionedBinder ss b) =

215+ binderToCoreFn env (Just ss) b

216+

217+-- |

218+-- Converts a ProperName to an Ident.

219+--

220+properToIdent :: ProperName -> Ident

221+properToIdent = Ident . runProperName

222+

223+-- |

224+-- Gets metadata for data constructors.

225+--

226+getConstructorMeta :: Environment -> Qualified ProperName -> Meta

227+getConstructorMeta env ctor =

228+ case lookupConstructor env ctor of

229+ (Newtype, _, _) -> IsNewtype

230+ dc@(Data, _, ty) ->

231+ let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

232+ in IsConstructor constructorType (getArity ty)

233+ where

234+ getArity :: Type -> Int

235+ getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1

236+ getArity (ForAll _ ty _) = getArity ty

237+ getArity _ = 0

238+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int

239+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

240+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)

241+ typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)

242+ typeConstructor _ = error "Invalid argument to typeConstructor"

src/Language/PureScript/CoreFn/Expr.hsnew file+97

@@ -0,0 +1,97 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Expr

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.CoreFn.Expr where

18+

19+import qualified Data.Data as D

20+

21+import Language.PureScript.CoreFn.Binders

22+import Language.PureScript.CoreFn.Literals

23+import Language.PureScript.CoreFn.Meta

24+import Language.PureScript.Names

25+

26+-- |

27+-- Data type for expressions and terms

28+--

29+data Expr a

30+ -- |

31+ -- A literal value

32+ --

33+ = Literal a (Literal (Expr a))

34+ -- |

35+ -- A data constructor (type name, constructor name, arity)

36+ --

37+ | Constructor a ProperName ProperName Arity

38+ -- |

39+ -- A record property accessor

40+ --

41+ | Accessor a String (Expr a)

42+ -- |

43+ -- Partial record update

44+ --

45+ | ObjectUpdate a (Expr a) [(String, Expr a)]

46+ -- |

47+ -- Function introduction

48+ --

49+ | Abs a Ident (Expr a)

50+ -- |

51+ -- Function application

52+ --

53+ | App a (Expr a) (Expr a)

54+ -- |

55+ -- Variable

56+ --

57+ | Var a (Qualified Ident)

58+ -- |

59+ -- A case expression

60+ --

61+ | Case a [Expr a] [CaseAlternative a]

62+ -- |

63+ -- A let binding

64+ --

65+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)

66+

67+-- |

68+-- A let or module binding.

69+--

70+data Bind a

71+ -- |

72+ -- Non-recursive binding for a single value

73+ --

74+ = NonRec Ident (Expr a)

75+ -- |

76+ -- Mutually recursive binding group for several values

77+ --

78+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)

79+

80+-- |

81+-- A guard is just a boolean-valued expression that appears alongside a set of binders

82+--

83+type Guard a = Expr a

84+

85+-- |

86+-- An alternative in a case statement

87+--

88+data CaseAlternative a = CaseAlternative

89+ { -- |

90+ -- A collection of binders with which to match the inputs

91+ --

92+ caseAlternativeBinders :: [Binder a]

93+ -- |

94+ -- The result expression or a collect of guarded expressions

95+ --

96+ , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

97+ } deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/CoreFn/Literals.hsnew file+45

@@ -0,0 +1,45 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Literals

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation for literal values.

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.CoreFn.Literals where

18+

19+import qualified Data.Data as D

20+

21+-- |

22+-- Data type for literal values. Parameterised so it can be used for Exprs and

23+-- Binders.

24+--

25+data Literal a

26+ -- |

27+ -- A numeric literal

28+ --

29+ = NumericLiteral (Either Integer Double)

30+ -- |

31+ -- A string literal

32+ --

33+ | StringLiteral String

34+ -- |

35+ -- A boolean literal

36+ --

37+ | BooleanLiteral Bool

38+ -- |

39+ -- An array literal

40+ --

41+ | ArrayLiteral [a]

42+ -- |

43+ -- An object literal

44+ --

45+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/CoreFn/Meta.hsnew file+54

@@ -0,0 +1,54 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Meta

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Metadata annotations for core functional representation

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.CoreFn.Meta where

18+

19+import qualified Data.Data as D

20+

21+-- |

22+-- Metadata annotations

23+--

24+data Meta

25+ -- |

26+ -- The contained value is a data constructor

27+ --

28+ = IsConstructor ConstructorType Arity

29+ -- |

30+ -- The contained value is a newtype

31+ --

32+ | IsNewtype

33+ -- |

34+ -- The contained value is a typeclass dictionary constructor

35+ --

36+ | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)

37+

38+-- |

39+-- Type alias for constructor arity

40+--

41+type Arity = Int

42+

43+-- |

44+-- Data constructor metadata

45+--

46+data ConstructorType

47+ -- |

48+ -- The constructor is for a type with a single construcor

49+ --

50+ = ProductType

51+ -- |

52+ -- The constructor is for a type with multiple construcors

53+ --

54+ | SumType deriving (Show, D.Data, D.Typeable)

src/Language/PureScript/CoreFn/Module.hsnew file+30

@@ -0,0 +1,30 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Module

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The CoreFn module representation

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Module where

16+

17+import Language.PureScript.CodeGen.JS.AST

18+import Language.PureScript.CoreFn.Expr

19+import Language.PureScript.Names

20+import Language.PureScript.Types

21+

22+data Module a = Module

23+ { moduleName :: ModuleName

24+ , moduleImports :: [ModuleName]

25+ , moduleExports :: [Ident]

26+ , moduleForeign :: [ForeignDecl]

27+ , moduleDecls :: [Bind a]

28+ } deriving (Show)

29+

30+type ForeignDecl = (Ident, Maybe JS, Type)

src/Language/PureScript/CoreFn/Traversals.hsnew file+85

@@ -0,0 +1,85 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Traversals

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | CoreFn traversal helpers

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Traversals where

16+

17+import Control.Arrow (second, (***), (+++))

18+

19+import Language.PureScript.CoreFn.Binders

20+import Language.PureScript.CoreFn.Expr

21+import Language.PureScript.CoreFn.Literals

22+

23+everywhereOnValues :: (Bind a -> Bind a) ->

24+ (Expr a -> Expr a) ->

25+ (Binder a -> Binder a) ->

26+ (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

27+everywhereOnValues f g h = (f', g', h')

28+ where

29+ f' (NonRec name e) = f (NonRec name (g' e))

30+ f' (Rec es) = f (Rec (map (second g') es))

31+

32+ g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

33+ g' (Accessor ann prop e) = g (Accessor ann prop (g' e))

34+ g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))

35+ g' (Abs ann name e) = g (Abs ann name (g' e))

36+ g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))

37+ g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))

38+ g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))

39+ g' e = g e

40+

41+ h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

42+ h' (NamedBinder a name b) = h (NamedBinder a name (h' b))

43+ h' b = h b

44+

45+ handleCaseAlternative ca =

46+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

47+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)

48+ }

49+

50+ handleLiteral :: (a -> a) -> Literal a -> Literal a

51+ handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)

52+ handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)

53+ handleLiteral _ other = other

54+

55+everythingOnValues :: (r -> r -> r) ->

56+ (Bind a -> r) ->

57+ (Expr a -> r) ->

58+ (Binder a -> r) ->

59+ (CaseAlternative a -> r) ->

60+ (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

61+everythingOnValues (<>) f g h i = (f', g', h', i')

62+ where

63+ f' b@(NonRec _ e) = f b <> g' e

64+ f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

65+

66+ g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))

67+ g' v@(Accessor _ _ e1) = g v <> g' e1

68+ g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

69+ g' v@(Abs _ _ e1) = g v <> g' e1

70+ g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2

71+ g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)

72+ g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1

73+ g' v = g v

74+

75+ h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))

76+ h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)

77+ h' b@(NamedBinder _ _ b1) = h b <> h' b1

78+ h' b = h b

79+

80+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

81+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

82+

83+ extractLiteral (ArrayLiteral xs) = xs

84+ extractLiteral (ObjectLiteral xs) = map snd xs

85+ extractLiteral _ = []

src/Language/PureScript/DeadCodeElimination.hs+57−71

@@ -8,7 +8,7 @@

8-- Stability : experimental

9-- Portability :

10--

11−-- |

11+-- | Dead code elimination.

12--

13-----------------------------------------------------------------------------

@@ -16,98 +16,84 @@ module Language.PureScript.DeadCodeElimination (

16 eliminateDeadCode

17) where

19−import Data.List

20import Data.Graph

19import Data.Graph

20+import Data.List

21import Data.Maybe (mapMaybe)

23+import Language.PureScript.CoreFn

23import Language.PureScript.Names

24import Language.PureScript.Names

24−import Language.PureScript.AST

26-- |

27-- Eliminate all declarations which are not a transitive dependency of the entry point module

28--

29−eliminateDeadCode :: [ModuleName] -> [Module] -> [Module]

29+eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]

30eliminateDeadCode entryPoints ms = map go ms

31 where

32− go (Module moduleName ds (Just exps)) = Module moduleName ds' (Just exps')

32+ go (Module mn imps exps foreigns ds) = Module mn imps exps' foreigns' ds'

33 where

34− ds' = filter (isUsed moduleName graph vertexFor entryPointVertices) ds

34+ ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds

35− exps' = mapMaybe (filterExport ds') exps

35+ foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns

36− go _ = error "Exports should have been elaborated in name desugaring"

36+ names = concatMap bindIdents ds' ++ map foreignIdent foreigns'

37+ exps' = filter (`elem` names) exps

37 declarations = concatMap declarationsByModule ms

38 declarations = concatMap declarationsByModule ms

38 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

39 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

39 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

40 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

41− filterExport :: [Declaration] -> DeclarationRef -> Maybe DeclarationRef

42+-- |

42− filterExport decls r@(TypeRef name _) | (any $ typeOrClassExists name) decls = Just r

43+-- Extract declaration names for a binding group.

43− filterExport decls r@(TypeClassRef name) | (any $ typeOrClassExists name) decls = Just r

44+--

44− filterExport decls r@(ValueRef name) | (any $ valueExists name) decls = Just r

45+bindIdents :: Bind a -> [Ident]

45− filterExport decls r@(TypeInstanceRef name) | (any $ valueExists name) decls = Just r

46+bindIdents (NonRec name _) = [name]

46− filterExport _ _ = Nothing

47+bindIdents (Rec names) = map fst names

47−

48− valueExists :: Ident -> Declaration -> Bool

49− valueExists name (ValueDeclaration name' _ _ _) = name == name'

50− valueExists name (ExternDeclaration _ name' _ _) = name == name'

51− valueExists name (BindingGroupDeclaration decls) = any (\(name', _, _) -> name == name') decls

52− valueExists name (PositionedDeclaration _ d) = valueExists name d

53− valueExists _ _ = False

55− typeOrClassExists :: ProperName -> Declaration -> Bool

49+-- |

56− typeOrClassExists name (DataDeclaration _ name' _ _) = name == name'

50+-- Extract the ident for a foreign declaration.

57− typeOrClassExists name (TypeClassDeclaration name' _ _ _) = name == name'

51+--

58− typeOrClassExists name (DataBindingGroupDeclaration decls) = any (typeOrClassExists name) decls

52+foreignIdent :: ForeignDecl -> Ident

59− typeOrClassExists name (PositionedDeclaration _ d) = typeOrClassExists name d

53+foreignIdent (name, _, _) = name

60− typeOrClassExists _ _ = False

55+-- |

56+-- Key type to use in graph

57+--

62−type Key = (ModuleName, Either Ident ProperName)

58+type Key = (ModuleName, Ident)

60+-- |

61+-- Find dependencies for each member in a module.

62+--

64−declarationsByModule :: Module -> [(Key, [Key])]

63+declarationsByModule :: Module a -> [(Key, [Key])]

65−declarationsByModule (Module moduleName ds _) = concatMap go ds

64+declarationsByModule (Module mn _ _ fs ds) =

65+ let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs

66+ in fs' ++ concatMap go ds

66 where

67 where

67− go :: Declaration -> [(Key, [Key])]

68+ go :: Bind a -> [(Key, [Key])]

68− go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies moduleName d)]

69+ go d@(NonRec name _) = [((mn, name), dependencies d)]

69− go (DataDeclaration _ _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

70− go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

71− go d@(BindingGroupDeclaration names') = map (\(name, _, _) -> ((moduleName, Left name), dependencies moduleName d)) names'

70+ go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names'

72− go (DataBindingGroupDeclaration ds') = concatMap go ds'

73− go (TypeClassDeclaration name _ _ _) = [((moduleName, Right name), [])]

74− go (PositionedDeclaration _ d) = go d

75− go _ = []

72+-- |

73+-- Find all referenced values within a binding group.

74+--

77−dependencies :: ModuleName -> Declaration -> [Key]

75+dependencies :: Bind a -> [Key]

78−dependencies moduleName =

76+dependencies =

79− let (f, _, _, _, _) = everythingOnValues (++) (const []) values (const []) (const []) (const [])

77+ let (f, _, _, _) = everythingOnValues (++) (const []) values (const []) (const [])

80 in nub . f

78 in nub . f

81 where

79 where

82− values :: Expr -> [Key]

80+ values :: Expr a -> [Key]

83− values (Var ident) = let (mn, name) = qualify moduleName ident in [(mn, Left name)]

81+ values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]

84− values (Constructor (Qualified (Just mn) name)) = [(mn, Right name)]

85− values (Constructor (Qualified Nothing _)) = error "Found unqualified data constructor"

86− values (TypeClassDictionaryConstructorApp (Qualified (Just mn) name) _) = [(mn, Right name)]

87− values (TypeClassDictionaryConstructorApp (Qualified Nothing _) _) = error "Found unqualified class dictionary constructor"

88 values _ = []

82 values _ = []

84+-- |

85+-- Check whether a binding group is used.

86+--

90−isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Declaration -> Bool

87+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool

91−isUsed moduleName graph vertexFor entryPointVertices (ValueDeclaration name _ _ _) =

88+isUsed mn graph vertexFor entryPointVertices (NonRec name _) =

92− let Just v' = vertexFor (moduleName, Left name)

93− in any (\v -> path graph v v') entryPointVertices

94−isUsed moduleName graph vertexFor entryPointVertices (FixityDeclaration _ name) =

89+ isUsed' mn graph vertexFor entryPointVertices name

95− let Just v' = vertexFor (moduleName, Left $ Op name)

96− in any (\v -> path graph v v') entryPointVertices

97−isUsed moduleName graph vertexFor entryPointVertices (DataDeclaration _ _ _ dctors) =

90+isUsed mn graph vertexFor entryPointVertices (Rec ds) =

98− any (\(pn, _) -> let Just v' = vertexFor (moduleName, Right pn)

99− in any (\v -> path graph v v') entryPointVertices) dctors

100−isUsed moduleName graph vertexFor entryPointVertices (ExternDeclaration _ name _ _) =

91+ any (isUsed' mn graph vertexFor entryPointVertices . fst) ds

101− let Just v' = vertexFor (moduleName, Left name)

92+

102− in any (\v -> path graph v v') entryPointVertices

93+-- |

103−isUsed moduleName graph vertexFor entryPointVertices (BindingGroupDeclaration ds) =

94+-- Check whether a named declaration is used.

104− any (\(name, _, _) -> let Just v' = vertexFor (moduleName, Left name)

95+--

105− in any (\v -> path graph v v') entryPointVertices) ds

96+isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool

106−isUsed moduleName graph vertexFor entryPointVertices (DataBindingGroupDeclaration ds) =

107− any (isUsed moduleName graph vertexFor entryPointVertices) ds

108−isUsed moduleName graph vertexFor entryPointVertices (TypeClassDeclaration name _ _ _) =

97+isUsed' mn graph vertexFor entryPointVertices name =

109− let Just v' = vertexFor (moduleName, Right name)

98+ let Just v' = vertexFor (mn, name)

110 in any (\v -> path graph v v') entryPointVertices

99 in any (\v -> path graph v v') entryPointVertices

111−isUsed moduleName graph vertexFor entryPointVertices (PositionedDeclaration _ d) =

112− isUsed moduleName graph vertexFor entryPointVertices d

113−isUsed _ _ _ _ _ = True

src/Language/PureScript/Environment.hs+20−5

@@ -17,15 +17,15 @@

17module Language.PureScript.Environment where

19import Data.Data

20+import Data.Maybe (fromMaybe)

21+import qualified Data.Map as M

21−import Language.PureScript.Names

22−import Language.PureScript.Types

23import Language.PureScript.Kinds

24+import Language.PureScript.Names

24import Language.PureScript.TypeClassDictionaries

25import Language.PureScript.TypeClassDictionaries

26+import Language.PureScript.Types

25import qualified Language.PureScript.Constants as C

27import qualified Language.PureScript.Constants as C

27−import qualified Data.Map as M

28−

29-- |

30-- The @Environment@ defines all values and types which are currently in scope:

31--

@@ -53,7 +53,7 @@ data Environment = Environment {

53 -- |

54 -- Type classes

55 --

56− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])

56+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])

57 } deriving (Show)

59-- |

@@ -219,3 +219,18 @@ primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star

219 , (primName "String" , (Star, ExternData))

220 , (primName "Number" , (Star, ExternData))

221 , (primName "Boolean" , (Star, ExternData)) ]

222+

223+-- |

224+-- Finds information about data constructors from the current environment.

225+--

226+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)

227+lookupConstructor env ctor =

228+ fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env

229+

230+-- |

231+-- Checks whether a data constructor is for a newtype.

232+--

233+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool

234+isNewtypeConstructor e ctor = case lookupConstructor e ctor of

235+ (Newtype, _, _) -> True

236+ (Data, _, _) -> False

src/Language/PureScript/Names.hs+2−2

@@ -13,7 +13,7 @@

13--

14-----------------------------------------------------------------------------

16−{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}

18module Language.PureScript.Names where

@@ -71,7 +71,7 @@ instance Show ModuleName where

71-- |

72-- A qualified name, i.e. a name with an optional module name

73--

74−data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)

74+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)

76instance (Show a) => Show (Qualified a) where

77 show (Qualified Nothing a) = show a

src/Language/PureScript/Pretty/JS.hs+9−7

@@ -17,17 +17,19 @@ module Language.PureScript.Pretty.JS (

17 prettyPrintJS

18) where

20−import Language.PureScript.Pretty.Common

21−import Language.PureScript.CodeGen.JS (identNeedsEscaping)

22−import Language.PureScript.CodeGen.JS.AST

23−

24import Data.List

20import Data.List

25import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

26−import qualified Control.Arrow as A

22+

27−import Control.Arrow ((<+>))

28−import Control.PatternArrows

29import Control.Applicative

23import Control.Applicative

24+import Control.Arrow ((<+>))

30import Control.Monad.State

25import Control.Monad.State

26+import Control.PatternArrows

27+import qualified Control.Arrow as A

28+

29+import Language.PureScript.CodeGen.JS.AST

30+import Language.PureScript.CodeGen.JS.Common

31+import Language.PureScript.Pretty.Common

32+

31import Numeric

33import Numeric

33literals :: Pattern PrinterState JS String

35literals :: Pattern PrinterState JS String

src/Language/PureScript/Renamer.hs+58−75

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

1-----------------------------------------------------------------------------

2+-----------------------------------------------------------------------------

2--

3--

3-- Module : Language.PureScript.Renamer

4-- Module : Language.PureScript.Renamer

@@ -23,8 +24,7 @@ import Data.List (find)

23import qualified Data.Map as M

24import qualified Data.Map as M

24import qualified Data.Set as S

25import qualified Data.Set as S

26−import Language.PureScript.AST

27+import Language.PureScript.CoreFn

27−import Language.PureScript.Environment

28import Language.PureScript.Names

29import Language.PureScript.Traversals

@@ -100,25 +100,21 @@ lookupIdent name = do

100-- |

101-- Finds idents introduced by declarations.

102--

103−findDeclIdents :: [Declaration] -> [Ident]

103+findDeclIdents :: [Bind Ann] -> [Ident]

104findDeclIdents = concatMap go

105 where

106− go (ValueDeclaration ident _ _ _) = [ident]

106+ go (NonRec ident _) = [ident]

107− go (BindingGroupDeclaration ds) = map (\(name, _, _) -> name) ds

107+ go (Rec ds) = map fst ds

108− go (ExternDeclaration _ ident _ _) = [ident]

109− go (TypeClassDeclaration _ _ _ ds) = findDeclIdents ds

110− go (PositionedDeclaration _ d) = go d

111− go _ = []

112

108

113-- |

109-- |

114-- Renames within each declaration in a module.

110-- Renames within each declaration in a module.

115--

111--

116−renameInModules :: [Module] -> [Module]

112+renameInModules :: [Module Ann] -> [Module Ann]

117renameInModules = map go

113renameInModules = map go

118 where

114 where

119− go :: Module -> Module

115+ go :: Module Ann -> Module Ann

120− go (Module mn decls exps) = Module mn (renameInDecl' (findDeclIdents decls) `map` decls) exps

116+ go m@(Module _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }

121− renameInDecl' :: [Ident] -> Declaration -> Declaration

117+ renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann

122 renameInDecl' scope = runRename scope . renameInDecl True

118 renameInDecl' scope = runRename scope . renameInDecl True

123

119

124-- |

120-- |

@@ -128,65 +124,57 @@ renameInModules = map go

128-- been added), whereas in a Let declarations are renamed if their name shadows

124-- been added), whereas in a Let declarations are renamed if their name shadows

129-- another in the current scope.

125-- another in the current scope.

130--

126--

131−renameInDecl :: Bool -> Declaration -> Rename Declaration

127+renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

132−renameInDecl isTopLevel (ValueDeclaration name nameKind [] (Right val)) = do

128+renameInDecl isTopLevel (NonRec name val) = do

133 name' <- if isTopLevel then return name else updateScope name

129 name' <- if isTopLevel then return name else updateScope name

134− ValueDeclaration name' nameKind [] . Right <$> renameInValue val

130+ NonRec name' <$> renameInValue val

135−renameInDecl isTopLevel (BindingGroupDeclaration ds) = do

131+renameInDecl isTopLevel (Rec ds) = do

136 ds' <- mapM updateNames ds

132 ds' <- mapM updateNames ds

137− BindingGroupDeclaration <$> mapM updateValues ds'

133+ Rec <$> mapM updateValues ds'

138 where

134 where

139− updateNames :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)

135+ updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

140− updateNames (name, nameKind, val) = do

136+ updateNames (name, val) = do

141 name' <- if isTopLevel then return name else updateScope name

137 name' <- if isTopLevel then return name else updateScope name

142− return (name', nameKind, val)

138+ return (name', val)

143− updateValues :: (Ident, NameKind, Expr) -> Rename (Ident, NameKind, Expr)

139+ updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

144− updateValues (name, nameKind, val) =

145− (,,) name nameKind <$> renameInValue val

140+ updateValues (name, val) = (,) name <$> renameInValue val

146−renameInDecl _ (TypeInstanceDeclaration name cs className args ds) =

147− TypeInstanceDeclaration name cs className args <$> mapM (renameInDecl True) ds

148−renameInDecl isTopLevel (PositionedDeclaration pos d) =

149− PositionedDeclaration pos <$> renameInDecl isTopLevel d

150−renameInDecl _ other = return other

151

141

152-- |

142-- |

153-- Renames within a value.

143-- Renames within a value.

154--

144--

155−renameInValue :: Expr -> Rename Expr

145+renameInValue :: Expr Ann -> Rename (Expr Ann)

156−renameInValue (UnaryMinus v) =

157− UnaryMinus <$> renameInValue v

158−renameInValue (ArrayLiteral vs) =

146+renameInValue (Literal ann l) =

159− ArrayLiteral <$> mapM renameInValue vs

147+ Literal ann <$> renameInLiteral renameInValue l

160−renameInValue (ObjectLiteral vs) =

148+renameInValue c@(Constructor{}) = return c

161− ObjectLiteral <$> mapM (\(name, v) -> (,) name <$> renameInValue v) vs

162−renameInValue (Accessor prop v) =

149+renameInValue (Accessor ann prop v) =

163− Accessor prop <$> renameInValue v

150+ Accessor ann prop <$> renameInValue v

164−renameInValue (ObjectUpdate obj vs) =

151+renameInValue (ObjectUpdate ann obj vs) =

165− ObjectUpdate <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs

152+ ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs

166−renameInValue (Abs (Left name) v) =

153+renameInValue e@(Abs (_, _, Just IsTypeClassConstructor) _ _) = return e

154+renameInValue (Abs ann name v) =

167− newScope $ Abs . Left <$> updateScope name <*> renameInValue v

155+ newScope $ Abs ann <$> updateScope name <*> renameInValue v

168−renameInValue (App v1 v2) =

156+renameInValue (App ann v1 v2) =

169− App <$> renameInValue v1 <*> renameInValue v2

157+ App ann <$> renameInValue v1 <*> renameInValue v2

170−renameInValue (Var (Qualified Nothing name)) =

158+renameInValue (Var ann (Qualified Nothing name)) =

171− Var . Qualified Nothing <$> lookupIdent name

159+ Var ann . Qualified Nothing <$> lookupIdent name

172−renameInValue (IfThenElse v1 v2 v3) =

160+renameInValue v@(Var{}) = return v

173− IfThenElse <$> renameInValue v1 <*> renameInValue v2 <*> renameInValue v3

174−renameInValue (Case vs alts) =

161+renameInValue (Case ann vs alts) =

175− newScope $ Case <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts

162+ newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts

176−renameInValue (TypedValue check v ty) =

163+renameInValue (Let ann ds v) =

177− TypedValue check <$> renameInValue v <*> pure ty

178−renameInValue (Let ds v) =

179− newScope $ Let <$> mapM (renameInDecl False) ds <*> renameInValue v

164+ newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v

180−renameInValue (TypeClassDictionaryConstructorApp name v) =

165+

181− TypeClassDictionaryConstructorApp name <$> renameInValue v

166+-- |

182−renameInValue (PositionedValue pos v) =

167+-- Renames within literals.

183− PositionedValue pos <$> renameInValue v

168+--

184−renameInValue v = return v

169+renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)

170+renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs

171+renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs

172+renameInLiteral _ l = return l

185

173

186-- |

174-- |

187-- Renames within case alternatives.

175-- Renames within case alternatives.

188--

176--

189−renameInCaseAlternative :: CaseAlternative -> Rename CaseAlternative

177+renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)

190renameInCaseAlternative (CaseAlternative bs v) =

178renameInCaseAlternative (CaseAlternative bs v) =

191 CaseAlternative <$> mapM renameInBinder bs

179 CaseAlternative <$> mapM renameInBinder bs

192 <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

180 <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

@@ -194,18 +182,13 @@ renameInCaseAlternative (CaseAlternative bs v) =

194-- |

182-- |

195-- Renames within binders.

183-- Renames within binders.

196--

184--

197−renameInBinder :: Binder -> Rename Binder

185+renameInBinder :: Binder a -> Rename (Binder a)

198−renameInBinder (VarBinder name) =

199− VarBinder <$> updateScope name

200−renameInBinder (ConstructorBinder name bs) =

186+renameInBinder n@(NullBinder{}) = return n

201− ConstructorBinder name <$> mapM renameInBinder bs

187+renameInBinder (LiteralBinder ann b) =

202−renameInBinder (ObjectBinder bs) =

188+ LiteralBinder ann <$> renameInLiteral renameInBinder b

203− ObjectBinder <$> mapM (sndM renameInBinder) bs

189+renameInBinder (VarBinder ann name) =

204−renameInBinder (ArrayBinder bs) =

190+ VarBinder ann <$> updateScope name

205− ArrayBinder <$> mapM renameInBinder bs

191+renameInBinder (ConstructorBinder ann tctor dctor bs) =

206−renameInBinder (ConsBinder b1 b2) =

192+ ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs

207− ConsBinder <$> renameInBinder b1 <*> renameInBinder b2

193+renameInBinder (NamedBinder ann name b) =

208−renameInBinder (NamedBinder name b) =

194+ NamedBinder ann <$> updateScope name <*> renameInBinder b

209− NamedBinder <$> updateScope name <*> renameInBinder b

210−renameInBinder (PositionedBinder _ b) = renameInBinder b

211−renameInBinder other = return other

src/Language/PureScript/Sugar/TypeClasses.hs+38−35

@@ -14,9 +14,11 @@

14--

15-----------------------------------------------------------------------------

17−module Language.PureScript.Sugar.TypeClasses (

17+module Language.PureScript.Sugar.TypeClasses

18− desugarTypeClasses

18+ ( desugarTypeClasses

19+ , typeClassMemberName

20+ , superClassDictionaryNames

19−) where

21+ ) where

21import Language.PureScript.AST hiding (isExported)

23import Language.PureScript.AST hiding (isExported)

22import Language.PureScript.Names

24import Language.PureScript.Names

@@ -198,13 +200,12 @@ memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)

198memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

200memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d

199memberToNameAndType _ = error "Invalid declaration in type class definition"

201memberToNameAndType _ = error "Invalid declaration in type class definition"

200

202

201−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration

203+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration

202typeClassDictionaryDeclaration name args implies members =

204typeClassDictionaryDeclaration name args implies members =

203− let superclassTypes = [ (fieldName, function unit tySynApp)

205+ let superclassTypes = superClassDictionaryNames implies `zip`

204− | (index, (superclass, tyArgs)) <- zip [0..] implies

205− , let tySynApp = foldl TypeApp (TypeConstructor superclass) tyArgs

206+ [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)

206− , let fieldName = mkSuperclassDictionaryName superclass index

207+ | (superclass, tyArgs) <- implies

207− ]

208+ ]

208 members' = map (first runIdent . memberToNameAndType) members

209 members' = map (first runIdent . memberToNameAndType) members

209 mtys = members' ++ superclassTypes

210 mtys = members' ++ superclassTypes

210 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

211 in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))

@@ -218,13 +219,10 @@ typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =

218 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

219 PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d

219typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

220typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"

220

221

221−mkSuperclassDictionaryName :: Qualified ProperName -> Integer -> String

222−mkSuperclassDictionaryName pn index = C.__superclass_ ++ show pn ++ "_" ++ show index

223−

224unit :: Type

222unit :: Type

225unit = TypeApp tyObject REmpty

223unit = TypeApp tyObject REmpty

226

224

227−typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [(Qualified ProperName, [Type])] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

225+typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration

228typeInstanceDictionaryDeclaration name mn deps className tys decls =

226typeInstanceDictionaryDeclaration name mn deps className tys decls =

229 rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do

227 rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do

230 m <- get

228 m <- get

@@ -242,22 +240,23 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

242

240

243 -- Replace the type arguments with the appropriate types in the member types

241 -- Replace the type arguments with the appropriate types in the member types

244 let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys

242 let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys

243+

245 -- Create values for the type instance members

244 -- Create values for the type instance members

246− memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls

245+ members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls

246+

247 -- Create the type of the dictionary

248 -- The type is an object type, but depending on type instance dependencies, may be constrained.

249 -- The dictionary itself is an object literal.

250− let superclasses =

250+ let superclasses = superClassDictionaryNames implies `zip`

251− [ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))

251+ [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)

252− | (index, (superclass, suTyArgs)) <- zip [0..] implies

252+ | (superclass, suTyArgs) <- implies

253 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

254− , let fieldName = mkSuperclassDictionaryName superclass index

255 ]

254 ]

256

255

257− let memberNames' = ObjectLiteral (memberNames ++ superclasses)

256+ let props = ObjectLiteral (members ++ superclasses)

258 dictTy = foldl TypeApp (TypeConstructor className) tys

257 dictTy = foldl TypeApp (TypeConstructor className) tys

259 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

258 constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

260− dict = TypeClassDictionaryConstructorApp className memberNames'

259+ dict = TypeClassDictionaryConstructorApp className props

261 result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))

260 result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))

262 return result

261 return result

263

262

@@ -269,19 +268,23 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

269 declName (TypeDeclaration ident _) = Just ident

268 declName (TypeDeclaration ident _) = Just ident

270 declName _ = Nothing

269 declName _ = Nothing

271

270

272− memberToNameAndValue :: [(Ident, Type)] -> Declaration -> Desugar (Ident, Expr)

271+ memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr

273− memberToNameAndValue tys' d@(ValueDeclaration ident _ _ _) = do

272+ memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do

274 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'

273 _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'

275− let memberValue = typeInstanceDictionaryEntryValue d

274+ return val

276− return (ident, memberValue)

277− memberToNameAndValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

275+ memberToValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do

278− (ident, val) <- memberToNameAndValue tys' d

276+ val <- memberToValue tys' d

279− return (ident, PositionedValue pos val)

277+ return (PositionedValue pos val)

280− memberToNameAndValue _ _ = error "Invalid declaration in type instance definition"

278+ memberToValue _ _ = error "Invalid declaration in type instance definition"

281−

279+

282− typeInstanceDictionaryEntryValue :: Declaration -> Expr

280+typeClassMemberName :: Declaration -> String

283− typeInstanceDictionaryEntryValue (ValueDeclaration _ _ [] (Right val)) = val

281+typeClassMemberName (TypeDeclaration ident _) = runIdent ident

284− typeInstanceDictionaryEntryValue (PositionedDeclaration pos d) = PositionedValue pos (typeInstanceDictionaryEntryValue d)

282+typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident

283+typeClassMemberName (PositionedDeclaration _ d) = typeClassMemberName d

285− typeInstanceDictionaryEntryValue _ = error "Invalid declaration in type instance definition"

284+typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d

286−

285+

287−

286+superClassDictionaryNames :: [Constraint] -> [String]

287+superClassDictionaryNames supers =

288+ [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)

289+ | (index, (pn, _)) <- zip [0..] supers

290+ ]

src/Language/PureScript/TypeChecker.hs+12−8

@@ -78,7 +78,7 @@ addValue moduleName name ty nameKind = do

78 env <- getEnv

79 putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })

81−addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()

81+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check ()

82addTypeClass moduleName pn args implies ds =

83 let members = map toPair ds in

84 modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }

@@ -235,15 +235,24 @@ typeCheckAll mainModuleName moduleName exps = go

235 addTypeClass moduleName pn args implies tys

236 ds <- go rest

237 return $ d : ds

238− go (TypeInstanceDeclaration dictName deps className tys _ : rest) =

238+ go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do

239− go (ExternInstanceDeclaration dictName deps className tys : rest)

239+ goInstance d dictName deps className tys rest

240 go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do

241+ goInstance d dictName deps className tys rest

242+ go (PositionedDeclaration pos d : rest) =

243+ rethrowWithPosition pos $ do

244+ (d' : rest') <- go (d : rest)

245+ return (PositionedDeclaration pos d' : rest')

246+ goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]

247+ goInstance d dictName deps className tys rest = do

241 mapM_ (checkTypeClassInstance moduleName) tys

248 mapM_ (checkTypeClassInstance moduleName) tys

242 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

249 forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd

243 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]

250 addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]

244 ds <- go rest

251 ds <- go rest

245 return $ d : ds

252 return $ d : ds

253+

246 where

254 where

255+

247 isInstanceExported :: Bool

256 isInstanceExported :: Bool

248 isInstanceExported = any exportsInstance exps

257 isInstanceExported = any exportsInstance exps

249

258

@@ -252,11 +261,6 @@ typeCheckAll mainModuleName moduleName exps = go

252 exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

261 exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r

253 exportsInstance _ = False

262 exportsInstance _ = False

254

263

255− go (PositionedDeclaration pos d : rest) =

256− rethrowWithPosition pos $ do

257− (d' : rest') <- go (d : rest)

258− return (PositionedDeclaration pos d' : rest')

259−

260 -- |

264 -- |

261 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

265 -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,

262 -- extracted from the kind of the type constructor itself.

266 -- extracted from the kind of the type constructor itself.

src/Language/PureScript/TypeChecker/Entailment.hs+2−2

@@ -64,7 +64,7 @@ data DictionaryValue

64-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

65-- return a type class dictionary reference.

66--

67−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, [Type]) -> Bool -> Check Expr

67+entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr

68entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))

69 where

70 sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]

@@ -107,7 +107,7 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt

107 -- Create dictionaries for subgoals which still need to be solved by calling go recursively

108 -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type

109 -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.

110− solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]

110+ solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]

111 solveSubgoals _ Nothing = return Nothing

112 solveSubgoals subst (Just subgoals) = do

113 dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals

src/Language/PureScript/TypeClassDictionaries.hs+1−1

@@ -41,7 +41,7 @@ data TypeClassDictionaryInScope

41 -- |

42 -- Type class dependencies which must be satisfied to construct this dictionary

43 --

44− , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]

44+ , tcdDependencies :: Maybe [Constraint]

45 -- |

46 -- The type of this dictionary

47 --

src/Language/PureScript/Types.hs+10−5

@@ -69,7 +69,7 @@ data Type

69 -- |

70 -- A type with a set of type class constraints

71 --

72− | ConstrainedType [(Qualified ProperName, [Type])] Type

72+ | ConstrainedType [Constraint] Type

73 -- |

74 -- A skolem constant

75 --

@@ -84,7 +84,7 @@ data Type

84 | RCons String Type Type

85 -- |

86 -- A type with a kind annotation

87− --

87+ --

88 | KindedType Type Kind

89 --

90 -- |

@@ -104,6 +104,11 @@ data Type

104 --

105 | PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)

106

107+-- |

108+-- A typeclass constraint

109+--

110+type Constraint = (Qualified ProperName, [Type])

111+

107-- |

112-- |

108-- Convert a row to a list of pairs of labels and types

113-- Convert a row to a list of pairs of labels and types

109--

114--

@@ -144,9 +149,9 @@ replaceTypeVars v r = replaceAllTypeVars [(v, r)]

144replaceAllTypeVars :: [(String, Type)] -> Type -> Type

149replaceAllTypeVars :: [(String, Type)] -> Type -> Type

145replaceAllTypeVars = go []

150replaceAllTypeVars = go []

146 where

151 where

147−

152+

148 go :: [String] -> [(String, Type)] -> Type -> Type

153 go :: [String] -> [(String, Type)] -> Type -> Type

149− go _ m (TypeVar v) =

154+ go _ m (TypeVar v) =

150 case v `lookup` m of

155 case v `lookup` m of

151 Just r -> r

156 Just r -> r

152 Nothing -> TypeVar v

157 Nothing -> TypeVar v

@@ -165,7 +170,7 @@ replaceAllTypeVars = go []

165 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

170 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

166 go bs m (KindedType t k) = KindedType (go bs m t) k

171 go bs m (KindedType t k) = KindedType (go bs m t) k

167 go _ _ ty = ty

172 go _ _ ty = ty

168−

173+

169 genName orig inUse = try 0

174 genName orig inUse = try 0

170 where

175 where

171 try :: Integer -> String

176 try :: Integer -> String