79d6d63 · rowtype-yoga/purescript-native

docgen/Main.hs+16−16

compare with golang

unifiedsplit

@@ -60,7 +60,7 @@ renderModules ms = do

60

61renderModule :: P.Module -> Docs

62renderModule (P.Module moduleName ds) = do

63− headerLevel 2 $ "Module " ++ (P.runModuleName moduleName)

63+ headerLevel 2 $ "Module " ++ P.runModuleName moduleName

64 spacer

65 headerLevel 3 "Types"

66 spacer

@@ -90,23 +90,23 @@ renderDeclaration n (P.TypeDeclaration ident ty) =

90renderDeclaration n (P.ExternDeclaration _ ident _ ty) =

91 atIndent n $ show ident ++ " :: " ++ P.prettyPrintType ty

92renderDeclaration n (P.DataDeclaration name args ctors) = do

93− let typeName = P.runProperName name ++ " " ++ intercalate " " args

93+ let typeName = P.runProperName name ++ " " ++ unwords args

94 atIndent n $ "data " ++ typeName ++ " where"

95− forM_ ctors $ \(ctor, tys) -> do

95+ forM_ ctors $ \(ctor, tys) ->

96− atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concat (map (\ty -> P.prettyPrintType ty ++ " -> ") tys) ++ typeName

96+ atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ concatMap (\ty -> P.prettyPrintType ty ++ " -> ") tys ++ typeName

97renderDeclaration n (P.ExternDataDeclaration name kind) =

98 atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

99renderDeclaration n (P.TypeSynonymDeclaration name args ty) = do

100− let typeName = P.runProperName name ++ " " ++ intercalate " " args

100+ let typeName = P.runProperName name ++ " " ++ unwords args

101 atIndent n $ "type " ++ typeName ++ " = " ++ P.prettyPrintType ty

102renderDeclaration n (P.TypeClassDeclaration name args ds) = do

103− atIndent n $ "class " ++ P.runProperName name ++ " " ++ intercalate " " args ++ " where"

103+ atIndent n $ "class " ++ P.runProperName name ++ " " ++ unwords args ++ " where"

104 mapM_ (renderDeclaration (n + 2)) ds

105renderDeclaration n (P.TypeInstanceDeclaration constraints name tys _) = do

106 let constraintsText = case constraints of

107 [] -> ""

108− cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ intercalate " " (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "

108+ cs -> "(" ++ intercalate "," (map (\(pn, tys') -> show pn ++ " (" ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys') ++ ")") cs) ++ ") => "

109− atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ intercalate " " (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)

109+ atIndent n $ constraintsText ++ "instance " ++ show name ++ " " ++ unwords (map (("(" ++) . (++ ")") . P.prettyPrintType) tys)

110renderDeclaration _ _ = return ()

111

112getName :: P.Declaration -> String

@@ -120,22 +120,22 @@ getName (P.TypeInstanceDeclaration _ name _ _) = show name

120getName _ = error "Invalid argument to getName"

121

122isValueDeclaration :: P.Declaration -> Bool

123−isValueDeclaration (P.TypeDeclaration _ _) = True

123+isValueDeclaration P.TypeDeclaration{} = True

124−isValueDeclaration (P.ExternDeclaration _ _ _ _) = True

124+isValueDeclaration P.ExternDeclaration{} = True

125isValueDeclaration _ = False

126

127isTypeDeclaration :: P.Declaration -> Bool

128−isTypeDeclaration (P.DataDeclaration _ _ _) = True

128+isTypeDeclaration P.DataDeclaration{} = True

129−isTypeDeclaration (P.ExternDataDeclaration _ _) = True

129+isTypeDeclaration P.ExternDataDeclaration{} = True

130−isTypeDeclaration (P.TypeSynonymDeclaration _ _ _) = True

130+isTypeDeclaration P.TypeSynonymDeclaration{} = True

131isTypeDeclaration _ = False

132

133isTypeClassDeclaration :: P.Declaration -> Bool

134−isTypeClassDeclaration (P.TypeClassDeclaration _ _ _) = True

134+isTypeClassDeclaration P.TypeClassDeclaration{} = True

135isTypeClassDeclaration _ = False

136

137isTypeInstanceDeclaration :: P.Declaration -> Bool

138−isTypeInstanceDeclaration (P.TypeInstanceDeclaration _ _ _ _) = True

138+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True

139isTypeInstanceDeclaration _ = False

140

141inputFile :: Term FilePath

@@ -147,7 +147,7 @@ term = docgen <$> inputFile

147termInfo :: TermInfo

148termInfo = defTI

149 { termName = "docgen"

150− , version = showVersion $ Paths.version

150+ , version = showVersion Paths.version

151 , termDoc = "Generate Markdown documentation from PureScript extern files"

152 }

153

psc/Main.hs+2−2

@@ -28,7 +28,7 @@ preludeFilename :: IO FilePath

28preludeFilename = Paths.getDataFileName "prelude/prelude.purs"

29

30readInput :: Maybe [FilePath] -> IO (Either ParseError [P.Module])

31−readInput Nothing = getContents >>= return . P.runIndentParser "" P.parseModules

31+readInput Nothing = P.runIndentParser "" P.parseModules <$> getContents

32readInput (Just input) = fmap (fmap concat . sequence) $ forM input $ \inputFile -> do

33 text <- U.readFile inputFile

34 return $ P.runIndentParser inputFile P.parseModules text

@@ -118,7 +118,7 @@ term prelude = compile <$> options <*> stdInOrInputFiles prelude <*> outputFile

118termInfo :: TermInfo

119termInfo = defTI

120 { termName = "psc"

121− , version = showVersion $ Paths.version

121+ , version = showVersion Paths.version

122 , termDoc = "Compiles PureScript to Javascript"

123 }

124

psci/Main.hs+1−1

@@ -312,7 +312,7 @@ term = loop <$> inputFiles

312termInfo :: Cmd.TermInfo

313termInfo = Cmd.defTI

314 { Cmd.termName = "psci"

315− , Cmd.version = showVersion $ Paths.version

315+ , Cmd.version = showVersion Paths.version

316 , Cmd.termDoc = "Interactive mode for PureScript"

317 }

318

src/Language/PureScript.hs+10−11

@@ -31,10 +31,9 @@ import Language.PureScript.ModuleDependencies as P

31import Language.PureScript.DeadCodeElimination as P

32

33import Data.List (intercalate)

34−import Data.Maybe (mapMaybe, fromMaybe)

34+import Data.Maybe (mapMaybe)

35−import Control.Monad (when, forM)

36import Control.Monad.State.Lazy

35import Control.Monad.State.Lazy

37−import Control.Applicative ((<$>), (<|>))

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

38import qualified Data.Map as M

37import qualified Data.Map as M

39

38

40-- |

39-- |

@@ -60,20 +59,20 @@ compile :: Options -> [Module] -> Either String (String, String, Environment)

60compile opts ms = do

59compile opts ms = do

61 sorted <- sortModules ms

60 sorted <- sortModules ms

62 desugared <- desugar sorted

61 desugared <- desugar sorted

63− (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName decls) -> do

62+ (elaborated, env) <- runCheck $ forM desugared $ \(Module moduleName' decls) -> do

64− modify (\s -> s { checkCurrentModule = Just moduleName })

63+ modify (\s -> s { checkCurrentModule = Just moduleName' })

65− Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls

64+ Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls

66 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

65 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

67 let entryPoints = moduleNameFromString `map` optionsModules opts

66 let entryPoints = moduleNameFromString `map` optionsModules opts

68 let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

67 let elim = if null entryPoints then regrouped else eliminateDeadCode env entryPoints regrouped

69 let js = mapMaybe (flip (moduleToJs opts) env) elim

68 let js = mapMaybe (flip (moduleToJs opts) env) elim

70− let exts = intercalate "\n" . map (flip moduleToPs env) $ elim

69+ let exts = intercalate "\n" . map (`moduleToPs` env) $ elim

71− js' <- case mainModuleIdent of

70+ js' <- case mainModuleIdent of

72 Just mmi -> do

71 Just mmi -> do

73− when ((mmi, Ident "main") `M.notMember` (names env)) $

72+ when ((mmi, Ident "main") `M.notMember` names env) $

74− Left $ (show mmi) ++ ".main is undefined"

73+ Left $ show mmi ++ ".main is undefined"

75 return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]

74 return $ js ++ [JSApp (JSAccessor "main" (JSAccessor (moduleNameToJs mmi) (JSVar "_ps"))) []]

76 _ -> return js

75 _ -> return js

77− return (prettyPrintJS [(wrapExportsContainer opts js')], exts, env)

76+ return (prettyPrintJS [wrapExportsContainer opts js'], exts, env)

78 where

77 where

79 mainModuleIdent = moduleNameFromString <$> optionsMain opts

78 mainModuleIdent = moduleNameFromString <$> optionsMain opts

src/Language/PureScript/CodeGen/Common.hs+60−60

@@ -69,66 +69,66 @@ identCharToString c = '$' : show (ord c)

69--

70nameIsJsReserved :: String -> Bool

71nameIsJsReserved name =

72− elem name [ "abstract"

72+ name `elem` [ "abstract"

73− , "arguments"

73+ , "arguments"

74− , "boolean"

74+ , "boolean"

75− , "break"

75+ , "break"

76− , "byte"

76+ , "byte"

77− , "case"

77+ , "case"

78− , "catch"

78+ , "catch"

79− , "char"

79+ , "char"

80− , "class"

80+ , "class"

81− , "const"

81+ , "const"

82− , "continue"

82+ , "continue"

83− , "debugger"

83+ , "debugger"

84− , "default"

84+ , "default"

85− , "delete"

85+ , "delete"

86− , "do"

86+ , "do"

87− , "double"

87+ , "double"

88− , "else"

88+ , "else"

89− , "enum"

89+ , "enum"

90− , "eval"

90+ , "eval"

91− , "export"

91+ , "export"

92− , "extends"

92+ , "extends"

93− , "final"

93+ , "final"

94− , "finally"

94+ , "finally"

95− , "float"

95+ , "float"

96− , "for"

96+ , "for"

97− , "function"

97+ , "function"

98− , "goto"

98+ , "goto"

99− , "if"

99+ , "if"

100− , "implements"

100+ , "implements"

101− , "import"

101+ , "import"

102− , "in"

102+ , "in"

103− , "instanceof"

103+ , "instanceof"

104− , "int"

104+ , "int"

105− , "interface"

105+ , "interface"

106− , "let"

106+ , "let"

107− , "long"

107+ , "long"

108− , "native"

108+ , "native"

109− , "new"

109+ , "new"

110− , "package"

110+ , "package"

111− , "private"

111+ , "private"

112− , "protected"

112+ , "protected"

113− , "public"

113+ , "public"

114− , "return"

114+ , "return"

115− , "short"

115+ , "short"

116− , "static"

116+ , "static"

117− , "super"

117+ , "super"

118− , "switch"

118+ , "switch"

119− , "synchronized"

119+ , "synchronized"

120− , "this"

120+ , "this"

121− , "throw"

121+ , "throw"

122− , "throws"

122+ , "throws"

123− , "transient"

123+ , "transient"

124− , "try"

124+ , "try"

125− , "typeof"

125+ , "typeof"

126− , "var"

126+ , "var"

127− , "void"

127+ , "void"

128− , "volatile"

128+ , "volatile"

129− , "while"

129+ , "while"

130− , "with"

130+ , "with"

131− , "yield" ]

131+ , "yield" ]

132

133moduleNameToJs :: ModuleName -> String

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

src/Language/PureScript/CodeGen/Externs.hs+2−2

@@ -30,14 +30,14 @@ import Data.List (intercalate)

30--

31moduleToPs :: Module -> Environment -> String

32moduleToPs (Module mn decls) env =

33− "module " ++ (runModuleName mn) ++ " where\n" ++

33+ "module " ++ runModuleName mn ++ " where\n" ++

34 (intercalate "\n" . map (" " ++) . concatMap (declToPs mn env) $ decls)

35

36declToPs :: ModuleName -> Environment -> Declaration -> [String]

37declToPs path env (ValueDeclaration name _ _ _) = maybeToList $ do

38 (ty, _) <- M.lookup (path, name) $ names env

39 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

40−declToPs path env (BindingGroupDeclaration vals) = do

40+declToPs path env (BindingGroupDeclaration vals) =

41 flip mapMaybe vals $ \(name, _) -> do

42 (ty, _) <- M.lookup (path, name) $ names env

43 return $ "foreign import " ++ show name ++ " :: " ++ prettyPrintType ty

src/Language/PureScript/CodeGen/JS.hs+12−14

@@ -23,7 +23,6 @@ module Language.PureScript.CodeGen.JS (

23) where

24

25import Data.Maybe (fromMaybe, mapMaybe)

26−import Data.List (sortBy)

27import Data.Function (on)

26import Data.Function (on)

28import Data.Data (Data)

27import Data.Data (Data)

29import Data.Generics (mkQ, everything)

28import Data.Generics (mkQ, everything)

@@ -38,7 +37,6 @@ import Language.PureScript.Values

38import Language.PureScript.Names

37import Language.PureScript.Names

39import Language.PureScript.Scope

38import Language.PureScript.Scope

40import Language.PureScript.Declarations

39import Language.PureScript.Declarations

41−import Language.PureScript.Pretty.Common

42import Language.PureScript.CodeGen.Monad

40import Language.PureScript.CodeGen.Monad

43import Language.PureScript.Options

41import Language.PureScript.Options

44import Language.PureScript.CodeGen.JS.AST as AST

42import Language.PureScript.CodeGen.JS.AST as AST

@@ -57,16 +55,16 @@ moduleToJs opts (Module name decls) env =

57 [] -> Nothing

55 [] -> Nothing

58 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

56 _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar "_ps")) $

59 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

57 JSApp (JSFunction Nothing ["module"] (JSBlock $ jsDecls ++ [JSReturn $ JSVar "module"]))

60− [(JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral []))]

58+ [JSBinary Or (JSAccessor (moduleNameToJs name) (JSVar "_ps")) (JSObjectLiteral [])]

61 where

59 where

62− jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) (decls))

60+ jsDecls = concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls

63

61

64-- |

62-- |

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

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

66--

64--

67declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

65declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS]

68declToJs opts mp (ValueDeclaration ident _ _ val) e =

66declToJs opts mp (ValueDeclaration ident _ _ val) e =

69− Just $ [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

67+ Just [ JSVariableIntroduction (identToJs ident) (Just (valueToJs opts mp e val))

70 , setExportProperty ident (var ident) ]

68 , setExportProperty ident (var ident) ]

71declToJs opts mp (BindingGroupDeclaration vals) e =

69declToJs opts mp (BindingGroupDeclaration vals) e =

72 Just $ concatMap (\(ident, val) ->

70 Just $ concatMap (\(ident, val) ->

@@ -85,8 +83,8 @@ declToJs _ mp (DataDeclaration _ _ ctors) _ =

85 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

83 (JSBlock [JSReturn (go pn (index + 1) tys' (JSVar ("value" ++ show index) : values))])

86declToJs opts mp (DataBindingGroupDeclaration ds) e =

84declToJs opts mp (DataBindingGroupDeclaration ds) e =

87 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

85 Just $ concat $ mapMaybe (flip (declToJs opts mp) e) ds

88−declToJs _ mp (ExternDeclaration importTy ident (Just js) _) _ =

86+declToJs _ _ (ExternDeclaration _ ident (Just js) _) _ =

89− Just $ [js, setExportProperty ident (var ident)]

87+ Just [js, setExportProperty ident (var ident)]

90declToJs _ _ _ _ = Nothing

88declToJs _ _ _ _ = Nothing

91

89

92-- |

90-- |

@@ -94,7 +92,7 @@ declToJs _ _ _ _ = Nothing

94-- declaration from a module.

92-- declaration from a module.

95--

93--

96setExportProperty :: Ident -> JS -> JS

94setExportProperty :: Ident -> JS -> JS

97−setExportProperty ident val = JSAssignment (accessor ident (JSVar "module")) val

95+setExportProperty ident = JSAssignment (accessor ident (JSVar "module"))

98

96

99-- |

97-- |

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

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

@@ -194,12 +192,12 @@ runtimeTypeChecks arg ty =

194varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

192varToJs :: ModuleName -> Environment -> Qualified Ident -> JS

195varToJs m e qual@(Qualified _ ident) = go qual

193varToJs m e qual@(Qualified _ ident) = go qual

196 where

194 where

197− go qual = case M.lookup (qualify m qual) (names e) of

195+ go qual' = case M.lookup (qualify m qual') (names e) of

198 Just (_, ty) | isExtern ty -> var ident

196 Just (_, ty) | isExtern ty -> var ident

199 Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)

197 Just (_, Alias aliasModule aliasIdent) -> go (Qualified (Just aliasModule) aliasIdent)

200− _ -> case qual of

198+ _ -> case qual' of

201 Qualified Nothing _ -> var ident

199 Qualified Nothing _ -> var ident

202− _ -> qualifiedToJS m id qual

200+ _ -> qualifiedToJS m id qual'

203 isExtern (Extern ForeignImport) = True

201 isExtern (Extern ForeignImport) = True

204 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

202 isExtern (Alias m' ident') = case M.lookup (m', ident') (names e) of

205 Just (_, ty') -> isExtern ty'

203 Just (_, ty') -> isExtern ty'

@@ -212,7 +210,7 @@ varToJs m e qual@(Qualified _ ident) = go qual

212--

210--

213qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

211qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

214qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")

212qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar "_ps")

215−qualifiedToJS m f (Qualified _ a) = JSVar $ identToJs (f a)

213+qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

216

214

217-- |

215-- |

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

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

@@ -256,7 +254,7 @@ binderToJs _ _ varName done (BooleanBinder True) =

256 return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

254 return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

257binderToJs _ _ varName done (BooleanBinder False) =

255binderToJs _ _ varName done (BooleanBinder False) =

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

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

259−binderToJs m e varName done (VarBinder ident) =

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

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

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

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

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

262 js <- go 0 done bs

260 js <- go 0 done bs

@@ -326,7 +324,7 @@ isOnlyConstructor m e ctor =

326 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn

324 typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn

327

325

328wrapExportsContainer :: Options -> [JS] -> JS

326wrapExportsContainer :: Options -> [JS] -> JS

329−wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ (JSStringLiteral "use strict") : modules) [exportSelector]

327+wrapExportsContainer opts modules = JSApp (JSFunction Nothing ["_ps"] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]

330 where

328 where

331 exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))

329 exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))

332 (JSAccessor "exports" (JSVar "module"))

330 (JSAccessor "exports" (JSVar "module"))

src/Language/PureScript/CodeGen/Monad.hs−1

@@ -21,7 +21,6 @@ module Language.PureScript.CodeGen.Monad where

21

22import Control.Monad.State

23import Control.Applicative

24−import Language.PureScript.Names

25

24

26-- |

25-- |

27-- Code generation monad data type

26-- Code generation monad data type

src/Language/PureScript/CodeGen/Optimize.hs+20−22

@@ -73,10 +73,10 @@ applyAll :: [a -> a] -> a -> a

73applyAll = foldl1 (.)

74

75untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

76−untilFixedPoint f a = go a

76+untilFixedPoint f = go

77 where

78− go a' = let a'' = f a' in

78+ go a = let a' = f a in

79− if a'' == a' then a'' else go a''

79+ if a' == a then a' else go a'

80

81replaceIdent :: (Data d) => String -> JS -> d -> d

82replaceIdent var1 js = everywhere (mkT replace)

@@ -100,7 +100,7 @@ isReassigned var1 = everything (||) (mkQ False check)

100 check _ = False

101

102isRebound :: (Data d) => JS -> d -> Bool

103−isRebound js d = any (\var -> isReassigned var d) (everything (++) (mkQ [] variablesOf) js)

103+isRebound js d = any (`isReassigned` d) (everything (++) (mkQ [] variablesOf) js)

104 where

105 variablesOf (JSVar var) = [var]

106 variablesOf _ = []

@@ -135,25 +135,23 @@ shouldInline (JSAccessor _ val) = shouldInline val

135shouldInline (JSIndexer index val) = shouldInline index && shouldInline val

136shouldInline _ = False

137

138+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

139+removeFromBlock go (JSBlock sts) = JSBlock (go sts)

140+removeFromBlock _ js = js

141+

138inlineVariables :: JS -> JS

142inlineVariables :: JS -> JS

139−inlineVariables = everywhere (mkT removeFromBlock)

143+inlineVariables = everywhere (mkT $ removeFromBlock go)

140 where

144 where

141− removeFromBlock :: JS -> JS

142− removeFromBlock (JSBlock sts) = JSBlock (go sts)

143− removeFromBlock js = js

144 go :: [JS] -> [JS]

145 go :: [JS] -> [JS]

145 go [] = []

146 go [] = []

146− go (s@(JSVariableIntroduction var (Just js)) : sts)

147+ go (JSVariableIntroduction var (Just js) : sts)

147 | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =

148 | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =

148 go (replaceIdent var js sts)

149 go (replaceIdent var js sts)

149 go (s:sts) = s : go sts

150 go (s:sts) = s : go sts

150

151

151removeUnusedVariables :: JS -> JS

152removeUnusedVariables :: JS -> JS

152−removeUnusedVariables = everywhere (mkT removeFromBlock)

153+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)

153 where

154 where

154− removeFromBlock :: JS -> JS

155− removeFromBlock (JSBlock sts) = JSBlock (go sts)

156− removeFromBlock js = js

157 go :: [JS] -> [JS]

155 go :: [JS] -> [JS]

158 go [] = []

156 go [] = []

159 go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts

157 go (JSVariableIntroduction var _ : sts) | not (isUsed var sts) = go sts

@@ -165,8 +163,8 @@ etaConvert = everywhere (mkT convert)

165 convert :: JS -> JS

163 convert :: JS -> JS

166 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

164 convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

167 | all shouldInline args &&

165 | all shouldInline args &&

168− not (any (flip isRebound block) (map JSVar idents)) &&

166+ not (any (`isRebound` block) (map JSVar idents)) &&

169− not (or (map (flip isRebound block) args))

167+ not (any (`isRebound` block) args)

170 = JSBlock (replaceIdents (zip idents args) body)

168 = JSBlock (replaceIdents (zip idents args) body)

171 convert js = js

169 convert js = js

172

170

@@ -191,7 +189,7 @@ tco' = everywhere (mkT convert)

191 copyVar :: String -> String

189 copyVar :: String -> String

192 copyVar arg = "__copy_" ++ arg

190 copyVar arg = "__copy_" ++ arg

193 convert :: JS -> JS

191 convert :: JS -> JS

194− convert js@(JSVariableIntroduction name (Just fn@(JSFunction _ _ _))) =

192+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =

195 let

193 let

196 (argss, body', replace) = collectAllFunctionArgs [] id fn

194 (argss, body', replace) = collectAllFunctionArgs [] id fn

197 in case () of

195 in case () of

@@ -206,11 +204,11 @@ tco' = everywhere (mkT convert)

206 collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

204 collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

207 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

205 collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

208 collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

206 collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

209− (args : allArgs, body, \b -> f (JSFunction ident (map copyVar args) b))

207+ (args : allArgs, body, f . JSFunction ident (map copyVar args))

210 collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

208 collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

211 collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

209 collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

212 collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

210 collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

213− (args : allArgs, body, \b -> f (JSReturn (JSFunction ident (map copyVar args) b)))

211+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))

214 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

212 collectAllFunctionArgs allArgs f body = (allArgs, body, f)

215 isTailCall :: String -> JS -> Bool

213 isTailCall :: String -> JS -> Bool

216 isTailCall ident js =

214 isTailCall ident js =

@@ -359,7 +357,7 @@ inlineST = everywhere (mkT convertBlock)

359 convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =

357 convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc "modifySTRef" f =

360 if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])

358 if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor "value" ref) (JSApp func [JSAccessor "value" ref])

361 convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =

359 convert _ (JSApp (JSApp (JSApp f [arr]) [i]) []) | isSTFunc "peekSTArray" f =

362− (JSIndexer i arr)

360+ JSIndexer i arr

363 convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =

361 convert _ (JSApp (JSApp (JSApp (JSApp f [arr]) [i]) [val]) []) | isSTFunc "pokeSTArray" f =

364 JSAssignment (JSIndexer i arr) val

362 JSAssignment (JSIndexer i arr) val

365 convert _ other = other

363 convert _ other = other

@@ -369,7 +367,7 @@ inlineST = everywhere (mkT convertBlock)

369 -- Find all ST Refs initialized in this block

367 -- Find all ST Refs initialized in this block

370 findSTRefsIn = everything (++) (mkQ [] isSTRef)

368 findSTRefsIn = everything (++) (mkQ [] isSTRef)

371 where

369 where

372− isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [arg]) []))) | isSTFunc "newSTRef" f = [ident]

370+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc "newSTRef" f = [ident]

373 isSTRef _ = []

371 isSTRef _ = []

374 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

372 -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

375 findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)

373 findAllSTUsagesIn = everything (++) (mkQ [] isSTUsage)

@@ -400,7 +398,7 @@ inlineOperator :: String -> (JS -> JS -> JS) -> JS -> JS

400inlineOperator op f = everywhere (mkT convert)

398inlineOperator op f = everywhere (mkT convert)

401 where

399 where

402 convert :: JS -> JS

400 convert :: JS -> JS

403− convert (JSApp (JSApp op [x]) [y]) | isOp op = f x y

401+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

404 convert other = other

402 convert other = other

405 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True

403 isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar "_ps"))) | longForm == identToJs (Op op) = True

406 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True

404 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | op == op' = True

@@ -446,7 +444,7 @@ inlineCommonOperators = applyAll

446 convert :: JS -> JS

444 convert :: JS -> JS

447 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y

445 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict className classTy dict = JSBinary op x y

448 convert other = other

446 convert other = other

449− isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar ps))) | longForm == identToJs (Op opString) = True

447+ isOp (JSAccessor longForm (JSAccessor "Prelude" (JSVar _))) | longForm == identToJs (Op opString) = True

450 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True

448 isOp (JSIndexer (JSStringLiteral op') (JSAccessor "Prelude" (JSVar "_ps"))) | opString == op' = True

451 isOp _ = False

449 isOp _ = False

452 binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS

450 binaryFunction :: String -> String -> Type -> BinaryOperator -> JS -> JS

src/Language/PureScript/DeadCodeElimination.hs+5−5

@@ -35,19 +35,19 @@ eliminateDeadCode env entryPoints ms =

35 let declarations = concatMap (declarationsByModule env) ms

36 (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations

37 entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations

38− in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed (moduleName) graph vertexFor entryPointVertices) ds)

38+ in flip map ms $ \(Module moduleName ds) -> Module moduleName (filter (isUsed moduleName graph vertexFor entryPointVertices) ds)

39

40type Key = (ModuleName, Either Ident ProperName)

41

42declarationsByModule :: Environment -> Module -> [(Key, [Key])]

43−declarationsByModule env (Module moduleName ds) = concatMap go $ ds

43+declarationsByModule env (Module moduleName ds) = concatMap go ds

44 where

45 go :: Declaration -> [(Key, [Key])]

46− go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env (moduleName) d)]

46+ go d@(ValueDeclaration name _ _ _) = [((moduleName, Left name), dependencies env moduleName d)]

47 go (DataDeclaration _ _ dctors) = map (\(name, _) -> ((moduleName, Right name), [])) dctors

48 go (ExternDeclaration _ name _ _) = [((moduleName, Left name), [])]

49− go d@(BindingGroupDeclaration names) = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names

49+ go d@(BindingGroupDeclaration names') = map (\(name, _) -> ((moduleName, Left name), dependencies env moduleName d)) names'

50− go (DataBindingGroupDeclaration ds) = concatMap go ds

50+ go (DataBindingGroupDeclaration ds') = concatMap go ds'

51 go _ = []

52

53dependencies :: (Data d) => Environment -> ModuleName -> d -> [Key]

src/Language/PureScript/Declarations.hs+9−9

@@ -123,49 +123,49 @@ data Declaration

123-- Test if a declaration is a value declaration

124--

125isValueDecl :: Declaration -> Bool

126−isValueDecl (ValueDeclaration _ _ _ _) = True

126+isValueDecl ValueDeclaration{} = True

127isValueDecl _ = False

128

129-- |

130-- Test if a declaration is a data type or type synonym declaration

131--

132isDataDecl :: Declaration -> Bool

133−isDataDecl (DataDeclaration _ _ _) = True

133+isDataDecl DataDeclaration{} = True

134−isDataDecl (TypeSynonymDeclaration _ _ _) = True

134+isDataDecl TypeSynonymDeclaration{} = True

135isDataDecl _ = False

136

137-- |

138-- Test if a declaration is a module import

139--

140isImportDecl :: Declaration -> Bool

141−isImportDecl (ImportDeclaration _ _) = True

141+isImportDecl ImportDeclaration{} = True

142isImportDecl _ = False

143

144-- |

145-- Test if a declaration is a data type foreign import

146--

147isExternDataDecl :: Declaration -> Bool

148−isExternDataDecl (ExternDataDeclaration _ _) = True

148+isExternDataDecl ExternDataDeclaration{} = True

149isExternDataDecl _ = False

150

151-- |

152-- Test if a declaration is a fixity declaration

153--

154isFixityDecl :: Declaration -> Bool

155−isFixityDecl (FixityDeclaration _ _) = True

155+isFixityDecl FixityDeclaration{} = True

156isFixityDecl _ = False

157

158-- |

159-- Test if a declaration is a foreign import

160--

161isExternDecl :: Declaration -> Bool

162−isExternDecl (ExternDeclaration _ _ _ _) = True

162+isExternDecl ExternDeclaration{} = True

163isExternDecl _ = False

164

165-- |

166-- Test if a declaration is a type class or instance declaration

167--

168isTypeClassDeclaration :: Declaration -> Bool

169−isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True

169+isTypeClassDeclaration TypeClassDeclaration{} = True

170−isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True

170+isTypeClassDeclaration TypeInstanceDeclaration{} = True

171isTypeClassDeclaration _ = False

src/Language/PureScript/ModuleDependencies.hs+1−4

@@ -19,13 +19,10 @@ module Language.PureScript.ModuleDependencies (

19import Data.Data

20import Data.Graph

21import Data.Generics

22−import Data.List (nub, intersect)

22+import Data.List (nub)

23−import Control.Applicative ((<$>))

24

23

25import Language.PureScript.Declarations

24import Language.PureScript.Declarations

26import Language.PureScript.Names

25import Language.PureScript.Names

27−import Language.PureScript.Values

28−import Language.PureScript.Types

29

26

30-- |

27-- |

31-- Sort a collection of modules based on module dependencies.

28-- Sort a collection of modules based on module dependencies.

src/Language/PureScript/Options.hs+1−1

@@ -33,7 +33,7 @@ data Options = Options {

33 , optionsMagicDo :: Bool

34 -- |

35 -- When specified, checks the type of `main` in the module, and generate a call to run main

36− -- after the module definitions.

36+ -- after the module definitions.

37 --

38 , optionsMain :: Maybe String

39 -- |

src/Language/PureScript/Parser/Common.hs+1−1

@@ -328,7 +328,7 @@ buildPostfixParser fs first = do

328-- Parse an identifier in backticks or an operator

329--

330parseIdentInfix :: P.Parsec String ParseState (Qualified Ident)

331−parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> Qualified Nothing <$> (Op <$> operator)

331+parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> Qualified Nothing <$> (Op <$> operator)

332

333-- |

334-- Mark the current indentation level

src/Language/PureScript/Parser/Declarations.hs+5−8

@@ -20,11 +20,9 @@ module Language.PureScript.Parser.Declarations (

20) where

21

22import Data.Maybe (isJust, fromMaybe)

23−import Control.Monad (when)

24import Control.Applicative

23import Control.Applicative

25import qualified Text.Parsec as P

24import qualified Text.Parsec as P

26

25

27−import Language.PureScript.Names

28import Language.PureScript.Parser.State

26import Language.PureScript.Parser.State

29import Language.PureScript.Parser.Common

27import Language.PureScript.Parser.Common

30import Language.PureScript.Declarations

28import Language.PureScript.Declarations

@@ -32,7 +30,6 @@ import Language.PureScript.Parser.Values

32import Language.PureScript.Parser.Types

30import Language.PureScript.Parser.Types

33import Language.PureScript.Parser.Kinds

31import Language.PureScript.Parser.Kinds

34import Language.PureScript.CodeGen.JS.AST

32import Language.PureScript.CodeGen.JS.AST

35−import Language.PureScript.Values

36

33

37parseDataDeclaration :: P.Parsec String ParseState Declaration

34parseDataDeclaration :: P.Parsec String ParseState Declaration

38parseDataDeclaration = do

35parseDataDeclaration = do

@@ -59,15 +56,15 @@ parseValueDeclaration =

59 ValueDeclaration <$> parseIdent

56 ValueDeclaration <$> parseIdent

60 <*> P.many parseBinderNoParens

57 <*> P.many parseBinderNoParens

61 <*> P.optionMaybe parseGuard

58 <*> P.optionMaybe parseGuard

62− <*> ((lexeme (indented *> P.char '=')) *> parseValue)

59+ <*> (lexeme (indented *> P.char '=') *> parseValue)

63

60

64parseExternDeclaration :: P.Parsec String ParseState Declaration

61parseExternDeclaration :: P.Parsec String ParseState Declaration

65−parseExternDeclaration = P.try (reserved "foreign") *> indented *> (reserved "import") *> indented *>

62+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

66 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

63 (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

67 <*> (lexeme (indented *> P.string "::") *> parseKind)

64 <*> (lexeme (indented *> P.string "::") *> parseKind)

68 <|> do ident <- parseIdent

65 <|> do ident <- parseIdent

69 js <- P.optionMaybe (JSRaw <$> stringLiteral)

66 js <- P.optionMaybe (JSRaw <$> stringLiteral)

70− ty <- (lexeme (indented *> P.string "::") *> parsePolyType)

67+ ty <- lexeme (indented *> P.string "::") *> parsePolyType

71 return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)

68 return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty)

72

69

73parseAssociativity :: P.Parsec String ParseState Associativity

70parseAssociativity :: P.Parsec String ParseState Associativity

@@ -89,9 +86,9 @@ parseImportDeclaration :: P.Parsec String ParseState Declaration

89parseImportDeclaration = do

86parseImportDeclaration = do

90 reserved "import"

87 reserved "import"

91 indented

88 indented

92− moduleName <- moduleName

89+ moduleName' <- moduleName

93 idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

90 idents <- P.optionMaybe $ parens $ commaSep1 (Left <$> parseIdent <|> Right <$> properName)

94− return $ ImportDeclaration moduleName idents

91+ return $ ImportDeclaration moduleName' idents

95

92

96parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

93parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

97parseTypeClassDeclaration = do

94parseTypeClassDeclaration = do

src/Language/PureScript/Parser/Types.hs+7−9

@@ -51,15 +51,15 @@ parseObject = braces $ Object <$> parseRow False

51parseTypeVariable :: P.Parsec String ParseState Type

52parseTypeVariable = do

53 ident <- identifier

54− when (ident `elem` reservedTypeNames) $ P.unexpected $ ident

54+ when (ident `elem` reservedTypeNames) $ P.unexpected ident

55 return $ TypeVar ident

56

57parseTypeConstructor :: P.Parsec String ParseState Type

58parseTypeConstructor = TypeConstructor <$> parseQualified properName

59

60parseForAll :: P.Parsec String ParseState Type

61−parseForAll = (mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

61+parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

62− <*> parseConstrainedType)

62+ <*> parseConstrainedType

63

64-- |

65-- Parse a type as it appears in e.g. a data constructor

@@ -94,7 +94,7 @@ parseConstrainedType = do

94 return $ maybe ty (flip ConstrainedType ty) constraints

95

96parseAnyType :: P.Parsec String ParseState Type

97−parseAnyType = (P.buildExpressionParser operators $ parseTypeAtom) P.<?> "type"

97+parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"

98 where

99 operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

100 , [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]

@@ -112,9 +112,7 @@ parseType = do

112-- Parse a polytype

113--

114parsePolyType :: P.Parsec String ParseState Type

115−parsePolyType = do

115+parsePolyType = parseAnyType

116− ty <- parseAnyType

117− return ty

118

116

119parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

117parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

120parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p

118parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p

@@ -123,5 +121,5 @@ parseRowEnding :: P.Parsec String ParseState Type

123parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

121parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

124

122

125parseRow :: Bool -> P.Parsec String ParseState Type

123parseRow :: Bool -> P.Parsec String ParseState Type

126−parseRow nonEmpty = (curry rowFromList <$> (many $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

124+parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

127− where many = if nonEmpty then commaSep1 else commaSep

125+ where many' = if nonEmpty then commaSep1 else commaSep

src/Language/PureScript/Parser/Values.hs+11−8

@@ -20,13 +20,16 @@ module Language.PureScript.Parser.Values (

20 parseBinderNoParens,

21) where

22

23+import Control.Applicative

24+

23import Language.PureScript.Values

25import Language.PureScript.Values

24import Language.PureScript.Parser.State

26import Language.PureScript.Parser.State

27+import Language.PureScript.Parser.Types

28+

29+import Text.Parsec.Expr

30+

25import qualified Language.PureScript.Parser.Common as C

31import qualified Language.PureScript.Parser.Common as C

26−import Control.Applicative

27import qualified Text.Parsec as P

32import qualified Text.Parsec as P

28−import Text.Parsec.Expr

29−import Language.PureScript.Parser.Types

30

33

31booleanLiteral :: P.Parsec String ParseState Bool

34booleanLiteral :: P.Parsec String ParseState Bool

32booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

35booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)

@@ -59,7 +62,7 @@ parseAbs = do

59 return $ toFunction args value

62 return $ toFunction args value

60 where

63 where

61 toFunction :: [Value -> Value] -> Value -> Value

64 toFunction :: [Value -> Value] -> Value -> Value

62− toFunction args value = foldr (($)) value args

65+ toFunction args value = foldr ($) value args

63

66

64parseVar :: P.Parsec String ParseState Value

67parseVar :: P.Parsec String ParseState Value

65parseVar = Var <$> C.parseQualified C.parseIdent

68parseVar = Var <$> C.parseQualified C.parseIdent

@@ -154,7 +157,7 @@ parseValue =

154 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

157 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

155 postfixTable1 = [ parseAccessor

158 postfixTable1 = [ parseAccessor

156 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

159 , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]

157− postfixTable2 = [ \v -> P.try (C.indented *> indexersAndAccessors >>= return . flip App) <*> pure v

160+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

158 , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

161 , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v

159 ]

162 ]

160 operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

163 operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->

@@ -177,13 +180,13 @@ parseNullaryConstructorBinder :: P.Parsec String ParseState Binder

177parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []

180parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []

178

181

179parseConstructorBinder :: P.Parsec String ParseState Binder

182parseConstructorBinder :: P.Parsec String ParseState Binder

180−parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> (many (C.indented *> parseBinderNoParens))

183+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)

181

184

182parseObjectBinder :: P.Parsec String ParseState Binder

185parseObjectBinder :: P.Parsec String ParseState Binder

183parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

186parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))

184

187

185parseArrayBinder :: P.Parsec String ParseState Binder

188parseArrayBinder :: P.Parsec String ParseState Binder

186−parseArrayBinder = C.squares $ ArrayBinder <$> (C.commaSep (C.indented *> parseBinder))

189+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)

187

190

188parseNamedBinder :: P.Parsec String ParseState Binder

191parseNamedBinder :: P.Parsec String ParseState Binder

189parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

192parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))

@@ -203,7 +206,7 @@ parseIdentifierAndBinder = do

203-- Parse a binder

206-- Parse a binder

204--

207--

205parseBinder :: P.Parsec String ParseState Binder

208parseBinder :: P.Parsec String ParseState Binder

206−parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression"

209+parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression"

207 where

210 where

208 operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

211 operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]

209 parseBinderAtom :: P.Parsec String ParseState Binder

212 parseBinderAtom :: P.Parsec String ParseState Binder

src/Language/PureScript/Pretty/JS.hs+11−13

@@ -17,8 +17,6 @@ module Language.PureScript.Pretty.JS (

17 prettyPrintJS

18) where

19

20−import Language.PureScript.Names

21−import Language.PureScript.Values

22import Language.PureScript.Pretty.Common

20import Language.PureScript.Pretty.Common

23import Language.PureScript.CodeGen.JS.AST

21import Language.PureScript.CodeGen.JS.AST

24

22

@@ -69,7 +67,7 @@ literals = mkPattern' match

69 , fmap (intercalate ", ") $ forM xs prettyPrintJS'

67 , fmap (intercalate ", ") $ forM xs prettyPrintJS'

70 , return " ]"

68 , return " ]"

71 ]

69 ]

72− match (JSObjectLiteral []) = return "{}"

70+ match (JSObjectLiteral []) = return "{}"

73 match (JSObjectLiteral ps) = fmap concat $ sequence

71 match (JSObjectLiteral ps) = fmap concat $ sequence

74 [ return "{\n"

72 [ return "{\n"

75 , withIndent $ do

73 , withIndent $ do

@@ -82,10 +80,7 @@ literals = mkPattern' match

82 ]

80 ]

83 match (JSBlock sts) = fmap concat $ sequence

81 match (JSBlock sts) = fmap concat $ sequence

84 [ return "{\n"

82 [ return "{\n"

85− , withIndent $ do

83+ , withIndent $ prettyStatements sts

86− jss <- forM sts prettyPrintJS'

87− indentString <- currentIndent

88− return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss

89 , return "\n"

84 , return "\n"

90 , currentIndent

85 , currentIndent

91 , return "}"

86 , return "}"

@@ -195,6 +190,12 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

195 match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

190 match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

196 match' _ = Nothing

191 match' _ = Nothing

197

192

193+prettyStatements :: [JS] -> StateT PrinterState Maybe String

194+prettyStatements sts = do

195+ jss <- forM sts prettyPrintJS'

196+ indentString <- currentIndent

197+ return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss

198+

198-- |

199-- |

199-- Generate a pretty-printed string representing a Javascript expression

200-- Generate a pretty-printed string representing a Javascript expression

200--

201--

@@ -205,10 +206,7 @@ prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (Print

205-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

206-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

206--

207--

207prettyPrintJS :: [JS] -> String

208prettyPrintJS :: [JS] -> String

208−prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do

209+prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

209− jss <- forM sts prettyPrintJS'

210− indentString <- currentIndent

211− return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss

212

210

213-- |

211-- |

214-- Generate an indented, pretty-printed string representing a Javascript expression

212-- Generate an indented, pretty-printed string representing a Javascript expression

@@ -224,8 +222,8 @@ prettyPrintJS' = A.runKleisli $ runPattern matchValue

224 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

222 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

225 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

223 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

226 , [ Wrap lam $ \(name, args) ret -> "function "

224 , [ Wrap lam $ \(name, args) ret -> "function "

227− ++ maybe "" id name

225+ ++ fromMaybe "" name

228− ++ "(" ++ (intercalate ", " args) ++ ") "

226+ ++ "(" ++ intercalate ", " args ++ ") "

229 ++ ret ]

227 ++ ret ]

230 , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

228 , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

231 , [ binary LessThan "<" ]

229 , [ binary LessThan "<" ]

src/Language/PureScript/Pretty/Types.hs+3−3

@@ -35,14 +35,14 @@ typeLiterals = mkPattern match

35 match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

36 match (TypeVar var) = Just var

37 match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

38− match ty@(TypeConstructor ctor) = Just $ show ctor

38+ match (TypeConstructor ctor) = Just $ show ctor

39 match (TUnknown (Unknown u)) = Just $ 'u' : show u

40 match (Skolem s _) = Just $ 's' : show s

41− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ intercalate " " (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty

41+ match (ConstrainedType deps ty) = Just $ "(" ++ intercalate "," (map (\(pn, ty') -> show pn ++ " (" ++ unwords (map prettyPrintType ty') ++ ")") deps) ++ ") => " ++ prettyPrintType ty

42 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

43 match (ForAll ident ty _) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

44 match REmpty = Just "()"

45− match row@(RCons _ _ _) = Just $ '(' : prettyPrintRow row ++ ")"

45+ match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"

46 match _ = Nothing

47

48-- |

src/Language/PureScript/Pretty/Values.hs+3−3

@@ -38,7 +38,7 @@ literals = mkPattern match

38 match (ArrayLiteral xs) = Just $ "[" ++ intercalate ", " (map prettyPrintValue xs) ++ "]"

39 match (ObjectLiteral ps) = Just $ "{" ++ intercalate ", " (map (uncurry prettyPrintObjectProperty) ps) ++ "}"

40 match (Constructor name) = Just $ show name

41− match (Case values binders) = Just $ "case " ++ intercalate " " (map prettyPrintValue values) ++

41+ match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++

42 " of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"

43 match (Var ident) = Just $ show ident

44 match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"

@@ -47,7 +47,7 @@ literals = mkPattern match

47

48prettyPrintCaseAlternative :: ([Binder], Maybe Guard, Value) -> String

49prettyPrintCaseAlternative (binders, grd, val) = "(" ++ intercalate ", " (map prettyPrintBinder binders) ++ ") " ++

50− (maybe "" (("| " ++) . prettyPrintValue) grd) ++ " -> " ++ prettyPrintValue val

50+ maybe "" (("| " ++) . prettyPrintValue) grd ++ " -> " ++ prettyPrintValue val

51

52ifThenElse :: Pattern () Value ((Value, Value), Value)

53ifThenElse = mkPattern match

@@ -118,7 +118,7 @@ prettyPrintBinderAtom = mkPattern match

118 match (BooleanBinder True) = Just "true"

119 match (BooleanBinder False) = Just "false"

120 match (VarBinder ident) = Just $ show ident

121− match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ intercalate " " (map (parens . prettyPrintBinder) args)

121+ match (ConstructorBinder ctor args) = Just $ show ctor ++ " " ++ unwords (map (parens . prettyPrintBinder) args)

122 match (ObjectBinder bs) = Just $ "{ " ++ intercalate ", " (map (uncurry prettyPrintObjectPropertyBinder) bs) ++ " }"

123 match (ArrayBinder bs) = Just $ "[ " ++ intercalate ", " (map prettyPrintBinder bs) ++ " ]"

124 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

src/Language/PureScript/Scope.hs+4−2

@@ -18,6 +18,8 @@ module Language.PureScript.Scope (

18 unusedNames

19) where

20

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

22+

21import Data.Data

23import Data.Data

22import Data.List ((\\), nub)

24import Data.List ((\\), nub)

23import Data.Generics (extQ, mkQ, everything)

25import Data.Generics (extQ, mkQ, everything)

@@ -41,8 +43,8 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesB `extQ` namesJ

41 namesB _ = []

43 namesB _ = []

42 namesJS :: JS -> [Ident]

44 namesJS :: JS -> [Ident]

43 namesJS (JSVar name) = [Ident name]

45 namesJS (JSVar name) = [Ident name]

44− namesJS (JSFunction (Just name) args _) = (Ident name) : (Ident `map` args)

46+ namesJS (JSFunction (Just name) args _) = Ident name : (Ident <$> args)

45− namesJS (JSFunction Nothing args _) = (Ident `map` args)

47+ namesJS (JSFunction Nothing args _) = Ident <$> args

46 namesJS (JSVariableIntroduction name _) = [Ident name]

48 namesJS (JSVariableIntroduction name _) = [Ident name]

47 namesJS (JSFor name _ _ _) = [Ident name]

49 namesJS (JSFor name _ _ _) = [Ident name]

48 namesJS _ = []

50 namesJS _ = []

src/Language/PureScript/Sugar/BindingGroups.hs+3−3

@@ -69,7 +69,7 @@ createBindingGroups moduleName ds = do

69-- Collapse all binding groups to individual declarations

70--

71collapseBindingGroups :: [Declaration] -> [Declaration]

72−collapseBindingGroups ds = concatMap go ds

72+collapseBindingGroups = concatMap go

73 where

74 go (DataBindingGroupDeclaration ds) = ds

75 go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds

@@ -112,10 +112,10 @@ toDataBindingGroup (CyclicSCC ds')

112 | all isTypeSynonym ds' = Left "Cycle in type synonyms"

113 | otherwise = return $ DataBindingGroupDeclaration ds'

114 where

115− isTypeSynonym (TypeSynonymDeclaration _ _ _) = True

115+ isTypeSynonym TypeSynonymDeclaration{} = True

116 isTypeSynonym _ = False

117

118fromValueDecl :: Declaration -> (Ident, Value)

119fromValueDecl (ValueDeclaration ident [] Nothing val) = (ident, val)

120−fromValueDecl (ValueDeclaration _ _ _ _) = error "Binders should have been desugared"

120+fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

121fromValueDecl _ = error "Expected ValueDeclaration"

src/Language/PureScript/Sugar/CaseDeclarations.hs+1−1

@@ -75,7 +75,7 @@ makeCaseDeclaration ident alternatives =

75 let

76 argPattern = length . fst . head $ alternatives

77 args = take argPattern $ unusedNames (ident, alternatives)

78− vars = map (\arg -> Var (Qualified Nothing arg)) args

78+ vars = map (Var . Qualified Nothing) args

79 binders = [ (bs, g, val) | (bs, (g, val)) <- alternatives ]

80 value = foldr (\arg ret -> Abs (Left arg) ret) (Case vars binders) args

81 in

src/Language/PureScript/Sugar/Operators.hs+12−8

@@ -27,13 +27,17 @@ import Language.PureScript.Names

27import Language.PureScript.Declarations

28import Language.PureScript.Values

29

30+import Control.Applicative

31+import Control.Arrow (first)

32+import Control.Monad.State

33+

30import Data.Function (on)

34import Data.Function (on)

31import Data.List (groupBy, sortBy)

35import Data.List (groupBy, sortBy)

36+

32import qualified Data.Map as M

37import qualified Data.Map as M

33import qualified Data.Generics as G

38import qualified Data.Generics as G

34import qualified Data.Generics.Extras as G

39import qualified Data.Generics.Extras as G

35−import Control.Monad.State

40+

36−import Control.Applicative

37import qualified Text.Parsec as P

41import qualified Text.Parsec as P

38import qualified Text.Parsec.Pos as P

42import qualified Text.Parsec.Pos as P

39import qualified Text.Parsec.Expr as P

43import qualified Text.Parsec.Expr as P

@@ -62,9 +66,9 @@ customOperatorTable fixities =

62 -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name

66 -- The fixity map can therefore map from module name/ident pairs to fixities, where the module name is the name

63 -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to

67 -- of the module imported into, not from. This is useful in matchOp, but here we have to discard the module name to

64 -- make sure that the generated code is correct.

68 -- make sure that the generated code is correct.

65− applyUserOp (Qualified _ name) t1 t2 = App (App (Var (Qualified Nothing name)) t1) t2

69+ applyUserOp (Qualified _ name) t1 = App (App (Var (Qualified Nothing name)) t1)

66 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

70 userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) . M.toList $ fixities

67− sorted = reverse $ sortBy (compare `on` (\(_, _, p, _) -> p)) userOps

71+ sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps

68 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

72 groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted

69 in

73 in

70 map (map (\(name, f, _, a) -> (name, f, a))) groups

74 map (map (\(name, f, _, a) -> (name, f, a))) groups

@@ -72,10 +76,10 @@ customOperatorTable fixities =

72type Chain = [Either Value (Qualified Ident)]

76type Chain = [Either Value (Qualified Ident)]

73

77

74matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

78matchOperators :: ModuleName -> [[(Qualified Ident, Value -> Value -> Value, Associativity)]] -> Value -> Either String Value

75−matchOperators moduleName ops val = G.everywhereM' (G.mkM parseChains) val

79+matchOperators moduleName ops = G.everywhereM' (G.mkM parseChains)

76 where

80 where

77 parseChains :: Value -> Either String Value

81 parseChains :: Value -> Either String Value

78− parseChains b@(BinaryNoParens _ _ _) = bracketChain (extendChain b)

82+ parseChains b@BinaryNoParens{} = bracketChain (extendChain b)

79 parseChains other = return other

83 parseChains other = return other

80 extendChain :: Value -> Chain

84 extendChain :: Value -> Chain

81 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

85 extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r

@@ -108,7 +112,7 @@ collectFixities m moduleName (FixityDeclaration fixity name : rest) = do

108 collectFixities (M.insert qual fixity m) moduleName rest

112 collectFixities (M.insert qual fixity m) moduleName rest

109collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do

113collectFixities m moduleName (ImportDeclaration importedModule _ : rest) = do

110 let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]

114 let fs = [ (i, fixity) | (Qualified mn i, fixity) <- M.toList m, mn == Just importedModule ]

111− let m' = M.fromList (map (\(i, fixity) -> (Qualified (Just moduleName) i, fixity)) fs)

115+ let m' = M.fromList (map (first (Qualified (Just moduleName))) fs)

112− collectFixities (M.union m' m) moduleName rest

116+ collectFixities (m' `M.union` m) moduleName rest

113collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

117collectFixities m moduleName (_:ds) = collectFixities m moduleName ds

114

118

src/Language/PureScript/Sugar/TypeClasses.hs+5−7

@@ -31,11 +31,9 @@ import qualified Data.Map as M

31

32import Control.Applicative

33import Control.Monad.State

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

34+import Control.Arrow (second)

35

36−import Data.Maybe (fromMaybe)

37−import Data.List (intercalate, nub)

36+import Data.List (intercalate)

38−import Data.Generics (mkQ, everything)

39import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)

37import Language.PureScript.CodeGen.Common (identToJs, moduleNameToJs)

40

38

41type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

39type MemberMap = M.Map (ModuleName, ProperName) ([String], [(String, Type)])

@@ -122,16 +120,16 @@ typeInstanceDictionaryDeclaration mn deps name tys decls = do

122 m <- get

120 m <- get

123 (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right

121 (args, instanceTys) <- lift $ maybe (Left $ "Type class " ++ show name ++ " is undefined. Type class names must be qualified.") Right

124 $ M.lookup (qualify mn name) m

122 $ M.lookup (qualify mn name) m

125− let memberTypes = map (id *** (\instanceTy -> replaceAllTypeVars (zip args tys) instanceTy)) instanceTys

123+ let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys

126 entryName <- lift $ mkDictionaryValueName mn name tys

124 entryName <- lift $ mkDictionaryValueName mn name tys

127 memberNames <- mapM (memberToNameAndValue memberTypes) decls

125 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128 return $ ValueDeclaration entryName [] Nothing

126 return $ ValueDeclaration entryName [] Nothing

129 (TypedValue True

127 (TypedValue True

130− (foldr Abs (ObjectLiteral memberNames) (map (\n -> Left . Ident $ '_' : show n) [1..max 1 (length deps)]))

128+ (foldr (Abs . (\n -> Left . Ident $ '_' : show n)) (ObjectLiteral memberNames) [1..max 1 (length deps)])

131 (quantify (if null deps then

129 (quantify (if null deps then

132 function unit (foldl TypeApp (TypeConstructor name) tys)

130 function unit (foldl TypeApp (TypeConstructor name) tys)

133 else

131 else

134− foldr function (foldl TypeApp (TypeConstructor name) tys) (map (\(pn, tys) -> foldl TypeApp (TypeConstructor pn) tys) deps)))

132+ foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor name) tys) deps))

135 )

133 )

136 where

134 where

137 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

135 memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)

src/Language/PureScript/TypeChecker.hs+7−7

@@ -86,7 +86,7 @@ addValue moduleName name ty = do

86 putEnv (env { names = M.insert (moduleName, name) (qualifyAllUnqualifiedNames moduleName env ty, Value) (names env) })

87

88addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()

89−addTypeClassDictionaries entries = do

89+addTypeClassDictionaries entries =

90 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } }

91

92checkTypeClassInstance :: ModuleName -> Type -> Check ()

@@ -154,7 +154,7 @@ typeCheckAll mainModuleName moduleName (ValueDeclaration name [] Nothing val : r

154 return $ ValueDeclaration name [] Nothing val'

155 ds <- typeCheckAll mainModuleName moduleName rest

156 return $ d : ds

157−typeCheckAll _ _ (ValueDeclaration _ _ _ _ : _) = error "Binders were not desugared"

157+typeCheckAll _ _ (ValueDeclaration{} : _) = error "Binders were not desugared"

158typeCheckAll mainModuleName moduleName (BindingGroupDeclaration vals : rest) = do

159 d <- rethrow (("Error in binding group " ++ show (map fst vals) ++ ":\n") ++) $ do

160 forM_ (map fst vals) $ \name ->

@@ -206,7 +206,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

206 filterModule = filter ((== moduleName) . fst) . M.keys

207 moduleExists env = not (null (filterModule (names env))) || not (null (filterModule (types env)))

208 shadowIdents idents' env =

209− forM_ idents' $ \ident -> do

209+ forM_ idents' $ \ident ->

210 case (moduleName, ident) `M.lookup` names env of

211 Just (_, Alias _ _) -> return ()

212 Just (pt, _) -> do

@@ -214,7 +214,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

214 modifyEnv (\e -> e { names = M.insert (currentModule, ident) (pt, Alias moduleName ident) (names e) })

215 Nothing -> throwError (show moduleName ++ "." ++ show ident ++ " is undefined")

216 shadowTypes pns env =

217− forM_ pns $ \pn -> do

217+ forM_ pns $ \pn ->

218 case (moduleName, pn) `M.lookup` types env of

219 Nothing -> throwError (show moduleName ++ "." ++ show pn ++ " is undefined")

220 Just (_, DataAlias _ _) -> return ()

@@ -222,7 +222,7 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

222 guardWith (show currentModule ++ "." ++ show pn ++ " is already defined") $ (currentModule, pn) `M.notMember` types env

223 modifyEnv (\e -> e { types = M.insert (currentModule, pn) (k, DataAlias moduleName pn) (types e) })

224 let keys = map (snd . fst) . filter (\(_, (fn, _)) -> fn `constructs` pn) . M.toList . dataConstructors $ env

225− forM_ keys $ \dctor -> do

225+ forM_ keys $ \dctor ->

226 case (moduleName, dctor) `M.lookup` dataConstructors env of

227 Just (_, Alias _ _) -> return ()

228 Just (ctorTy, _) -> do

@@ -236,14 +236,14 @@ typeCheckAll mainModuleName currentModule (d@(ImportDeclaration moduleName ident

236 ) (typeClassDictionaries env)

237 forM_ instances $ \tcd -> do

238 let (Qualified _ ident) = tcdName tcd

239− addTypeClassDictionaries [tcd { tcdName = (Qualified (Just currentModule) ident), tcdType = TCDAlias (tcdName tcd) }]

239+ addTypeClassDictionaries [tcd { tcdName = Qualified (Just currentModule) ident, tcdType = TCDAlias (tcdName tcd) }]

240 constructs (TypeConstructor (Qualified (Just mn) pn')) pn

241 = mn == moduleName && pn' == pn

242 constructs (ForAll _ ty _) pn = ty `constructs` pn

243 constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn

244 constructs (TypeApp ty _) pn = ty `constructs` pn

245 constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn

246−typeCheckAll mainModuleName moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

246+typeCheckAll mainModuleName moduleName (d@TypeClassDeclaration{} : rest) = do

247 env <- getEnv

248 ds <- typeCheckAll mainModuleName moduleName rest

249 return $ qualifyAllUnqualifiedNames moduleName env d : ds

src/Language/PureScript/TypeChecker/Kinds.hs+3−6

@@ -14,7 +14,6 @@

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

15

16{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# LANGUAGE DeriveDataTypeable #-}

18{-# LANGUAGE MultiParamTypeClasses #-}

17{-# LANGUAGE MultiParamTypeClasses #-}

19

18

20module Language.PureScript.TypeChecker.Kinds (

19module Language.PureScript.TypeChecker.Kinds (

@@ -29,10 +28,8 @@ import Language.PureScript.Names

29import Language.PureScript.TypeChecker.Monad

28import Language.PureScript.TypeChecker.Monad

30import Language.PureScript.Pretty

29import Language.PureScript.Pretty

31

30

32−import Control.Monad (forM_)

33import Control.Monad.State

31import Control.Monad.State

34import Control.Monad.Error

32import Control.Monad.Error

35−import Control.Monad.Reader

36import Control.Monad.Unify

33import Control.Monad.Unify

37

34

38import Control.Applicative

35import Control.Applicative

@@ -60,7 +57,7 @@ instance Unifiable Check Kind where

60-- Infer the kind of a single type

57-- Infer the kind of a single type

61--

58--

62kindOf :: ModuleName -> Type -> Check Kind

59kindOf :: ModuleName -> Type -> Check Kind

63−kindOf moduleName ty =

60+kindOf _ ty =

64 rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $

61 rethrow (("Error checking kind of " ++ prettyPrintType ty ++ ":\n") ++) $

65 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty

62 fmap tidyUp . liftUnify $ starIfUnknown <$> infer ty

66 where

63 where

@@ -88,8 +85,8 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do

88 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

85 let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars

89 bindLocalTypeVariables moduleName dict $ do

86 bindLocalTypeVariables moduleName dict $ do

90 tyCons <- replicateM (length tys) fresh

87 tyCons <- replicateM (length tys) fresh

91− let dict = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

88+ let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons

92− bindLocalTypeVariables moduleName dict $ do

89+ bindLocalTypeVariables moduleName dict' $ do

93 data_ks <- zipWithM (\tyCon (_, args, ts) -> do

90 data_ks <- zipWithM (\tyCon (_, args, ts) -> do

94 kargs <- replicateM (length args) fresh

91 kargs <- replicateM (length args) fresh

95 let argDict = zip (map ProperName args) kargs

92 let argDict = zip (map ProperName args) kargs

src/Language/PureScript/TypeChecker/Monad.hs+9−11

@@ -13,8 +13,8 @@

13--

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

15

16−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes, DeriveDataTypeable,

16+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,

17− GADTs, StandaloneDeriving, MultiParamTypeClasses, FlexibleContexts #-}

17+ MultiParamTypeClasses, FlexibleContexts #-}

18

19module Language.PureScript.TypeChecker.Monad where

20

@@ -26,15 +26,13 @@ import Language.PureScript.Declarations

26

27import Data.Data

28import Data.Maybe

29−import Data.Monoid

30import Data.Generics (mkT, everywhere)

29import Data.Generics (mkT, everywhere)

31

30

32import Control.Applicative

31import Control.Applicative

33import Control.Monad.State

32import Control.Monad.State

34import Control.Monad.Error

33import Control.Monad.Error

35−import Control.Monad.Reader

36import Control.Monad.Unify

34import Control.Monad.Unify

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

35+import Control.Arrow (first)

38

36

39import qualified Data.Map as M

37import qualified Data.Map as M

40

38

@@ -173,15 +171,15 @@ getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

173-- Temporarily bind a collection of names to local variables

171-- Temporarily bind a collection of names to local variables

174--

172--

175bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

173bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

176−bindLocalVariables moduleName bindings action =

174+bindLocalVariables moduleName bindings =

177− bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

175+ bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable)))

178

176

179-- |

177-- |

180-- Temporarily bind a collection of names to local type variables

178-- Temporarily bind a collection of names to local type variables

181--

179--

182bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

180bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

183−bindLocalTypeVariables moduleName bindings action =

181+bindLocalTypeVariables moduleName bindings =

184− bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action

182+ bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable)))

185

183

186-- |

184-- |

187-- Lookup the type of a value by name in the @Environment@

185-- Lookup the type of a value by name in the @Environment@

@@ -322,7 +320,7 @@ liftUnify unify = do

322 case e of

320 case e of

323 Left err -> throwError err

321 Left err -> throwError err

324 Right (a, ust) -> do

322 Right (a, ust) -> do

325− modify $ \st -> st { checkNextVar = unifyNextVar ust }

323+ modify $ \st' -> st' { checkNextVar = unifyNextVar ust }

326 return (a, unifyCurrentSubstitution ust)

324 return (a, unifyCurrentSubstitution ust)

327

325

328-- |

326-- |

@@ -334,7 +332,7 @@ qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

334 go :: Type -> Type

332 go :: Type -> Type

335 go (TypeConstructor nm) = TypeConstructor $ qualify' nm

333 go (TypeConstructor nm) = TypeConstructor $ qualify' nm

336 go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args

334 go (SaturatedTypeSynonym nm args) = SaturatedTypeSynonym (qualify' nm) args

337− go (ConstrainedType constraints ty) = ConstrainedType (map (qualify' *** id) constraints) ty

335+ go (ConstrainedType constraints ty) = ConstrainedType (map (first qualify') constraints) ty

338 go other = other

336 go other = other

339 qualify' qual = let (mn', pn') = canonicalizeType mn env qual

337 qualify' qual = let (mn', pn') = canonicalizeType mn env qual

340 in Qualified (Just mn') pn'

338 in Qualified (Just mn') pn'

src/Language/PureScript/TypeChecker/Types.hs+42−44

@@ -14,7 +14,6 @@

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

15

16{-# OPTIONS_GHC -fno-warn-orphans #-}

17−{-# LANGUAGE DeriveDataTypeable #-}

18{-# LANGUAGE FlexibleContexts #-}

17{-# LANGUAGE FlexibleContexts #-}

19{-# LANGUAGE MultiParamTypeClasses #-}

18{-# LANGUAGE MultiParamTypeClasses #-}

20

19

@@ -60,7 +59,6 @@ import Language.PureScript.Pretty

60

59

61import Control.Monad.State

60import Control.Monad.State

62import Control.Monad.Error

61import Control.Monad.Error

63−import Control.Monad.Reader

64import Control.Monad.Unify

62import Control.Monad.Unify

65

63

66import Control.Applicative

64import Control.Applicative

@@ -82,7 +80,7 @@ instance Unifiable Check Type where

82-- Unify two types, updating the current substitution

80-- Unify two types, updating the current substitution

83--

81--

84unifyTypes :: Type -> Type -> UnifyT Type Check ()

82unifyTypes :: Type -> Type -> UnifyT Type Check ()

85−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do

83+unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $

86 unifyTypes' t1 t2

84 unifyTypes' t1 t2

87 where

85 where

88 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

86 unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()

@@ -104,8 +102,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

104 sko <- newSkolemConstant

102 sko <- newSkolemConstant

105 let sk = skolemize ident sko sc ty1

103 let sk = skolemize ident sko sc ty1

106 sk `unifyTypes` ty2

104 sk `unifyTypes` ty2

107− unifyTypes' (ForAll _ _ _) _ = throwError "Skolem variable scope is unspecified"

105+ unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"

108− unifyTypes' ty f@(ForAll _ _ _) = f `unifyTypes` ty

106+ unifyTypes' ty f@ForAll{} = f `unifyTypes` ty

109 unifyTypes' (Object row1) (Object row2) = row1 =?= row2

107 unifyTypes' (Object row1) (Object row2) = row1 =?= row2

110 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

108 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()

111 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

109 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do

@@ -116,8 +114,8 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

116 t3 `unifyTypes` t5

114 t3 `unifyTypes` t5

117 t4 `unifyTypes` t6

115 t4 `unifyTypes` t6

118 unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()

116 unifyTypes' (Skolem s1 _) (Skolem s2 _) | s1 == s2 = return ()

119− unifyTypes' r1@(RCons _ _ _) r2 = unifyRows r1 r2

117+ unifyTypes' r1@RCons{} r2 = unifyRows r1 r2

120− unifyTypes' r1 r2@(RCons _ _ _) = unifyRows r1 r2

118+ unifyTypes' r1 r2@RCons{} = unifyRows r1 r2

121 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

119 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

122 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

120 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

123 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

121 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

@@ -187,30 +185,30 @@ typesOf mainModuleName moduleName vals = do

187 -- If the declaration is a function, it has access to other values in the binding group.

185 -- If the declaration is a function, it has access to other values in the binding group.

188 -- If not, the generated code might fail at runtime since those values might be undefined.

186 -- If not, the generated code might fail at runtime since those values might be undefined.

189 let dict' = if isFunction val then dict else M.empty

187 let dict' = if isFunction val then dict else M.empty

190− triple@(_, (val, ty)) <- case e of

188+ triple@(_, (val', ty)) <- case e of

191 -- Typed declarations

189 -- Typed declarations

192− (ident, (val, Just (ty, checkType))) -> do

190+ (ident, (val', Just (ty, checkType))) -> do

193 -- Kind check

191 -- Kind check

194 kind <- liftCheck $ kindOf moduleName ty

192 kind <- liftCheck $ kindOf moduleName ty

195 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

193 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star

196 -- Check the type with the new names in scope

194 -- Check the type with the new names in scope

197 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

195 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty

198− val' <- bindNames dict' $ if checkType

196+ val'' <- bindNames dict' $ if checkType

199− then TypedValue True <$> check val ty' <*> pure ty'

197+ then TypedValue True <$> check val' ty' <*> pure ty'

200− else return (TypedValue False val ty')

198+ else return (TypedValue False val' ty')

201− return (ident, (val', ty'))

199+ return (ident, (val'', ty'))

202 -- Untyped declarations

200 -- Untyped declarations

203− (ident, (val, Nothing)) -> do

201+ (ident, (val', Nothing)) -> do

204 -- Infer the type with the new names in scope

202 -- Infer the type with the new names in scope

205− TypedValue _ val' ty <- bindNames dict' $ infer val

203+ TypedValue _ val'' ty <- bindNames dict' $ infer val'

206 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

204 ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)

207− return (ident, (TypedValue True val' ty, ty))

205+ return (ident, (TypedValue True val'' ty, ty))

208 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

206 -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a

209 when (Just moduleName == mainModuleName && fst e == Ident "main") $ do

207 when (Just moduleName == mainModuleName && fst e == Ident "main") $ do

210 [eff, a] <- replicateM 2 fresh

208 [eff, a] <- replicateM 2 fresh

211 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

209 ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a

212 -- Make sure unification variables do not escape

210 -- Make sure unification variables do not escape

213− escapeCheck val ty

211+ escapeCheck val' ty

214 return triple

212 return triple

215 forM tys $ \(ident, (val, ty)) -> do

213 forM tys $ \(ident, (val, ty)) -> do

216 -- Replace type class dictionary placeholders with actual dictionaries

214 -- Replace type class dictionary placeholders with actual dictionaries

@@ -221,7 +219,7 @@ typesOf mainModuleName moduleName vals = do

221 -- top-level unification variables with named type variables.

219 -- top-level unification variables with named type variables.

222 let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'

220 let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'

223 ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty

221 ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty

224− return $ (ident, (val'', ty'))

222+ return (ident, (val'', ty'))

225 where

223 where

226 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

224 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values

227 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

225 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts

@@ -284,7 +282,7 @@ entails moduleName context goal@(className, tys) = do

284 solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]

282 solveSubgoals :: Environment -> [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [Value]]

285 solveSubgoals _ _ Nothing = return Nothing

283 solveSubgoals _ _ Nothing = return Nothing

286 solveSubgoals env subst (Just subgoals) = do

284 solveSubgoals env subst (Just subgoals) = do

287− dict <- mapM (go env) (map (id *** map (replaceAllTypeVars subst)) subgoals)

285+ dict <- mapM (go env . second (map (replaceAllTypeVars subst))) subgoals

288 return $ Just dict

286 return $ Just dict

289 -- Make a dictionary from subgoal dictionaries by applying the correct function

287 -- Make a dictionary from subgoal dictionaries by applying the correct function

290 mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

288 mkDictionary :: Qualified Ident -> Maybe [Value] -> Value

@@ -320,7 +318,7 @@ typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructo

320typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

318typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2

321typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

319typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

322typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of

320typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of

323− Left err -> Nothing

321+ Left _ -> Nothing

324 Right t1 -> typeHeadsAreEqual m e t1 t2

322 Right t1 -> typeHeadsAreEqual m e t1 t2

325typeHeadsAreEqual _ _ _ _ = Nothing

323typeHeadsAreEqual _ _ _ _ = Nothing

326

324

@@ -350,7 +348,7 @@ findAllTypes = everything (++) (mkQ [] go)

350--

348--

351skolemEscapeCheck :: Value -> Check ()

349skolemEscapeCheck :: Value -> Check ()

352skolemEscapeCheck (TypedValue False _ _) = return ()

350skolemEscapeCheck (TypedValue False _ _) = return ()

353−skolemEscapeCheck root@(TypedValue _ _ _) =

351+skolemEscapeCheck root@TypedValue{} =

354 -- Every skolem variable is created when a ForAll type is skolemized.

352 -- Every skolem variable is created when a ForAll type is skolemized.

355 -- This determines the scope of that skolem variable, which is copied from the SkolemScope

353 -- This determines the scope of that skolem variable, which is copied from the SkolemScope

356 -- field of the ForAll constructor.

354 -- field of the ForAll constructor.

@@ -374,10 +372,10 @@ skolemEscapeCheck root@(TypedValue _ _ _) =

374 collect _ = []

372 collect _ = []

375 go _ scos = ([], scos)

373 go _ scos = ([], scos)

376 findBindingScope :: SkolemScope -> Maybe Value

374 findBindingScope :: SkolemScope -> Maybe Value

377− findBindingScope sco = something (mkQ Nothing go) root

375+ findBindingScope sco = something (mkQ Nothing go') root

378 where

376 where

379− go val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val

377+ go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = Just val

380− go _ = Nothing

378+ go' _ = Nothing

381skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val

379skolemEscapeCheck val = throwError $ "Untyped value passed to skolemEscapeCheck: " ++ prettyPrintValue val

382

380

383-- |

381-- |

@@ -399,7 +397,7 @@ varIfUnknown :: Type -> Type

399varIfUnknown ty =

397varIfUnknown ty =

400 let unks = nub $ unknowns ty

398 let unks = nub $ unknowns ty

401 toName = (:) 't' . show

399 toName = (:) 't' . show

402− ty' = everywhere (mkT typeToVar) $ ty

400+ ty' = everywhere (mkT typeToVar) ty

403 typeToVar :: Type -> Type

401 typeToVar :: Type -> Type

404 typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

402 typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)

405 typeToVar t = t

403 typeToVar t = t

@@ -430,7 +428,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)

430replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type

428replaceVarWithUnknown :: String -> Type -> UnifyT Type Check Type

431replaceVarWithUnknown ident ty = do

429replaceVarWithUnknown ident ty = do

432 tu <- fresh

430 tu <- fresh

433− return $ replaceTypeVars ident tu $ ty

431+ return $ replaceTypeVars ident tu ty

434

432

435-- |

433-- |

436-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

434-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

@@ -603,11 +601,11 @@ inferBinder val (ConstructorBinder ctor binders) = do

603 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

601 (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contains constraints") ty

604 go binders fn

602 go binders fn

605 where

603 where

606− go [] ty = do

604+ go [] ty' = do

607− subsumes Nothing val ty

605+ subsumes Nothing val ty'

608 return M.empty

606 return M.empty

609− go (binder : binders) (TypeApp (TypeApp t obj) ret) | t == tyFunction =

607+ go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =

610− M.union <$> inferBinder obj binder <*> go binders ret

608+ M.union <$> inferBinder obj binder <*> go binders' ret

611 go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor

609 go _ _ = throwError $ "Wrong number of arguments to constructor " ++ show ctor

612 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

610 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"

613inferBinder val (ObjectBinder props) = do

611inferBinder val (ObjectBinder props) = do

@@ -713,7 +711,7 @@ check val ty = rethrow errorMessage $ check' val ty

713-- Check the type of a value

711-- Check the type of a value

714--

712--

715check' :: Value -> Type -> UnifyT Type Check Value

713check' :: Value -> Type -> UnifyT Type Check Value

716−check' val t@(ForAll ident ty _) = do

714+check' val (ForAll ident ty _) = do

717 scope <- newSkolemScope

715 scope <- newSkolemScope

718 sko <- newSkolemConstant

716 sko <- newSkolemConstant

719 let sk = skolemize ident sko scope ty

717 let sk = skolemize ident sko scope ty

@@ -722,15 +720,15 @@ check' val t@(ForAll ident ty _) = do

722check' val t@(ConstrainedType constraints ty) = do

720check' val t@(ConstrainedType constraints ty) = do

723 env <- getEnv

721 env <- getEnv

724 Just moduleName <- checkCurrentModule <$> get

722 Just moduleName <- checkCurrentModule <$> get

725− dictNames <- flip mapM constraints $ \(Qualified _ (ProperName className), _) -> do

723+ dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do

726 n <- liftCheck freshDictionaryName

724 n <- liftCheck freshDictionaryName

727 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

725 return $ Ident $ "__dict_" ++ className ++ "_" ++ show n

728 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

726 val' <- withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->

729 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

727 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

730 (qualifyAllUnqualifiedNames moduleName env constraints)) $

728 (qualifyAllUnqualifiedNames moduleName env constraints)) $

731 check val ty

729 check val ty

732− return $ TypedValue True (foldr Abs val' (map Left dictNames)) t

730+ return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

733−check' val t@(SaturatedTypeSynonym name args) = do

731+check' val (SaturatedTypeSynonym name args) = do

734 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

732 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

735 val' <- check val ty

733 val' <- check val ty

736 return $ TypedValue True val' ty

734 return $ TypedValue True val' ty

@@ -747,8 +745,8 @@ check' v@(StringLiteral _) t | t == tyString =

747check' v@(BooleanLiteral _) t | t == tyBoolean =

745check' v@(BooleanLiteral _) t | t == tyBoolean =

748 return $ TypedValue True v t

746 return $ TypedValue True v t

749check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do

747check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do

750− arr <- ArrayLiteral <$> forM vals (\val -> check val ty)

748+ array <- ArrayLiteral <$> forM vals (`check` ty)

751− return $ TypedValue True arr t

749+ return $ TypedValue True array t

752check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

750check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

753 Just moduleName <- checkCurrentModule <$> get

751 Just moduleName <- checkCurrentModule <$> get

754 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

752 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

@@ -944,17 +942,17 @@ subsumes' val (Object r1) (Object r2) = do

944 go ts1' ts2' r1' r2'

942 go ts1' ts2' r1' r2'

945 return val

943 return val

946 where

944 where

947− go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2)

945+ go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')

948− go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1)

946+ go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')

949− go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2

947+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

950 | p1 == p2 = do subsumes Nothing ty1 ty2

948 | p1 == p2 = do subsumes Nothing ty1 ty2

951− go ts1 ts2 r1 r2

949+ go ts1 ts2 r1' r2'

952 | p1 < p2 = do rest <- fresh

950 | p1 < p2 = do rest <- fresh

953− r2 =?= RCons p1 ty1 rest

951+ r2' =?= RCons p1 ty1 rest

954− go ts1 ((p2, ty2) : ts2) r1 rest

952+ go ts1 ((p2, ty2) : ts2) r1' rest

955 | p1 > p2 = do rest <- fresh

953 | p1 > p2 = do rest <- fresh

956− r1 =?= RCons p2 ty2 rest

954+ r1' =?= RCons p2 ty2 rest

957− go ((p1, ty1) : ts1) ts2 rest r2

955+ go ((p1, ty1) : ts1) ts2 rest r2'

958subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

956subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

959subsumes' val ty1 ty2 = do

957subsumes' val ty1 ty2 = do

960 ty1 =?= ty2

958 ty1 =?= ty2

src/Language/PureScript/Types.hs+9−9

@@ -19,10 +19,10 @@ module Language.PureScript.Types where

19

20import Data.Data

21import Data.List (nub)

22−import Data.Generics (everything, mkT, mkQ, everywhereBut)

22+import Data.Generics (everything, mkQ)

23

24import Control.Monad.Unify

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

25+import Control.Arrow (second)

26

27import Language.PureScript.Names

28

@@ -122,7 +122,7 @@ tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"])

122-- Smart constructor for function types

123--

124function :: Type -> Type -> Type

125−function t1 t2 = TypeApp (TypeApp tyFunction t1) t2

125+function t1 = TypeApp (TypeApp tyFunction t1)

126

127-- |

128-- Convert a row to a list of pairs of labels and types

@@ -143,8 +143,8 @@ rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

143-- Check whether a type is a monotype

144--

145isMonoType :: Type -> Bool

146−isMonoType (ForAll _ _ _) = False

146+isMonoType ForAll{} = False

147−isMonoType ty = True

147+isMonoType _ = True

148

149-- |

150-- Universally quantify a type

@@ -168,17 +168,17 @@ replaceTypeVars = replaceTypeVars' []

168 where

169 go :: [String] -> Type -> Type

170 go bs (Object r) = Object $ go bs r

171− go bs (TypeVar v) | v == name = replacement

171+ go _ (TypeVar v) | v == name = replacement

172 go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)

173− go bs (SaturatedTypeSynonym name ts) = SaturatedTypeSynonym name $ map (go bs) ts

173+ go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts

174 go bs f@(ForAll v t sco) | v == name = f

175 | v `elem` usedTypeVariables replacement =

176 let v' = genName v (name : bs ++ usedTypeVariables replacement)

177 t' = replaceTypeVars' bs v (TypeVar v') t

178 in ForAll v' (go (v' : bs) t') sco

179 | otherwise = ForAll v (go (v : bs) t) sco

180− go bs (ConstrainedType cs t) = ConstrainedType (map (id *** map (go bs)) cs) (go bs t)

180+ go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)

181− go bs (RCons name t r) = RCons name (go bs t) (go bs r)

181+ go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)

182 go _ ty = ty

183 genName orig inUse = try 0

184 where

tests/Main.hs+5−7

@@ -20,7 +20,6 @@ import qualified Language.PureScript as P

20

21import Data.List (isSuffixOf)

22import Data.Traversable (traverse)

23−import Control.Applicative

24import Control.Monad

23import Control.Monad

25import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

26import System.Exit

25import System.Exit

@@ -31,7 +30,6 @@ import System.Environment (getArgs)

31import Text.Parsec (ParseError)

30import Text.Parsec (ParseError)

32import qualified Paths_purescript as Paths

31import qualified Paths_purescript as Paths

33import qualified System.IO.UTF8 as U

32import qualified System.IO.UTF8 as U

34−import qualified Data.Map as M

35

33

36preludeFilename :: IO FilePath

34preludeFilename :: IO FilePath

37preludeFilename = Paths.getDataFileName "prelude/prelude.purs"

35preludeFilename = Paths.getDataFileName "prelude/prelude.purs"

@@ -45,13 +43,13 @@ compile :: P.Options -> [FilePath] -> IO (Either String String)

45compile opts inputFiles = do

43compile opts inputFiles = do

46 modules <- readInput inputFiles

44 modules <- readInput inputFiles

47 case modules of

45 case modules of

48− Left parseError -> do

46+ Left parseError ->

49 return (Left $ show parseError)

47 return (Left $ show parseError)

50− Right ms -> do

48+ Right ms ->

51 case P.compile opts ms of

49 case P.compile opts ms of

52− Left typeError -> do

50+ Left typeError ->

53 return (Left typeError)

51 return (Left typeError)

54− Right (js, _, _) -> do

52+ Right (js, _, _) ->

55 return (Right js)

53 return (Right js)

56

54

57assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()

55assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()

@@ -93,7 +91,7 @@ assertDoesNotCompile inputFile = do

93main :: IO ()

91main :: IO ()

94main = do

92main = do

95 cd <- getCurrentDirectory

93 cd <- getCurrentDirectory

96− putStrLn $ cd

94+ putStrLn cd

97 let examples = cd ++ pathSeparator : "examples"

95 let examples = cd ++ pathSeparator : "examples"

98 let passing = examples ++ pathSeparator : "passing"

96 let passing = examples ++ pathSeparator : "passing"

99 passingTestCases <- getDirectoryContents passing

97 passingTestCases <- getDirectoryContents passing