b241715 · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

commitb241715c6fd5210d20f1dbf9d31564e5161c7f28 authorAndy Arvanitis <andyarvanitis@gmail.com> dateSat 26 Mar 2016, 17:45 (11 years ago) parent36aede6 fd59e1a

32 files changed+85−66

compare with golang

unifiedsplit

CONTRIBUTORS.md+1

@@ -24,6 +24,7 @@ This file lists the contributors to the PureScript compiler project, and the ter

2424- [@epost](https://github.com/epost) (Erik Post) - My existing contributions and all future contributions until further notice are Copyright Erik Post, and are licensed to the owners and users of the PureScript compiler project under the terms of the MIT license

2525- [@erdeszt](https://github.com/erdeszt) (Tibor Erdesz) My existing contributions and all future contributions until further notice are Copyright Tibor Erdesz, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

2626- [@etrepum](https://github.com/etrepum) (Bob Ippolito) My existing contributions and all future contributions until further notice are Copyright Bob Ippolito, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

27+- [@faineance](https://github.com/faineance) My existing contributions and all future contributions until further notice are Copyright faineance, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

2728- [@garyb](https://github.com/garyb) (Gary Burgess) My existing contributions and all future contributions until further notice are Copyright Gary Burgess, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

2829- [@hdgarrood](https://github.com/hdgarrood) (Harry Garrood) My existing contributions and all future contributions until further notice are Copyright Harry Garrood, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

2930- [@izgzhen](https://github.com/izgzhen) (Zhen Zhang) My existing contributions and all future contributions until further notice are Copyright Zhen Zhang, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT).

examples/docs/LICENSEnew file+1

@@ -0,0 +1 @@

1+This isn't a real license, it's just here for the sake of the tests.

examples/docs/bower.json+2−1

@@ -15,5 +15,6 @@

1515 "output"

1616 ],

1717 "dependencies": {

18− }

18+ },

19+ "license": "replaceme"

1920}

license-generator/generate.hs+1−1

@@ -27,7 +27,7 @@ depsLicense dep = do

2727 putStrLn ""

2828 putStrLn $ f license

2929 where

30− f = unlines . map trimEnd . map (" " ++) . lines

30+ f = unlines . map (trimEnd . (" " ++)) . lines

3131 trimEnd = reverse . dropWhile isSpace . reverse

3232

3333main :: IO ()

psc-bundle/Main.hs+2−1

@@ -19,6 +19,7 @@

1919

2020module Main (main) where

2121

22+import Data.Maybe

2223import Data.Traversable (for)

2324import Data.Version (showVersion)

2425

@@ -125,7 +126,7 @@ options = Options <$> some inputFile

125126main :: IO ()

126127main = do

127128 opts <- execParser (info (version <*> helper <*> options) infoModList)

128− when (optionsRequirePath opts /= Nothing) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."

129+ when (isJust (optionsRequirePath opts)) $ hPutStrLn stderr "The require-path option is deprecated and will be removed in PureScript 0.9."

129130 output <- runExceptT (app opts)

130131 case output of

131132 Left err -> do

psc-docs/Main.hs+2−2

@@ -32,7 +32,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP

3232import qualified Language.PureScript as P

3333import qualified Paths_purescript as Paths

3434import System.Exit (exitFailure)

35−import System.IO (hPutStrLn, stderr)

35+import System.IO (hPutStrLn, hPrint, stderr)

3636import System.Directory (createDirectoryIfMissing)

3737import System.FilePath (takeDirectory)

3838import System.FilePath.Glob (glob)

@@ -139,7 +139,7 @@ dumpTags input renderTags = do

139139 e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

140140 case e of

141141 Left err -> do

142− hPutStrLn stderr (show err)

142+ hPrint stderr err

143143 exitFailure

144144 Right ms ->

145145 ldump (renderTags (pairs ms))

psci/PSCi.hs+1−1

@@ -337,7 +337,7 @@ handleKindOf typ = do

337337 k = check (P.kindOf typ') chk

338338

339339 check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)

340− check sew cs = fst . runWriter . runExceptT . runStateT sew $ cs

340+ check sew = fst . runWriter . runExceptT . runStateT sew

341341 case k of

342342 Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

343343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

purescript.cabal+2−1

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

11name: purescript

2−version: 0.8.2.0

2+version: 0.8.3.0

33cabal-version: >=1.8

44build-type: Simple

55license: MIT

@@ -23,6 +23,7 @@ extra-source-files: examples/passing/*.purs

2323 , examples/failing/*.purs

2424 , examples/docs/bower_components/purescript-prelude/src/*.purs

2525 , examples/docs/bower.json

26+ , examples/docs/LICENSE

2627 , examples/docs/src/*.purs

2728 , tests/support/setup.js

2829 , tests/support/package.json

src/Control/Monad/Supply/Class.hs+1−1

@@ -21,4 +21,4 @@ instance (MonadSupply m) => MonadSupply (StateT s m) where

2121 fresh = lift fresh

2222

2323freshName :: (MonadSupply m) => m String

24−freshName = liftM (('$' :) . show) fresh

24+freshName = fmap (('$' :) . show) fresh

src/Language/PureScript/CodeGen/JS.hs+3−3

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

5555 rethrow (addHint (ErrorInModule mn)) $ do

5656 let usedNames = concatMap getNames decls

5757 let mnLookup = renameImports usedNames imps

58− jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd $ imps

58+ jsImports <- T.traverse (importToJs mnLookup) . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ map snd imps

5959 let decls' = renameModules mnLookup decls

6060 jsDecls <- mapM bindToJs decls'

6161 optimized <- T.traverse (T.traverse optimize) jsDecls

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

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

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

6969 let standardExps = exps \\ foreignExps

70− let exps' = JSObjectLiteral Nothing $ map (runIdent &&& (JSVar Nothing) . identToJs) standardExps

70+ let exps' = JSObjectLiteral Nothing $ map (runIdent &&& JSVar Nothing . identToJs) standardExps

7171 ++ map (runIdent &&& foreignIdent) foreignExps

7272 return $ moduleBody ++ [JSAssignment Nothing (JSAccessor Nothing "exports" (JSVar Nothing "module")) exps']

7373

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

8585 -- with declaration names.

8686 --

8787 renameImports :: [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

88− renameImports ids mns = go M.empty ids mns

88+ renameImports = go M.empty

8989 where

9090 go :: M.Map ModuleName (Ann, ModuleName) -> [Ident] -> [(Ann, ModuleName)] -> M.Map ModuleName (Ann, ModuleName)

9191 go acc used ((ann, mn') : mns') =

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

@@ -78,7 +78,7 @@ nameIsJsReserved name =

7878--

7979nameIsJsBuiltIn :: String -> Bool

8080nameIsJsBuiltIn name =

81− elem name

81+ name `elem`

8282 [ "arguments"

8383 , "Array"

8484 , "ArrayBuffer"

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

@@ -96,9 +96,9 @@ inlineCommonValues = everywhereOnJS convert

9696 fnOne = [(C.prelude, C.one), (C.dataSemiring, C.one)]

9797 fnBottom = [(C.prelude, C.bottom), (C.dataBounded, C.bottom)]

9898 fnTop = [(C.prelude, C.top), (C.dataBounded, C.top)]

99− fnAdd = [(C.prelude, (C.+)), (C.prelude, (C.add)), (C.dataSemiring, (C.+)), (C.dataSemiring, (C.add))]

100− fnDivide = [(C.prelude, (C./)), (C.prelude, (C.div)), (C.dataModuloSemiring, C.div)]

101− fnMultiply = [(C.prelude, (C.*)), (C.prelude, (C.mul)), (C.dataSemiring, (C.*)), (C.dataSemiring, (C.mul))]

99+ fnAdd = [(C.prelude, (C.+)), (C.prelude, C.add), (C.dataSemiring, (C.+)), (C.dataSemiring, C.add)]

100+ fnDivide = [(C.prelude, (C./)), (C.prelude, C.div), (C.dataModuloSemiring, C.div)]

101+ fnMultiply = [(C.prelude, (C.*)), (C.prelude, C.mul), (C.dataSemiring, (C.*)), (C.dataSemiring, C.mul)]

102102 fnSubtract = [(C.prelude, (C.-)), (C.prelude, C.sub), (C.dataRing, C.sub)]

103103 intOp ss op x y = JSBinary ss BitwiseOr (JSBinary ss op x y) (JSNumericLiteral ss (Left 0))

104104

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

@@ -144,7 +144,7 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =

144144 binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

145145 binderToCoreFn ss com (A.LiteralBinder lit) =

146146 LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)

147− binderToCoreFn ss com (A.NullBinder) =

147+ binderToCoreFn ss com A.NullBinder =

148148 NullBinder (ss, com, Nothing, Nothing)

149149 binderToCoreFn ss com (A.VarBinder name) =

150150 VarBinder (ss, com, Nothing, Nothing) name

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

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

11{-# LANGUAGE TupleSections #-}

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE RecordWildCards #-}

4−{-# LANGUAGE ViewPatterns #-}

53{-# LANGUAGE FlexibleContexts #-}

75-- | Functions for converting PureScript ASTs into values of the data types

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

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

1−{-# LANGUAGE ViewPatterns #-}

21{-# LANGUAGE TupleSections #-}

32{-# LANGUAGE RecordWildCards #-}

43{-# LANGUAGE FlexibleContexts #-}

@@ -217,8 +216,7 @@ lookupValueDeclaration importedFrom ident = do

217216 pure (importedFrom, [Left r'])

218217 other ->

219218 errOther other

220− other -> do

221− errOther other

219+ other -> errOther other

222220

223221 where

224222 thd :: (a, b, c) -> c

@@ -381,7 +379,7 @@ handleEnv TypeClassEnv{..} =

381379 promoteChild constraint ChildDeclaration{..} =

382380 case cdeclInfo of

383381 ChildTypeClassMember typ ->

384− pure $ Declaration

382+ pure Declaration

385383 { declTitle = cdeclTitle

386384 , declComments = cdeclComments

387385 , declSourceSpan = cdeclSourceSpan

src/Language/PureScript/Docs/Convert/Single.hs+3−4

@@ -11,11 +11,10 @@ module Language.PureScript.Docs.Convert.Single

1111

1212import Prelude ()

1313import Prelude.Compat

14−import Data.Maybe (catMaybes)

14+import Data.Maybe (mapMaybe, isNothing)

1515

1616import Control.Monad

1717import Control.Category ((>>>))

18−import Data.Maybe (mapMaybe, isNothing)

1918import Data.Either

2019import Data.List (nub, isPrefixOf, isSuffixOf)

2120

@@ -137,7 +136,7 @@ basicDeclaration title info = Just $ Right $ mkDeclaration title info

137136convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration

138137convertDeclaration (P.ValueDeclaration _ _ _ (Right (P.TypedValue _ _ ty))) title =

139138 basicDeclaration title (ValueDeclaration ty)

140−convertDeclaration (P.ValueDeclaration _ _ _ _) title =

139+convertDeclaration (P.ValueDeclaration {}) title =

141140 -- If no explicit type declaration was provided, insert a wildcard, so that

142141 -- the actual type will be added during type checking.

143142 basicDeclaration title (ValueDeclaration P.TypeWildcard)

@@ -205,7 +204,7 @@ convertDeclaration _ _ = Nothing

205204convertComments :: [P.Comment] -> Maybe String

206205convertComments cs = do

207206 let raw = concatMap toLines cs

208− let docs = catMaybes (map stripPipe raw)

207+ let docs = mapMaybe stripPipe raw

209208 guard (not (null docs))

210209 pure (unlines docs)

211210

src/Language/PureScript/Errors.hs+8−7

@@ -637,7 +637,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

637637 renderSimpleErrorMessage (CycleInDeclaration nm) =

638638 line $ "The value of " ++ showIdent nm ++ " is undefined here, so this reference is not allowed."

639639 renderSimpleErrorMessage (CycleInModules mns) =

640− paras [ line $ "There is a cycle in module dependencies in these modules: "

640+ paras [ line "There is a cycle in module dependencies in these modules: "

641641 , indent $ paras (map (line . runModuleName) mns)

642642 ]

643643 renderSimpleErrorMessage (CycleInTypeSynonym name) =

@@ -671,7 +671,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

671671 sortRows' :: ([(String, Type)], Type) -> ([(String, Type)], Type) -> (Type, Type)

672672 sortRows' (s1, r1) (s2, r2) =

673673 let common :: [(String, (Type, Type))]

674− common = sortBy (comparing fst) $ [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

674+ common = sortBy (comparing fst) [ (name, (t1, t2)) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]

675675

676676 sd1, sd2 :: [(String, Type)]

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

@@ -840,8 +840,9 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

840840 paras [ line "A case expression could not be determined to cover all inputs."

841841 , line "The following additional cases are required to cover all inputs:\n"

842842 , indent $ paras $

843− [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]

844− ++ [ line "..." | not b ]

843+ Box.hsep 1 Box.left

844+ (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

845+ : [line "..." | not b]

845846 , line "Or alternatively, add a Partial constraint to the type of the enclosing value."

846847 , line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."

847848 ]

@@ -973,7 +974,7 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

973974 line "An anonymous function argument appears in an invalid context."

974975

975976 renderSimpleErrorMessage (InvalidOperatorInBinder op fn) =

976− paras $ [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."

977+ paras [ line $ "Operator " ++ showIdent op ++ " cannot be used in a pattern as it is an alias for function " ++ showIdent fn ++ "."

977978 , line "Only aliases for data constructors may be used in patterns."

978979 ]

979980

@@ -1197,11 +1198,11 @@ prettyPrintMultipleWarnings full = unlines . map renderBox . prettyPrintMultiple

11971198

11981199-- | Pretty print warnings as a Box

11991200prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> [Box.Box]

1200−prettyPrintMultipleWarningsBox full = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning" full

1201+prettyPrintMultipleWarningsBox = prettyPrintMultipleErrorsWith Warning "Warning found:" "Warning"

12011202

12021203-- | Pretty print errors as a Box

12031204prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> [Box.Box]

1204−prettyPrintMultipleErrorsBox full = prettyPrintMultipleErrorsWith Error "Error found:" "Error" full

1205+prettyPrintMultipleErrorsBox = prettyPrintMultipleErrorsWith Error "Error found:" "Error"

12051206

12061207prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> [Box.Box]

12071208prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) =

src/Language/PureScript/Ide/CaseSplit.hs+2−1

@@ -19,6 +19,7 @@ module Language.PureScript.Ide.CaseSplit

1919import Prelude ()

2020import Prelude.Compat hiding (lex)

2121

22+import Control.Arrow (second)

2223import Control.Monad.Error.Class

2324import "monad-logger" Control.Monad.Logger

2425import Data.List (find)

@@ -58,7 +59,7 @@ caseSplit q = do

5859 (tc, args) <- splitTypeConstructor type'

5960 (EDType _ _ (DataType typeVars ctors)) <- findTypeDeclaration tc

6061 let applyTypeVars = everywhereOnTypes (replaceAllTypeVars (zip (map fst typeVars) args))

61− let appliedCtors = map (\(n, ts) -> (n, map applyTypeVars ts)) ctors

62+ let appliedCtors = map (second (map applyTypeVars)) ctors

6263 pure appliedCtors

6364

6465findTypeDeclaration :: (PscIde m, MonadLogger m, MonadError PscIdeError m) =>

src/Language/PureScript/Ide/State.hs+5−6

@@ -72,9 +72,8 @@ insertModule externsFile = do

7272 liftIO . atomically $ insertModule' (envStateVar env) externsFile

7373

7474insertModule' :: TVar PscIdeState -> ExternsFile -> STM ()

75−insertModule' st ef = do

76− modifyTVar st $ \x ->

77− x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)

78− , pscStateModules = let (mn, decls) = convertExterns ef

79− in M.insert mn decls (pscStateModules x)

80− }

75+insertModule' st ef = modifyTVar st $ \x ->

76+ x { externsFiles = M.insert (efModuleName ef) ef (externsFiles x)

77+ , pscStateModules = let (mn, decls) = convertExterns ef

78+ in M.insert mn decls (pscStateModules x)

79+ }

src/Language/PureScript/Ide/Types.hs−1

@@ -2,7 +2,6 @@

22{-# LANGUAGE FlexibleContexts #-}

33{-# LANGUAGE GeneralizedNewtypeDeriving #-}

44{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE RecordWildCards #-}

65{-# LANGUAGE ScopedTypeVariables #-}

87module Language.PureScript.Ide.Types where

src/Language/PureScript/Linter/Imports.hs+1−1

@@ -152,7 +152,7 @@ lintImports (Module _ _ mn mdecls mexports) env usedImps = do

152152 in foldr go used (classes ++ types ++ dctors ++ values)

153153 where

154154 go :: (ModuleName, Name) -> UsedImports -> UsedImports

155− go (q, name) acc = M.alter (Just . maybe [name] (name :)) q acc

155+ go (q, name) = M.alter (Just . maybe [name] (name :)) q

156156

157157 extractByQual

158158 :: (Eq a)

src/Language/PureScript/Make.hs+3−4

@@ -40,7 +40,7 @@ import Control.Monad.Trans.Control (MonadBaseControl(..))

4040import Control.Concurrent.Lifted as C

4141

4242import Data.List (foldl', sort)

43−import Data.Maybe (fromMaybe, catMaybes)

43+import Data.Maybe (fromMaybe, catMaybes, isJust)

4444import Data.Time.Clock

4545import Data.String (fromString)

4646import Data.Foldable (for_)

@@ -151,7 +151,7 @@ make :: forall m. (Monad m, MonadBaseControl IO m, MonadReader Options m, MonadE

151151 -> m Environment

152152make MakeActions{..} ms = do

153153 requirePath <- asks optionsRequirePath

154− when (requirePath /= Nothing) $ tell $ errorMessage DeprecatedRequirePath

154+ when (isJust requirePath) $ tell $ errorMessage DeprecatedRequirePath

155155

156156 checkModuleNamesAreUnique

157157

@@ -364,8 +364,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =

364364 , mapSourceFile = sourceFile

365365 , mapGenerated = convertPos $ add (extraLines+1) 0 gen

366366 , mapName = Nothing

367− }) $

368− mappings

367+ }) mappings

369368 }

370369 let mapping = generate rawMapping

371370 writeTextFile mapFile $ BU8.toString . B.toStrict . encode $ mapping

src/Language/PureScript/Parser/Declarations.hs−1

@@ -184,7 +184,6 @@ parseTypeClassDeclaration = do

184184 indented *> reserved "where"

185185 indented *> mark (P.many (same *> positioned parseTypeDeclaration))

186186 return $ TypeClassDeclaration className idents implies members

187− where

188187

189188parseConstraint :: TokenParser Constraint

190189parseConstraint = (,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)

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

@@ -148,7 +148,7 @@ prettyPrintMany :: (Emit gen) => (a -> StateT PrinterState Maybe gen) -> [a] ->

148148prettyPrintMany f xs = do

149149 ss <- mapM f xs

150150 indentString <- currentIndent

151− return $ intercalate (emit "\n") $ map (\s -> mappend indentString s) ss

151+ return $ intercalate (emit "\n") $ map (mappend indentString) ss

152152

153153-- |

154154-- Prints an object key, escaping reserved names.

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

@@ -274,8 +274,7 @@ prettyPrintJSWithSourceMaps js =

274274 in (s, mp)

275275

276276prettyPrintJS :: [JS] -> String

277−prettyPrintJS = fromMaybe (internalError "Incomplete pattern") . fmap runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

278−

277+prettyPrintJS = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

279278-- |

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

281280--

src/Language/PureScript/Publish.hs+15−7

@@ -18,7 +18,7 @@ module Language.PureScript.Publish

1818 , getGitWorkingTreeStatus

1919 , checkCleanWorkingTree

2020 , getVersionFromGitTag

21− , getBowerInfo

21+ , getBowerRepositoryInfo

2222 , getModulesAndBookmarks

2323 , getResolvedDependencies

2424 ) where

@@ -127,19 +127,24 @@ otherError = throwError . OtherError

127127catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b

128128catchLeft a f = either f pure a

129129

130+unlessM :: Monad m => m Bool -> m () -> m ()

131+unlessM cond act = cond >>= flip unless act

132+

130133preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage

131134preparePackage' opts = do

132− exists <- liftIO (doesFileExist "bower.json")

133− unless exists (userError BowerJSONNotFound)

134−

135+ unlessM (liftIO (doesFileExist "bower.json")) (userError BowerJSONNotFound)

135136 checkCleanWorkingTree opts

136137

137138 pkgMeta <- liftIO (Bower.decodeFile "bower.json")

138139 >>= flip catchLeft (userError . CouldntDecodeBowerJSON)

140+ unlessM (liftIO (doesFileExist "LICENSE")) (userError LicenseNotFound)

141+

139142 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

140− pkgGithub <- getBowerInfo pkgMeta

143+ pkgGithub <- getBowerRepositoryInfo pkgMeta

141144 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

142145

146+ unless (bowerLicenseExists pkgMeta) (userError NoLicenseSpecified)

147+

143148 let declaredDeps = map fst (bowerDependencies pkgMeta ++

144149 bowerDevDependencies pkgMeta)

145150 pkgResolvedDependencies <- getResolvedDependencies declaredDeps

@@ -199,8 +204,8 @@ getVersionFromGitTag = do

199204 dropPrefix prefix str =

200205 fromMaybe str (stripPrefix prefix str)

201206

202−getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)

203−getBowerInfo = either (userError . BadRepositoryField) return . tryExtract

207+getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)

208+getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract

204209 where

205210 tryExtract pkgMeta =

206211 case bowerRepository pkgMeta of

@@ -210,6 +215,9 @@ getBowerInfo = either (userError . BadRepositoryField) return . tryExtract

210215 (Left (BadRepositoryType repositoryType))

211216 maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)

212217

218+bowerLicenseExists :: PackageMeta -> Bool

219+bowerLicenseExists = any (not . null) . bowerLicense

220+

213221extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)

214222extractGithub = stripGitHubPrefixes

215223 >>> fmap (splitOn "/")

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

@@ -55,11 +55,13 @@ data PackageWarning

5555-- | An error that should be fixed by the user.

5656data UserError

5757 = BowerJSONNotFound

58+ | LicenseNotFound

5859 | BowerExecutableNotFound [String] -- list of executable names tried

5960 | CouldntDecodeBowerJSON (ParseError BowerError)

6061 | TagMustBeCheckedOut

6162 | AmbiguousVersions [Version] -- Invariant: should contain at least two elements

6263 | BadRepositoryField RepositoryFieldError

64+ | NoLicenseSpecified

6365 | MissingDependencies (NonEmpty PackageName)

6466 | CompileError P.MultipleErrors

6567 | DirtyWorkingTree

@@ -71,6 +73,7 @@ data RepositoryFieldError

7173 | NotOnGithub

7274 deriving (Show)

7375

76+

7477-- | An error that probably indicates a bug in this module.

7578data InternalError

7679 = JSONError JSONSource (ParseError BowerError)

@@ -126,6 +129,12 @@ displayUserError e = case e of

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

127130 "`pulp init`."

128131 )

132+ LicenseNotFound ->

133+ para (concat

134+ ["No LICENSE file was found. Please create one. ",

135+ "Distributing code without a license means that nobody ",

136+ "will be able to (legally) use it."

137+ ])

129138 BowerExecutableNotFound names ->

130139 para (concat

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

@@ -172,6 +181,12 @@ displayUserError e = case e of

172181 ] ++ bulletedList showVersion vs

173182 BadRepositoryField err ->

174183 displayRepositoryError err

184+ NoLicenseSpecified ->

185+ para (concat

186+ ["No license specified in bower.json. Please add one. ",

187+ "Distributing code without a license means that nobody ",

188+ "will be able to (legally) use it."

189+ ])

175190 MissingDependencies pkgs ->

176191 let singular = NonEmpty.length pkgs == 1

177192 pl a b = if singular then b else a

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

@@ -164,7 +164,7 @@ resolveExports env mn imps exps refs =

164164 exps' <- envModuleExports <$> mn'' `M.lookup` env

165165 ((_, dctors'), mnOrig) <- find (\((name', _), _) -> name == name') (exportedTypes exps')

166166 let relevantDctors = mapMaybe (\(Qualified mn''' dctor) -> if mn''' == Just mn'' then Just dctor else Nothing) dctors

167− return ((name, intersect relevantDctors dctors'), mnOrig)

167+ return ((name, relevantDctors `intersect` dctors'), mnOrig)

168168 go (Qualified Nothing _) = internalError "Unqualified value in resolveTypeExports"

169169

170170

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

@@ -103,7 +103,7 @@ rebracket externs ms = do

103103 Nothing ->

104104 maybe id rethrowWithPosition pos $

105105 throwError . errorMessage $ UnknownValue name

106− goBinder _ (BinaryNoParensBinder _ _ _) =

106+ goBinder _ (BinaryNoParensBinder {}) =

107107 internalError "BinaryNoParensBinder has no OpBinder"

108108 goBinder pos other = return (pos, other)

109109

src/Language/PureScript/TypeChecker/Monad.hs+1−3

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

21{-# LANGUAGE FlexibleInstances #-}

32{-# LANGUAGE RankNTypes #-}

43{-# LANGUAGE MultiParamTypeClasses #-}

@@ -225,8 +224,7 @@ runCheck = runCheck' initEnvironment

225224

226225-- | Run a computation in the typechecking monad, failing with an error, or succeeding with a return value and the final @Environment@.

227226runCheck' :: (Functor m) => Environment -> StateT CheckState m a -> m (a, Environment)

228−runCheck' env check = fmap (second checkEnv) $ runStateT check (emptyCheckState env)

229−

227+runCheck' env check = second checkEnv <$> runStateT check (emptyCheckState env)

230228-- | Make an assertion, failing with an error message

231229guardWith :: (MonadError e m) => e -> Bool -> m ()

232230guardWith _ True = return ()

tests/TestDocs.hs+4−3

@@ -38,7 +38,8 @@ main = pushd "examples/docs" $ do

3838 forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) ->

3939 let mdl = takeJust ("module not found in docs: " ++ P.runModuleName mn)

4040 (find ((==) mn . Docs.modName) pkgModules)

41− in forM_ pragmas (flip runAssertionIO mdl)

41+ in forM_ pragmas (`runAssertionIO` mdl)

42+

4243

4344takeJust :: String -> Maybe a -> a

4445takeJust msg = fromMaybe (error msg)

@@ -257,8 +258,8 @@ testCases =

257258

258259 , ("ExplicitTypeSignatures",

259260 [ ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "explicit" (ShowFn (hasTypeVar "something"))

260− , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn ((==) P.tyInt))

261− , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn ((==) P.tyNumber))

261+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "anInt" (ShowFn (P.tyInt ==))

262+ , ValueShouldHaveTypeSignature (n "ExplicitTypeSignatures") "aNumber" (ShowFn (P.tyNumber ==))

262263 ])

263264 ]

264265

tests/TestPscPublish.hs+1−1

@@ -63,7 +63,7 @@ testPackage dir = pushd dir $ do

6363 pure ()

6464 other -> do

6565 putStrLn ("psc-publish tests failed on " ++ dir ++ ":")

66− putStrLn (show other)

66+ print other

6767 exitFailure

6868 where

6969 preparePackageError e@(UserError BowerJSONNotFound) = do