5621449 · rowtype-yoga/purescript-native

.travis.yml+6−6

compare with golang

unifiedsplit

@@ -9,8 +9,8 @@ matrix:

9 - env: GHCVER=7.8.4 COVERAGE_SUITE=psci-tests

10 compiler: ": #GHC 7.8.4 - psci-tests"

11 addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

12− - env: GHCVER=7.8.4 STACKAGE=lts-22

12+ - env: GHCVER=7.8.4 STACKAGE=lts-2.22

13− compiler: ": #GHC 7.8.4 - lts-2.22"

13+ compiler: ": #GHC 7.8.4 - lts-2.22-1"

14 addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

15 - env: GHCVER=7.6.3

16 compiler: ": #GHC 7.6.3"

@@ -18,11 +18,11 @@ matrix:

18 - env: GHCVER=7.10.1

19 compiler: ": #GHC 7.10.1"

20 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

21− - env: GHCVER=7.10.2 STACKAGE=lts=3.4 RUNSDISTTESTS=YES

21+ - env: GHCVER=7.10.2 STACKAGE=lts=3.6 RUNSDISTTESTS=YES

22− compiler: ": #GHC 7.10.2 lts-3.4"

22+ compiler: ": #GHC 7.10.2 lts-3.6"

23 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

24− - env: GHCVER=7.10.2 STACKAGE=nightly-2015-08-24

24+ - env: GHCVER=7.10.2 STACKAGE=nightly-2015-09-29

25− compiler: ": #GHC 7.10.2 nightly-2015-09-09"

25+ compiler: ": #GHC 7.10.2 nightly-2015-09-29"

26 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2,happy-1.19.5,alex-3.1.4], sources: [hvr-ghc]}}

27before_install:

28 - unset CC

CONTRIBUTORS.md+1

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

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

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

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

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

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

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

57

58

58### Companies

59### Companies

examples/passing/LargeSumType.pursnew file+33

@@ -0,0 +1,33 @@

1+module Main where

2+

3+data Large = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z

4+

5+explode A A = "A"

6+explode B B = "B"

7+explode C C = "C"

8+explode D D = "D"

9+explode E E = "E"

10+explode F F = "F"

11+explode G G = "G"

12+explode H H = "H"

13+explode I I = "I"

14+explode J J = "J"

15+explode K K = "K"

16+explode L L = "L"

17+explode M M = "M"

18+explode N N = "N"

19+explode O O = "O"

20+explode P P = "P"

21+explode Q Q = "Q"

22+explode R R = "R"

23+explode S S = "S"

24+explode T T = "T"

25+explode U U = "U"

26+explode V V = "V"

27+explode W W = "W"

28+explode X X = "X"

29+explode Y Y = "Y"

30+explode Z Z = "Z"

31+explode _ _ = ""

32+

33+main = Control.Monad.Eff.Console.log "Done"

examples/passing/OptionalQualified.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

2+

3+-- qualified import with the "qualified" keyword

4+import qualified Prelude as P

5+

6+-- qualified import without the "qualified" keyword

7+import Control.Monad.Eff.Console as Console

8+

9+bind = P.bind

10+

11+main = do

12+ message <- P.return "success!"

13+ Console.log message

examples/passing/QualifiedQualifiedImports.pursnew file+6

@@ -0,0 +1,6 @@

1+module Main where

2+

3+-- qualified import with qualified imported names

4+import qualified Control.Monad.Eff.Console (log) as Console

5+

6+main = Console.log "Success!"

examples/passing/UTF8Sourcefile.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

2+

3+import Control.Monad.Eff.Console

4+

5+-- '→' is multibyte sequence \u2192.

6+utf8multibyte = "Hello λ→ world!!"

7+

8+main = do

9+ log "done"

10+

psc/Main.hs+4−2

@@ -32,6 +32,7 @@ import Options.Applicative as Opts

32

33import System.Exit (exitSuccess, exitFailure)

34import System.IO (hPutStrLn, stderr)

35+import System.IO.UTF8

35import System.FilePath.Glob (glob)

36import System.FilePath.Glob (glob)

36

37

37import qualified Language.PureScript as P

38import qualified Language.PureScript as P

@@ -60,7 +61,7 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d

60 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input

61 let (jsFiles, pursFiles) = partition (isSuffixOf ".js") input

61 moduleFiles <- readInput (InputOptions pursFiles)

62 moduleFiles <- readInput (InputOptions pursFiles)

62 inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob

63 inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob

63− foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readFile inFile)

64+ foreignFiles <- forM (inputForeign ++ jsFiles) (\inFile -> (inFile,) <$> readUTF8File inFile)

64 case runWriterT (parseInputs moduleFiles foreignFiles) of

65 case runWriterT (parseInputs moduleFiles foreignFiles) of

65 Left errs -> do

66 Left errs -> do

66 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

67 hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)

@@ -93,7 +94,7 @@ globWarningOnMisses warn = concatMapM globWithWarning

93 concatMapM f = liftM concat . mapM f

94 concatMapM f = liftM concat . mapM f

94

95

95readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

96readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

96−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

97+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readUTF8File inFile

97

98

98parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

99parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)

99 => [(Either P.RebuildPolicy FilePath, String)]

100 => [(Either P.RebuildPolicy FilePath, String)]

@@ -178,6 +179,7 @@ pscMakeOptions = PSCMakeOptions <$> many inputFile

178 <*> options

179 <*> options

179 <*> (not <$> noPrefix)

180 <*> (not <$> noPrefix)

180

181

182+

181main :: IO ()

183main :: IO ()

182main = execParser opts >>= compile

184main = execParser opts >>= compile

183 where

185 where

purescript.cabal+2−1

@@ -58,7 +58,7 @@ library

58 language-javascript == 0.5.*,

59 syb -any,

60 Glob >= 0.7 && < 0.8,

61− process >= 1.2.0 && < 1.3,

61+ process >= 1.2.0 && < 1.4,

62 safe >= 0.3.9 && < 0.4,

63 semigroups >= 0.16.2 && < 0.18

64

@@ -165,6 +165,7 @@ library

165 Control.Monad.Supply

166 Control.Monad.Supply.Class

167

168+ System.IO.UTF8

168 exposed: True

169 exposed: True

169 buildable: True

170 buildable: True

170 hs-source-dirs: src

171 hs-source-dirs: src

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

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

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

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

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

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

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

70

71 typeName (TypeRef n _) = Just n

72 typeName (PositionedDeclarationRef _ _ r) = typeName r

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

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

385 where

386 isElementEmpty :: ModuleElement -> Bool

387 isElementEmpty (ExportsList exps) = null exps

388− isElementEmpty (Require _ _ _) = True

388+ isElementEmpty Require{} = True

389 isElementEmpty (Other _) = True

390 isElementEmpty _ = False

391

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

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

27 ) where

28

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

30+import Data.Maybe (isNothing)

30import qualified Data.Traversable as T (traverse)

31import qualified Data.Traversable as T (traverse)

31

32

32#if __GLASGOW_HASKELL__ < 710

33#if __GLASGOW_HASKELL__ < 710

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

62 comments <- not <$> asks optionsNoComments

63 comments <- not <$> asks optionsNoComments

63 let strict = JSStringLiteral "use strict"

64 let strict = JSStringLiteral "use strict"

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

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

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

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

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

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

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

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

68 let standardExps = exps \\ foreignExps

69 let standardExps = exps \\ foreignExps

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

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

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

256 convert other = return other

257 isFnCompose :: JS -> JS -> Bool

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

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

259

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

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

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

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

124 hasFunction :: JS -> Bool

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

126 where

127− isFunction (JSFunction _ _ _) = True

127+ isFunction JSFunction{} = True

128 isFunction _ = False

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

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

29 where

30 go :: [JS] -> [JS]

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

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

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

33 isJSReturn (JSReturn _) = True

34 isJSReturn _ = False

35

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

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

101instance Functor CaseAlternative where

102

103 fmap f (CaseAlternative cabs car) = CaseAlternative

104− (fmap (fmap f) $ cabs)

104+ (fmap (fmap f) cabs)

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

106

107-- |

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

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

147 basicDeclaration title (ExternDataDeclaration kind')

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

149 basicDeclaration title (TypeSynonymDeclaration args ty)

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

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

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

152 where

153 info = TypeClassDeclaration args implies

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

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

159 convertClassMember _ =

160 error "Invalid argument to convertClassMember."

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

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

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

163 where

164 classNameString = unQual className

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

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

10

11module Language.PureScript.Docs.Render where

12

13+import Data.Maybe (maybeToList)

13import Data.Monoid ((<>))

14import Data.Monoid ((<>))

14import qualified Language.PureScript as P

15import qualified Language.PureScript as P

15

16

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

46 ]

47 ]

47 TypeClassDeclaration args implies ->

48 TypeClassDeclaration args implies ->

48 [ keywordClass ]

49 [ keywordClass ]

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

50+ ++ maybeToList superclasses

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

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

51 ++ if any (isTypeClassMember . cdeclInfo) declChildren

52 ++ if any (isTypeClassMember . cdeclInfo) declChildren

52 then [keywordWhere]

53 then [keywordWhere]

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

75 [ keywordInstance

76 [ keywordInstance

76 , ident cdeclTitle

77 , ident cdeclTitle

77 , syntax "::"

78 , syntax "::"

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

79+ ] ++ maybeToList (renderConstraints constraints)

79 ++ [ renderType' ty ]

80 ++ [ renderType' ty ]

80 ChildDataConstructor args ->

81 ChildDataConstructor args ->

81 [ renderType' typeApp' ]

82 [ renderType' typeApp' ]

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

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

425

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

427 toJSON Package{..} =

428− A.object $

428+ A.object

429 [ "packageMeta" .= pkgMeta

430 , "version" .= showVersion pkgVersion

431 , "versionTag" .= pkgVersionTag

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

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

20module Language.PureScript.Errors where

21

22import Data.Either (lefts, rights)

23−import Data.List (intercalate, transpose)

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

24import Data.Function (on)

25#if __GLASGOW_HASKELL__ < 710

26import Data.Foldable (fold, foldMap)

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

52import qualified Text.Parsec as P

53import qualified Text.Parsec.Error as PE

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

55−import Data.List (nub)

56

55

57-- |

56-- |

58-- A type of error messages

57-- A type of error messages

@@ -100,6 +99,7 @@ data SimpleErrorMessage

100 | CtorConflictsWithClass ProperName

99 | CtorConflictsWithClass ProperName

101 | ClassConflictsWithType ProperName

100 | ClassConflictsWithType ProperName

102 | ClassConflictsWithCtor ProperName

101 | ClassConflictsWithCtor ProperName

102+ | DuplicateModuleName ModuleName

103 | DuplicateClassExport ProperName

104 | DuplicateValueExport Ident

105 | DuplicateTypeArgument String

@@ -145,6 +145,7 @@ data SimpleErrorMessage

145 | WildcardInferredType Type

146 | NotExhaustivePattern [[Binder]] Bool

147 | OverlappingPattern [[Binder]] Bool

148+ | IncompleteExhaustivityCheck

148 | ClassOperator ProperName Ident

149 | ClassOperator ProperName Ident

149 | MisleadingEmptyTypeImport ModuleName ProperName

150 | MisleadingEmptyTypeImport ModuleName ProperName

150 | ImportHidingModule ModuleName

151 | ImportHidingModule ModuleName

@@ -229,6 +230,7 @@ errorCode em = case unwrapErrorMessage em of

229 CtorConflictsWithClass{} -> "CtorConflictsWithClass"

230 CtorConflictsWithClass{} -> "CtorConflictsWithClass"

230 ClassConflictsWithType{} -> "ClassConflictsWithType"

231 ClassConflictsWithType{} -> "ClassConflictsWithType"

231 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"

232 ClassConflictsWithCtor{} -> "ClassConflictsWithCtor"

233+ DuplicateModuleName{} -> "DuplicateModuleName"

232 DuplicateClassExport{} -> "DuplicateClassExport"

234 DuplicateClassExport{} -> "DuplicateClassExport"

233 DuplicateValueExport{} -> "DuplicateValueExport"

235 DuplicateValueExport{} -> "DuplicateValueExport"

234 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

236 DuplicateTypeArgument{} -> "DuplicateTypeArgument"

@@ -274,6 +276,7 @@ errorCode em = case unwrapErrorMessage em of

274 WildcardInferredType{} -> "WildcardInferredType"

276 WildcardInferredType{} -> "WildcardInferredType"

275 NotExhaustivePattern{} -> "NotExhaustivePattern"

277 NotExhaustivePattern{} -> "NotExhaustivePattern"

276 OverlappingPattern{} -> "OverlappingPattern"

278 OverlappingPattern{} -> "OverlappingPattern"

279+ IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

277 ClassOperator{} -> "ClassOperator"

280 ClassOperator{} -> "ClassOperator"

278 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

281 MisleadingEmptyTypeImport{} -> "MisleadingEmptyTypeImport"

279 ImportHidingModule{} -> "ImportHidingModule"

282 ImportHidingModule{} -> "ImportHidingModule"

@@ -364,33 +367,33 @@ replaceUnknowns = everywhereOnTypesM replaceTypes

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

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

365onTypesInErrorMessageM f = g

368onTypesInErrorMessageM f = g

366 where

369 where

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

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

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

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

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

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

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

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

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

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

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

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

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

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

374 gSimple other = pure other

377 gSimple other = pure other

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

395

398

396-- |

399-- |

@@ -524,6 +527,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

524 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

527 line $ "Type class " ++ runProperName nm ++ " conflicts with type declaration of the same name"

525 goSimple (ClassConflictsWithCtor nm) =

528 goSimple (ClassConflictsWithCtor nm) =

526 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

529 line $ "Type class " ++ runProperName nm ++ " conflicts with data constructor declaration of the same name"

530+ goSimple (DuplicateModuleName mn) =

531+ line $ "Module " ++ runModuleName mn ++ " has been defined multiple times."

527 goSimple (DuplicateClassExport nm) =

532 goSimple (DuplicateClassExport nm) =

528 line $ "Duplicate export declaration for type class " ++ runProperName nm

533 line $ "Duplicate export declaration for type class " ++ runProperName nm

529 goSimple (DuplicateValueExport nm) =

534 goSimple (DuplicateValueExport nm) =

@@ -662,6 +667,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

662 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

667 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

663 ] ++

668 ] ++

664 [ line "..." | not b ]

669 [ line "..." | not b ]

670+ goSimple IncompleteExhaustivityCheck =

671+ paras [ line "An exhaustivity check was abandoned due to too many possible cases."

672+ , line "You may want to decomposing your data types into smaller types."

673+ ]

665 go (NotYetDefined names err) =

674 go (NotYetDefined names err) =

666 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

675 paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map showIdent names) ++ ":"

667 , indent $ go err

676 , indent $ go err

@@ -732,7 +741,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

732 , go err

741 , go err

733 ]

742 ]

734 go (ErrorInDataBindingGroup err) =

743 go (ErrorInDataBindingGroup err) =

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

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

736 , go err

745 , go err

737 ]

746 ]

738 go (ErrorInTypeSynonym name err) =

747 go (ErrorInTypeSynonym name err) =

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

851 , result

860 , result

852 ]

861 ]

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

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

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

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

855 return $

864 return $

856 Box.vcat Box.left [ Box.text intro

865 Box.vcat Box.left [ Box.text intro

857 , Box.vsep 1 Box.left result

866 , Box.vsep 1 Box.left result

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

859

868

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

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

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

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

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

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

863

872

864-- |

873-- |

865-- Pretty print ParseError detail messages.

874-- Pretty print ParseError detail messages.

@@ -872,9 +881,9 @@ prettyPrintParseErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEnd

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

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

873

882

874 where

883 where

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

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

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

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

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

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

878

887

879 showExpect = showMany msgExpecting expect

888 showExpect = showMany msgExpecting expect

880 showUnExpect = showMany msgUnExpected unExpect

889 showUnExpect = showMany msgUnExpected unExpect

@@ -922,7 +931,7 @@ renderBox = unlines . map trimEnd . lines . Box.render

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

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

923interpretMultipleErrorsAndWarnings (err, ws) = do

932interpretMultipleErrorsAndWarnings (err, ws) = do

924 tell ws

933 tell ws

925− either throwError return $ err

934+ either throwError return err

926

935

927-- |

936-- |

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

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

src/Language/PureScript/Linter/Exhaustive.hs+46−28

@@ -29,6 +29,9 @@ import qualified Data.Map as M

29import Data.Maybe (fromMaybe)

30import Data.List (foldl', sortBy, nub)

31import Data.Function (on)

32+#if __GLASGOW_HASKELL__ < 710

33+import Data.Traversable (sequenceA)

34+#endif

32

35

33import Control.Monad (unless)

36import Control.Monad (unless)

34import Control.Applicative

37import Control.Applicative

@@ -45,6 +48,14 @@ import Language.PureScript.Errors

45

48

46import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)

49import Language.PureScript.AST.Traversals (everywhereOnValuesTopDownM)

47

50

51+-- | There are two modes of failure for the redudancy check:

52+--

53+-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.

54+-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.

55+--

56+-- We want to warn the user in the first case.

57+data RedudancyError = Incomplete | Unknown

58+

48-- |

59-- |

49-- Qualifies a propername from a given qualified propername and a default module name

60-- Qualifies a propername from a given qualified propername and a default module name

50--

61--

@@ -59,20 +70,20 @@ qualifyName n defmn qn = Qualified (Just mn) n

59-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

70-- where: - ProperName is the name of the constructor (for example, "Nothing" in Maybe)

60-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

71-- - [Type] is the list of arguments, if it has (for example, "Just" has [TypeVar "a"])

61--

72--

62−getConstructors :: Environment -> ModuleName -> (Qualified ProperName) -> [(ProperName, [Type])]

73+getConstructors :: Environment -> ModuleName -> Qualified ProperName -> [(ProperName, [Type])]

63getConstructors env defmn n = extractConstructors lnte

74getConstructors env defmn n = extractConstructors lnte

64 where

75 where

65 qpn :: Qualified ProperName

76 qpn :: Qualified ProperName

66 qpn = getConsDataName n

77 qpn = getConsDataName n

67

78

68− getConsDataName :: (Qualified ProperName) -> (Qualified ProperName)

79+ getConsDataName :: Qualified ProperName -> Qualified ProperName

69 getConsDataName con = qualifyName nm defmn con

80 getConsDataName con = qualifyName nm defmn con

70 where

81 where

71 nm = case getConsInfo con of

82 nm = case getConsInfo con of

72 Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

83 Nothing -> error $ "Constructor " ++ showQualified runProperName con ++ " not in the scope of the current environment in getConsDataName."

73 Just (_, pm, _, _) -> pm

84 Just (_, pm, _, _) -> pm

74

85

75− getConsInfo :: (Qualified ProperName) -> Maybe (DataDeclType, ProperName, Type, [Ident])

86+ getConsInfo :: Qualified ProperName -> Maybe (DataDeclType, ProperName, Type, [Ident])

76 getConsInfo con = M.lookup con dce

87 getConsInfo con = M.lookup con dce

77 where

88 where

78 dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

89 dce :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])

@@ -103,27 +114,27 @@ genericMerge _ [] [] = []

103genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs

114genericMerge f bs [] = map (\(s, b) -> f s (Just b) Nothing) bs

104genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs

115genericMerge f [] bs = map (\(s, b) -> f s Nothing (Just b)) bs

105genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

116genericMerge f bsl@((s, b):bs) bsr@((s', b'):bs')

106− | s < s' = (f s (Just b) Nothing) : genericMerge f bs bsr

117+ | s < s' = f s (Just b) Nothing : genericMerge f bs bsr

107− | s > s' = (f s' Nothing (Just b')) : genericMerge f bsl bs'

118+ | s > s' = f s' Nothing (Just b') : genericMerge f bsl bs'

108− | otherwise = (f s (Just b) (Just b')) : genericMerge f bs bs'

119+ | otherwise = f s (Just b) (Just b') : genericMerge f bs bs'

109

120

110-- |

121-- |

111-- Find the uncovered set between two binders:

122-- Find the uncovered set between two binders:

112-- the first binder is the case we are trying to cover, the second one is the matching binder

123-- the first binder is the case we are trying to cover, the second one is the matching binder

113--

124--

114−missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Maybe Bool)

125+missingCasesSingle :: Environment -> ModuleName -> Binder -> Binder -> ([Binder], Either RedudancyError Bool)

115−missingCasesSingle _ _ _ NullBinder = ([], Just True)

126+missingCasesSingle _ _ _ NullBinder = ([], return True)

116−missingCasesSingle _ _ _ (VarBinder _) = ([], Just True)

127+missingCasesSingle _ _ _ (VarBinder _) = ([], return True)

117missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

128missingCasesSingle env mn (VarBinder _) b = missingCasesSingle env mn NullBinder b

118missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl

129missingCasesSingle env mn br (NamedBinder _ bl) = missingCasesSingle env mn br bl

119missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

130missingCasesSingle env mn NullBinder cb@(ConstructorBinder con _) =

120− (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, Just True)

131+ (concatMap (\cp -> fst $ missingCasesSingle env mn cp cb) allPatterns, return True)

121 where

132 where

122 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))

133 allPatterns = map (\(p, t) -> ConstructorBinder (qualifyName p mn con) (initialize $ length t))

123 $ getConstructors env mn con

134 $ getConstructors env mn con

124missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

135missingCasesSingle env mn cb@(ConstructorBinder con bs) (ConstructorBinder con' bs')

125 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

136 | con == con' = let (bs'', pr) = missingCasesMultiple env mn bs bs' in (map (ConstructorBinder con) bs'', pr)

126− | otherwise = ([cb], Just False)

137+ | otherwise = ([cb], return False)

127missingCasesSingle env mn NullBinder (ObjectBinder bs) =

138missingCasesSingle env mn NullBinder (ObjectBinder bs) =

128 (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

139 (map (ObjectBinder . zip (map fst bs)) allMisses, pr)

129 where

140 where

@@ -146,12 +157,12 @@ missingCasesSingle env mn (ObjectBinder bs) (ObjectBinder bs') =

146 compBS e s b b' = (s, compB e b b')

157 compBS e s b b' = (s, compB e b b')

147

158

148 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

159 (sortedNames, binders) = unzip $ genericMerge (compBS NullBinder) sbs sbs'

149−missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], Just True)

160+missingCasesSingle _ _ NullBinder (BooleanBinder b) = ([BooleanBinder $ not b], return True)

150missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

161missingCasesSingle _ _ (BooleanBinder bl) (BooleanBinder br)

151− | bl == br = ([], Just True)

162+ | bl == br = ([], return True)

152− | otherwise = ([BooleanBinder bl], Just False)

163+ | otherwise = ([BooleanBinder bl], return False)

153missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

164missingCasesSingle env mn b (PositionedBinder _ _ cb) = missingCasesSingle env mn b cb

154−missingCasesSingle _ _ b _ = ([b], Nothing)

165+missingCasesSingle _ _ b _ = ([b], Left Unknown)

155

166

156-- |

167-- |

157-- Returns the uncovered set of binders

168-- Returns the uncovered set of binders

@@ -179,7 +190,7 @@ missingCasesSingle _ _ b _ = ([b], Nothing)

179-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

190-- redundant or not, but uncovered at least. If we use `y` instead, we'll need to have a redundancy checker

180-- (which ought to be available soon), or increase the complexity of the algorithm.

191-- (which ought to be available soon), or increase the complexity of the algorithm.

181--

192--

182−missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Maybe Bool)

193+missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

183missingCasesMultiple env mn = go

194missingCasesMultiple env mn = go

184 where

195 where

185 go [] [] = ([], pure True)

196 go [] [] = ([], pure True)

@@ -213,10 +224,10 @@ isExhaustiveGuard (Right _) = True

213-- |

224-- |

214-- Returns the uncovered set of case alternatives

225-- Returns the uncovered set of case alternatives

215--

226--

216−missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Maybe Bool)

227+missingCases :: Environment -> ModuleName -> [Binder] -> CaseAlternative -> ([[Binder]], Either RedudancyError Bool)

217missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

228missingCases env mn uncovered ca = missingCasesMultiple env mn uncovered (caseAlternativeBinders ca)

218

229

219−missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Maybe Bool)

230+missingAlternative :: Environment -> ModuleName -> CaseAlternative -> [Binder] -> ([[Binder]], Either RedudancyError Bool)

220missingAlternative env mn ca uncovered

231missingAlternative env mn ca uncovered

221 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

232 | isExhaustiveGuard (caseAlternativeResult ca) = mcases

222 | otherwise = ([uncovered], snd mcases)

233 | otherwise = ([uncovered], snd mcases)

@@ -232,24 +243,31 @@ missingAlternative env mn ca uncovered

232checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

243checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()

233checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

244checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas

234 where

245 where

235− step :: ([[Binder]], (Maybe Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Maybe Bool, [[Binder]]))

246+ step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))

236 step (uncovered, (nec, redundant)) ca =

247 step (uncovered, (nec, redundant)) ca =

237 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

248 let (missed, pr) = unzip (map (missingAlternative env mn ca) uncovered)

249+ (missed', approx) = splitAt 10000 (concat missed)

238− cond = or <$> sequenceA pr

250+ cond = liftA2 (&&) (or <$> sequenceA pr) nec

239− in (concat missed, (liftA2 (&&) cond nec,

251+ in (missed', ( if null approx

252+ then cond

253+ else Left Incomplete

254+ , if either (const True) id cond

255+ then redundant

240− if fromMaybe True cond then redundant else caseAlternativeBinders ca : redundant))

256+ else caseAlternativeBinders ca : redundant

241−#if __GLASGOW_HASKELL__ < 710

257+ )

242− where

258+ )

243− sequenceA = foldr (liftA2 (:)) (pure [])

244−#endif

245

259

246− makeResult :: ([[Binder]], (Maybe Bool, [[Binder]])) -> m ()

260+ makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()

247− makeResult (bss, (_, bss')) =

261+ makeResult (bss, (rr, bss')) =

248 do unless (null bss) tellExhaustive

262 do unless (null bss) tellExhaustive

249 unless (null bss') tellRedundant

263 unless (null bss') tellRedundant

264+ case rr of

265+ Left Incomplete -> tellIncomplete

266+ _ -> return ()

250 where

267 where

251 tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

268 tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

252 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

269 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'

270+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

253

271

254-- |

272-- |

255-- Exhaustivity checking over a list of declarations

273-- Exhaustivity checking over a list of declarations

src/Language/PureScript/Make.hs+48−24

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

52

53import Control.Concurrent.Lifted as C

54

55−import Data.List (foldl')

55+import Data.List (foldl', sort)

56import Data.Maybe (fromMaybe, catMaybes)

57import Data.Time.Clock

58import Data.String (fromString)

@@ -159,6 +159,8 @@ make :: forall m. (Functor m, Applicative m, Monad m, MonadBaseControl IO m, Mon

159 -> [Module]

160 -> m Environment

161make MakeActions{..} ms = do

162+ checkModuleNamesAreUnique

163+

162 (sorted, graph) <- sortModules ms

164 (sorted, graph) <- sortModules ms

163

165

164 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

166 barriers <- zip (map getModuleName sorted) <$> replicateM (length ms) ((,) <$> C.newEmptyMVar <*> C.newEmptyMVar)

@@ -178,12 +180,32 @@ make MakeActions{..} ms = do

178 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs)

180 return $ foldl' (flip applyExternsFileToEnvironment) initEnvironment (fromMaybe (error "make: externs were missing but no errors reported.") externs)

179

181

180 where

182 where

183+ checkModuleNamesAreUnique :: m ()

184+ checkModuleNamesAreUnique =

185+ case findDuplicate (map getModuleName ms) of

186+ Nothing -> return ()

187+ Just mn -> throwError . errorMessage $ DuplicateModuleName mn

188+

189+ -- Verify that a list of values has unique keys

190+ findDuplicate :: (Ord a) => [a] -> Maybe a

191+ findDuplicate = go . sort

192+ where

193+ go (x : y : xs)

194+ | x == y = Just x

195+ | otherwise = go (y : xs)

196+ go _ = Nothing

197+

181 -- Sort a list so its elements appear in the same order as in another list.

198 -- Sort a list so its elements appear in the same order as in another list.

182 inOrderOf :: (Ord a) => [a] -> [a] -> [a]

199 inOrderOf :: (Ord a) => [a] -> [a] -> [a]

183 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys

200 inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys

184

201

185 buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()

202 buildModule :: [(ModuleName, (C.MVar (Maybe ExternsFile), C.MVar (Maybe MultipleErrors)))] -> Module -> [ModuleName] -> m ()

186 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do

203 buildModule barriers m@(Module _ _ moduleName _ _) deps = flip catchError (markComplete Nothing . Just) $ do

204+ -- We need to wait for dependencies to be built, before checking if the current

205+ -- module should be rebuilt, so the first thing to do is to wait on the

206+ -- MVars for the module's dependencies.

207+ mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps

208+

187 outputTimestamp <- getOutputTimestamp moduleName

209 outputTimestamp <- getOutputTimestamp moduleName

188 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

210 dependencyTimestamp <- maximumMaybe <$> mapM (fmap shouldExist . getOutputTimestamp) deps

189 inputTimestamp <- getInputTimestamp moduleName

211 inputTimestamp <- getInputTimestamp moduleName

@@ -194,29 +216,31 @@ make MakeActions{..} ms = do

194 (Left RebuildNever, _, Just _) -> False

216 (Left RebuildNever, _, Just _) -> False

195 _ -> True

217 _ -> True

196

218

197− exts <- if shouldRebuild

219+ let rebuild =

198− then do

220+ case mexterns of

199− mexterns <- sequence <$> mapM (readMVar . fst . fromMaybe (error "make: no barrier") . flip lookup barriers) deps

200−

201− for mexterns $ \externs -> do

221+ Just externs -> do

202− progress $ CompilingModule moduleName

222+ progress $ CompilingModule moduleName

203− let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

223+ let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

204− lint m

224+ lint m

205− ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]

225+ ([desugared], nextVar) <- runSupplyT 0 $ desugar externs [m]

206− (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared

226+ (checked@(Module ss coms _ elaborated exps), env') <- runCheck' env $ typeCheckModule desugared

207− checkExhaustiveModule env' checked

227+ checkExhaustiveModule env' checked

208− regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

228+ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

209− let mod' = Module ss coms moduleName regrouped exps

229+ let mod' = Module ss coms moduleName regrouped exps

210− corefn = CF.moduleToCoreFn env' mod'

230+ corefn = CF.moduleToCoreFn env' mod'

211− [renamed] = renameInModules [corefn]

231+ [renamed] = renameInModules [corefn]

212− exts = moduleToExternsFile mod' env'

232+ exts = moduleToExternsFile mod' env'

213− evalSupplyT nextVar $ codegen renamed env' $ encode exts

233+ evalSupplyT nextVar $ codegen renamed env' $ encode exts

214− return exts

234+ markComplete (Just exts) Nothing

235+ Nothing -> markComplete Nothing Nothing

236+

237+ if shouldRebuild

238+ then rebuild

215− else do

239+ else do

216− mexts <- decodeExterns . snd <$> readExterns moduleName

240+ mexts <- decodeExterns . snd <$> readExterns moduleName

217− return $ Just $ fromMaybe (error "make: externs files are out of date. Try 'rm output/*/externs.json'.") mexts

241+ case mexts of

218−

242+ Just exts -> markComplete (Just exts) Nothing

219− markComplete exts Nothing

243+ Nothing -> rebuild

220 where

244 where

221 markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m ()

245 markComplete :: Maybe ExternsFile -> Maybe MultipleErrors -> m ()

222 markComplete externs errors = do

246 markComplete externs errors = do

src/Language/PureScript/Parser/Declarations.hs+25−27

@@ -151,33 +151,34 @@ parseImportDeclaration' = do

151 where

152 stdImport = do

153 moduleName' <- moduleName

154− stdImportHiding moduleName' <|> stdImportQualifying moduleName'

154+ suffixHiding moduleName' <|> suffixQualifyingList moduleName'

155 where

156− stdImportHiding mn = do

156+ suffixHiding mn = do

157 reserved "hiding"

158− declType <- importDeclarationType Hiding

158+ declType <- qualifyingList Hiding

159− return (mn, declType, Nothing)

160− stdImportQualifying mn = do

161− declType <- importDeclarationType Explicit

162 return (mn, declType, Nothing)

159 return (mn, declType, Nothing)

160+ suffixQualifyingList mn = do

161+ declType <- qualifyingList Explicit

162+ qName <- P.optionMaybe qualifiedName

163+ return (mn, declType, qName)

164+ qualifiedName = reserved "as" *> moduleName

163 qualImport = do

165 qualImport = do

164 reserved "qualified"

166 reserved "qualified"

165 indented

167 indented

166 moduleName' <- moduleName

168 moduleName' <- moduleName

167− declType <- importDeclarationType Explicit

169+ declType <- qualifyingList Explicit

168− reserved "as"

170+ qName <- qualifiedName

169− asQ <- moduleName

170− return (moduleName', declType, Just asQ)

171+ return (moduleName', declType, Just qName)

171− importDeclarationType expectedType = do

172+ qualifyingList expectedType = do

172 idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)

173 idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)

173 return $ fromMaybe Implicit (expectedType <$> idents)

174 return $ fromMaybe Implicit (expectedType <$> idents)

174

175

176

176parseDeclarationRef :: TokenParser DeclarationRef

177parseDeclarationRef :: TokenParser DeclarationRef

177parseDeclarationRef =

178parseDeclarationRef =

178− parseModuleRef <|> (

179+ parseModuleRef <|>

179− withSourceSpan PositionedDeclarationRef $

180+ withSourceSpan PositionedDeclarationRef

180− ValueRef <$> parseIdent

181+ (ValueRef <$> parseIdent

181 <|> do name <- properName

182 <|> do name <- properName

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

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

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

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

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

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

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

204 return $ TypeClassDeclaration className idents implies members

205 return $ TypeClassDeclaration className idents implies members

205

206

206−parseTypeInstanceDeclaration :: TokenParser Declaration

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

207−parseTypeInstanceDeclaration = do

208+parseInstanceDeclaration = do

208 reserved "instance"

209 reserved "instance"

209 name <- parseIdent <* indented <* doubleColon

210 name <- parseIdent <* indented <* doubleColon

210 deps <- P.optionMaybe $ do

211 deps <- P.optionMaybe $ do

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

214 return deps

215 return deps

215 className <- indented *> parseQualified properName

216 className <- indented *> parseQualified properName

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

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

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

219+

220+parseTypeInstanceDeclaration :: TokenParser Declaration

221+parseTypeInstanceDeclaration = do

222+ instanceDecl <- parseInstanceDeclaration

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

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

218 indented *> reserved "where"

224 indented *> reserved "where"

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

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

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

226+ return $ instanceDecl (ExplicitInstance members)

221

227

222parseDerivingInstanceDeclaration :: TokenParser Declaration

228parseDerivingInstanceDeclaration :: TokenParser Declaration

223parseDerivingInstanceDeclaration = do

229parseDerivingInstanceDeclaration = do

224 reserved "derive"

230 reserved "derive"

225− reserved "instance"

231+ instanceDecl <- parseInstanceDeclaration

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

227− deps <- P.optionMaybe $ do

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

229− indented

230− rfatArrow

231− return deps

232− className <- indented *> parseQualified properName

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

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

232+ return $ instanceDecl DerivedInstance

235

233

236positioned :: TokenParser Declaration -> TokenParser Declaration

234positioned :: TokenParser Declaration -> TokenParser Declaration

237positioned = withSourceSpan PositionedDeclaration

235positioned = withSourceSpan PositionedDeclaration

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

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

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

47 where

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

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

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

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

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

479 go _ = Nothing

480

481validModuleName :: String -> Bool

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

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

483

484-- |

485-- A list of purescript reserved identifiers

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

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

45 match (JSStringLiteral s) = return $ string s

46 match (JSBooleanLiteral True) = return "true"

47 match (JSBooleanLiteral False) = return "false"

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

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

49 [ return "[ "

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

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

51 , return " ]"

52 ]

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

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

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

55 [ return "{\n"

56 , withIndent $ do

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

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

65 objectPropertyToString :: String -> String

66 objectPropertyToString s | identNeedsEscaping s = show s

67 | otherwise = s

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

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

69 [ return "{\n"

70 , withIndent $ prettyStatements sts

71 , return "\n"

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

73 , return "}"

74 ]

75 match (JSVar ident) = return ident

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

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

77 [ return "var "

78 , return ident

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

80 ]

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

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

82 [ prettyPrintJS' target

83 , return " = "

84 , prettyPrintJS' value

85 ]

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

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

87 [ return "while ("

88 , prettyPrintJS' cond

89 , return ") "

90 , prettyPrintJS' sts

91 ]

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

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

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

94 , prettyPrintJS' start

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

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

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

98 , prettyPrintJS' sts

99 ]

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

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

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

102 , prettyPrintJS' obj

103 , return ") "

104 , prettyPrintJS' sts

105 ]

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

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

107 [ return "if ("

108 , prettyPrintJS' cond

109 , return ") "

110 , prettyPrintJS' thens

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

112 ]

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

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

114 [ return "return "

115 , prettyPrintJS' value

116 ]

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

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

118 [ return "throw "

119 , prettyPrintJS' value

120 ]

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

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

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

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

124 [ return $ lbl ++ ": "

125 , prettyPrintJS' js

126 ]

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

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

153getGitWorkingTreeStatus = do

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

155 return $

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

156+ if all null . lines $ out

157 then Clean

158 else Dirty

159

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

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

98 case err of

99 UserError e ->

100 vcat

101− [ para (concat

101+ [ para (

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

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

103− , "it could not be published."

103+ "it could not be published."

104− ])

104+ )

105 , para "Details:"

106 , indented (displayUserError e)

107 ]

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

123displayUserError :: UserError -> Box

124displayUserError e = case e of

125 BowerJSONNotFound ->

126− para (concat

126+ para (

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

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

128− , "`pulp init`."

128+ "`pulp init`."

129− ])

129+ )

130 BowerExecutableNotFound names ->

131 para (concat

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

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

217 , indented (P.prettyPrintMultipleErrorsBox False err)

218 ]

219 DirtyWorkingTree ->

220− para (concat

220+ para (

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

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

222− , "your changes first."

222+ "your changes first."

223− ])

223+ )

224

225displayRepositoryError :: RepositoryFieldError -> Box

226displayRepositoryError err = case err of

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

356 are = pl "are" "is"

357 dependencies = pl "dependencies" "a dependency"

358 in vcat $

359− [ para (concat

359+ para (concat

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

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

362 ])

363− ] ++

364− bulletedList runPackageName (NonEmpty.toList pkgNames)

363+ : bulletedList runPackageName (NonEmpty.toList pkgNames)

365

364

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

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

367warnUnacceptableVersions pkgs =

366warnUnacceptableVersions pkgs =

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

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

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

81updateScope name = do

82 scope <- get

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

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

84− True -> do

84+ then do

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

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

87 return newName

88− False -> return name

88+ else return name

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

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

91 }

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

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

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

43

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

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

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

46desugarDo d =

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

48 in f d

49 where

50 bind :: Expr

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

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

52

53 replace :: Expr -> m Expr

54 replace (Do els) = go els

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

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

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

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

134 fqValues :: Expr -> [ModuleName]

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

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

136 fqValues _ = []

137 mkImport :: ModuleName -> Declaration

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

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

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

205 -- the data constructor to check.

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

207 checkDcon tcon exps' name =

208− if name `elem` exps'

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

209− then return ()

210− else throwError . errorMessage $ UnknownExportDataConstructor tcon name

209+ throwError . errorMessage $ UnknownExportDataConstructor tcon name

211

210

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

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

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

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

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

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

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

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

61 fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name

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

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

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

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

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

src/Language/PureScript/TypeChecker/Entailment.hs−1

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

13--

14-----------------------------------------------------------------------------

15

16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17{-# LANGUAGE CPP #-}

16{-# LANGUAGE CPP #-}

18

17

19module Language.PureScript.TypeChecker.Entailment (

18module Language.PureScript.TypeChecker.Entailment (

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

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

399

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

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

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

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

403 TypedValue _ val' ty <- infer val

404 if inst

405 then instantiatePolyTypeWithUnknowns val' ty

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

@@ -141,7 +141,7 @@ unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True

141unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True

142unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2

143unifiesWith REmpty REmpty = True

144−unifiesWith r1@(RCons _ _ _) r2@(RCons _ _ _) =

144+unifiesWith r1@RCons{} r2@RCons{} =

145 let (s1, r1') = rowToList r1

146 (s2, r2') = rowToList r2

147

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

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

22

23import Data.Data

24import Data.List (nub)

25+import Data.Maybe (fromMaybe)

25import qualified Data.Aeson as A

26import qualified Data.Aeson as A

26import qualified Data.Aeson.TH as A

27import qualified Data.Aeson.TH as A

27

28

@@ -152,10 +153,7 @@ replaceAllTypeVars = go []

152 where

153 where

153

154

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

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

155− go _ m (TypeVar v) =

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

156− case v `lookup` m of

157− Just r -> r

158− Nothing -> TypeVar v

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

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

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

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

161 | v `elem` usedVars =

159 | v `elem` usedVars =

src/System/IO/UTF8.hsnew file+9

@@ -0,0 +1,9 @@

1+module System.IO.UTF8

2+where

3+import System.IO (hGetContents, hSetEncoding, openFile, utf8, IOMode (..))

4+

5+readUTF8File :: FilePath -> IO String

6+readUTF8File inFile = do

7+ h <- openFile inFile ReadMode

8+ hSetEncoding h utf8

9+ hGetContents h

stack-lts-3.yaml+1−1

@@ -2,4 +2,4 @@ flags: {}

2packages:

3- '.'

4extra-deps:

5−resolver: lts-3.4

5+resolver: lts-3.6

stack-nightly.yaml+1−1

@@ -2,4 +2,4 @@ flags: {}

2packages:

3- '.'

4extra-deps:

5−resolver: nightly-2015-09-09

5+resolver: nightly-2015-09-29

tests/Main.hs+4−3

@@ -66,6 +66,7 @@ import System.Exit

66import System.Process

67import System.FilePath

68import System.Directory

69+import System.IO.UTF8

69import qualified System.Info

70import qualified System.Info

70import qualified System.FilePath.Glob as Glob

71import qualified System.FilePath.Glob as Glob

71

72

@@ -97,7 +98,7 @@ makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input

97

98

98readInput :: [FilePath] -> IO [(FilePath, String)]

99readInput :: [FilePath] -> IO [(FilePath, String)]

99readInput inputFiles = forM inputFiles $ \inputFile -> do

100readInput inputFiles = forM inputFiles $ \inputFile -> do

100− text <- readFile inputFile

101+ text <- readUTF8File inputFile

101 return (inputFile, text)

102 return (inputFile, text)

102

103

103type TestM = WriterT [(FilePath, String)] IO

104type TestM = WriterT [(FilePath, String)] IO

@@ -157,7 +158,7 @@ assertDoesNotCompile inputFiles foreigns = do

157

158

158 where

159 where

159 getShouldFailWith =

160 getShouldFailWith =

160− readFile

161+ readUTF8File

161 >>> liftIO

162 >>> liftIO

162 >>> fmap ( lines

163 >>> fmap ( lines

163 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")

164 >>> mapMaybe (stripPrefix "-- @shouldFailWith ")

@@ -184,7 +185,7 @@ main = do

184 supportPurs <- supportFiles "purs"

185 supportPurs <- supportFiles "purs"

185 supportJS <- supportFiles "js"

186 supportJS <- supportFiles "js"

186

187

187− foreignFiles <- forM supportJS (\f -> (f,) <$> readFile f)

188+ foreignFiles <- forM supportJS (\f -> (f,) <$> readUTF8File f)

188 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles

189 Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles

189

190

190 let passing = cwd </> "examples" </> "passing"

191 let passing = cwd </> "examples" </> "passing"