a74e6e5 · rowtype-yoga/purescript-native

CONTRIBUTORS.md+1

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

56- [@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).

57- [@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).

58<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).

59

60

60### Companies

61### Companies

61

62

README.md+1

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

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

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

28- [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

17 | D { a :: a }

18 | E Void

19

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)

21

25

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

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

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

27main = 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)

9

10import qualified Paths_purescript as Paths

11import Language.PureScript.Publish

12+import Language.PureScript.Publish.ErrorsWarnings

12

13

13dryRun :: Parser Bool

14dryRun :: Parser Bool

14dryRun = switch $

15dryRun = switch $

15 long "dry-run"

16 long "dry-run"

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

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

17

18

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+

18main :: IO ()

26main :: IO ()

19main = execParser opts >>= publish

27main = execParser opts >>= publish

20 where

28 where

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

30publish isDryRun =

38publish isDryRun =

31 if isDryRun

39 if isDryRun

32 then do

40 then do

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

41+ _ <- preparePackage dryRunOptions

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

35 putStrLn "Dry run completed, no errors."

42 putStrLn "Dry run completed, no errors."

36 else do

43 else do

37 pkg <- preparePackage defaultPublishOptions

44 pkg <- preparePackage defaultPublishOptions

psci/PSCi.hs+101−15

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

24import Prelude.Compat

25

26import Data.Foldable (traverse_)

27+import Data.Maybe (mapMaybe)

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

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

28import Data.Tuple (swap)

29import Data.Tuple (swap)

29import Data.Version (showVersion)

30import Data.Version (showVersion)

30import qualified Data.Map as M

31import qualified Data.Map as M

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

48import System.FilePath.Glob (glob)

49import System.FilePath.Glob (glob)

49import System.Process (readProcessWithExitCode)

50import System.Process (readProcessWithExitCode)

50import System.IO.Error (tryIOError)

51import System.IO.Error (tryIOError)

52+import qualified Text.PrettyPrint.Boxes as Box

51

53

52import qualified Language.PureScript as P

54import qualified Language.PureScript as P

53import qualified Language.PureScript.Names as N

55import qualified Language.PureScript.Names as N

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

374-- Pretty print a module's signatures

376-- Pretty print a module's signatures

375--

377--

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

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

377−printModuleSignatures moduleName env =

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

378− PSCI $ let namesEnv = P.names env

380+ PSCI $

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

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

380− in case moduleNamesIdent of

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

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

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

382− _ -> ( outputStrLn

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

383− . unlines

385+

384− . sort

386+ in

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

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+

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

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

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

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

398+

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

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

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

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

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

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+

391

477

392-- |

478-- |

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

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

purescript.cabal+3−2

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

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

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

215 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

217

218

218 main-is: Main.hs

219 main-is: Main.hs

219 buildable: True

220 buildable: True

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

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

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

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

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

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

303 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

304 type: exitcode-stdio-1.0

305 type: exitcode-stdio-1.0

305 main-is: Main.hs

306 main-is: Main.hs

306 other-modules: TestsSetup

307 other-modules: TestsSetup

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

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

71renderChildDeclarationWithOptions opts ChildDeclaration{..} =

72 mintersperse sp $ case cdeclInfo of

73 ChildInstance constraints ty ->

74− [ keywordInstance

75− , ident cdeclTitle

76− , syntax "::"

77− ] ++ maybeToList (renderConstraints constraints)

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

78− ++ [ renderType' ty ]

79 ChildDataConstructor args ->

75 ChildDataConstructor args ->

80 [ renderType' typeApp' ]

76 [ renderType' typeApp' ]

81 where

77 where

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

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

32import Control.Monad.Writer

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

34import Control.Monad.Trans.State.Lazy

35−import Control.Arrow(first)

35+import Control.Arrow (first)

36

37import Language.PureScript.Crash

38import Language.PureScript.AST

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

139 | ImportHidingModule ModuleName

140 | UnusedImport ModuleName

141 | UnusedExplicitImport ModuleName [String]

142+ | UnusedDctorImport ProperName

143+ | UnusedDctorExplicitImport ProperName [ProperName]

142 deriving (Show)

144 deriving (Show)

143

145

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

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

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

271 ImportHidingModule{} -> "ImportHidingModule"

273 ImportHidingModule{} -> "ImportHidingModule"

272 UnusedImport{} -> "UnusedImport"

274 UnusedImport{} -> "UnusedImport"

273 UnusedExplicitImport{} -> "UnusedExplicitImport"

275 UnusedExplicitImport{} -> "UnusedExplicitImport"

276+ UnusedDctorImport{} -> "UnusedDctorImport"

277+ UnusedDctorExplicitImport{} -> "UnusedDctorExplicitImport"

278+

274

279

275-- |

280-- |

276-- A stack trace for an error

281-- A stack trace for an error

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

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

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

681 , indent $ paras $ map line names ]

686 , indent $ paras $ map line names ]

682

687

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+

683 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

695 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

684 renderHint (ErrorUnifyingTypes t1 t2) detail =

696 renderHint (ErrorUnifyingTypes t1 t2) detail =

685 paras [ detail

697 paras [ detail

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

938 where

950 where

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

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

940

952

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−

949-- |

953-- |

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

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

951--

955--

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

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

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

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

954

958

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+

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

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

956warnAndRethrow f = rethrow f . censor f

966warnAndRethrow f = rethrow f . censor f

957

967

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

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

8

9import qualified Data.Map as M

10import Data.Maybe (mapMaybe)

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

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

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

13import Control.Monad.Writer.Class

14import Control.Monad(unless,when)

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

35-- or references in an explicit import list.

36--

37findUnusedImports :: 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

39 imps <- findImports mdecls

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

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

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

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

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

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

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

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

45+ usedDctors = mapMaybe (matchDctor qualifierName) names

43− case declType of

46+ in case declType of

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

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

45− Explicit declrefs -> do

48+ Explicit declrefs -> do

46− let idents = mapMaybe runDeclRef declrefs

49+ let idents = mapMaybe runDeclRef declrefs

47− let diff = idents \\ usedNames

50+ let diff = idents \\ usedNames

51+ case (length diff, length idents) of

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

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

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

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+

49− _ -> return ()

68+ _ -> return ()

50 where

69 where

51− sugarNames :: [ Name ]

70+ sugarNames :: ModuleName -> [ Name ]

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

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

53

84

54− autoIncludes :: [ ModuleName ]

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

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

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

56

94

57 typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

95 typeForDCtor :: ModuleName -> ProperName -> Maybe ProperName

58 typeForDCtor mn pn =

96 typeForDCtor mn pn =

59− getTy <$> find matches tys

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

60 where

98 where

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

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

62 getTy ((ty, _), _) = ty

100 getTy ((ty, _), _) = ty

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

101+

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

65

102

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

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

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

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

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

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

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

70matchName _ _ _ = Nothing

107matchName _ _ _ = Nothing

71

108

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

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

111+matchDctor _ _ = Nothing

112+

72runDeclRef :: DeclarationRef -> Maybe String

113runDeclRef :: DeclarationRef -> Maybe String

73runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

114runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref

74runDeclRef (ValueRef ident) = Just $ showIdent ident

115runDeclRef (ValueRef ident) = Just $ showIdent ident

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

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

76runDeclRef _ = Nothing

117runDeclRef _ = Nothing

77

118

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+

78addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

124addModuleLocError :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

79addModuleLocError sp err =

125addModuleLocError sp err =

80 case sp of

126 case sp of

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

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

8 , preparePackage'

9 , PrepareM()

10 , runPrepareM

11+ , warn

12+ , userError

13+ , internalError

14+ , otherError

11 , PublishOptions(..)

15 , PublishOptions(..)

12 , defaultPublishOptions

16 , defaultPublishOptions

13 , getGitWorkingTreeStatus

17 , getGitWorkingTreeStatus

14− , requireCleanWorkingTree

18+ , checkCleanWorkingTree

15 , getVersionFromGitTag

19 , getVersionFromGitTag

16 , getBowerInfo

20 , getBowerInfo

17 , getModulesAndBookmarks

21 , getModulesAndBookmarks

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

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

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

64 -- generated will refer to.

68 -- generated will refer to.

65 publishGetVersion :: PrepareM (String, Version)

69 publishGetVersion :: PrepareM (String, Version)

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

71+ publishWorkingTreeDirty :: PrepareM ()

66 }

72 }

67

73

68defaultPublishOptions :: PublishOptions

74defaultPublishOptions :: PublishOptions

69defaultPublishOptions = PublishOptions

75defaultPublishOptions = PublishOptions

70 { publishGetVersion = getVersionFromGitTag

76 { publishGetVersion = getVersionFromGitTag

77+ , publishWorkingTreeDirty = userError DirtyWorkingTree

71 }

78 }

72

79

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

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

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

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

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

120 unless exists (userError BowerJSONNotFound)

127 unless exists (userError BowerJSONNotFound)

121

128

122− requireCleanWorkingTree

129+ checkCleanWorkingTree opts

123

130

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

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

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

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

126 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

133 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

127 pkgGithub <- getBowerInfo pkgMeta

134 pkgGithub <- getBowerInfo pkgMeta

128 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

135 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

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

155 then Clean

162 then Clean

156 else Dirty

163 else Dirty

157

164

158−requireCleanWorkingTree :: PrepareM ()

165+checkCleanWorkingTree :: PublishOptions -> PrepareM ()

159−requireCleanWorkingTree = do

166+checkCleanWorkingTree opts = do

160 status <- getGitWorkingTreeStatus

167 status <- getGitWorkingTreeStatus

161 unless (status == Clean) $

168 unless (status == Clean) $

162− userError DirtyWorkingTree

169+ publishWorkingTreeDirty opts

163

170

164getVersionFromGitTag :: PrepareM (String, Version)

171getVersionFromGitTag :: PrepareM (String, Version)

165getVersionFromGitTag = do

172getVersionFromGitTag = do

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

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

29import qualified Data.Text as T

30

31import Control.Exception (IOException)

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

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

33import qualified Web.Bower.PackageMeta as Bower

34

35import qualified Language.PureScript as P

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

49 = NoResolvedVersion PackageName

50 | UndeclaredDependency PackageName

51 | UnacceptableVersion (PackageName, String)

52+ | DirtyWorkingTree_Warn

52 deriving (Show)

53 deriving (Show)

53

54

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

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

55data UserError

56data UserError

56 = BowerJSONNotFound

57 = BowerJSONNotFound

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

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

58− | CouldntParseBowerJSON (ParseError BowerError)

59+ | CouldntDecodeBowerJSON (ParseError BowerError)

59− | BowerJSONNameMissing

60 | TagMustBeCheckedOut

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

62 | BadRepositoryField RepositoryFieldError

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

130 ])

131 where

132 format = intercalate ", " . map show

133− CouldntParseBowerJSON err ->

133+ CouldntDecodeBowerJSON err ->

134 vcat

135− [ successivelyIndented

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

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

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

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

137+ , spacer

138− ]

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

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

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

148 ]

139 ]

149 TagMustBeCheckedOut ->

140 TagMustBeCheckedOut ->

150 vcat

141 vcat

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

289 { noResolvedVersions :: [PackageName]

280 { noResolvedVersions :: [PackageName]

290 , undeclaredDependencies :: [PackageName]

281 , undeclaredDependencies :: [PackageName]

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

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

283+ , dirtyWorkingTree :: Any

292 }

284 }

293 deriving (Show, Eq, Ord)

285 deriving (Show, Eq, Ord)

294

286

295instance Monoid CollectedWarnings where

287instance Monoid CollectedWarnings where

296− mempty = CollectedWarnings mempty mempty mempty

288+ mempty = CollectedWarnings mempty mempty mempty mempty

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

289+ mappend (CollectedWarnings as bs cs d)

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

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

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

299

292

300collectWarnings :: [PackageWarning] -> CollectedWarnings

293collectWarnings :: [PackageWarning] -> CollectedWarnings

301collectWarnings = foldMap singular

294collectWarnings = foldMap singular

302 where

295 where

303 singular w = case w of

296 singular w = case w of

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

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

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

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

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

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

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

307

301

308renderWarnings :: [PackageWarning] -> Box

302renderWarnings :: [PackageWarning] -> Box

309renderWarnings warns =

303renderWarnings warns =

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

312 mboxes = [ go warnNoResolvedVersions noResolvedVersions

306 mboxes = [ go warnNoResolvedVersions noResolvedVersions

313 , go warnUndeclaredDependencies undeclaredDependencies

307 , go warnUndeclaredDependencies undeclaredDependencies

314 , go warnUnacceptableVersions unacceptableVersions

308 , go warnUnacceptableVersions unacceptableVersions

309+ , if getAny dirtyWorkingTree

310+ then Just warnDirtyWorkingTree

311+ else Nothing

315 ]

312 ]

316 in case catMaybes mboxes of

313 in case catMaybes mboxes of

317 [] -> nullBox

314 [] -> nullBox

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

387 where

384 where

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

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

389

386

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+

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

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

391printWarnings = printToStderr . renderWarnings

395printWarnings = printToStderr . renderWarnings

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

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

158 -- Import something explicitly

159 importExplicit :: Imports -> DeclarationRef -> m Imports

160 importExplicit imp (PositionedDeclarationRef pos _ r) =

161− rethrowWithPosition pos . warnWithPosition pos $ importExplicit imp r

161+ warnAndRethrowWithPosition pos $ importExplicit imp r

162 importExplicit imp (ValueRef name) = do

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

164 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

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

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

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

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

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

56 , 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

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

59 = throwError . errorMessage $ CannotDerive className tys

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

61deriveInstance _ _ e = return e

62

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

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

64−unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon

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

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

65+unwrapTypeConstructor (TypeApp ty arg) = do

66+ (tyCon, args) <- unwrapTypeConstructor ty

67+ return (tyCon, arg : args)

66unwrapTypeConstructor _ = Nothing

68unwrapTypeConstructor _ = Nothing

67

69

68dataGeneric :: ModuleName

70dataGeneric :: ModuleName

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

71dataMaybe :: ModuleName

73dataMaybe :: ModuleName

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

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

73

75

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

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

75−deriveGeneric mn ds tyConNm = do

77+deriveGeneric mn ds tyConNm args = do

76 tyCon <- findTypeDecl tyConNm ds

78 tyCon <- findTypeDecl tyConNm ds

77 toSpine <- mkSpineFunction mn tyCon

79 toSpine <- mkSpineFunction mn tyCon

78 fromSpine <- mkFromSpineFunction mn tyCon

80 fromSpine <- mkFromSpineFunction mn tyCon

79− let toSignature = mkSignatureFunction mn tyCon

81+ let toSignature = mkSignatureFunction mn tyCon args

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

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

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

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

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

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

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

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

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

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

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

120

122

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

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

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

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

123 where

125 where

124 mkSigProd :: [Expr] -> Expr

126 mkSigProd :: [Expr] -> Expr

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

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

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

132

134

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

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

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

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

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

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

136 ]

138 ]

137

139

138 mkProductSignature :: Type -> Expr

140 mkProductSignature :: Type -> Expr

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

144 ]

146 ]

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

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

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

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

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

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

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

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

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

149

152

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

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

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

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

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

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

211

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

213liftUnify ::

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

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

215 m a ->

216 m (a, Substitution)

217liftUnify = liftUnifyWarnings (const id)

218

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

220liftUnifyWarnings ::

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

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

222 (Substitution -> ErrorMessage -> ErrorMessage) ->

223 m a ->

224 m (a, Substitution)

225liftUnifyWarnings replace ma = do

226 orig <- get

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

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

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

229 subst <- gets checkSubstitution

230 tell . onErrorMessages (replace subst) $ w

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