79d6d63 · rowtype-yoga/purescript-native

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

Removed most lint.

commit79d6d639d1edbf089d0a813063be2c31af6901d6 authorjoneshf <jones3.hardy@gmail.com> dateSat 22 Feb 2014, 02:03 (13 years ago) parenteb2ce65

31 files changed+280−298

compare with golang

unifiedsplit

docgen/Main.hs+16−16

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

6060

6161renderModule :: P.Module -> Docs

6262renderModule (P.Module moduleName ds) = do

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

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

6464 spacer

6565 headerLevel 3 "Types"

6666 spacer

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

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

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

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

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

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

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

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

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

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

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

9797renderDeclaration n (P.ExternDataDeclaration name kind) =

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

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

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

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

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

102102renderDeclaration 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"

104104 mapM_ (renderDeclaration (n + 2)) ds

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

106106 let constraintsText = case constraints of

107107 [] -> ""

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

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

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

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

110110renderDeclaration _ _ = return ()

111111

112112getName :: P.Declaration -> String

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

120120getName _ = error "Invalid argument to getName"

121121

122122isValueDeclaration :: P.Declaration -> Bool

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

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

123+isValueDeclaration P.TypeDeclaration{} = True

124+isValueDeclaration P.ExternDeclaration{} = True

125125isValueDeclaration _ = False

126126

127127isTypeDeclaration :: P.Declaration -> Bool

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

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

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

128+isTypeDeclaration P.DataDeclaration{} = True

129+isTypeDeclaration P.ExternDataDeclaration{} = True

130+isTypeDeclaration P.TypeSynonymDeclaration{} = True

131131isTypeDeclaration _ = False

132132

133133isTypeClassDeclaration :: P.Declaration -> Bool

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

134+isTypeClassDeclaration P.TypeClassDeclaration{} = True

135135isTypeClassDeclaration _ = False

136136

137137isTypeInstanceDeclaration :: P.Declaration -> Bool

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

138+isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True

139139isTypeInstanceDeclaration _ = False

140140

141141inputFile :: Term FilePath

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

147147termInfo :: TermInfo

148148termInfo = defTI

149149 { termName = "docgen"

150− , version = showVersion $ Paths.version

150+ , version = showVersion Paths.version

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

152152 }

153153

psc/Main.hs+2−2

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

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

2929

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

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

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

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

3333 text <- U.readFile inputFile

3434 return $ P.runIndentParser inputFile P.parseModules text

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

118118termInfo :: TermInfo

119119termInfo = defTI

120120 { termName = "psc"

121− , version = showVersion $ Paths.version

121+ , version = showVersion Paths.version

122122 , termDoc = "Compiles PureScript to Javascript"

123123 }

124124

psci/Main.hs+1−1

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

312312termInfo :: Cmd.TermInfo

313313termInfo = Cmd.defTI

314314 { Cmd.termName = "psci"

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

315+ , Cmd.version = showVersion Paths.version

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

317317 }

318318

src/Language/PureScript.hs+10−11

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

3131import Language.PureScript.DeadCodeElimination as P

3232

3333import Data.List (intercalate)

34−import Data.Maybe (mapMaybe, fromMaybe)

35−import Control.Monad (when, forM)

34+import Data.Maybe (mapMaybe)

3635import Control.Monad.State.Lazy

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

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

3837import qualified Data.Map as M

3938

4039-- |

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

6059compile opts ms = do

6160 sorted <- sortModules ms

6261 desugared <- desugar sorted

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

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

65− Module moduleName <$> typeCheckAll mainModuleIdent moduleName decls

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

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

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

6665 regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

6766 let entryPoints = moduleNameFromString `map` optionsModules opts

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

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

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

71− js' <- case mainModuleIdent of

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

70+ js' <- case mainModuleIdent of

7271 Just mmi -> do

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

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

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

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

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

7675 _ -> return js

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

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

7877 where

7978 mainModuleIdent = moduleNameFromString <$> optionsMain opts

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

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

6969--

7070nameIsJsReserved :: String -> Bool

7171nameIsJsReserved name =

72− elem name [ "abstract"

73− , "arguments"

74− , "boolean"

75− , "break"

76− , "byte"

77− , "case"

78− , "catch"

79− , "char"

80− , "class"

81− , "const"

82− , "continue"

83− , "debugger"

84− , "default"

85− , "delete"

86− , "do"

87− , "double"

88− , "else"

89− , "enum"

90− , "eval"

91− , "export"

92− , "extends"

93− , "final"

94− , "finally"

95− , "float"

96− , "for"

97− , "function"

98− , "goto"

99− , "if"

100− , "implements"

101− , "import"

102− , "in"

103− , "instanceof"

104− , "int"

105− , "interface"

106− , "let"

107− , "long"

108− , "native"

109− , "new"

110− , "package"

111− , "private"

112− , "protected"

113− , "public"

114− , "return"

115− , "short"

116− , "static"

117− , "super"

118− , "switch"

119− , "synchronized"

120− , "this"

121− , "throw"

122− , "throws"

123− , "transient"

124− , "try"

125− , "typeof"

126− , "var"

127− , "void"

128− , "volatile"

129− , "while"

130− , "with"

131− , "yield" ]

72+ name `elem` [ "abstract"

73+ , "arguments"

74+ , "boolean"

75+ , "break"

76+ , "byte"

77+ , "case"

78+ , "catch"

79+ , "char"

80+ , "class"

81+ , "const"

82+ , "continue"

83+ , "debugger"

84+ , "default"

85+ , "delete"

86+ , "do"

87+ , "double"

88+ , "else"

89+ , "enum"

90+ , "eval"

91+ , "export"

92+ , "extends"

93+ , "final"

94+ , "finally"

95+ , "float"

96+ , "for"

97+ , "function"

98+ , "goto"

99+ , "if"

100+ , "implements"

101+ , "import"

102+ , "in"

103+ , "instanceof"

104+ , "int"

105+ , "interface"

106+ , "let"

107+ , "long"

108+ , "native"

109+ , "new"

110+ , "package"

111+ , "private"

112+ , "protected"

113+ , "public"

114+ , "return"

115+ , "short"

116+ , "static"

117+ , "super"

118+ , "switch"

119+ , "synchronized"

120+ , "this"

121+ , "throw"

122+ , "throws"

123+ , "transient"

124+ , "try"

125+ , "typeof"

126+ , "var"

127+ , "void"

128+ , "volatile"

129+ , "while"

130+ , "with"

131+ , "yield" ]

132132

133133moduleNameToJs :: ModuleName -> String

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

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

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

3030--

3131moduleToPs :: Module -> Environment -> String

3232moduleToPs (Module mn decls) env =

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

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

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

3535

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

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

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

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

40−declToPs path env (BindingGroupDeclaration vals) = do

40+declToPs path env (BindingGroupDeclaration vals) =

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

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

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

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

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

2323) where

2424

2525import Data.Maybe (fromMaybe, mapMaybe)

26−import Data.List (sortBy)

2726import Data.Function (on)

2827import Data.Data (Data)

2928import Data.Generics (mkQ, everything)

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

3837import Language.PureScript.Names

3938import Language.PureScript.Scope

4039import Language.PureScript.Declarations

41−import Language.PureScript.Pretty.Common

4240import Language.PureScript.CodeGen.Monad

4341import Language.PureScript.Options

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

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

5755 [] -> Nothing

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

5957 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 [])]

6159 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

6361

6462-- |

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

6664--

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

6866declToJs 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))

7068 , setExportProperty ident (var ident) ]

7169declToJs opts mp (BindingGroupDeclaration vals) e =

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

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

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

8684declToJs opts mp (DataBindingGroupDeclaration ds) e =

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

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

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

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

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

9088declToJs _ _ _ _ = Nothing

9189

9290-- |

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

9492-- declaration from a module.

9593--

9694setExportProperty :: Ident -> JS -> JS

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

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

9896

9997-- |

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

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

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

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

196194 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

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

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

200− _ -> case qual of

198+ _ -> case qual' of

201199 Qualified Nothing _ -> var ident

202− _ -> qualifiedToJS m id qual

200+ _ -> qualifiedToJS m id qual'

203201 isExtern (Extern ForeignImport) = True

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

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

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

212210--

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

214212qualifiedToJS 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)

216214

217215-- |

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

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

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

257255binderToJs _ _ varName done (BooleanBinder False) =

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

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

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

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

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

262260 js <- go 0 done bs

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

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

327325

328326wrapExportsContainer :: 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]

330328 where

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

332330 (JSAccessor "exports" (JSVar "module"))

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

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

2121

2222import Control.Monad.State

2323import Control.Applicative

24−import Language.PureScript.Names

2524

2625-- |

2726-- Code generation monad data type

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

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

7373applyAll = foldl1 (.)

7474

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

76−untilFixedPoint f a = go a

76+untilFixedPoint f = go

7777 where

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

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

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

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

8080

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

8282replaceIdent var1 js = everywhere (mkT replace)

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

100100 check _ = False

101101

102102isRebound :: (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)

104104 where

105105 variablesOf (JSVar var) = [var]

106106 variablesOf _ = []

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

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

136136shouldInline _ = False

137137

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

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

140+removeFromBlock _ js = js

141+

138142inlineVariables :: JS -> JS

139−inlineVariables = everywhere (mkT removeFromBlock)

143+inlineVariables = everywhere (mkT $ removeFromBlock go)

140144 where

141− removeFromBlock :: JS -> JS

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

143− removeFromBlock js = js

144145 go :: [JS] -> [JS]

145146 go [] = []

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

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

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

148149 go (replaceIdent var js sts)

149150 go (s:sts) = s : go sts

150151

151152removeUnusedVariables :: JS -> JS

152−removeUnusedVariables = everywhere (mkT removeFromBlock)

153+removeUnusedVariables = everywhere (mkT $ removeFromBlock go)

153154 where

154− removeFromBlock :: JS -> JS

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

156− removeFromBlock js = js

157155 go :: [JS] -> [JS]

158156 go [] = []

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

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

165163 convert :: JS -> JS

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

167165 | all shouldInline args &&

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

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

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

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

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

171169 convert js = js

172170

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

191189 copyVar :: String -> String

192190 copyVar arg = "__copy_" ++ arg

193191 convert :: JS -> JS

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

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

195193 let

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

197195 in case () of

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

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

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

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

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

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

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

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

215213 isTailCall :: String -> JS -> Bool

216214 isTailCall ident js =

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

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

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

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

362− (JSIndexer i arr)

360+ JSIndexer i arr

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

364362 JSAssignment (JSIndexer i arr) val

365363 convert _ other = other

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

369367 -- Find all ST Refs initialized in this block

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

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

373371 isSTRef _ = []

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

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

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

400398inlineOperator op f = everywhere (mkT convert)

401399 where

402400 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

404402 convert other = other

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

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

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

446444 convert :: JS -> JS

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

448446 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

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

451449 isOp _ = False

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

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

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

3535 let declarations = concatMap (declarationsByModule env) ms

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

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

3939

4040type Key = (ModuleName, Either Ident ProperName)

4141

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

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

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

4444 where

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

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

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

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

50− go (DataBindingGroupDeclaration ds) = concatMap go ds

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

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

5151 go _ = []

5252

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

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

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

123123-- Test if a declaration is a value declaration

124124--

125125isValueDecl :: Declaration -> Bool

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

126+isValueDecl ValueDeclaration{} = True

127127isValueDecl _ = False

128128

129129-- |

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

131131--

132132isDataDecl :: Declaration -> Bool

133−isDataDecl (DataDeclaration _ _ _) = True

134−isDataDecl (TypeSynonymDeclaration _ _ _) = True

133+isDataDecl DataDeclaration{} = True

134+isDataDecl TypeSynonymDeclaration{} = True

135135isDataDecl _ = False

136136

137137-- |

138138-- Test if a declaration is a module import

139139--

140140isImportDecl :: Declaration -> Bool

141−isImportDecl (ImportDeclaration _ _) = True

141+isImportDecl ImportDeclaration{} = True

142142isImportDecl _ = False

143143

144144-- |

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

146146--

147147isExternDataDecl :: Declaration -> Bool

148−isExternDataDecl (ExternDataDeclaration _ _) = True

148+isExternDataDecl ExternDataDeclaration{} = True

149149isExternDataDecl _ = False

150150

151151-- |

152152-- Test if a declaration is a fixity declaration

153153--

154154isFixityDecl :: Declaration -> Bool

155−isFixityDecl (FixityDeclaration _ _) = True

155+isFixityDecl FixityDeclaration{} = True

156156isFixityDecl _ = False

157157

158158-- |

159159-- Test if a declaration is a foreign import

160160--

161161isExternDecl :: Declaration -> Bool

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

162+isExternDecl ExternDeclaration{} = True

163163isExternDecl _ = False

164164

165165-- |

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

167167--

168168isTypeClassDeclaration :: Declaration -> Bool

169−isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True

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

169+isTypeClassDeclaration TypeClassDeclaration{} = True

170+isTypeClassDeclaration TypeInstanceDeclaration{} = True

171171isTypeClassDeclaration _ = False

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

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

1919import Data.Data

2020import Data.Graph

2121import Data.Generics

22−import Data.List (nub, intersect)

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

22+import Data.List (nub)

2423

2524import Language.PureScript.Declarations

2625import Language.PureScript.Names

27−import Language.PureScript.Values

28−import Language.PureScript.Types

2926

3027-- |

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

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

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

3333 , optionsMagicDo :: Bool

3434 -- |

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

3737 --

3838 , optionsMain :: Maybe String

3939 -- |

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

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

328328-- Parse an identifier in backticks or an operator

329329--

330330parseIdentInfix :: 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)

332332

333333-- |

334334-- Mark the current indentation level

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

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

2020) where

2121

2222import Data.Maybe (isJust, fromMaybe)

23−import Control.Monad (when)

2423import Control.Applicative

2524import qualified Text.Parsec as P

2625

27−import Language.PureScript.Names

2826import Language.PureScript.Parser.State

2927import Language.PureScript.Parser.Common

3028import Language.PureScript.Declarations

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

3230import Language.PureScript.Parser.Types

3331import Language.PureScript.Parser.Kinds

3432import Language.PureScript.CodeGen.JS.AST

35−import Language.PureScript.Values

3633

3734parseDataDeclaration :: P.Parsec String ParseState Declaration

3835parseDataDeclaration = do

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

5956 ValueDeclaration <$> parseIdent

6057 <*> P.many parseBinderNoParens

6158 <*> P.optionMaybe parseGuard

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

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

6360

6461parseExternDeclaration :: 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 *>

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

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

6865 <|> do ident <- parseIdent

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

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

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

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

7269

7370parseAssociativity :: P.Parsec String ParseState Associativity

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

8986parseImportDeclaration = do

9087 reserved "import"

9188 indented

92− moduleName <- moduleName

89+ moduleName' <- moduleName

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

94− return $ ImportDeclaration moduleName idents

91+ return $ ImportDeclaration moduleName' idents

9592

9693parseTypeClassDeclaration :: P.Parsec String ParseState Declaration

9794parseTypeClassDeclaration = do

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

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

5151parseTypeVariable :: P.Parsec String ParseState Type

5252parseTypeVariable = do

5353 ident <- identifier

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

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

5555 return $ TypeVar ident

5656

5757parseTypeConstructor :: P.Parsec String ParseState Type

5858parseTypeConstructor = TypeConstructor <$> parseQualified properName

5959

6060parseForAll :: P.Parsec String ParseState Type

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

62− <*> parseConstrainedType)

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

62+ <*> parseConstrainedType

6363

6464-- |

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

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

9494 return $ maybe ty (flip ConstrainedType ty) constraints

9595

9696parseAnyType :: P.Parsec String ParseState Type

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

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

9898 where

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

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

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

112112-- Parse a polytype

113113--

114114parsePolyType :: P.Parsec String ParseState Type

115−parsePolyType = do

116− ty <- parseAnyType

117− return ty

115+parsePolyType = parseAnyType

118116

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

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

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

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

124122

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

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

127− where many = if nonEmpty then commaSep1 else commaSep

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

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 (

2020 parseBinderNoParens,

2121) where

2222

23+import Control.Applicative

24+

2325import Language.PureScript.Values

2426import Language.PureScript.Parser.State

27+import Language.PureScript.Parser.Types

28+

29+import Text.Parsec.Expr

30+

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

26−import Control.Applicative

2732import qualified Text.Parsec as P

28−import Text.Parsec.Expr

29−import Language.PureScript.Parser.Types

3033

3134booleanLiteral :: P.Parsec String ParseState Bool

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

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

5962 return $ toFunction args value

6063 where

6164 toFunction :: [Value -> Value] -> Value -> Value

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

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

6366

6467parseVar :: P.Parsec String ParseState Value

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

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

154157 indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

155158 postfixTable1 = [ parseAccessor

156159 , \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

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

159162 ]

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

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

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

178181

179182parseConstructorBinder :: 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)

181184

182185parseObjectBinder :: P.Parsec String ParseState Binder

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

184187

185188parseArrayBinder :: 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)

187190

188191parseNamedBinder :: P.Parsec String ParseState Binder

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

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

203206-- Parse a binder

204207--

205208parseBinder :: P.Parsec String ParseState Binder

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

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

207210 where

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

209212 parseBinderAtom :: P.Parsec String ParseState Binder

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

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

1717 prettyPrintJS

1818) where

1919

20−import Language.PureScript.Names

21−import Language.PureScript.Values

2220import Language.PureScript.Pretty.Common

2321import Language.PureScript.CodeGen.JS.AST

2422

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

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

7068 , return " ]"

7169 ]

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

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

7371 match (JSObjectLiteral ps) = fmap concat $ sequence

7472 [ return "{\n"

7573 , withIndent $ do

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

8280 ]

8381 match (JSBlock sts) = fmap concat $ sequence

8482 [ return "{\n"

85− , withIndent $ do

86− jss <- forM sts prettyPrintJS'

87− indentString <- currentIndent

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

83+ , withIndent $ prettyStatements sts

8984 , return "\n"

9085 , currentIndent

9186 , return "}"

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

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

196191 match' _ = Nothing

197192

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+

198199-- |

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

200201--

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

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

206207--

207208prettyPrintJS :: [JS] -> String

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

209− jss <- forM sts prettyPrintJS'

210− indentString <- currentIndent

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

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

212210

213211-- |

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

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

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

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

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

227− ++ maybe "" id name

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

225+ ++ fromMaybe "" name

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

229227 ++ ret ]

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

231229 , [ binary LessThan "<" ]

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

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

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

3636 match (TypeVar var) = Just var

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

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

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

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

4040 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

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

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

4444 match REmpty = Just "()"

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

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

4646 match _ = Nothing

4747

4848-- |

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

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

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

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

4040 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) ++

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

4343 match (Var ident) = Just $ show ident

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

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

4747

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

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

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

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

5151

5252ifThenElse :: Pattern () Value ((Value, Value), Value)

5353ifThenElse = mkPattern match

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

118118 match (BooleanBinder True) = Just "true"

119119 match (BooleanBinder False) = Just "false"

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

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

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

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

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

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

1818 unusedNames

1919) where

2020

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

22+

2123import Data.Data

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

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

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

4143 namesB _ = []

4244 namesJS :: JS -> [Ident]

4345 namesJS (JSVar name) = [Ident name]

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

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

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

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

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

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

4850 namesJS _ = []

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

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

6969-- Collapse all binding groups to individual declarations

7070--

7171collapseBindingGroups :: [Declaration] -> [Declaration]

72−collapseBindingGroups ds = concatMap go ds

72+collapseBindingGroups = concatMap go

7373 where

7474 go (DataBindingGroupDeclaration ds) = ds

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

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

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

113113 | otherwise = return $ DataBindingGroupDeclaration ds'

114114 where

115− isTypeSynonym (TypeSynonymDeclaration _ _ _) = True

115+ isTypeSynonym TypeSynonymDeclaration{} = True

116116 isTypeSynonym _ = False

117117

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

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

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

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

121121fromValueDecl _ = error "Expected ValueDeclaration"

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

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

7575 let

7676 argPattern = length . fst . head $ alternatives

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

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

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

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

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

8181 in

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

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

2727import Language.PureScript.Declarations

2828import Language.PureScript.Values

2929

30+import Control.Applicative

31+import Control.Arrow (first)

32+import Control.Monad.State

33+

3034import Data.Function (on)

3135import Data.List (groupBy, sortBy)

36+

3237import qualified Data.Map as M

3338import qualified Data.Generics as G

3439import qualified Data.Generics.Extras as G

35−import Control.Monad.State

36−import Control.Applicative

40+

3741import qualified Text.Parsec as P

3842import qualified Text.Parsec.Pos as P

3943import qualified Text.Parsec.Expr as P

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

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

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

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

6670 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

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

6973 in

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

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

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

7377

7478matchOperators :: 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)

7680 where

7781 parseChains :: Value -> Either String Value

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

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

7983 parseChains other = return other

8084 extendChain :: Value -> Chain

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

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

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

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

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

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

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

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

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

114118

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

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

3131

3232import Control.Applicative

3333import Control.Monad.State

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

34+import Control.Arrow (second)

3535

36−import Data.Maybe (fromMaybe)

37−import Data.List (intercalate, nub)

38−import Data.Generics (mkQ, everything)

36+import Data.List (intercalate)

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

4038

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

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

122120 m <- get

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

124122 $ 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

126124 entryName <- lift $ mkDictionaryValueName mn name tys

127125 memberNames <- mapM (memberToNameAndValue memberTypes) decls

128126 return $ ValueDeclaration entryName [] Nothing

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

131129 (quantify (if null deps then

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

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

135133 )

136134 where

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

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

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

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

8787

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

89−addTypeClassDictionaries entries = do

89+addTypeClassDictionaries entries =

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

9191

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

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

154154 return $ ValueDeclaration name [] Nothing val'

155155 ds <- typeCheckAll mainModuleName moduleName rest

156156 return $ d : ds

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

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

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

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

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

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

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

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

208208 shadowIdents idents' env =

209− forM_ idents' $ \ident -> do

209+ forM_ idents' $ \ident ->

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

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

212212 Just (pt, _) -> do

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

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

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

216216 shadowTypes pns env =

217− forM_ pns $ \pn -> do

217+ forM_ pns $ \pn ->

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

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

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

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

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

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

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

225− forM_ keys $ \dctor -> do

225+ forM_ keys $ \dctor ->

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

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

228228 Just (ctorTy, _) -> do

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

236236 ) (typeClassDictionaries env)

237237 forM_ instances $ \tcd -> do

238238 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) }]

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

241241 = mn == moduleName && pn' == pn

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

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

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

245245 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

247247 env <- getEnv

248248 ds <- typeCheckAll mainModuleName moduleName rest

249249 return $ qualifyAllUnqualifiedNames moduleName env d : ds

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

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

1414-----------------------------------------------------------------------------

1515

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

17−{-# LANGUAGE DeriveDataTypeable #-}

1817{-# LANGUAGE MultiParamTypeClasses #-}

1918

2019module Language.PureScript.TypeChecker.Kinds (

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

2928import Language.PureScript.TypeChecker.Monad

3029import Language.PureScript.Pretty

3130

32−import Control.Monad (forM_)

3331import Control.Monad.State

3432import Control.Monad.Error

35−import Control.Monad.Reader

3633import Control.Monad.Unify

3734

3835import Control.Applicative

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

6057-- Infer the kind of a single type

6158--

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

63−kindOf moduleName ty =

60+kindOf _ ty =

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

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

6663 where

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

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

8986 bindLocalTypeVariables moduleName dict $ do

9087 tyCons <- replicateM (length tys) fresh

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

92− bindLocalTypeVariables moduleName dict $ do

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

89+ bindLocalTypeVariables moduleName dict' $ do

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

9491 kargs <- replicateM (length args) fresh

9592 let argDict = zip (map ProperName args) kargs

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

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

1313--

1414-----------------------------------------------------------------------------

1515

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

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

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

17+ MultiParamTypeClasses, FlexibleContexts #-}

1818

1919module Language.PureScript.TypeChecker.Monad where

2020

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

2626

2727import Data.Data

2828import Data.Maybe

29−import Data.Monoid

3029import Data.Generics (mkT, everywhere)

3130

3231import Control.Applicative

3332import Control.Monad.State

3433import Control.Monad.Error

35−import Control.Monad.Reader

3634import Control.Monad.Unify

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

35+import Control.Arrow (first)

3836

3937import qualified Data.Map as M

4038

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

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

174172--

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

176−bindLocalVariables moduleName bindings action =

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

174+bindLocalVariables moduleName bindings =

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

178176

179177-- |

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

181179--

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

183−bindLocalTypeVariables moduleName bindings action =

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

181+bindLocalTypeVariables moduleName bindings =

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

185183

186184-- |

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

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

322320 case e of

323321 Left err -> throwError err

324322 Right (a, ust) -> do

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

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

326324 return (a, unifyCurrentSubstitution ust)

327325

328326-- |

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

334332 go :: Type -> Type

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

336334 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

338336 go other = other

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

340338 in Qualified (Just mn') pn'

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

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

1414-----------------------------------------------------------------------------

1515

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

17−{-# LANGUAGE DeriveDataTypeable #-}

1817{-# LANGUAGE FlexibleContexts #-}

1918{-# LANGUAGE MultiParamTypeClasses #-}

2019

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

6059

6160import Control.Monad.State

6261import Control.Monad.Error

63−import Control.Monad.Reader

6462import Control.Monad.Unify

6563

6664import Control.Applicative

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

8280-- Unify two types, updating the current substitution

8381--

8482unifyTypes :: 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) $

8684 unifyTypes' t1 t2

8785 where

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

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

104102 sko <- newSkolemConstant

105103 let sk = skolemize ident sko sc ty1

106104 sk `unifyTypes` ty2

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

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

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

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

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

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

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

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

116114 t3 `unifyTypes` t5

117115 t4 `unifyTypes` t6

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

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

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

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

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

121119 unifyTypes' r1@REmpty r2 = unifyRows r1 r2

122120 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

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

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

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

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

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

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

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

191189 -- Typed declarations

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

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

193191 -- Kind check

194192 kind <- liftCheck $ kindOf moduleName ty

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

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

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

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

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

200− else return (TypedValue False val ty')

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

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

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

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

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

202200 -- Untyped declarations

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

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

204202 -- 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'

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

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

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

210208 [eff, a] <- replicateM 2 fresh

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

212210 -- Make sure unification variables do not escape

213− escapeCheck val ty

211+ escapeCheck val' ty

214212 return triple

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

216214 -- Replace type class dictionary placeholders with actual dictionaries

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

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

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

223221 ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty

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

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

225223 where

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

227225 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

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

285283 solveSubgoals _ _ Nothing = return Nothing

286284 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

288286 return $ Just dict

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

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

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

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

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

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

323− Left err -> Nothing

321+ Left _ -> Nothing

324322 Right t1 -> typeHeadsAreEqual m e t1 t2

325323typeHeadsAreEqual _ _ _ _ = Nothing

326324

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

350348--

351349skolemEscapeCheck :: Value -> Check ()

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

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

351+skolemEscapeCheck root@TypedValue{} =

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

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

356354 -- field of the ForAll constructor.

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

374372 collect _ = []

375373 go _ scos = ([], scos)

376374 findBindingScope :: SkolemScope -> Maybe Value

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

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

378376 where

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

380− go _ = Nothing

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

378+ go' _ = Nothing

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

382380

383381-- |

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

399397varIfUnknown ty =

400398 let unks = nub $ unknowns ty

401399 toName = (:) 't' . show

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

400+ ty' = everywhere (mkT typeToVar) ty

403401 typeToVar :: Type -> Type

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

405403 typeToVar t = t

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

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

431429replaceVarWithUnknown ident ty = do

432430 tu <- fresh

433− return $ replaceTypeVars ident tu $ ty

431+ return $ replaceTypeVars ident tu ty

434432

435433-- |

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

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

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

604602 go binders fn

605603 where

606− go [] ty = do

607− subsumes Nothing val ty

604+ go [] ty' = do

605+ subsumes Nothing val ty'

608606 return M.empty

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

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

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

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

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

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

613611inferBinder val (ObjectBinder props) = do

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

713711-- Check the type of a value

714712--

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

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

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

717715 scope <- newSkolemScope

718716 sko <- newSkolemConstant

719717 let sk = skolemize ident sko scope ty

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

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

723721 env <- getEnv

724722 Just moduleName <- checkCurrentModule <$> get

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

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

726724 n <- liftCheck freshDictionaryName

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

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

729727 TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular) (map (Qualified Nothing) dictNames)

730728 (qualifyAllUnqualifiedNames moduleName env constraints)) $

731729 check val ty

732− return $ TypedValue True (foldr Abs val' (map Left dictNames)) t

733−check' val t@(SaturatedTypeSynonym name args) = do

730+ return $ TypedValue True (foldr (Abs . Left) val' dictNames) t

731+check' val (SaturatedTypeSynonym name args) = do

734732 ty <- introduceSkolemScope <=< expandTypeSynonym name $ args

735733 val' <- check val ty

736734 return $ TypedValue True val' ty

@@ -747,8 +745,8 @@ check' v@(StringLiteral _) t | t == tyString =

747745check' v@(BooleanLiteral _) t | t == tyBoolean =

748746 return $ TypedValue True v t

749747check' (ArrayLiteral vals) t@(TypeApp a ty) | a == tyArray = do

750− arr <- ArrayLiteral <$> forM vals (\val -> check val ty)

751− return $ TypedValue True arr t

748+ array <- ArrayLiteral <$> forM vals (`check` ty)

749+ return $ TypedValue True array t

752750check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do

753751 Just moduleName <- checkCurrentModule <$> get

754752 ret' <- bindLocalVariables moduleName [(arg, argTy)] $ check ret retTy

@@ -944,17 +942,17 @@ subsumes' val (Object r1) (Object r2) = do

944942 go ts1' ts2' r1' r2'

945943 return val

946944 where

947− go [] ts2 r1 r2 = r1 =?= rowFromList (ts2, r2)

948− go ts1 [] r1 r2 = r2 =?= rowFromList (ts1, r1)

949− go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1 r2

945+ go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')

946+ go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')

947+ go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'

950948 | p1 == p2 = do subsumes Nothing ty1 ty2

951− go ts1 ts2 r1 r2

949+ go ts1 ts2 r1' r2'

952950 | p1 < p2 = do rest <- fresh

953− r2 =?= RCons p1 ty1 rest

954− go ts1 ((p2, ty2) : ts2) r1 rest

951+ r2' =?= RCons p1 ty1 rest

952+ go ts1 ((p2, ty2) : ts2) r1' rest

955953 | p1 > p2 = do rest <- fresh

956− r1 =?= RCons p2 ty2 rest

957− go ((p1, ty1) : ts1) ts2 rest r2

954+ r1' =?= RCons p2 ty2 rest

955+ go ((p1, ty1) : ts1) ts2 rest r2'

958956subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1

959957subsumes' val ty1 ty2 = do

960958 ty1 =?= ty2

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

@@ -19,10 +19,10 @@ module Language.PureScript.Types where

1919

2020import Data.Data

2121import Data.List (nub)

22−import Data.Generics (everything, mkT, mkQ, everywhereBut)

22+import Data.Generics (everything, mkQ)

2323

2424import Control.Monad.Unify

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

25+import Control.Arrow (second)

2626

2727import Language.PureScript.Names

2828

@@ -122,7 +122,7 @@ tyArray = TypeConstructor $ (Qualified $ Just $ ModuleName [ProperName "Prim"])

122122-- Smart constructor for function types

123123--

124124function :: Type -> Type -> Type

125−function t1 t2 = TypeApp (TypeApp tyFunction t1) t2

125+function t1 = TypeApp (TypeApp tyFunction t1)

126126

127127-- |

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

143143-- Check whether a type is a monotype

144144--

145145isMonoType :: Type -> Bool

146−isMonoType (ForAll _ _ _) = False

147−isMonoType ty = True

146+isMonoType ForAll{} = False

147+isMonoType _ = True

148148

149149-- |

150150-- Universally quantify a type

@@ -168,17 +168,17 @@ replaceTypeVars = replaceTypeVars' []

168168 where

169169 go :: [String] -> Type -> Type

170170 go bs (Object r) = Object $ go bs r

171− go bs (TypeVar v) | v == name = replacement

171+ go _ (TypeVar v) | v == name = replacement

172172 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

174174 go bs f@(ForAll v t sco) | v == name = f

175175 | v `elem` usedTypeVariables replacement =

176176 let v' = genName v (name : bs ++ usedTypeVariables replacement)

177177 t' = replaceTypeVars' bs v (TypeVar v') t

178178 in ForAll v' (go (v' : bs) t') sco

179179 | otherwise = ForAll v (go (v : bs) t) sco

180− go bs (ConstrainedType cs t) = ConstrainedType (map (id *** map (go bs)) cs) (go bs t)

181− go bs (RCons name t r) = RCons name (go bs t) (go bs r)

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)

182182 go _ ty = ty

183183 genName orig inUse = try 0

184184 where

tests/Main.hs+5−7

@@ -20,7 +20,6 @@ import qualified Language.PureScript as P

2020

2121import Data.List (isSuffixOf)

2222import Data.Traversable (traverse)

23−import Control.Applicative

2423import Control.Monad

2524import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

2625import System.Exit

@@ -31,7 +30,6 @@ import System.Environment (getArgs)

3130import Text.Parsec (ParseError)

3231import qualified Paths_purescript as Paths

3332import qualified System.IO.UTF8 as U

34−import qualified Data.Map as M

3533

3634preludeFilename :: IO FilePath

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

@@ -45,13 +43,13 @@ compile :: P.Options -> [FilePath] -> IO (Either String String)

4543compile opts inputFiles = do

4644 modules <- readInput inputFiles

4745 case modules of

48− Left parseError -> do

46+ Left parseError ->

4947 return (Left $ show parseError)

50− Right ms -> do

48+ Right ms ->

5149 case P.compile opts ms of

52− Left typeError -> do

50+ Left typeError ->

5351 return (Left typeError)

54− Right (js, _, _) -> do

52+ Right (js, _, _) ->

5553 return (Right js)

5654

5755assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()

@@ -93,7 +91,7 @@ assertDoesNotCompile inputFile = do

9391main :: IO ()

9492main = do

9593 cd <- getCurrentDirectory

96− putStrLn $ cd

94+ putStrLn cd

9795 let examples = cd ++ pathSeparator : "examples"

9896 let passing = examples ++ pathSeparator : "passing"

9997 passingTestCases <- getDirectoryContents passing