c70560a · rowtype-yoga/purescript-native

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

Merge pull request #1503 from kRITZCREEK/cleanup-refactor

removes duplication and cleans up

commitc70560ae0ac337b1df3f4c1bafd52917d1004284 authorPhil Freeman <paf31@cantab.net> dateSat 10 Oct 2015, 16:06 (11 years ago) parentf7ff352 132a430

26 files changed+107−114

compare with golang

unifiedsplit

src/Language/PureScript/AST/Exported.hs+1−1

@@ -66,7 +66,7 @@ filterInstances (Just exps) =

6666 -- * the name is defined in a different module (and must be exported from

6767 -- that module; the code would fail to compile otherwise).

6868 visibleOutside _ (Qualified (Just _) _) = True

69− visibleOutside refs (Qualified Nothing n) = any (== n) refs

69+ visibleOutside refs (Qualified Nothing n) = n `elem` refs

7070

7171 typeName (TypeRef n _) = Just n

7272 typeName (PositionedDeclarationRef _ _ r) = typeName r

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

@@ -385,7 +385,7 @@ isModuleEmpty (Module _ els) = all isElementEmpty els

385385 where

386386 isElementEmpty :: ModuleElement -> Bool

387387 isElementEmpty (ExportsList exps) = null exps

388− isElementEmpty (Require _ _ _) = True

388+ isElementEmpty Require{} = True

389389 isElementEmpty (Other _) = True

390390 isElementEmpty _ = False

391391

src/Language/PureScript/CodeGen/JS.hs+2−1

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

2727 ) where

2828

2929import Data.List ((\\), delete, intersect)

30+import Data.Maybe (isNothing)

3031import qualified Data.Traversable as T (traverse)

3132

3233#if __GLASGOW_HASKELL__ < 710

@@ -62,7 +63,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = do

6263 comments <- not <$> asks optionsNoComments

6364 let strict = JSStringLiteral "use strict"

6465 let header = if comments && not (null coms) then JSComment coms strict else strict

65− let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || foreign_ == Nothing]

66+ let foreign' = [JSVariableIntroduction "$foreign" foreign_ | not $ null foreigns || isNothing foreign_]

6667 let moduleBody = header : foreign' ++ jsImports ++ concat optimized

6768 let foreignExps = exps `intersect` (fst `map` foreigns)

6869 let standardExps = exps \\ foreignExps

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+1−1

@@ -255,7 +255,7 @@ inlineFnComposition = everywhereOnJSTopDownM convert

255255 return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])

256256 convert other = return other

257257 isFnCompose :: JS -> JS -> Bool

258− isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn (C.compose) fn)

258+ isFnCompose dict' fn = isDict semigroupoidFn dict' && (isPreludeFn (C.<<<) fn || isPreludeFn C.compose fn)

259259

260260isDict :: (String, String) -> JS -> Bool

261261isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName

src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+1−1

@@ -124,5 +124,5 @@ tco' = everywhereOnJS convert

124124 hasFunction :: JS -> Bool

125125 hasFunction = getAny . everythingOnJS mappend (Any . isFunction)

126126 where

127− isFunction (JSFunction _ _ _) = True

127+ isFunction JSFunction{} = True

128128 isFunction _ = False

src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+1−1

@@ -29,7 +29,7 @@ removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)

2929 where

3030 go :: [JS] -> [JS]

3131 go jss | not (any isJSReturn jss) = jss

32− | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]

32+ | otherwise = let (body, ret : _) = break isJSReturn jss in body ++ [ret]

3333 isJSReturn (JSReturn _) = True

3434 isJSReturn _ = False

3535

src/Language/PureScript/CoreFn/Expr.hs+1−1

@@ -101,7 +101,7 @@ data CaseAlternative a = CaseAlternative

101101instance Functor CaseAlternative where

102102

103103 fmap f (CaseAlternative cabs car) = CaseAlternative

104− (fmap (fmap f) $ cabs)

104+ (fmap (fmap f) cabs)

105105 (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)

106106

107107-- |

src/Language/PureScript/Docs/Convert.hs+2−2

@@ -147,7 +147,7 @@ convertDeclaration (P.ExternDataDeclaration _ kind') title =

147147 basicDeclaration title (ExternDataDeclaration kind')

148148convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =

149149 basicDeclaration title (TypeSynonymDeclaration args ty)

150−convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do

150+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title =

151151 Just (Right (mkDeclaration title info) { declChildren = children })

152152 where

153153 info = TypeClassDeclaration args implies

@@ -158,7 +158,7 @@ convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do

158158 ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty)

159159 convertClassMember _ =

160160 error "Invalid argument to convertClassMember."

161−convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do

161+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title =

162162 Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))

163163 where

164164 classNameString = unQual className

src/Language/PureScript/Docs/Render.hs+3−2

@@ -10,6 +10,7 @@

1010

1111module Language.PureScript.Docs.Render where

1212

13+import Data.Maybe (maybeToList)

1314import Data.Monoid ((<>))

1415import qualified Language.PureScript as P

1516

@@ -46,7 +47,7 @@ renderDeclarationWithOptions opts Declaration{..} =

4647 ]

4748 TypeClassDeclaration args implies ->

4849 [ keywordClass ]

49− ++ maybe [] (:[]) superclasses

50+ ++ maybeToList superclasses

5051 ++ [renderType' (typeApp declTitle args)]

5152 ++ if any (isTypeClassMember . cdeclInfo) declChildren

5253 then [keywordWhere]

@@ -75,7 +76,7 @@ renderChildDeclarationWithOptions opts ChildDeclaration{..} =

7576 [ keywordInstance

7677 , ident cdeclTitle

7778 , syntax "::"

78− ] ++ maybe [] (:[]) (renderConstraints constraints)

79+ ] ++ maybeToList (renderConstraints constraints)

7980 ++ [ renderType' ty ]

8081 ChildDataConstructor args ->

8182 [ renderType' typeApp' ]

src/Language/PureScript/Docs/Types.hs+1−1

@@ -425,7 +425,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString

425425

426426instance A.ToJSON a => A.ToJSON (Package a) where

427427 toJSON Package{..} =

428− A.object $

428+ A.object

429429 [ "packageMeta" .= pkgMeta

430430 , "version" .= showVersion pkgVersion

431431 , "versionTag" .= pkgVersionTag

src/Language/PureScript/Errors.hs+33−34

@@ -20,7 +20,7 @@

2020module Language.PureScript.Errors where

2121

2222import Data.Either (lefts, rights)

23−import Data.List (intercalate, transpose)

23+import Data.List (intercalate, transpose, nub)

2424import Data.Function (on)

2525#if __GLASGOW_HASKELL__ < 710

2626import Data.Foldable (fold, foldMap)

@@ -52,7 +52,6 @@ import qualified Text.PrettyPrint.Boxes as Box

5252import qualified Text.Parsec as P

5353import qualified Text.Parsec.Error as PE

5454import Text.Parsec.Error (Message(..))

55−import Data.List (nub)

5655

5756-- |

5857-- A type of error messages

@@ -366,33 +365,33 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

366365onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage

367366onTypesInErrorMessageM f = g

368367 where

369− gSimple (InfiniteType t) = InfiniteType <$> (f t)

370− gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)

371− gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)

372− gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)

373− gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)

374− gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)

368+ gSimple (InfiniteType t) = InfiniteType <$> f t

369+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> f t1 <*> f t2

370+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> f t1 <*> f t2

371+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

372+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> f t

373+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> pure e

375374 gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t

376375 gSimple other = pure other

377− g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)

378− g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)

379− g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)

380− g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em

381− g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)

382− g (NotYetDefined x e) = NotYetDefined x <$> (g e)

383− g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)

384− g (ErrorInModule x e) = ErrorInModule x <$> (g e)

385− g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)

386− g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)

387− g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)

388− g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)

389− g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)

390− g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)

391− g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)

392− g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)

393− g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> (g e)

394− g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)

395− g (PositionedError x e) = PositionedError x <$> (g e)

376+ g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> f t1 <*> f t2 <*> g em

377+ g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> f t1 <*> f t2 <*> g e

378+ g (ErrorCheckingType e t em) = ErrorCheckingType e <$> f t <*> g em

379+ g (ErrorCheckingKind t em) = ErrorCheckingKind <$> f t <*> g em

380+ g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> f t1 <*> pure e2 <*> g em

381+ g (NotYetDefined x e) = NotYetDefined x <$> g e

382+ g (ErrorInExpression x e) = ErrorInExpression x <$> g e

383+ g (ErrorInModule x e) = ErrorInModule x <$> g e

384+ g (ErrorInInstance x y e) = ErrorInInstance x y <$> g e

385+ g (ErrorInferringType x e) = ErrorInferringType x <$> g e

386+ g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> g e

387+ g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> g e

388+ g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> g e

389+ g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> g e

390+ g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> g e

391+ g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> g e

392+ g (ErrorInTypeDeclaration x e) = ErrorInTypeDeclaration x <$> g e

393+ g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> g e

394+ g (PositionedError x e) = PositionedError x <$> g e

396395 g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem

397396

398397-- |

@@ -738,7 +737,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

738737 , go err

739738 ]

740739 go (ErrorInDataBindingGroup err) =

741− paras [ lineWithLevel $ "in data binding group:"

740+ paras [ lineWithLevel "in data binding group:"

742741 , go err

743742 ]

744743 go (ErrorInTypeSynonym name err) =

@@ -857,7 +856,7 @@ prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do

857856 , result

858857 ]

859858prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

860− result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level

859+ result <- forM es $ liftM (Box.moveRight 2) . prettyPrintSingleError full level

861860 return $

862861 Box.vcat Box.left [ Box.text intro

863862 , Box.vsep 1 Box.left result

@@ -865,7 +864,7 @@ prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do

865864

866865-- | Pretty print a Parsec ParseError as a Box

867866prettyPrintParseError :: P.ParseError -> Box.Box

868−prettyPrintParseError = (prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input") . PE.errorMessages

867+prettyPrintParseError = prettyPrintParseErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" . PE.errorMessages

869868

870869-- |

871870-- Pretty print ParseError detail messages.

@@ -878,9 +877,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

878877 | otherwise = Box.vcat Box.left $ map Box.text $ clean [showSysUnExpect,showUnExpect,showExpect,showMessages]

879878

880879 where

881− (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs

882− (unExpect,msgs2) = span ((UnExpect "") ==) msgs1

883− (expect,messages) = span ((Expect "") ==) msgs2

880+ (sysUnExpect,msgs1) = span (SysUnExpect "" ==) msgs

881+ (unExpect,msgs2) = span (UnExpect "" ==) msgs1

882+ (expect,messages) = span (Expect "" ==) msgs2

884883

885884 showExpect = showMany msgExpecting expect

886885 showUnExpect = showMany msgUnExpected unExpect

@@ -928,7 +927,7 @@ renderBox = unlines . map trimEnd . lines . Box.render

928927interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a

929928interpretMultipleErrorsAndWarnings (err, ws) = do

930929 tell ws

931− either throwError return $ err

930+ either throwError return err

932931

933932-- |

934933-- Rethrow an error with a more detailed error message in the case of failure

src/Language/PureScript/Parser/Declarations.hs+13−16

@@ -176,9 +176,9 @@ parseImportDeclaration' = do

176176

177177parseDeclarationRef :: TokenParser DeclarationRef

178178parseDeclarationRef =

179− parseModuleRef <|> (

180− withSourceSpan PositionedDeclarationRef $

181− ValueRef <$> parseIdent

179+ parseModuleRef <|>

180+ withSourceSpan PositionedDeclarationRef

181+ (ValueRef <$> parseIdent

182182 <|> do name <- properName

183183 dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

184184 return $ maybe (TypeClassRef name) (TypeRef name) dctors

@@ -204,8 +204,8 @@ parseTypeClassDeclaration = do

204204 mark (P.many (same *> positioned parseTypeDeclaration))

205205 return $ TypeClassDeclaration className idents implies members

206206

207−parseTypeInstanceDeclaration :: TokenParser Declaration

208−parseTypeInstanceDeclaration = do

207+parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

208+parseInstanceDeclaration = do

209209 reserved "instance"

210210 name <- parseIdent <* indented <* doubleColon

211211 deps <- P.optionMaybe $ do

@@ -215,24 +215,21 @@ parseTypeInstanceDeclaration = do

215215 return deps

216216 className <- indented *> parseQualified properName

217217 ty <- P.many (indented *> noWildcards parseTypeAtom)

218+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty

219+

220+parseTypeInstanceDeclaration :: TokenParser Declaration

221+parseTypeInstanceDeclaration = do

222+ instanceDecl <- parseInstanceDeclaration

218223 members <- P.option [] . P.try $ do

219224 indented *> reserved "where"

220225 mark (P.many (same *> positioned parseValueDeclaration))

221− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)

226+ return $ instanceDecl (ExplicitInstance members)

222227

223228parseDerivingInstanceDeclaration :: TokenParser Declaration

224229parseDerivingInstanceDeclaration = do

225230 reserved "derive"

226− reserved "instance"

227− name <- parseIdent <* indented <* doubleColon

228− deps <- P.optionMaybe $ do

229− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

230− indented

231− rfatArrow

232− return deps

233− className <- indented *> parseQualified properName

234− ty <- P.many (indented *> noWildcards parseTypeAtom)

235− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance

231+ instanceDecl <- parseInstanceDeclaration

232+ return $ instanceDecl DerivedInstance

236233

237234positioned :: TokenParser Declaration -> TokenParser Declaration

238235positioned = withSourceSpan PositionedDeclaration

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

@@ -46,4 +46,4 @@ parseKind :: TokenParser Kind

4646parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

4747 where

4848 operators = [ [ P.Prefix (symbol' "#" >> return Row) ]

49− , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]

49+ , [ P.Infix (P.try rarrow >> return FunKind) P.AssocRight ] ]

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

@@ -479,7 +479,7 @@ identifier = token go P.<?> "identifier"

479479 go _ = Nothing

480480

481481validModuleName :: String -> Bool

482−validModuleName s = not ('_' `elem` s)

482+validModuleName s = '_' `notElem` s

483483

484484-- |

485485-- A list of purescript reserved identifiers

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

@@ -45,13 +45,13 @@ literals = mkPattern' match

4545 match (JSStringLiteral s) = return $ string s

4646 match (JSBooleanLiteral True) = return "true"

4747 match (JSBooleanLiteral False) = return "false"

48− match (JSArrayLiteral xs) = fmap concat $ sequence

48+ match (JSArrayLiteral xs) = concat <$> sequence

4949 [ return "[ "

50− , fmap (intercalate ", ") $ forM xs prettyPrintJS'

50+ , intercalate ", " <$> forM xs prettyPrintJS'

5151 , return " ]"

5252 ]

5353 match (JSObjectLiteral []) = return "{}"

54− match (JSObjectLiteral ps) = fmap concat $ sequence

54+ match (JSObjectLiteral ps) = concat <$> sequence

5555 [ return "{\n"

5656 , withIndent $ do

5757 jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value

@@ -65,7 +65,7 @@ literals = mkPattern' match

6565 objectPropertyToString :: String -> String

6666 objectPropertyToString s | identNeedsEscaping s = show s

6767 | otherwise = s

68− match (JSBlock sts) = fmap concat $ sequence

68+ match (JSBlock sts) = concat <$> sequence

6969 [ return "{\n"

7070 , withIndent $ prettyStatements sts

7171 , return "\n"

@@ -73,23 +73,23 @@ literals = mkPattern' match

7373 , return "}"

7474 ]

7575 match (JSVar ident) = return ident

76− match (JSVariableIntroduction ident value) = fmap concat $ sequence

76+ match (JSVariableIntroduction ident value) = concat <$> sequence

7777 [ return "var "

7878 , return ident

7979 , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

8080 ]

81− match (JSAssignment target value) = fmap concat $ sequence

81+ match (JSAssignment target value) = concat <$> sequence

8282 [ prettyPrintJS' target

8383 , return " = "

8484 , prettyPrintJS' value

8585 ]

86− match (JSWhile cond sts) = fmap concat $ sequence

86+ match (JSWhile cond sts) = concat <$> sequence

8787 [ return "while ("

8888 , prettyPrintJS' cond

8989 , return ") "

9090 , prettyPrintJS' sts

9191 ]

92− match (JSFor ident start end sts) = fmap concat $ sequence

92+ match (JSFor ident start end sts) = concat <$> sequence

9393 [ return $ "for (var " ++ ident ++ " = "

9494 , prettyPrintJS' start

9595 , return $ "; " ++ ident ++ " < "

@@ -97,30 +97,30 @@ literals = mkPattern' match

9797 , return $ "; " ++ ident ++ "++) "

9898 , prettyPrintJS' sts

9999 ]

100− match (JSForIn ident obj sts) = fmap concat $ sequence

100+ match (JSForIn ident obj sts) = concat <$> sequence

101101 [ return $ "for (var " ++ ident ++ " in "

102102 , prettyPrintJS' obj

103103 , return ") "

104104 , prettyPrintJS' sts

105105 ]

106− match (JSIfElse cond thens elses) = fmap concat $ sequence

106+ match (JSIfElse cond thens elses) = concat <$> sequence

107107 [ return "if ("

108108 , prettyPrintJS' cond

109109 , return ") "

110110 , prettyPrintJS' thens

111111 , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

112112 ]

113− match (JSReturn value) = fmap concat $ sequence

113+ match (JSReturn value) = concat <$> sequence

114114 [ return "return "

115115 , prettyPrintJS' value

116116 ]

117− match (JSThrow value) = fmap concat $ sequence

117+ match (JSThrow value) = concat <$> sequence

118118 [ return "throw "

119119 , prettyPrintJS' value

120120 ]

121121 match (JSBreak lbl) = return $ "break " ++ lbl

122122 match (JSContinue lbl) = return $ "continue " ++ lbl

123− match (JSLabel lbl js) = fmap concat $ sequence

123+ match (JSLabel lbl js) = concat <$> sequence

124124 [ return $ lbl ++ ": "

125125 , prettyPrintJS' js

126126 ]

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

@@ -153,7 +153,7 @@ getGitWorkingTreeStatus :: PrepareM TreeStatus

153153getGitWorkingTreeStatus = do

154154 out <- readProcess' "git" ["status", "--porcelain"] ""

155155 return $

156− if null . filter (not . null) . lines $ out

156+ if all null . lines $ out

157157 then Clean

158158 else Dirty

159159

src/Language/PureScript/Publish/ErrorsWarnings.hs+14−15

@@ -98,10 +98,10 @@ renderError err =

9898 case err of

9999 UserError e ->

100100 vcat

101− [ para (concat

102− [ "There is a problem with your package, which meant that "

103− , "it could not be published."

104− ])

101+ [ para (

102+ "There is a problem with your package, which meant that " ++

103+ "it could not be published."

104+ )

105105 , para "Details:"

106106 , indented (displayUserError e)

107107 ]

@@ -123,10 +123,10 @@ renderError err =

123123displayUserError :: UserError -> Box

124124displayUserError e = case e of

125125 BowerJSONNotFound ->

126− para (concat

127− [ "The bower.json file was not found. Please create one, or run "

128− , "`pulp init`."

129− ])

126+ para (

127+ "The bower.json file was not found. Please create one, or run " ++

128+ "`pulp init`."

129+ )

130130 BowerExecutableNotFound names ->

131131 para (concat

132132 [ "The Bower executable was not found (tried: ", format names, "). Please"

@@ -217,10 +217,10 @@ displayUserError e = case e of

217217 , indented (P.prettyPrintMultipleErrorsBox False err)

218218 ]

219219 DirtyWorkingTree ->

220− para (concat

221− [ "Your git working tree is dirty. Please commit, discard, or stash "

222− , "your changes first."

223− ])

220+ para (

221+ "Your git working tree is dirty. Please commit, discard, or stash " ++

222+ "your changes first."

223+ )

224224

225225displayRepositoryError :: RepositoryFieldError -> Box

226226displayRepositoryError err = case err of

@@ -356,12 +356,11 @@ warnUndeclaredDependencies pkgNames =

356356 are = pl "are" "is"

357357 dependencies = pl "dependencies" "a dependency"

358358 in vcat $

359− [ para (concat

359+ para (concat

360360 [ "The following Bower ", packages, " ", are, " installed, but not "

361361 , "declared as ", dependencies, " in your bower.json file:"

362362 ])

363− ] ++

364− bulletedList runPackageName (NonEmpty.toList pkgNames)

363+ : bulletedList runPackageName (NonEmpty.toList pkgNames)

365364

366365warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box

367366warnUnacceptableVersions pkgs =

src/Language/PureScript/Renamer.hs+3−3

@@ -80,12 +80,12 @@ updateScope :: Ident -> Rename Ident

8080updateScope i@(Ident name) | name == C.__unused = return i

8181updateScope name = do

8282 scope <- get

83− name' <- case name `S.member` rsUsedNames scope of

84− True -> do

83+ name' <- if name `S.member` rsUsedNames scope

84+ then do

8585 let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

8686 Just newName = find (`S.notMember` rsUsedNames scope) newNames

8787 return newName

88− False -> return name

88+ else return name

8989 modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

9090 , rsUsedNames = S.insert name' (rsUsedNames s)

9191 }

src/Language/PureScript/Sugar/DoNotation.hs+2−2

@@ -42,13 +42,13 @@ desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleE

4242desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desugarDo <*> pure exts

4343

4444desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration

45−desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)

45+desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d)

4646desugarDo d =

4747 let (f, _, _) = everywhereOnValuesM return replace return

4848 in f d

4949 where

5050 bind :: Expr

51− bind = Var (Qualified Nothing (Ident (C.bind)))

51+ bind = Var (Qualified Nothing (Ident C.bind))

5252

5353 replace :: Expr -> m Expr

5454 replace (Do els) = go els

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

@@ -132,7 +132,7 @@ elaborateImports imps (Module ss coms mn decls exps) = Module ss coms mn decls'

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

133133 in mkImport `map` nub (f `concatMap` decls) ++ decls

134134 fqValues :: Expr -> [ModuleName]

135− fqValues (Var (Qualified (Just mn') _)) | notElem mn' (importedModules imps) = [mn']

135+ fqValues (Var (Qualified (Just mn') _)) | mn' `notElem` importedModules imps = [mn']

136136 fqValues _ = []

137137 mkImport :: ModuleName -> Declaration

138138 mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing

src/Language/PureScript/Sugar/Names/Exports.hs+2−3

@@ -205,9 +205,8 @@ filterModule mn exps refs = do

205205 -- the data constructor to check.

206206 checkDcon :: ProperName -> [ProperName] -> ProperName -> m ()

207207 checkDcon tcon exps' name =

208− if name `elem` exps'

209− then return ()

210− else throwError . errorMessage $ UnknownExportDataConstructor tcon name

208+ unless (name `elem` exps') $

209+ throwError . errorMessage $ UnknownExportDataConstructor tcon name

211210

212211 -- Takes a list of all the exportable classes, the accumulated list of

213212 -- filtered exports, and a `DeclarationRef` for an explicit export. When the

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

@@ -59,7 +59,7 @@ desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do

5959 (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'

6060 return (ident, nameKind, PositionedValue pos com val)

6161 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

62−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name

62+desugarTypeDeclarations [TypeDeclaration name _] = throwError . errorMessage $ OrphanTypeDeclaration name

6363desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do

6464 let (_, f, _) = everywhereOnValuesTopDownM return go return

6565 f' (Left gs) = Left <$> mapM (pairM return f) gs

src/Language/PureScript/TypeChecker/Entailment.hs+2−3

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

1313--

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

1515

16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1716{-# LANGUAGE CPP #-}

1817

1918module Language.PureScript.TypeChecker.Entailment (

@@ -160,14 +159,14 @@ typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynon

160159 Left _ -> Nothing

161160 Right t1 -> typeHeadsAreEqual m e t1 t2

162161typeHeadsAreEqual _ _ REmpty REmpty = Just []

163−typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =

162+typeHeadsAreEqual m e r1@RCons{} r2@RCons{} =

164163 let (s1, r1') = rowToList r1

165164 (s2, r2') = rowToList r2

166165

167166 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

168167 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

169168 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

170− in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int

169+ in (++) <$> foldMap (uncurry (typeHeadsAreEqual m e)) int

171170 <*> go sd1 r1' sd2 r2'

172171 where

173172 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]

src/Language/PureScript/TypeChecker/Types.hs+1−1

@@ -419,7 +419,7 @@ binderRequiresMonotype _ = True

419419

420420-- | Instantiate polytypes only when necessitated by a binder.

421421instantiateForBinders :: [Expr] -> [CaseAlternative] -> UnifyT Type Check ([Expr], [Type])

422−instantiateForBinders vals cas = fmap unzip $ zipWithM (\val inst -> do

422+instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do

423423 TypedValue _ val' ty <- infer val

424424 if inst

425425 then instantiatePolyTypeWithUnknowns val' ty

src/Language/PureScript/TypeChecker/Unify.hs+3−3

@@ -133,7 +133,7 @@ unifyRows r1 r2 =

133133 u1 =:= rowFromList (sd2, rest)

134134 u2 =:= rowFromList (sd1, rest)

135135 unifyRows' sd1 (SaturatedTypeSynonym name args) sd2 r2' = do

136− r1' <- expandTypeSynonym name $ args

136+ r1' <- expandTypeSynonym name args

137137 unifyRows (rowFromList (sd1, r1')) (rowFromList (sd2, r2'))

138138 unifyRows' sd1 r1' sd2 r2'@(SaturatedTypeSynonym _ _) = unifyRows' sd2 r2' sd1 r1'

139139 unifyRows' [] REmpty [] REmpty = return ()

@@ -156,14 +156,14 @@ unifiesWith e (SaturatedTypeSynonym name args) t2 =

156156 Right t1 -> unifiesWith e t1 t2

157157unifiesWith e t1 t2@(SaturatedTypeSynonym _ _) = unifiesWith e t2 t1

158158unifiesWith _ REmpty REmpty = True

159−unifiesWith e r1@(RCons _ _ _) r2@(RCons _ _ _) =

159+unifiesWith e r1@RCons{} r2@RCons{} =

160160 let (s1, r1') = rowToList r1

161161 (s2, r2') = rowToList r2

162162

163163 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

164164 sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]

165165 sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]

166− in all (\(t1, t2) -> unifiesWith e t1 t2) int && go sd1 r1' sd2 r2'

166+ in all (uncurry (unifiesWith e)) int && go sd1 r1' sd2 r2'

167167 where

168168 go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Bool

169169 go [] REmpty [] REmpty = True

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

@@ -22,6 +22,7 @@ module Language.PureScript.Types where

2222

2323import Data.Data

2424import Data.List (nub)

25+import Data.Maybe (fromMaybe)

2526import qualified Data.Aeson as A

2627import qualified Data.Aeson.TH as A

2728

@@ -156,10 +157,7 @@ replaceAllTypeVars = go []

156157 where

157158

158159 go :: [String] -> [(String, Type)] -> Type -> Type

159− go _ m (TypeVar v) =

160− case v `lookup` m of

161− Just r -> r

162− Nothing -> TypeVar v

160+ go _ m (TypeVar v) = fromMaybe (TypeVar v) (v `lookup` m)

163161 go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)

164162 go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts

165163 go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f