a74e6e5 · rowtype-yoga/purescript-native

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

Merge branch 'master' into pure11

commita74e6e5f727371697f89e7a99bb04e52db59066a authorAndy Arvanitis <andyarvanitis@gmail.com> dateTue 17 Nov 2015, 20:05 (11 years ago) parentbd0fbe4 e047dfa

14 files changed+265−99

compare with golang

unifiedsplit

CONTRIBUTORS.md+1

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

5656- [@zudov](https://github.com/zudov) (Konstantin Zudov) My existing contributions and all future contributions until further notice are Copyright Konstantin Zudov, 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).

5757- [@senju](https://github.com/senju) - My existing contributions and all future contributions until further notice are Copyright senju, 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).

5858<http://opensource.org/licenses/MIT>.

59+- [@soupi](https://github.com/soupi) (Gil Mizrahi) My existing contributions and all future contributions until further notice are Copyright Gil Mizrahi, 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).

5960

6061### Companies

6162

README.md+1

@@ -26,3 +26,4 @@ A small strongly typed programming language with expressive types that compiles

2626- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)

2727- [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)

2828- [Google Group](https://groups.google.com/forum/#!forum/purescript)

29+- [Gitter Channel](https://gitter.im/purescript/purescript?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)

core-tests/tests/generic-deriving/Main.purs+5−1

@@ -17,7 +17,11 @@ data A a

1717 | D { a :: a }

1818 | E Void

1919

20−derive instance genericA :: (Generic a) => Generic (A a)

20+derive instance genericA :: (Generic b) => Generic (A b)

21+

22+newtype X b = X b

23+

24+derive instance genericX :: Generic (X String)

2125

2226main :: forall eff. Eff (console :: CONSOLE | eff) Unit

2327main = Control.Monad.Eff.Console.log (gShow (D { a: C [ A 1.0 "test", B 42, D { a: true } ] }))

psc-publish/Main.hs+9−2

@@ -9,12 +9,20 @@ import Options.Applicative hiding (str)

1010import qualified Paths_purescript as Paths

1111import Language.PureScript.Publish

12+import Language.PureScript.Publish.ErrorsWarnings

1213

1314dryRun :: Parser Bool

1415dryRun = switch $

1516 long "dry-run"

1617 <> help "Produce no output, and don't require a tagged version to be checked out."

1718

19+dryRunOptions :: PublishOptions

20+dryRunOptions = defaultPublishOptions

21+ { publishGetVersion = return dummyVersion

22+ , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn

23+ }

24+ where dummyVersion = ("0.0.0", Version [0,0,0] [])

25+

1826main :: IO ()

1927main = execParser opts >>= publish

2028 where

@@ -30,8 +38,7 @@ publish :: Bool -> IO ()

3038publish isDryRun =

3139 if isDryRun

3240 then do

33− let dummyVersion = ("0.0.0", Version [0,0,0] [])

34− _ <- preparePackage $ defaultPublishOptions { publishGetVersion = return dummyVersion }

41+ _ <- preparePackage dryRunOptions

3542 putStrLn "Dry run completed, no errors."

3643 else do

3744 pkg <- preparePackage defaultPublishOptions

psci/PSCi.hs+101−15

@@ -24,7 +24,8 @@ import Prelude ()

2424import Prelude.Compat

2525

2626import Data.Foldable (traverse_)

27−import Data.List (intercalate, nub, sort)

27+import Data.Maybe (mapMaybe)

28+import Data.List (intersperse, intercalate, nub, sort)

2829import Data.Tuple (swap)

2930import Data.Version (showVersion)

3031import qualified Data.Map as M

@@ -48,6 +49,7 @@ import System.FilePath (pathSeparator, (</>), isPathSeparator)

4849import System.FilePath.Glob (glob)

4950import System.Process (readProcessWithExitCode)

5051import System.IO.Error (tryIOError)

52+import qualified Text.PrettyPrint.Boxes as Box

5153

5254import qualified Language.PureScript as P

5355import qualified Language.PureScript.Names as N

@@ -374,20 +376,104 @@ handleTypeOf val = do

374376-- Pretty print a module's signatures

375377--

376378printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

377−printModuleSignatures moduleName env =

378− PSCI $ let namesEnv = P.names env

379− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv

380− in case moduleNamesIdent of

381− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."

382− _ -> ( outputStrLn

383− . unlines

384− . sort

385− . map (showType . findType namesEnv)) moduleNamesIdent

386− where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

387− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

388− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String

389− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType

390− showType _ = P.internalError "The impossible happened in printModuleSignatures."

379+printModuleSignatures moduleName (P.Environment {..}) =

380+ PSCI $

381+ -- get relevant components of a module from environment

382+ let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names

383+ moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses

384+ moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types

385+

386+ in

387+ -- print each component

388+ (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)

389+ [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses

390+ , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types

391+ , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions

392+ ]

393+

394+ where printModule's showF = Box.vsep 1 Box.left . showF

395+

396+ findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

397+ findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

398+

399+ showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box

400+ showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType

401+ showNameType _ = P.internalError "The impossible happened in printModuleSignatures."

402+

403+ findTypeClass :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))

404+ findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)

405+

406+ showTypeClass :: (P.Qualified P.ProperName, Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])) -> Maybe Box.Box

407+ showTypeClass (_, Nothing) = Nothing

408+ showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =

409+ let constraints =

410+ if null constrs

411+ then Box.text ""

412+ else Box.text "("

413+ Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)

414+ Box.<> Box.text ") <= "

415+ className =

416+ Box.text (P.runProperName name)

417+ Box.<> Box.text (concatMap ((' ':) . fst) vars)

418+ classBody =

419+ Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)

420+

421+ in

422+ Just $

423+ (Box.text "class "

424+ Box.<> constraints

425+ Box.<> className

426+ Box.<+> if null body then Box.text "" else Box.text "where")

427+ Box.// Box.moveRight 2 classBody

428+

429+

430+ findType :: M.Map (P.Qualified P.ProperName) (P.Kind, P.TypeKind) -> P.Qualified P.ProperName -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

431+ findType envTypes name = (name, M.lookup name envTypes)

432+

433+ showType :: M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])

434+ -> M.Map (P.Qualified P.ProperName) (P.DataDeclType, P.ProperName, P.Type, [P.Ident])

435+ -> M.Map (P.Qualified P.ProperName) ([(String, Maybe P.Kind)], P.Type)

436+ -> (P.Qualified P.ProperName, Maybe (P.Kind, P.TypeKind))

437+ -> Maybe Box.Box

438+ showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =

439+ case (typ, M.lookup n typeSynonymsEnv) of

440+ (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->

441+ if M.member n typeClassesEnv

442+ then

443+ Nothing

444+ else

445+ Just $

446+ Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)

447+ Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)

448+

449+ (Just (_, P.DataType typevars pt), _) ->

450+ let prefix =

451+ case pt of

452+ [(dtProperName,_)] ->

453+ case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of

454+ Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType

455+ _ -> "data"

456+ _ -> "data"

457+

458+ in

459+ Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt

460+

461+ _ ->

462+ Nothing

463+

464+ where printCons pt =

465+ Box.moveRight 2 $

466+ Box.vcat Box.left $

467+ mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $

468+ map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt

469+

470+ prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t

471+

472+ mapFirstRest _ _ [] = []

473+ mapFirstRest f g (x:xs) = f x : map g xs

474+

475+ trimEnd = reverse . dropWhile (== ' ') . reverse

476+

391477

392478-- |

393479-- Browse a module and displays its signature (if module exists).

purescript.cabal+3−2

@@ -213,7 +213,8 @@ executable psci

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

214214 mtl -any, optparse-applicative >= 0.10.0, parsec -any,

215215 haskeline >= 0.7.0.0, purescript -any, transformers -any,

216− transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0

216+ transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,

217+ boxes >= 0.1.4 && < 0.2.0

217218

218219 main-is: Main.hs

219220 buildable: True

@@ -300,7 +301,7 @@ test-suite psci-tests

300301 mtl -any, optparse-applicative >= 0.10.0, parsec -any,

301302 haskeline >= 0.7.0.0, purescript -any, transformers -any,

302303 transformers-compat -any, process -any, HUnit -any, time -any,

303− Glob -any, base-compat >=0.6.0

304+ Glob -any, base-compat >=0.6.0, boxes >= 0.1.4 && < 0.2.0

304305 type: exitcode-stdio-1.0

305306 main-is: Main.hs

306307 other-modules: TestsSetup

src/Language/PureScript/Docs/Render.hs+1−5

@@ -71,11 +71,7 @@ renderChildDeclarationWithOptions :: RenderTypeOptions -> ChildDeclaration -> Re

7171renderChildDeclarationWithOptions opts ChildDeclaration{..} =

7272 mintersperse sp $ case cdeclInfo of

7373 ChildInstance constraints ty ->

74− [ keywordInstance

75− , ident cdeclTitle

76− , syntax "::"

77− ] ++ maybeToList (renderConstraints constraints)

78− ++ [ renderType' ty ]

74+ maybeToList (renderConstraints constraints) ++ [ renderType' ty ]

7975 ChildDataConstructor args ->

8076 [ renderType' typeApp' ]

8177 where

src/Language/PureScript/Errors.hs+19−9

@@ -32,7 +32,7 @@ import Control.Monad

3232import Control.Monad.Writer

3333import Control.Monad.Error.Class (MonadError(..))

3434import Control.Monad.Trans.State.Lazy

35−import Control.Arrow(first)

35+import Control.Arrow (first)

3636

3737import Language.PureScript.Crash

3838import Language.PureScript.AST

@@ -139,6 +139,8 @@ data SimpleErrorMessage

139139 | ImportHidingModule ModuleName

140140 | UnusedImport ModuleName

141141 | UnusedExplicitImport ModuleName [String]

142+ | UnusedDctorImport ProperName

143+ | UnusedDctorExplicitImport ProperName [ProperName]

142144 deriving (Show)

143145

144146-- | Error message hints, providing more detailed information about failure.

@@ -271,6 +273,9 @@ errorCode em = case unwrapErrorMessage em of

271273 ImportHidingModule{} -> "ImportHidingModule"

272274 UnusedImport{} -> "UnusedImport"

273275 UnusedExplicitImport{} -> "UnusedExplicitImport"

276+ UnusedDctorImport{} -> "UnusedDctorImport"

277+ UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

278+

274279

275280-- |

276281-- A stack trace for an error

@@ -680,6 +685,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

680685 paras [ line $ "The import of module " ++ runModuleName name ++ " contains the following unused references:"

681686 , indent $ paras $ map line names ]

682687

688+ renderSimpleErrorMessage (UnusedDctorImport name) =

689+ line $ "The import of type " ++ runProperName name ++ " includes data constructors but only the type is used"

690+

691+ renderSimpleErrorMessage (UnusedDctorExplicitImport name names) =

692+ paras [ line $ "The import of type " ++ runProperName name ++ " includes the following unused data constructors:"

693+ , indent $ paras $ map (line .runProperName) names ]

694+

683695 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

684696 renderHint (ErrorUnifyingTypes t1 t2) detail =

685697 paras [ detail

@@ -938,20 +950,18 @@ renderBox = unlines . map trimEnd . lines . Box.render

938950 where

939951 trimEnd = reverse . dropWhile (== ' ') . reverse

940952

941−-- |

942−-- Interpret multiple errors and warnings in a monad supporting errors and warnings

943−--

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

945−interpretMultipleErrorsAndWarnings (err, ws) = do

946− tell ws

947− either throwError return err

948−

949953-- |

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

951955--

952956rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

953957rethrow f = flip catchError $ \e -> throwError (f e)

954958

959+reifyErrors :: (Functor m, MonadError e m) => m a -> m (Either e a)

960+reifyErrors ma = catchError (fmap Right ma) (return . Left)

961+

962+reflectErrors :: (MonadError e m) => m (Either e a) -> m a

963+reflectErrors ma = ma >>= either throwError return

964+

955965warnAndRethrow :: (MonadError e m, MonadWriter e m) => (e -> e) -> m a -> m a

956966warnAndRethrow f = rethrow f . censor f

957967

src/Language/PureScript/Linter/Imports.hs+65−19

@@ -8,7 +8,7 @@ import Prelude.Compat

99import qualified Data.Map as M

1010import Data.Maybe (mapMaybe)

11−import Data.List ((\\), find)

11+import Data.List ((\\), find, intersect)

1212import Control.Monad.Error.Class (MonadError(..))

1313import Control.Monad.Writer.Class

1414import Control.Monad(unless,when)

@@ -35,33 +35,70 @@ type UsedImports = M.Map ModuleName [Name]

3535-- or references in an explicit import list.

3636--

3737findUnusedImports :: forall m. (Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => Module -> Env -> UsedImports -> m ()

38−findUnusedImports (Module _ _ _ mdecls _) env usedImps = do

38+findUnusedImports (Module _ _ _ mdecls mexports) env usedImps = do

3939 imps <- findImports mdecls

40− forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` autoIncludes) $

41− forM_ decls $ \(ss, declType, qualifierName) -> censor (onErrorMessages $ addModuleLocError ss) $

42− let usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) $ sugarNames ++ M.findWithDefault [] mni usedImps in

43− case declType of

44− Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni

45− Explicit declrefs -> do

46− let idents = mapMaybe runDeclRef declrefs

47− let diff = idents \\ usedNames

48− unless (null diff) $ tell $ errorMessage $ UnusedExplicitImport mni diff

49− _ -> return ()

40+ forM_ (M.toAscList imps) $ \(mni, decls) -> unless (mni `elem` alwaysUsedModules) $

41+ forM_ decls $ \(ss, declType, qualifierName) ->

42+ censor (onErrorMessages $ addModuleLocError ss) $ unless (qnameUsed qualifierName) $

43+ let names = sugarNames mni ++ M.findWithDefault [] mni usedImps

44+ usedNames = mapMaybe (matchName (typeForDCtor mni) qualifierName) names

45+ usedDctors = mapMaybe (matchDctor qualifierName) names

46+ in case declType of

47+ Implicit -> when (null usedNames) $ tell $ errorMessage $ UnusedImport mni

48+ Explicit declrefs -> do

49+ let idents = mapMaybe runDeclRef declrefs

50+ let diff = idents \\ usedNames

51+ case (length diff, length idents) of

52+ (0, _) -> return ()

53+ (n, m) | n == m -> tell $ errorMessage $ UnusedImport mni

54+ _ -> tell $ errorMessage $ UnusedExplicitImport mni diff

55+

56+ -- If we've not already warned a type is unused, check its data constructors

57+ forM_ (mapMaybe getTypeRef declrefs) $ \(tn, c) -> do

58+ let allCtors = dctorsForType mni tn

59+ when (runProperName tn `elem` usedNames) $ case (c, null $ usedDctors `intersect` allCtors) of

60+ (Nothing, True) -> tell $ errorMessage $ UnusedDctorImport tn

61+ (Just (_:_), True) -> tell $ errorMessage $ UnusedDctorImport tn

62+ (Just ctors, _) ->

63+ let ddiff = ctors \\ usedDctors

64+ in unless (null ddiff) $ tell $ errorMessage $ UnusedDctorExplicitImport tn ddiff

65+ _ -> return ()

66+ return ()

67+

68+ _ -> return ()

5069 where

51− sugarNames :: [ Name ]

52− sugarNames = [ IdentName $ Qualified Nothing (Ident C.bind) ]

70+ sugarNames :: ModuleName -> [ Name ]

71+ sugarNames (ModuleName [ProperName n]) | n == C.prelude = [ IdentName $ Qualified Nothing (Ident C.bind) ]

72+ sugarNames _ = []

73+

74+ -- rely on exports being elaborated by this point

75+ alwaysUsedModules :: [ ModuleName ]

76+ alwaysUsedModules = ModuleName [ProperName C.prim] : maybe [] (mapMaybe isExport) mexports

77+ where

78+ isExport (ModuleRef mn) = Just mn

79+ isExport _ = Nothing

80+

81+ qnameUsed :: Maybe ModuleName -> Bool

82+ qnameUsed (Just qn) = qn `elem` alwaysUsedModules

83+ qnameUsed Nothing = False

5384

54− autoIncludes :: [ ModuleName ]

55− autoIncludes = [ ModuleName [ProperName C.prim] ]

85+ dtys :: ModuleName -> [((ProperName, [ProperName]), ModuleName)]

86+ dtys mn = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

87+

88+ dctorsForType :: ModuleName -> ProperName -> [ProperName]

89+ dctorsForType mn tn =

90+ maybe [] getDctors (find matches $ dtys mn)

91+ where

92+ matches ((ty, _),_) = ty == tn

93+ getDctors ((_,ctors),_) = ctors

5694

5795 typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

5896 typeForDCtor mn pn =

59− getTy <$> find matches tys

97+ getTy <$> find matches (dtys mn)

6098 where

6199 matches ((_, ctors), _) = pn `elem` ctors

62100 getTy ((ty, _), _) = ty

63− tys :: [((ProperName, [ProperName]), ModuleName)]

64− tys = maybe [] exportedTypes $ envModuleExports <$> mn `M.lookup` env

101+

65102

66103matchName :: (ProperName -> Maybe ProperName) -> Maybe ModuleName -> Name -> Maybe String

67104matchName _ qual (IdentName (Qualified q x)) | q == qual = Just $ showIdent x

@@ -69,12 +106,21 @@ matchName _ qual (IsProperName (Qualified q x)) | q == qual = Just $ runProperNa

69106matchName lookupDc qual (DctorName (Qualified q x)) | q == qual = runProperName <$> lookupDc x

70107matchName _ _ _ = Nothing

71108

109+matchDctor :: Maybe ModuleName -> Name -> Maybe ProperName

110+matchDctor qual (DctorName (Qualified q x)) | q == qual = Just x

111+matchDctor _ _ = Nothing

112+

72113runDeclRef :: DeclarationRef -> Maybe String

73114runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

74115runDeclRef (ValueRef ident) = Just $ showIdent ident

75116runDeclRef (TypeRef pn _) = Just $ runProperName pn

76117runDeclRef _ = Nothing

77118

119+getTypeRef :: DeclarationRef -> Maybe (ProperName, Maybe [ProperName])

120+getTypeRef (PositionedDeclarationRef _ _ ref) = getTypeRef ref

121+getTypeRef (TypeRef pn x) = Just (pn, x)

122+getTypeRef _ = Nothing

123+

78124addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

79125addModuleLocError sp err =

80126 case sp of

src/Language/PureScript/Publish.hs+13−6

@@ -8,10 +8,14 @@ module Language.PureScript.Publish

88 , preparePackage'

99 , PrepareM()

1010 , runPrepareM

11+ , warn

12+ , userError

13+ , internalError

14+ , otherError

1115 , PublishOptions(..)

1216 , defaultPublishOptions

1317 , getGitWorkingTreeStatus

14− , requireCleanWorkingTree

18+ , checkCleanWorkingTree

1519 , getVersionFromGitTag

1620 , getBowerInfo

1721 , getModulesAndBookmarks

@@ -63,11 +67,14 @@ data PublishOptions = PublishOptions

6367 { -- | How to obtain the version tag and version that the data being

6468 -- generated will refer to.

6569 publishGetVersion :: PrepareM (String, Version)

70+ , -- | What to do when the working tree is dirty

71+ publishWorkingTreeDirty :: PrepareM ()

6672 }

6773

6874defaultPublishOptions :: PublishOptions

6975defaultPublishOptions = PublishOptions

7076 { publishGetVersion = getVersionFromGitTag

77+ , publishWorkingTreeDirty = userError DirtyWorkingTree

7178 }

7279

7380-- | Attempt to retrieve package metadata from the current directory.

@@ -119,10 +126,10 @@ preparePackage' opts = do

119126 exists <- liftIO (doesFileExist "bower.json")

120127 unless exists (userError BowerJSONNotFound)

121128

122− requireCleanWorkingTree

129+ checkCleanWorkingTree opts

123130

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

125− >>= flip catchLeft (userError . CouldntParseBowerJSON)

132+ >>= flip catchLeft (userError . CouldntDecodeBowerJSON)

126133 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

127134 pkgGithub <- getBowerInfo pkgMeta

128135 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

@@ -155,11 +162,11 @@ getGitWorkingTreeStatus = do

155162 then Clean

156163 else Dirty

157164

158−requireCleanWorkingTree :: PrepareM ()

159−requireCleanWorkingTree = do

165+checkCleanWorkingTree :: PublishOptions -> PrepareM ()

166+checkCleanWorkingTree opts = do

160167 status <- getGitWorkingTreeStatus

161168 unless (status == Clean) $

162− userError DirtyWorkingTree

169+ publishWorkingTreeDirty opts

163170

164171getVersionFromGitTag :: PrepareM (String, Version)

165172getVersionFromGitTag = do

src/Language/PureScript/Publish/ErrorsWarnings.hs+27−23

@@ -29,7 +29,7 @@ import qualified Data.List.NonEmpty as NonEmpty

2929import qualified Data.Text as T

3030

3131import Control.Exception (IOException)

32−import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName)

32+import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName, showBowerError)

3333import qualified Web.Bower.PackageMeta as Bower

3434

3535import qualified Language.PureScript as P

@@ -49,14 +49,14 @@ data PackageWarning

4949 = NoResolvedVersion PackageName

5050 | UndeclaredDependency PackageName

5151 | UnacceptableVersion (PackageName, String)

52+ | DirtyWorkingTree_Warn

5253 deriving (Show)

5354

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

5556data UserError

5657 = BowerJSONNotFound

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

58− | CouldntParseBowerJSON (ParseError BowerError)

59− | BowerJSONNameMissing

59+ | CouldntDecodeBowerJSON (ParseError BowerError)

6060 | TagMustBeCheckedOut

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

6262 | BadRepositoryField RepositoryFieldError

@@ -130,21 +130,12 @@ displayUserError e = case e of

130130 ])

131131 where

132132 format = intercalate ", " . map show

133− CouldntParseBowerJSON err ->

133+ CouldntDecodeBowerJSON err ->

134134 vcat

135− [ successivelyIndented

136− [ "The bower.json file could not be parsed as JSON:"

137− , "aeson reported: " ++ show err

138− ]

139− , para "Please ensure that your bower.json file is valid JSON."

140− ]

141− BowerJSONNameMissing ->

142− vcat

143− [ successivelyIndented

144− [ "In bower.json:"

145− , "the \"name\" key was not found."

146− ]

147− , para "Please give your package a name first."

135+ [ para "There was a problem with your bower.json file:"

136+ , indented (vcat (map (para . T.unpack) (displayError showBowerError err)))

137+ , spacer

138+ , para "Please ensure that your bower.json file is valid."

148139 ]

149140 TagMustBeCheckedOut ->

150141 vcat

@@ -289,21 +280,24 @@ data CollectedWarnings = CollectedWarnings

289280 { noResolvedVersions :: [PackageName]

290281 , undeclaredDependencies :: [PackageName]

291282 , unacceptableVersions :: [(PackageName, String)]

283+ , dirtyWorkingTree :: Any

292284 }

293285 deriving (Show, Eq, Ord)

294286

295287instance Monoid CollectedWarnings where

296− mempty = CollectedWarnings mempty mempty mempty

297− mappend (CollectedWarnings as bs cs) (CollectedWarnings as' bs' cs') =

298− CollectedWarnings (as <> as') (bs <> bs') (cs <> cs')

288+ mempty = CollectedWarnings mempty mempty mempty mempty

289+ mappend (CollectedWarnings as bs cs d)

290+ (CollectedWarnings as' bs' cs' d') =

291+ CollectedWarnings (as <> as') (bs <> bs') (cs <> cs') (d <> d')

299292

300293collectWarnings :: [PackageWarning] -> CollectedWarnings

301294collectWarnings = foldMap singular

302295 where

303296 singular w = case w of

304− NoResolvedVersion pn -> CollectedWarnings [pn] [] []

305− UndeclaredDependency pn -> CollectedWarnings [] [pn] []

306− UnacceptableVersion t -> CollectedWarnings [] [] [t]

297+ NoResolvedVersion pn -> CollectedWarnings [pn] mempty mempty mempty

298+ UndeclaredDependency pn -> CollectedWarnings mempty [pn] mempty mempty

299+ UnacceptableVersion t -> CollectedWarnings mempty mempty [t] mempty

300+ DirtyWorkingTree_Warn -> CollectedWarnings mempty mempty mempty (Any True)

307301

308302renderWarnings :: [PackageWarning] -> Box

309303renderWarnings warns =

@@ -312,6 +306,9 @@ renderWarnings warns =

312306 mboxes = [ go warnNoResolvedVersions noResolvedVersions

313307 , go warnUndeclaredDependencies undeclaredDependencies

314308 , go warnUnacceptableVersions unacceptableVersions

309+ , if getAny dirtyWorkingTree

310+ then Just warnDirtyWorkingTree

311+ else Nothing

315312 ]

316313 in case catMaybes mboxes of

317314 [] -> nullBox

@@ -387,5 +384,12 @@ warnUnacceptableVersions pkgs =

387384 where

388385 showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag

389386

387+warnDirtyWorkingTree :: Box

388+warnDirtyWorkingTree =

389+ para (concat

390+ [ "Your working tree is dirty. (Note: this would be an error if it "

391+ , "were not a dry run)"

392+ ])

393+

390394printWarnings :: [PackageWarning] -> IO ()

391395printWarnings = printToStderr . renderWarnings

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

@@ -158,7 +158,7 @@ resolveImport currentModule importModule exps imps impQual =

158158 -- Import something explicitly

159159 importExplicit :: Imports -> DeclarationRef -> m Imports

160160 importExplicit imp (PositionedDeclarationRef pos _ r) =

161− rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r

161+ warnAndRethrowWithPosition pos $ importExplicit imp r

162162 importExplicit imp (ValueRef name) = do

163163 values' <- updateImports (importedValues imp) showIdent (exportedValues exps) name

164164 return $ imp { importedValues = values' }

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+16−13

@@ -52,17 +52,19 @@ deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (derive

5252deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration

5353deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)

5454 | className == Qualified (Just dataGeneric) (ProperName C.generic)

55− , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty

55+ , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty

5656 , mn == fromMaybe mn mn'

57− = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon

57+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args

5858deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

5959 = throwError . errorMessage $ CannotDerive className tys

6060deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

6161deriveInstance _ _ e = return e

6262

63−unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)

64−unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon

65−unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty

63+unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName, [Type])

64+unwrapTypeConstructor (TypeConstructor tyCon) = Just (tyCon, [])

65+unwrapTypeConstructor (TypeApp ty arg) = do

66+ (tyCon, args) <- unwrapTypeConstructor ty

67+ return (tyCon, arg : args)

6668unwrapTypeConstructor _ = Nothing

6769

6870dataGeneric :: ModuleName

@@ -71,12 +73,12 @@ dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

7173dataMaybe :: ModuleName

7274dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]

7375

74−deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]

75−deriveGeneric mn ds tyConNm = do

76+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> [Type] -> m [Declaration]

77+deriveGeneric mn ds tyConNm args = do

7678 tyCon <- findTypeDecl tyConNm ds

7779 toSpine <- mkSpineFunction mn tyCon

7880 fromSpine <- mkFromSpineFunction mn tyCon

79− let toSignature = mkSignatureFunction mn tyCon

81+ let toSignature = mkSignatureFunction mn tyCon args

8082 return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)

8183 , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)

8284 , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)

@@ -118,8 +120,8 @@ mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorCl

118120mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d

119121mkSpineFunction _ _ = internalError "mkSpineFunction: expected DataDeclaration"

120122

121−mkSignatureFunction :: ModuleName -> Declaration -> Expr

122−mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args

123+mkSignatureFunction :: ModuleName -> Declaration -> [Type] -> Expr

124+mkSignatureFunction _ (DataDeclaration _ _ tyArgs args) classArgs = lamNull . mkSigProd $ map mkProdClause args

123125 where

124126 mkSigProd :: [Expr] -> Expr

125127 mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral

@@ -132,7 +134,7 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

132134

133135 mkProdClause :: (ProperName, [Type]) -> Expr

134136 mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))

135− , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)

137+ , ("sigValues", ArrayLiteral . map (mkProductSignature . instantiate) $ tys)

136138 ]

137139

138140 mkProductSignature :: Type -> Expr

@@ -144,8 +146,9 @@ mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map m

144146 ]

145147 mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)

146148 (TypedValue False (mkGenVar "anyProxy") (proxy typ))

147−mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d

148−mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149+ instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs)

150+mkSignatureFunction mn (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction mn d classArgs

151+mkSignatureFunction _ _ _ = internalError "mkSignatureFunction: expected DataDeclaration"

149152

150153mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr

151154mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)

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

@@ -211,21 +211,21 @@ freshDictionaryName = do

211211

212212-- | Run a computation in the substitution monad, generating a return value and the final substitution.

213213liftUnify ::

214− (MonadState CheckState m, MonadWriter MultipleErrors m) =>

214+ (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

215215 m a ->

216216 m (a, Substitution)

217217liftUnify = liftUnifyWarnings (const id)

218218

219219-- | Run a computation in the substitution monad, generating a return value, the final substitution and updating warnings values.

220220liftUnifyWarnings ::

221− (MonadState CheckState m, MonadWriter MultipleErrors m) =>

221+ (Functor m, MonadState CheckState m, MonadWriter MultipleErrors m, MonadError MultipleErrors m) =>

222222 (Substitution -> ErrorMessage -> ErrorMessage) ->

223223 m a ->

224224 m (a, Substitution)

225225liftUnifyWarnings replace ma = do

226226 orig <- get

227227 modify $ \st -> st { checkSubstitution = emptySubstitution }

228− (a, w) <- censor (const mempty) . listen $ ma

228+ (a, w) <- reflectErrors . censor (const mempty) . reifyErrors . listen $ ma

229229 subst <- gets checkSubstitution

230230 tell . onErrorMessages (replace subst) $ w

231231 modify $ \st -> st { checkSubstitution = checkSubstitution orig }