0e7c936 · rowtype-yoga/purescript-native

examples/passing/1991.purs+1

compare with golang

unifiedsplit

@@ -10,6 +10,7 @@ empty = []

10

11foldMap :: forall a m. (Semigroup m) => (a -> m) -> Array a -> m

12foldMap f [a, b, c, d, e] = f a <> f b <> f c <> f d <> f e

13+foldMap f xs = foldMap f xs -- spin, not used

13

14

14regression :: Array Int

15regression :: Array Int

15regression =

16regression =

examples/passing/2049.purs+1

@@ -9,5 +9,6 @@ infixr 6 Cons as :

9

10f :: List { x :: Int, y :: Int } -> Int

11f ( r@{ x } : _) = x + r.y

12+f _ = 0

12

13

13main = log "Done"

14main = log "Done"

examples/passing/BindersInFunctions.purs+6−2

@@ -1,11 +1,15 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafePartial)

4−import Test.Assert

5+import Test.Assert (assert')

6+import Control.Monad.Eff (Eff)

5

7

8+snd :: forall a. Partial => Array a -> a

6snd = \[_, y] -> y

9snd = \[_, y] -> y

7

10

11+main :: Eff _ _

8main = do

12main = do

9− let ts = snd [1.0, 2.0]

13+ let ts = unsafePartial (snd [1.0, 2.0])

10 assert' "Incorrect result from 'snd'." (ts == 2.0)

14 assert' "Incorrect result from 'snd'." (ts == 2.0)

11 Control.Monad.Eff.Console.log "Done"

15 Control.Monad.Eff.Console.log "Done"

examples/passing/CaseInDo.purs+2

@@ -1,6 +1,7 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafeCrashWith)

4import Control.Monad.Eff.Console

5import Control.Monad.Eff.Console

5import Control.Monad.Eff

6import Control.Monad.Eff

6

7

@@ -17,3 +18,4 @@ main = do

17 b <- set

18 b <- set

18 case b of

19 case b of

19 true -> log "Done"

20 true -> log "Done"

21+ false -> unsafeCrashWith "Failed"

examples/passing/CaseMultipleExpressions.purs+2

@@ -1,6 +1,7 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafeCrashWith)

4import Control.Monad.Eff.Console

5import Control.Monad.Eff.Console

5import Control.Monad.Eff

6import Control.Monad.Eff

6

7

@@ -17,3 +18,4 @@ main = do

17 b <- set

18 b <- set

18 case b of

19 case b of

19 true -> log "Done"

20 true -> log "Done"

21+ false -> unsafeCrashWith "Failed"

examples/passing/EmptyTypeClass.purs+5−6

@@ -1,12 +1,11 @@

1module Main where

2

3import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

4

6

5−class PartialP

6−

7−head :: forall a. (PartialP) => Array a -> a

7+head :: forall a. Partial => Array a -> a

8head [x] = x

9

10−instance allowPartials :: PartialP

10+main :: Eff _ _

11−

12−main = Control.Monad.Eff.Console.log $ head ["Done"]

11+main = log "Done"

examples/passing/Let.purs+6−3

@@ -1,6 +1,7 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafePartial)

4import Control.Monad.Eff

5import Control.Monad.Eff

5import Control.Monad.Eff.Console (log, logShow)

6import Control.Monad.Eff.Console (log, logShow)

6import Control.Monad.ST

7import Control.Monad.ST

@@ -18,8 +19,9 @@ test2 x y =

18test3 = let f x y z = x + y + z in

19test3 = let f x y z = x + y + z in

19 f 1.0 2.0 3.0

20 f 1.0 2.0 3.0

20

21

21−test4 = let f x [y, z] = x y z in

22+test4 = let

23+ f x [y, z] = x y z

22− f (+) [1.0, 2.0]

24+ in f (+) [1.0, 2.0]

23

25

24test5 = let

26test5 = let

25 f x | x > 0.0 = g (x / 2.0) + 1.0

27 f x | x > 0.0 = g (x / 2.0) + 1.0

@@ -44,11 +46,12 @@ test10 _ =

44 g x = f x / 2.0

46 g x = f x / 2.0

45 in f 10.0

47 in f 10.0

46

48

49+main :: Eff _ _

47main = do

50main = do

48 logShow (test1 1.0)

51 logShow (test1 1.0)

49 logShow (test2 1.0 2.0)

52 logShow (test2 1.0 2.0)

50 logShow test3

53 logShow test3

51− logShow test4

54+ unsafePartial (logShow test4)

52 logShow test5

55 logShow test5

53 logShow test7

56 logShow test7

54 logShow (test8 100.0)

57 logShow (test8 100.0)

examples/passing/PartialFunction.purs+11−13

@@ -1,13 +1,11 @@

1−module Main where

1+module Main where

2−

2+

3−import Prelude

3+import Prelude

4−import Control.Monad.Eff.Console (log)

4+import Control.Monad.Eff

5−import Test.Assert (assertThrows)

5+import Control.Monad.Eff.Console

6−

6+

7−fn :: Number -> Number

7+fn :: Partial => Number -> Number

8−fn 0.0 = 0.0

8+fn 0.0 = 0.0

9−fn 1.0 = 2.0

9+fn 1.0 = 2.0

10−

10+

11−main = do

12− assertThrows $ \_ -> fn 2.0

13− log "Done"

11+main = log "Done"

examples/passing/ReservedWords.purs+3

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

2module Main where

3

4import Prelude

5+import Control.Monad.Eff

5

6

6o :: { type :: String }

7o :: { type :: String }

7o = { type: "o" }

8o = { type: "o" }

@@ -11,5 +12,7 @@ p = o { type = "p" }

11

12

12f :: forall r. { type :: String | r } -> String

13f :: forall r. { type :: String | r } -> String

13f { type = "p" } = "Done"

14f { type = "p" } = "Done"

15+f _ = "Fail"

14

16

17+main :: Eff _ _

15main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" }

18main = Control.Monad.Eff.Console.log $ f { type: p.type, foo: "bar" }

examples/passing/ShadowedTCOLet.purs+4−1

@@ -1,12 +1,15 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafePartial)

5+import Control.Monad.Eff

4import Control.Monad.Eff.Console (log)

6import Control.Monad.Eff.Console (log)

5

7

6f x y z =

8f x y z =

7 let f 1.0 2.0 3.0 = 1.0

9 let f 1.0 2.0 3.0 = 1.0

8 in f x z y

10 in f x z y

9

11

12+main :: Eff _ _

10main = do

13main = do

11− log $ show $ f 1.0 3.0 2.0

14+ log $ show $ unsafePartial f 1.0 3.0 2.0

12 log "Done"

15 log "Done"

examples/passing/UnderscoreIdent.purs+1

@@ -7,5 +7,6 @@ data Data_type = Con_Structor | Con_2 String

7type Type_name = Data_type

8

9done (Con_2 s) = s

10+done _ = "Failed"

10

11

11main = Control.Monad.Eff.Console.log (done (Con_2 "Done"))

12main = Control.Monad.Eff.Console.log (done (Con_2 "Done"))

examples/passing/Where.purs+4−1

@@ -1,6 +1,8 @@

1module Main where

2

3import Prelude

4+import Partial.Unsafe (unsafePartial)

5+import Control.Monad.Eff

4import Control.Monad.Eff.Console (logShow, log)

6import Control.Monad.Eff.Console (logShow, log)

5

7

6test1 x = y

8test1 x = y

@@ -35,11 +37,12 @@ test7 x = go x

35 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

37 go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

36 go y = go $ (y + x / y) / 2.0

38 go y = go $ (y + x / y) / 2.0

37

39

40+main :: Eff _ _

38main = do

41main = do

39 logShow (test1 1.0)

42 logShow (test1 1.0)

40 logShow (test2 1.0 2.0)

43 logShow (test2 1.0 2.0)

41 logShow test3

44 logShow test3

42− logShow test4

45+ unsafePartial (logShow test4)

43 logShow test5

46 logShow test5

44 logShow test6

47 logShow test6

45 logShow (test7 100.0)

48 logShow (test7 100.0)

hierarchy/Main.hs+1−2

@@ -84,7 +84,7 @@ compile (HierarchyOptions inputGlob mOutput) = do

84

85superClasses :: P.Declaration -> [SuperMap]

86superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =

87− fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers

87+ fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers

88superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]

89superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl

90superClasses _ = []

@@ -113,4 +113,3 @@ main = execParser opts >>= compile

113 infoModList = fullDesc <> headerInfo <> footerInfo

114 headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"

115 footerInfo = footer $ "hierarchy " ++ showVersion Paths.version

116−

psci/PSCi/Printer.hs+1−1

@@ -58,7 +58,7 @@ printModuleSignatures moduleName (P.Environment {..}) =

58 if null constrs

59 then Box.text ""

60 else Box.text "("

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

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

62 Box.<> Box.text ") <= "

63 className =

64 Box.text (P.runProperName name)

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

@@ -99,7 +99,7 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _)

99 Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys)

100 where

101

102− fromConstraint (name, tys') = Left name : concatMap fromType tys'

102+ fromConstraint c = Left (constraintClass c) : concatMap fromType (constraintArgs c)

103 fromType = everythingOnTypes (++) go

104

105 -- Note that type synonyms are disallowed in instance declarations, so

src/Language/PureScript/AST/Traversals.hs+3−3

@@ -579,13 +579,13 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

579 where

580 forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)

581 forDecls (ExternDeclaration _ ty) = f ty

582− forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)

582+ forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . constraintArgs) implies)

583− forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)

583+ forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys)

584 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

585 forDecls (TypeDeclaration _ ty) = f ty

586 forDecls _ = mempty

587

588− forValues (TypeClassDictionary (_, cs) _) = mconcat (map f cs)

588+ forValues (TypeClassDictionary c _) = mconcat (map f (constraintArgs c))

589 forValues (SuperClassDictionary _ tys) = mconcat (map f tys)

590 forValues (TypedValue _ _ ty) = f ty

591 forValues _ = mempty

src/Language/PureScript/Constants.hs+14−3

@@ -1,8 +1,11 @@

1−-- |

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PatternSynonyms #-}

3+

2−-- Various constants which refer to things in the Prelude

4+-- | Various constants which refer to things in the Prelude

3−--

4module Language.PureScript.Constants where

5module Language.PureScript.Constants where

5

6

7+import Language.PureScript.Names

8+

6-- Operators

9-- Operators

7

10

8($) :: String

11($) :: String

@@ -317,6 +320,14 @@ toSignature = "toSignature"

317main :: String

320main :: String

318main = "main"

321main = "main"

319

322

323+-- Prim

324+

325+partial :: String

326+partial = "Partial"

327+

328+pattern Partial :: Qualified (ProperName 'ClassName)

329+pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")

330+

320-- Code Generation

331-- Code Generation

321

332

322__superclass_ :: String

333__superclass_ :: String

src/Language/PureScript/Docs/Convert/ReExports.hs+1−1

@@ -489,7 +489,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint

489typeClassConstraintFor Declaration{..} =

490 case declInfo of

491 TypeClassDeclaration tyArgs _ ->

492− Just (P.Qualified Nothing (P.ProperName declTitle), mkConstraint tyArgs)

492+ Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing)

493 _ ->

494 Nothing

495 where

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

@@ -107,7 +107,7 @@ renderConstraint :: P.Constraint -> RenderedCode

107renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

108

109renderConstraintWithOptions :: RenderTypeOptions -> P.Constraint -> RenderedCode

110−renderConstraintWithOptions opts (pn, tys) =

110+renderConstraintWithOptions opts (P.Constraint pn tys _) =

111 renderTypeWithOptions opts $ foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName pn)) tys

112

113renderConstraints :: [P.Constraint] -> Maybe RenderedCode

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

@@ -56,7 +56,7 @@ typeLiterals = mkPattern match

56 Nothing

57

58renderConstraint :: Constraint -> RenderedCode

59−renderConstraint (pn, tys) =

59+renderConstraint (Constraint pn tys _) =

60 let instApp = foldl TypeApp (TypeConstructor (fmap coerceProperName pn)) tys

61 in renderType instApp

62

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

@@ -465,8 +465,9 @@ asSourcePos = P.SourcePos <$> nth 0 asIntegral

465 <*> nth 1 asIntegral

466

467asConstraint :: Parse PackageError P.Constraint

468−asConstraint = (,) <$> nth 0 asQualifiedProperName

468+asConstraint = P.Constraint <$> key "constraintClass" asQualifiedProperName

469− <*> nth 1 (eachInArray asType)

469+ <*> key "constraintArgs" (eachInArray asType)

470+ <*> pure Nothing

470

471

471asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

472asQualifiedProperName :: Parse e (P.Qualified (P.ProperName a))

472asQualifiedProperName = fromAesonParser

473asQualifiedProperName = fromAesonParser

src/Language/PureScript/Errors.hs+15−15

@@ -29,6 +29,7 @@ import Language.PureScript.Pretty

29import Language.PureScript.Types

30import Language.PureScript.Names

31import Language.PureScript.Kinds

32+import qualified Language.PureScript.Constants as C

32import qualified Language.PureScript.Bundle as Bundle

33import qualified Language.PureScript.Bundle as Bundle

33

34

34import qualified Text.PrettyPrint.Boxes as Box

35import qualified Text.PrettyPrint.Boxes as Box

@@ -102,7 +103,7 @@ data SimpleErrorMessage

102 | KindsDoNotUnify Kind Kind

103 | KindsDoNotUnify Kind Kind

103 | ConstrainedTypeUnified Type Type

104 | ConstrainedTypeUnified Type Type

104 | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

105 | OverlappingInstances (Qualified (ProperName 'ClassName)) [Type] [Qualified Ident]

105− | NoInstanceFound (Qualified (ProperName 'ClassName)) [Type]

106+ | NoInstanceFound Constraint

106 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

107 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

107 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

108 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

108 | CannotFindDerivingType (ProperName 'TypeName)

109 | CannotFindDerivingType (ProperName 'TypeName)

@@ -130,7 +131,6 @@ data SimpleErrorMessage

130 | WildcardInferredType Type

131 | WildcardInferredType Type

131 | HoleInferredType String Type

132 | HoleInferredType String Type

132 | MissingTypeDeclaration Ident Type

133 | MissingTypeDeclaration Ident Type

133− | NotExhaustivePattern [[Binder]] Bool

134 | OverlappingPattern [[Binder]] Bool

135 | IncompleteExhaustivityCheck

136 | ClassOperator (ProperName 'ClassName) Ident

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

315 WildcardInferredType{} -> "WildcardInferredType"

316 HoleInferredType{} -> "HoleInferredType"

317 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

318− NotExhaustivePattern{} -> "NotExhaustivePattern"

319 OverlappingPattern{} -> "OverlappingPattern"

318 OverlappingPattern{} -> "OverlappingPattern"

320 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

319 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

321 ClassOperator{} -> "ClassOperator"

320 ClassOperator{} -> "ClassOperator"

@@ -422,7 +421,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

422 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

421 gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> f t

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

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

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

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

425− gSimple (NoInstanceFound cl ts) = NoInstanceFound cl <$> traverse f ts

424+ gSimple (NoInstanceFound con) = NoInstanceFound <$> overConstraintArgs (traverse f) con

426 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

425 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

427 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

426 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

428 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

427 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

@@ -755,7 +754,18 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

755 , line "They may be disallowed completely in a future version of the compiler."

754 , line "They may be disallowed completely in a future version of the compiler."

756 ]

755 ]

757 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

756 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"

758− renderSimpleErrorMessage (NoInstanceFound nm ts) =

757+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial

758+ _

759+ (Just (PartialConstraintData bs b)))) =

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

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

762+ , indent $ paras $

763+ Box.hsep 1 Box.left

764+ (map (paras . map line) (transpose bs))

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

766+ , line "Alternatively, add a Partial constraint to the type of the enclosing value."

767+ ]

768+ renderSimpleErrorMessage (NoInstanceFound (Constraint nm ts _)) =

759 paras [ line "No type class instance was found for"

769 paras [ line "No type class instance was found for"

760 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

770 , indent $ Box.hsep 1 Box.left [ line (showQualified runProperName nm)

761 , Box.vcat Box.left (map typeAtomAsBox ts)

771 , Box.vcat Box.left (map typeAtomAsBox ts)

@@ -887,16 +897,6 @@ prettyPrintSingleError full level showWiki e = flip evalState defaultUnknownMap

887 , line $ "The inferred type of " ++ showIdent ident ++ " was:"

897 , line $ "The inferred type of " ++ showIdent ident ++ " was:"

888 , indent $ typeAsBox ty

898 , indent $ typeAsBox ty

889 ]

899 ]

890− renderSimpleErrorMessage (NotExhaustivePattern bs b) =

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

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

893− , indent $ paras $

894− Box.hsep 1 Box.left

895− (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

896− : [line "..." | not b]

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

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

899− ]

900 renderSimpleErrorMessage (OverlappingPattern bs b) =

901 paras $ [ line "A case expression contains unreachable cases:\n"

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

src/Language/PureScript/Linter/Exhaustive.hs+89−63

@@ -7,7 +7,9 @@

7-- to bottom, where in each step it has the cases already missing (uncovered),

8-- and it generates the new set of missing cases.

9--

10−module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where

10+module Language.PureScript.Linter.Exhaustive

11+ ( checkExhaustiveExpr

12+ ) where

11

13

12import Prelude ()

14import Prelude ()

13import Prelude.Compat

15import Prelude.Compat

@@ -23,12 +25,15 @@ import Control.Arrow (first, second)

23import Control.Monad.Writer.Class

25import Control.Monad.Writer.Class

24

26

25import Language.PureScript.Crash

27import Language.PureScript.Crash

28+import qualified Language.PureScript.Constants as C

26import Language.PureScript.AST.Binders

29import Language.PureScript.AST.Binders

27import Language.PureScript.AST.Literals

30import Language.PureScript.AST.Literals

28import Language.PureScript.AST.Declarations

31import Language.PureScript.AST.Declarations

29import Language.PureScript.Environment

32import Language.PureScript.Environment

30import Language.PureScript.Names as P

33import Language.PureScript.Names as P

31import Language.PureScript.Kinds

34import Language.PureScript.Kinds

35+import Language.PureScript.Pretty.Values (prettyPrintBinderAtom)

36+import Language.PureScript.Traversals

32import Language.PureScript.Types as P

37import Language.PureScript.Types as P

33import Language.PureScript.Errors

38import Language.PureScript.Errors

34

39

@@ -179,12 +184,11 @@ missingCasesSingle _ _ b _ = ([b], Left Unknown)

179missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

184missingCasesMultiple :: Environment -> ModuleName -> [Binder] -> [Binder] -> ([[Binder]], Either RedundancyError Bool)

180missingCasesMultiple env mn = go

185missingCasesMultiple env mn = go

181 where

186 where

182− go [] [] = ([], pure True)

183 go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)

187 go (x:xs) (y:ys) = (map (: xs) miss1 ++ map (x :) miss2, liftA2 (&&) pr1 pr2)

184 where

188 where

185 (miss1, pr1) = missingCasesSingle env mn x y

189 (miss1, pr1) = missingCasesSingle env mn x y

186 (miss2, pr2) = go xs ys

190 (miss2, pr2) = go xs ys

187− go _ _ = internalError "Argument lengths did not match in missingCasesMultiple."

191+ go _ _ = ([], pure True)

188

192

189-- |

193-- |

190-- Guard handling

194-- Guard handling

@@ -229,8 +233,16 @@ missingAlternative env mn ca uncovered

229-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.

233-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.

230-- Then, returns the uncovered set of case alternatives.

234-- Then, returns the uncovered set of case alternatives.

231--

235--

236+checkExhaustive

237+ :: forall m

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

238+ . (MonadWriter MultipleErrors m)

239+ => Environment

240+ -> ModuleName

241+ -> Int

242+ -> [CaseAlternative]

243+ -> Expr

244+ -> m Expr

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

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

234 where

246 where

235 step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))

247 step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]]))

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

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

@@ -246,69 +258,83 @@ checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ fold

246 )

258 )

247 )

259 )

248

260

249− makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m ()

261+ makeResult :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> m Expr

250 makeResult (bss, (rr, bss')) =

262 makeResult (bss, (rr, bss')) =

251− do unless (hasConstraint || null bss) tellNonExhaustive

252− unless (null bss') tellRedundant

263+ do unless (null bss') tellRedundant

253 case rr of

264 case rr of

254− Left Incomplete -> unless hasConstraint tellIncomplete

265+ Left Incomplete -> tellIncomplete

255 _ -> return ()

266 _ -> return ()

267+ if null bss

268+ then return expr

269+ else return (addPartialConstraint (second null (splitAt 5 bss)) expr)

256 where

270 where

257− tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss

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

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

259− tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

272+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

260−

273+

261−-- |

274+ -- | We add a Partial constraint by adding a call to the following identity function:

262−-- Exhaustivity checking over a list of declarations

263−--

275+ --

264−checkExhaustiveDecls :: forall m. MonadWriter MultipleErrors m => Environment -> ModuleName -> [Declaration] -> m ()

276+ -- partial :: forall a. Partial => a -> a

265−checkExhaustiveDecls env mn = mapM_ onDecl

277+ --

266− where

278+ -- The binder information is provided so that it can be embedded in the constraint,

267− onDecl :: Declaration -> m ()

279+ -- and then included in the error message.

268− onDecl (BindingGroupDeclaration bs) = mapM_ (onDecl . convert) bs

280+ addPartialConstraint :: ([[Binder]], Bool) -> Expr -> Expr

269− where

281+ addPartialConstraint (bss, complete) e =

270− convert :: (Ident, NameKind, Expr) -> Declaration

282+ Let [ partial ] (App (Var (Qualified Nothing (Ident C.__unused))) e)

271− convert (name, nk, e) = ValueDeclaration name nk [] (Right e)

272− onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)

273− onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)

274− onDecl _ = return ()

275−

276− onExpr :: Bool -> Expr -> m ()

277− onExpr isP (UnaryMinus e) = onExpr isP e

278− onExpr isP (Literal (ArrayLiteral es)) = mapM_ (onExpr isP) es

279− onExpr isP (Literal (ObjectLiteral es)) = mapM_ (onExpr isP . snd) es

280− onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e

281− onExpr isP (Accessor _ e) = onExpr isP e

282− onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es

283− onExpr isP (Abs _ e) = onExpr isP e

284− onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2

285− onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3

286− onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas

287− onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e

288− onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e

289− onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)

290− onExpr _ _ = return ()

291−

292− onCaseAlternative :: Bool -> CaseAlternative -> m ()

293− onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es

294− onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e

295−

296− hasPartialConstraint :: Type -> Bool

297− hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs

298 where

283 where

299− go :: Qualified (ProperName 'ClassName) -> Bool

284+ partial :: Declaration

300− go qname

285+ partial = ValueDeclaration (Ident C.__unused)

301− | qname == partialClass = True

286+ Private

302− | otherwise =

287+ []

303− case qname `M.lookup` typeClasses env of

288+ (Right (TypedValue True (Abs (Left (Ident "x"))

304− Just ([], _, cs') -> any (go . fst) cs'

289+ (Var (Qualified Nothing (Ident "x"))))

305− _ -> False

290+ ty))

306− partialClass :: Qualified (ProperName 'ClassName)

291+

307− partialClass = primName "Partial"

292+ ty :: Type

308− hasPartialConstraint _ = False

293+ ty = ForAll "a" (ConstrainedType [ Constraint (Qualified (Just (ModuleName [ProperName C.prim]))

294+ (ProperName "Partial"))

295+ []

296+ (Just (PartialConstraintData (map (map prettyPrintBinderAtom) bss) complete))

297+ ]

298+ (TypeApp (TypeApp tyFunction (TypeVar "a"))

299+ (TypeVar "a")))

300+ Nothing

309

301

310-- |

302-- |

311−-- Exhaustivity checking over a single module

303+-- Exhaustivity checking

312--

304--

305+checkExhaustiveExpr

306+ :: forall m

313−checkExhaustiveModule :: forall m. MonadWriter MultipleErrors m => Environment -> Module -> m ()

307+ . MonadWriter MultipleErrors m

314−checkExhaustiveModule env (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ checkExhaustiveDecls env mn ds

308+ => Environment

309+ -> ModuleName

310+ -> Expr

311+ -> m Expr

312+checkExhaustiveExpr env mn = onExpr

313+ where

314+ onDecl :: Declaration -> m Declaration

315+ onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs

316+ onDecl (ValueDeclaration name x y (Right e)) = ValueDeclaration name x y . Right <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e)

317+ onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec)

318+ onDecl decl = return decl

319+

320+ onExpr :: Expr -> m Expr

321+ onExpr (UnaryMinus e) = UnaryMinus <$> onExpr e

322+ onExpr (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM onExpr es

323+ onExpr (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM onExpr) es

324+ onExpr (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr e

325+ onExpr (Accessor x e) = Accessor x <$> onExpr e

326+ onExpr (ObjectUpdate o es) = ObjectUpdate <$> onExpr o <*> mapM (sndM onExpr) es

327+ onExpr (Abs x e) = Abs x <$> onExpr e

328+ onExpr (App e1 e2) = App <$> onExpr e1 <*> onExpr e2

329+ onExpr (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr e1 <*> onExpr e2 <*> onExpr e3

330+ onExpr (Case es cas) = do

331+ case' <- Case <$> mapM onExpr es <*> mapM onCaseAlternative cas

332+ checkExhaustive env mn (length es) cas case'

333+ onExpr (TypedValue x e y) = TypedValue x <$> onExpr e <*> pure y

334+ onExpr (Let ds e) = Let <$> mapM onDecl ds <*> onExpr e

335+ onExpr (PositionedValue pos x e) = PositionedValue pos x <$> censor (addHint (PositionedError pos)) (onExpr e)

336+ onExpr expr = return expr

337+

338+ onCaseAlternative :: CaseAlternative -> m CaseAlternative

339+ onCaseAlternative (CaseAlternative x (Left es)) = CaseAlternative x . Left <$> mapM (\(e, g) -> (,) <$> onExpr e <*> onExpr g) es

340+ onCaseAlternative (CaseAlternative x (Right e)) = CaseAlternative x . Right <$> onExpr e

src/Language/PureScript/Make.hs+1−2

@@ -158,10 +158,9 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do

158 progress $ CompilingModule moduleName

159 let env = foldl' (flip applyExternsFileToEnvironment) initEnvironment externs

160 lint m

161− ((checked@(Module ss coms _ elaborated exps), env'), nextVar) <- runSupplyT 0 $ do

161+ ((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do

162 [desugared] <- desugar externs [m]

163 runCheck' env $ typeCheckModule desugared

164− checkExhaustiveModule env' checked

165 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

164 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

166 let mod' = Module ss coms moduleName regrouped exps

165 let mod' = Module ss coms moduleName regrouped exps

167 corefn = CF.moduleToCoreFn env' mod'

166 corefn = CF.moduleToCoreFn env' mod'

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

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

184 return $ TypeClassDeclaration className idents implies members

185

186parseConstraint :: TokenParser Constraint

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

187+parseConstraint = Constraint <$> parseQualified properName

188+ <*> P.many (noWildcards parseTypeAtom)

189+ <*> pure Nothing

188

190

189parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

191parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

190parseInstanceDeclaration = do

192parseInstanceDeclaration = do

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

@@ -75,7 +75,7 @@ parseConstrainedType = do

75 className <- parseQualified properName

76 indented

77 ty <- P.many parseTypeAtom

78− return (className, ty)

78+ return (Constraint className ty Nothing)

79

80

81parseAnyType :: TokenParser Type

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

@@ -42,8 +42,8 @@ typeLiterals = mkPattern match

42 match _ = Nothing

43

44constraintsAsBox :: [Constraint] -> Box -> Box

45−constraintsAsBox [(pn, tys)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

45+constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> text ") => " <> ty

46−constraintsAsBox xs ty = vcat left (zipWith (\i (pn, tys) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

46+constraintsAsBox xs ty = vcat left (zipWith (\i (Constraint pn tys _) -> text (if i == 0 then "( " else ", ") <> constraintAsBox pn tys) [0 :: Int ..] xs) `before` (text ") => " <> ty)

47

48constraintAsBox :: Qualified (ProperName a) -> [Type] -> Box

49constraintAsBox pn tys = hsep 1 left (text (runProperName (disqualify pn)) : map typeAtomAsBox tys)

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

@@ -14,6 +14,7 @@ import Language.PureScript.AST

14import Language.PureScript.Names

15import Language.PureScript.Pretty.Common

16import Language.PureScript.Pretty.Types (typeAsBox, typeAtomAsBox)

17+import Language.PureScript.Types (Constraint(..))

17

18

18import Text.PrettyPrint.Boxes

19import Text.PrettyPrint.Boxes

19

20

@@ -57,7 +58,7 @@ prettyPrintValue d (Let ds val) =

57 (text "in " <> prettyPrintValue (d - 1) val)

58 (text "in " <> prettyPrintValue (d - 1) val)

58prettyPrintValue d (Do els) =

59prettyPrintValue d (Do els) =

59 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

60 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

60−prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

61+prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

61prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

62prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

62prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

63prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

63 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

64 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

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

@@ -147,7 +147,7 @@ usedTypeNames moduleName =

147 usedNames :: Type -> [ProperName 'TypeName]

148 usedNames (ConstrainedType constraints _) =

149 flip mapMaybe constraints $ \case

150− (Qualified (Just moduleName') name, _)

150+ (Constraint (Qualified (Just moduleName') name) _ _)

151 | moduleName == moduleName' -> Just (coerceProperName name)

152 _ -> Nothing

153 usedNames (TypeConstructor (Qualified (Just moduleName') name))

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

@@ -251,7 +251,10 @@ renameInModule env imports (Module ss coms mn decls exps) =

251 updateType t = return t

252

253 updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint]

254+ updateConstraints pos = traverse (\(Constraint name ts info) ->

255+ Constraint <$> updateClassName name pos

254− updateConstraints pos = traverse (\(name, ts) -> (,) <$> updateClassName name pos <*> traverse (updateTypesEverywhere pos) ts)

256+ <*> traverse (updateTypesEverywhere pos) ts

257+ <*> pure info)

255

258

256 updateTypeName

259 updateTypeName

257 :: Qualified (ProperName 'TypeName)

260 :: Qualified (ProperName 'TypeName)

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

@@ -280,10 +280,10 @@ updateTypes goType = (goDecl, goExpr)

280 ty' <- goType' pos ty

281 return (pos, ExternDeclaration name ty')

282 goDecl pos (TypeClassDeclaration name args implies decls) = do

283− implies' <- traverse (sndM (traverse (goType' pos))) implies

283+ implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies

284 return (pos, TypeClassDeclaration name args implies' decls)

285 goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do

286− cs' <- traverse (sndM (traverse (goType' pos))) cs

286+ cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs

287 tys' <- traverse (goType' pos) tys

288 return (pos, TypeInstanceDeclaration name cs' className tys' impls)

289 goDecl pos (TypeSynonymDeclaration name args ty) = do

@@ -296,9 +296,9 @@ updateTypes goType = (goDecl, goExpr)

296

297 goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr)

298 goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e)

299− goExpr pos (TypeClassDictionary (name, tys) dicts) = do

299+ goExpr pos (TypeClassDictionary (Constraint name tys info) dicts) = do

300 tys' <- traverse (goType' pos) tys

301− return (pos, TypeClassDictionary (name, tys') dicts)

301+ return (pos, TypeClassDictionary (Constraint name tys' info) dicts)

302 goExpr pos (SuperClassDictionary cls tys) = do

303 tys' <- traverse (goType' pos) tys

304 return (pos, SuperClassDictionary cls tys')

src/Language/PureScript/Sugar/TypeClasses.hs+6−5

@@ -52,7 +52,8 @@ desugarTypeClasses

52desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

53 where

54 initialState :: MemberMap

55+ initialState = M.singleton (ModuleName [ProperName C.prim], ProperName C.partial) ([], [], [])

55− initialState = M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

56+ `M.union` M.fromList (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations)

56

57

57 fromExternsDecl

58 fromExternsDecl

58 :: ModuleName

59 :: ModuleName

@@ -233,7 +234,7 @@ typeClassDictionaryDeclaration

233typeClassDictionaryDeclaration name args implies members =

234typeClassDictionaryDeclaration name args implies members =

234 let superclassTypes = superClassDictionaryNames implies `zip`

235 let superclassTypes = superClassDictionaryNames implies `zip`

235 [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

236 [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs)

236− | (superclass, tyArgs) <- implies

237+ | (Constraint superclass tyArgs _) <- implies

237 ]

238 ]

238 members' = map (first runIdent . memberToNameAndType) members

239 members' = map (first runIdent . memberToNameAndType) members

239 mtys = members' ++ superclassTypes

240 mtys = members' ++ superclassTypes

@@ -249,7 +250,7 @@ typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =

249 let className = Qualified (Just mn) name

250 let className = Qualified (Just mn) name

250 in ValueDeclaration ident Private [] $ Right $

251 in ValueDeclaration ident Private [] $ Right $

251 TypedValue False (TypeClassDictionaryAccessor className ident) $

252 TypedValue False (TypeClassDictionaryAccessor className ident) $

252− moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))

253+ moveQuantifiersToFront (quantify (ConstrainedType [Constraint className (map (TypeVar . fst) args) Nothing] ty))

253typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

254typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =

254 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

255 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

255typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"

256typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition"

@@ -293,7 +294,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

293 -- The dictionary itself is an object literal.

294 -- The dictionary itself is an object literal.

294 let superclasses = superClassDictionaryNames implies `zip`

295 let superclasses = superClassDictionaryNames implies `zip`

295 [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)

296 [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)

296− | (superclass, suTyArgs) <- implies

297+ | (Constraint superclass suTyArgs _) <- implies

297 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

298 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

298 ]

299 ]

299

300

@@ -330,5 +331,5 @@ typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration

330superClassDictionaryNames :: [Constraint] -> [String]

331superClassDictionaryNames :: [Constraint] -> [String]

331superClassDictionaryNames supers =

332superClassDictionaryNames supers =

332 [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)

333 [ C.__superclass_ ++ showQualified runProperName pn ++ "_" ++ show (index :: Integer)

333− | (index, (pn, _)) <- zip [0..] supers

334+ | (index, Constraint pn _ _) <- zip [0..] supers

334 ]

335 ]

src/Language/PureScript/TypeChecker.hs+21−15

@@ -36,7 +36,9 @@ import Language.PureScript.Crash

36import Language.PureScript.Environment

37import Language.PureScript.Errors

38import Language.PureScript.Kinds

39+import Language.PureScript.Linter

39import Language.PureScript.Names

40import Language.PureScript.Names

41+import Language.PureScript.Traversals

40import Language.PureScript.TypeClassDictionaries

42import Language.PureScript.TypeClassDictionaries

41import Language.PureScript.Types

43import Language.PureScript.Types

42

44

@@ -228,26 +230,30 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

228 addTypeSynonym moduleName name args' ty kind

230 addTypeSynonym moduleName name args' ty kind

229 return $ TypeSynonymDeclaration name args ty

231 return $ TypeSynonymDeclaration name args ty

230 go TypeDeclaration{} = internalError "Type declarations should have been removed"

232 go TypeDeclaration{} = internalError "Type declarations should have been removed"

231− go (ValueDeclaration name nameKind [] (Right val)) =

233+ go (ValueDeclaration name nameKind [] (Right val)) = do

234+ env <- getEnv

232 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

236+ val' <- checkExhaustiveExpr env moduleName val

233 valueIsNotDefined moduleName name

237 valueIsNotDefined moduleName name

234− [(_, (val', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val)]

238+ [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')]

235 addValue moduleName name ty nameKind

239 addValue moduleName name ty nameKind

236− return $ ValueDeclaration name nameKind [] $ Right val'

240+ return $ ValueDeclaration name nameKind [] $ Right val''

237 go ValueDeclaration{} = internalError "Binders were not desugared"

241 go ValueDeclaration{} = internalError "Binders were not desugared"

238− go (BindingGroupDeclaration vals) =

242+ go (BindingGroupDeclaration vals) = do

243+ env <- getEnv

239 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

244 warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do

240− for_ (map (\(ident, _, _) -> ident) vals) $ \name ->

245+ for_ vals $ \(ident, _, _) ->

241− valueIsNotDefined moduleName name

246+ valueIsNotDefined moduleName ident

247+ vals' <- mapM (thirdM (checkExhaustiveExpr env moduleName)) vals

242− tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals

248+ tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals'

243− vals' <- forM [ (name, val, nameKind, ty)

249+ vals'' <- forM [ (name, val, nameKind, ty)

244− | (name, nameKind, _) <- vals

250+ | (name, nameKind, _) <- vals'

245− , (name', (val, ty)) <- tys

251+ , (name', (val, ty)) <- tys

246− , name == name'

252+ , name == name'

247− ] $ \(name, val, nameKind, ty) -> do

253+ ] $ \(name, val, nameKind, ty) -> do

248 addValue moduleName name ty nameKind

254 addValue moduleName name ty nameKind

249 return (name, nameKind, val)

255 return (name, nameKind, val)

250− return $ BindingGroupDeclaration vals'

256+ return $ BindingGroupDeclaration vals''

251 go (d@(ExternDataDeclaration name kind)) = do

257 go (d@(ExternDataDeclaration name kind)) = do

252 env <- getEnv

258 env <- getEnv

253 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

259 putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }

@@ -268,7 +274,7 @@ typeCheckAll moduleName _ ds = traverse go ds <* traverse_ checkFixities ds

268 return d

274 return d

269 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

275 go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do

270 traverse_ (checkTypeClassInstance moduleName) tys

276 traverse_ (checkTypeClassInstance moduleName) tys

271− forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . snd

277+ forM_ deps $ traverse_ (checkTypeClassInstance moduleName) . constraintArgs

272 checkOrphanInstance dictName className tys

278 checkOrphanInstance dictName className tys

273 _ <- traverseTypeInstanceBody checkInstanceMembers body

279 _ <- traverseTypeInstanceBody checkInstanceMembers body

274 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

280 let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps)

@@ -415,7 +421,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) = warnAndRethrow (addHint

415 findClasses :: Type -> [DeclarationRef]

421 findClasses :: Type -> [DeclarationRef]

416 findClasses = everythingOnTypes (++) go

422 findClasses = everythingOnTypes (++) go

417 where

423 where

418− go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs

424+ go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) cs

419 go _ = []

425 go _ = []

420 extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

426 extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> Maybe (ProperName 'ClassName)

421 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

427 extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name

src/Language/PureScript/TypeChecker/Entailment.hs+9−10

@@ -14,7 +14,6 @@ import Data.List (minimumBy, sortBy, groupBy)

14import Data.Maybe (maybeToList, mapMaybe)

15import qualified Data.Map as M

16

17−import Control.Arrow (Arrow(..))

18import Control.Monad.State

17import Control.Monad.State

19import Control.Monad.Writer

18import Control.Monad.Writer

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

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

@@ -81,13 +80,13 @@ entails shouldGeneralize moduleName context = solve

81 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

80 findDicts ctx cn = maybe [] M.elems . (>>= M.lookup cn) . flip M.lookup ctx

82

81

83 solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])

82 solve :: Constraint -> StateT Context m (Expr, [(Ident, Constraint)])

84− solve (className, tys) = do

83+ solve con = do

85− (dict, unsolved) <- go 0 className tys

84+ (dict, unsolved) <- go 0 con

86 return (dictionaryValueToValue dict, unsolved)

85 return (dictionaryValueToValue dict, unsolved)

87 where

86 where

88− go :: Int -> Qualified (ProperName 'ClassName) -> [Type] -> StateT Context m (DictionaryValue, [(Ident, Constraint)])

87+ go :: Int -> Constraint -> StateT Context m (DictionaryValue, [(Ident, Constraint)])

89− go work className' tys' | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

88+ go work (Constraint className' tys' _) | work > 1000 = throwError . errorMessage $ PossiblyInfiniteInstance className' tys'

90− go work className' tys' = do

89+ go work con'@(Constraint className' tys' _) = do

91 -- Get the inferred constraint context so far, and merge it with the global context

90 -- Get the inferred constraint context so far, and merge it with the global context

92 inferred <- get

91 inferred <- get

93 let instances = do

92 let instances = do

@@ -104,7 +103,7 @@ entails shouldGeneralize moduleName context = solve

104 (mkDictionary (tcdName tcd) args)

103 (mkDictionary (tcdName tcd) args)

105 (tcdPath tcd)

104 (tcdPath tcd)

106 return (match, unsolved)

105 return (match, unsolved)

107− Right unsolved@(unsolvedClassName@(Qualified _ pn), unsolvedTys) -> do

106+ Right unsolved@(Constraint unsolvedClassName@(Qualified _ pn) unsolvedTys _) -> do

108 -- Generate a fresh name for the unsolved constraint's new dictionary

107 -- Generate a fresh name for the unsolved constraint's new dictionary

109 ident <- freshIdent ("dict" ++ runProperName pn)

108 ident <- freshIdent ("dict" ++ runProperName pn)

110 let qident = Qualified Nothing ident

109 let qident = Qualified Nothing ident

@@ -117,8 +116,8 @@ entails shouldGeneralize moduleName context = solve

117 where

116 where

118

117

119 unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)

118 unique :: [(a, TypeClassDictionaryInScope)] -> m (Either (a, TypeClassDictionaryInScope) Constraint)

120− unique [] | shouldGeneralize && all canBeGeneralized tys' = return $ Right (className, tys)

119+ unique [] | shouldGeneralize && all canBeGeneralized tys' = return (Right con')

121− | otherwise = throwError . errorMessage $ NoInstanceFound className' tys'

120+ | otherwise = throwError . errorMessage $ NoInstanceFound con'

122 unique [a] = return $ Left a

121 unique [a] = return $ Left a

123 unique tcds | pairwise overlapping (map snd tcds) = do

122 unique tcds | pairwise overlapping (map snd tcds) = do

124 tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

123 tell . errorMessage $ OverlappingInstances className' tys' (map (tcdName . snd) tcds)

@@ -148,7 +147,7 @@ entails shouldGeneralize moduleName context = solve

148 solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])

147 solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Context m (Maybe [DictionaryValue], [(Ident, Constraint)])

149 solveSubgoals _ Nothing = return (Nothing, [])

148 solveSubgoals _ Nothing = return (Nothing, [])

150 solveSubgoals subst (Just subgoals) = do

149 solveSubgoals subst (Just subgoals) = do

151− zipped <- traverse (uncurry (go (work + 1)) . second (map (replaceAllTypeVars subst))) subgoals

150+ zipped <- traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars subst))) subgoals

152 let (dicts, unsolved) = unzip zipped

151 let (dicts, unsolved) = unzip zipped

153 return (Just dicts, concat unsolved)

152 return (Just dicts, concat unsolved)

154

153

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

@@ -262,7 +262,7 @@ infer' other = (, []) <$> go other

262 unifyKinds k2 (Row k1)

263 return $ Row k1

264 go (ConstrainedType deps ty) = do

265− forM_ deps $ \(className, tys) -> do

265+ forM_ deps $ \(Constraint className tys _) -> do

266 k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

267 unifyKinds k Star

268 k <- go ty

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

@@ -54,7 +54,7 @@ checkDuplicateLabels =

54 checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2

55 checkDups (ForAll _ t _) = checkDups t

56 checkDups (ConstrainedType args t) = do

57− mapM_ checkDups $ concatMap snd args

57+ mapM_ checkDups $ concatMap constraintArgs args

58 checkDups t

59 checkDups r@RCons{} =

60 let (ls, _) = rowToList r in

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

@@ -98,10 +98,10 @@ typesOf bindingGroupType moduleName vals = do

98 $ CannotGeneralizeRecursiveFunction ident generalized

99 -- Make sure any unsolved type constraints only use type variables which appear

100 -- unknown in the inferred type.

101− forM_ unsolved $ \(_, (className, classTys)) -> do

101+ forM_ unsolved $ \(_, con) -> do

102− let constraintTypeVars = nub $ foldMap unknownsInType classTys

102+ let constraintTypeVars = nub $ foldMap unknownsInType (constraintArgs con)

103 when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $

104− throwError . errorMessage $ NoInstanceFound className classTys

104+ throwError . errorMessage $ NoInstanceFound con

105

106 -- Check skolem variables did not escape their scope

107 skolemEscapeCheck val'

@@ -204,7 +204,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'

204 where

205 g :: Expr -> Expr

206 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)

207− g (TypeClassDictionary (nm, tys) sco) = TypeClassDictionary (nm, map f tys) sco

207+ g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco

208 g other = other

209

210-- | Check the kind of a type, failing if it is not of kind *.

@@ -319,7 +319,7 @@ infer' (Let ds val) = do

319 return $ TypedValue True (Let ds' val') valTy

320infer' (SuperClassDictionary className tys) = do

321 dicts <- getTypeClassDictionaries

322− return $ TypeClassDictionary (className, tys) dicts

322+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts

323infer' (TypedValue checkType val ty) = do

324 Just moduleName <- checkCurrentModule <$> get

325 (kind, args) <- kindOfWithScopedVars ty

@@ -527,7 +527,7 @@ check' val (ForAll ident ty _) = do

527 val' <- check skVal sk

528 return $ TypedValue True val' (ForAll ident ty (Just scope))

529check' val t@(ConstrainedType constraints ty) = do

530− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) ->

530+ dictNames <- forM constraints $ \(Constraint (Qualified _ (ProperName className)) _ _) ->

531 freshIdent ("dict" ++ className)

532 dicts <- join <$> zipWithM (newDictionaries []) (map (Qualified Nothing) dictNames) constraints

533 val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty

@@ -538,15 +538,15 @@ check' val t@(ConstrainedType constraints ty) = do

538 newDictionaries

539 :: [(Qualified (ProperName 'ClassName), Integer)]

540 -> Qualified Ident

541− -> (Qualified (ProperName 'ClassName), [Type])

541+ -> Constraint

542 -> m [TypeClassDictionaryInScope]

543− newDictionaries path name (className, instanceTy) = do

543+ newDictionaries path name (Constraint className instanceTy _) = do

544 tcs <- gets (typeClasses . checkEnv)

545 let (args, _, superclasses) = fromMaybe (internalError "newDictionaries: type class lookup failed") $ M.lookup className tcs

546− supDicts <- join <$> zipWithM (\(supName, supArgs) index ->

546+ supDicts <- join <$> zipWithM (\(Constraint supName supArgs _) index ->

547 newDictionaries ((supName, index) : path)

548 name

549− (supName, instantiateSuperclass (map fst args) supArgs instanceTy)

549+ (Constraint supName (instantiateSuperclass (map fst args) supArgs instanceTy) Nothing)

550 ) superclasses [0..]

551 return (TypeClassDictionaryInScope name path className instanceTy Nothing : supDicts)

552

@@ -599,7 +599,7 @@ check' (SuperClassDictionary className tys) _ = do

599 -- declaration gets desugared.

600 -}

601 dicts <- getTypeClassDictionaries

602− return $ TypeClassDictionary (className, tys) dicts

602+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts

603check' (TypedValue checkType val ty1) ty2 = do

604 Just moduleName <- checkCurrentModule <$> get

605 (kind, args) <- kindOfWithScopedVars ty1

src/Language/PureScript/Types.hs+35−14

@@ -14,12 +14,10 @@ import Data.Maybe (fromMaybe)

14import qualified Data.Aeson as A

15import qualified Data.Aeson.TH as A

16

17−import Control.Arrow (second)

18import Control.Monad ((<=<))

17import Control.Monad ((<=<))

19

18

20import Language.PureScript.Names

19import Language.PureScript.Names

21import Language.PureScript.Kinds

20import Language.PureScript.Kinds

22−import Language.PureScript.Traversals

23import Language.PureScript.AST.SourcePos

21import Language.PureScript.AST.SourcePos

24

22

25-- |

23-- |

@@ -109,12 +107,35 @@ data Type

109 | ParensInType Type

107 | ParensInType Type

110 deriving (Show, Read, Eq, Ord)

108 deriving (Show, Read, Eq, Ord)

111

109

112−-- |

110+-- | Additional data relevant to type class constraints

111+data ConstraintData

112+ = PartialConstraintData [[String]] Bool

113+ -- ^ Data to accompany a Partial constraint generated by the exhaustivity checker.

114+ -- It contains (rendered) binder information for those binders which were

115+ -- not matched, and a flag indicating whether the list was truncated or not.

116+ -- Note: we use 'String' here because using 'Binder' would introduce a cyclic

117+ -- dependency in the module graph.

118+ deriving (Show, Read, Eq, Ord)

119+

113−-- A typeclass constraint

120+-- | A typeclass constraint

114−--

121+data Constraint = Constraint

115−type Constraint = (Qualified (ProperName 'ClassName), [Type])

122+ { constraintClass :: Qualified (ProperName 'ClassName)

123+ -- ^ constraint class name

124+ , constraintArgs :: [Type]

125+ -- ^ type arguments

126+ , constraintData :: Maybe ConstraintData

127+ -- ^ additional data relevant to this constraint

128+ } deriving (Show, Read, Eq, Ord)

129+

130+mapConstraintArgs :: ([Type] -> [Type]) -> Constraint -> Constraint

131+mapConstraintArgs f c = c { constraintArgs = f (constraintArgs c) }

132+

133+overConstraintArgs :: Functor f => ([Type] -> f [Type]) -> Constraint -> f Constraint

134+overConstraintArgs f c = (\args -> c { constraintArgs = args }) <$> f (constraintArgs c)

116

135

117$(A.deriveJSON A.defaultOptions ''Type)

136$(A.deriveJSON A.defaultOptions ''Type)

137+$(A.deriveJSON A.defaultOptions ''Constraint)

138+$(A.deriveJSON A.defaultOptions ''ConstraintData)

118

139

119-- |

140-- |

120-- Convert a row to a list of pairs of labels and types

141-- Convert a row to a list of pairs of labels and types

@@ -169,7 +190,7 @@ replaceAllTypeVars = go []

169 where

190 where

170 keys = map fst m

191 keys = map fst m

171 usedVars = concatMap (usedTypeVariables . snd) m

192 usedVars = concatMap (usedTypeVariables . snd) m

172− go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)

193+ go bs m (ConstrainedType cs t) = ConstrainedType (map (mapConstraintArgs (map (go bs m))) cs) (go bs m t)

173 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

194 go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)

174 go bs m (KindedType t k) = KindedType (go bs m t) k

195 go bs m (KindedType t k) = KindedType (go bs m t) k

175 go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3)

196 go bs m (BinaryNoParensType t1 t2 t3) = BinaryNoParensType (go bs m t1) (go bs m t2) (go bs m t3)

@@ -201,7 +222,7 @@ freeTypeVariables = nub . go []

201 go bound (TypeVar v) | v `notElem` bound = [v]

222 go bound (TypeVar v) | v `notElem` bound = [v]

202 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

223 go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2

203 go bound (ForAll v t _) = go (v : bound) t

224 go bound (ForAll v t _) = go (v : bound) t

204− go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t

225+ go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . constraintArgs) cs ++ go bound t

205 go bound (RCons _ t r) = go bound t ++ go bound r

226 go bound (RCons _ t r) = go bound t ++ go bound r

206 go bound (KindedType t _) = go bound t

227 go bound (KindedType t _) = go bound t

207 go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3

228 go bound (BinaryNoParensType t1 t2 t3) = go bound t1 ++ go bound t2 ++ go bound t3

@@ -249,7 +270,7 @@ everywhereOnTypes f = go

249 where

270 where

250 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))

271 go (TypeApp t1 t2) = f (TypeApp (go t1) (go t2))

251 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

272 go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)

252− go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))

273+ go (ConstrainedType cs ty) = f (ConstrainedType (map (mapConstraintArgs (map go)) cs) (go ty))

253 go (RCons name ty rest) = f (RCons name (go ty) (go rest))

274 go (RCons name ty rest) = f (RCons name (go ty) (go rest))

254 go (KindedType ty k) = f (KindedType (go ty) k)

275 go (KindedType ty k) = f (KindedType (go ty) k)

255 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

276 go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))

@@ -264,7 +285,7 @@ everywhereOnTypesTopDown f = go . f

264 where

285 where

265 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))

286 go (TypeApp t1 t2) = TypeApp (go (f t1)) (go (f t2))

266 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

287 go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco

267− go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))

288+ go (ConstrainedType cs ty) = ConstrainedType (map (mapConstraintArgs (map (go . f))) cs) (go (f ty))

268 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

289 go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))

269 go (KindedType ty k) = KindedType (go (f ty)) k

290 go (KindedType ty k) = KindedType (go (f ty)) k

270 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

291 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))

@@ -279,7 +300,7 @@ everywhereOnTypesM f = go

279 where

300 where

280 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

301 go (TypeApp t1 t2) = (TypeApp <$> go t1 <*> go t2) >>= f

281 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

302 go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f

282− go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f

303+ go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (overConstraintArgs (mapM go)) cs <*> go ty) >>= f

283 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

304 go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f

284 go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f

305 go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f

285 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

306 go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f

@@ -294,7 +315,7 @@ everywhereOnTypesTopDownM f = go <=< f

294 where

315 where

295 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

316 go (TypeApp t1 t2) = TypeApp <$> (f t1 >>= go) <*> (f t2 >>= go)

296 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

317 go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco

297− go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)

318+ go (ConstrainedType cs ty) = ConstrainedType <$> mapM (overConstraintArgs (mapM (go <=< f))) cs <*> (f ty >>= go)

298 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

319 go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)

299 go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k

320 go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k

300 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

321 go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)

@@ -309,7 +330,7 @@ everythingOnTypes (<>) f = go

309 where

330 where

310 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

331 go t@(TypeApp t1 t2) = f t <> go t1 <> go t2

311 go t@(ForAll _ ty _) = f t <> go ty

332 go t@(ForAll _ ty _) = f t <> go ty

312− go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty

333+ go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap constraintArgs cs) <> go ty

313 go t@(RCons _ ty rest) = f t <> go ty <> go rest

334 go t@(RCons _ ty rest) = f t <> go ty <> go rest

314 go t@(KindedType ty _) = f t <> go ty

335 go t@(KindedType ty _) = f t <> go ty

315 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

336 go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2

@@ -325,7 +346,7 @@ everythingWithContextOnTypes s0 r0 (<>) f = go' s0

325 go' s t = let (s', r) = f s t in r <> go s' t

346 go' s t = let (s', r) = f s t in r <> go s' t

326 go s (TypeApp t1 t2) = go' s t1 <> go' s t2

347 go s (TypeApp t1 t2) = go' s t1 <> go' s t2

327 go s (ForAll _ ty _) = go' s ty

348 go s (ForAll _ ty _) = go' s ty

328− go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap snd cs) <> go' s ty

349+ go s (ConstrainedType cs ty) = foldl (<>) r0 (map (go' s) $ concatMap constraintArgs cs) <> go' s ty

329 go s (RCons _ ty rest) = go' s ty <> go' s rest

350 go s (RCons _ ty rest) = go' s ty <> go' s rest

330 go s (KindedType ty _) = go' s ty

351 go s (KindedType ty _) = go' s ty

331 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

352 go s (PrettyPrintFunction t1 t2) = go' s t1 <> go' s t2

tests/TestCompiler.hs+1−1

@@ -197,7 +197,7 @@ assertCompiles inputFiles foreigns = do

197 case result of

198 Just (ExitSuccess, out, err)

199 | not (null err) -> return $ Just $ "Test wrote to stderr:\n\n" <> err

200− | trim (last (lines out)) == "Done" -> return Nothing

200+ | not (null out) && trim (last (lines out)) == "Done" -> return Nothing

201 | otherwise -> return $ Just $ "Test did not finish with 'Done':\n\n" <> out

202 Just (ExitFailure _, _, err) -> return $ Just err

203 Nothing -> return $ Just "Couldn't find node.js executable"

tests/TestDocs.hs+1−1

@@ -197,7 +197,7 @@ checkConstrained ty tyClass =

197 False

198 where

199 matches className =

200− (==) className . P.runProperName . P.disqualify . fst

200+ (==) className . P.runProperName . P.disqualify . P.constraintClass

201

202runAssertionIO :: Assertion -> Docs.Module -> IO ()

203runAssertionIO assertion mdl = do

tests/TestUtils.hs+2

@@ -75,6 +75,8 @@ supportModules =

75 , "Data.Show"

76 , "Data.Unit"

77 , "Data.Void"

78+ , "Partial"

79+ , "Partial.Unsafe"

78 , "Prelude"

80 , "Prelude"

79 , "Test.Assert"

81 , "Test.Assert"

80 ]

82 ]

tests/support/bower.json+2−1

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

6 "purescript-eff": "1.0.0-rc.1",

7 "purescript-functions": "1.0.0-rc.1",

8 "purescript-prelude": "1.0.0-rc.3",

9− "purescript-st": "1.0.0-rc.1"

9+ "purescript-st": "1.0.0-rc.1",

10+ "purescript-partial": "1.1.1"

10 }

11 }

11}

12}