0e7c936 · rowtype-yoga/purescript-native

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

Require Partial instance on partial functions (#2072)

* Error on missing Partial constraint * Fix tests * Propagate binder information in constraint * Fix compiler warning * Fix test suite * Comments, pattern synonyms * Fix tests

commit0e7c9369cc1ed4c4fe973e3c4f2497a019a0f751 authorPhil Freeman <paf31@cantab.net> dateThu 5 May 2016, 08:59 (10 years ago) parent339c7ae

42 files changed+284−192

compare with golang

unifiedsplit

examples/passing/1991.purs+1

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

1010

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

1212foldMap 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

1314

1415regression :: Array Int

1516regression =

examples/passing/2049.purs+1

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

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

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

12+f _ = 0

1213

1314main = log "Done"

examples/passing/BindersInFunctions.purs+6−2

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

11module Main where

33import Prelude

4−import Test.Assert

4+import Partial.Unsafe (unsafePartial)

5+import Test.Assert (assert')

6+import Control.Monad.Eff (Eff)

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

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

710

11+main :: Eff _ _

812main = do

9− let ts = snd [1.0, 2.0]

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

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

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

examples/passing/CaseInDo.purs+2

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

11module Main where

33import Prelude

4+import Partial.Unsafe (unsafeCrashWith)

45import Control.Monad.Eff.Console

56import Control.Monad.Eff

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

1718 b <- set

1819 case b of

1920 true -> log "Done"

21+ false -> unsafeCrashWith "Failed"

examples/passing/CaseMultipleExpressions.purs+2

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

11module Main where

33import Prelude

4+import Partial.Unsafe (unsafeCrashWith)

45import Control.Monad.Eff.Console

56import Control.Monad.Eff

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

1718 b <- set

1819 case b of

1920 true -> log "Done"

21+ false -> unsafeCrashWith "Failed"

examples/passing/EmptyTypeClass.purs+5−6

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

11module Main where

33import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

5−class PartialP

6−

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

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

88head [x] = x

10−instance allowPartials :: PartialP

11−

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

10+main :: Eff _ _

11+main = log "Done"

examples/passing/Let.purs+6−3

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

11module Main where

33import Prelude

4+import Partial.Unsafe (unsafePartial)

45import Control.Monad.Eff

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

67import Control.Monad.ST

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

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

1920 f 1.0 2.0 3.0

2021

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

22− f (+) [1.0, 2.0]

22+test4 = let

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

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

2325

2426test5 = let

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

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

4446 g x = f x / 2.0

4547 in f 10.0

4648

49+main :: Eff _ _

4750main = do

4851 logShow (test1 1.0)

4952 logShow (test2 1.0 2.0)

5053 logShow test3

51− logShow test4

54+ unsafePartial (logShow test4)

5255 logShow test5

5356 logShow test7

5457 logShow (test8 100.0)

examples/passing/PartialFunction.purs+11−13

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

1−module Main where

2−

3−import Prelude

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

5−import Test.Assert (assertThrows)

6−

7−fn :: Number -> Number

8−fn 0.0 = 0.0

9−fn 1.0 = 2.0

10−

11−main = do

12− assertThrows $ \_ -> fn 2.0

13− log "Done"

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

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

8+fn 0.0 = 0.0

9+fn 1.0 = 2.0

10+

11+main = log "Done"

examples/passing/ReservedWords.purs+3

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

22module Main where

44import Prelude

5+import Control.Monad.Eff

67o :: { type :: String }

78o = { type: "o" }

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

1112

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

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

15+f _ = "Fail"

1416

17+main :: Eff _ _

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

examples/passing/ShadowedTCOLet.purs+4−1

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

11module Main where

33import Prelude

4+import Partial.Unsafe (unsafePartial)

5+import Control.Monad.Eff

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

68f x y z =

79 let f 1.0 2.0 3.0 = 1.0

810 in f x z y

911

12+main :: Eff _ _

1013main = do

11− log $ show $ f 1.0 3.0 2.0

14+ log $ show $ unsafePartial f 1.0 3.0 2.0

1215 log "Done"

examples/passing/UnderscoreIdent.purs+1

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

77type Type_name = Data_type

99done (Con_2 s) = s

10+done _ = "Failed"

1011

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

examples/passing/Where.purs+4−1

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

11module Main where

33import Prelude

4+import Partial.Unsafe (unsafePartial)

5+import Control.Monad.Eff

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

68test1 x = y

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

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

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

3739

40+main :: Eff _ _

3841main = do

3942 logShow (test1 1.0)

4043 logShow (test2 1.0 2.0)

4144 logShow test3

42− logShow test4

45+ unsafePartial (logShow test4)

4346 logShow test5

4447 logShow test6

4548 logShow (test7 100.0)

hierarchy/Main.hs+1−2

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

8484

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

8686superClasses (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

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

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

9090superClasses _ = []

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

113113 infoModList = fullDesc <> headerInfo <> footerInfo

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

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

116−

psci/PSCi/Printer.hs+1−1

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

5858 if null constrs

5959 then Box.text ""

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

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

6363 className =

6464 Box.text (P.runProperName name)

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

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

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

100100 where

101101

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

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

103103 fromType = everythingOnTypes (++) go

104104

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

579579 where

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

581581 forDecls (ExternDeclaration _ ty) = f ty

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

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

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

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

584584 forDecls (TypeSynonymDeclaration _ _ ty) = f ty

585585 forDecls (TypeDeclaration _ ty) = f ty

586586 forDecls _ = mempty

587587

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

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

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

590590 forValues (TypedValue _ _ ty) = f ty

591591 forValues _ = mempty

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

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

1−-- |

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

3−--

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE PatternSynonyms #-}

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

45module Language.PureScript.Constants where

7+import Language.PureScript.Names

69-- Operators

710

811($) :: String

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

317320main :: String

318321main = "main"

319322

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+

320331-- Code Generation

321332

322333__superclass_ :: String

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

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

489489typeClassConstraintFor Declaration{..} =

490490 case declInfo of

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

493493 _ ->

494494 Nothing

495495 where

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

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

107107renderConstraint = renderConstraintWithOptions defaultRenderTypeOptions

108108

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

110−renderConstraintWithOptions opts (pn, tys) =

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

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

112112

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

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

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

5656 Nothing

5757

5858renderConstraint :: Constraint -> RenderedCode

59−renderConstraint (pn, tys) =

59+renderConstraint (Constraint pn tys _) =

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

6161 in renderType instApp

6262

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

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

465465 <*> nth 1 asIntegral

466466

467467asConstraint :: Parse PackageError P.Constraint

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

469− <*> nth 1 (eachInArray asType)

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

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

470+ <*> pure Nothing

470471

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

472473asQualifiedProperName = fromAesonParser

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

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

2929import Language.PureScript.Types

3030import Language.PureScript.Names

3131import Language.PureScript.Kinds

32+import qualified Language.PureScript.Constants as C

3233import qualified Language.PureScript.Bundle as Bundle

3334

3435import qualified Text.PrettyPrint.Boxes as Box

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

102103 | KindsDoNotUnify Kind Kind

103104 | ConstrainedTypeUnified Type Type

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

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

106+ | NoInstanceFound Constraint

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

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

108109 | CannotFindDerivingType (ProperName 'TypeName)

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

130131 | WildcardInferredType Type

131132 | HoleInferredType String Type

132133 | MissingTypeDeclaration Ident Type

133− | NotExhaustivePattern [[Binder]] Bool

134134 | OverlappingPattern [[Binder]] Bool

135135 | IncompleteExhaustivityCheck

136136 | ClassOperator (ProperName 'ClassName) Ident

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

315315 WildcardInferredType{} -> "WildcardInferredType"

316316 HoleInferredType{} -> "HoleInferredType"

317317 MissingTypeDeclaration{} -> "MissingTypeDeclaration"

318− NotExhaustivePattern{} -> "NotExhaustivePattern"

319318 OverlappingPattern{} -> "OverlappingPattern"

320319 IncompleteExhaustivityCheck{} -> "IncompleteExhaustivityCheck"

321320 ClassOperator{} -> "ClassOperator"

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

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

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

424423 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

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

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

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

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

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

756755 ]

757756 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 _)) =

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

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

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

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

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

888898 , indent $ typeAsBox ty

889899 ]

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− ]

900900 renderSimpleErrorMessage (OverlappingPattern bs b) =

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

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

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

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

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

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

99--

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

10+module Language.PureScript.Linter.Exhaustive

11+ ( checkExhaustiveExpr

12+ ) where

1113

1214import Prelude ()

1315import Prelude.Compat

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

2325import Control.Monad.Writer.Class

2426

2527import Language.PureScript.Crash

28+import qualified Language.PureScript.Constants as C

2629import Language.PureScript.AST.Binders

2730import Language.PureScript.AST.Literals

2831import Language.PureScript.AST.Declarations

2932import Language.PureScript.Environment

3033import Language.PureScript.Names as P

3134import Language.PureScript.Kinds

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

36+import Language.PureScript.Traversals

3237import Language.PureScript.Types as P

3338import Language.PureScript.Errors

3439

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

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

180185missingCasesMultiple env mn = go

181186 where

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

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

184188 where

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

186190 (miss2, pr2) = go xs ys

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

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

188192

189193-- |

190194-- Guard handling

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

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

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

231235--

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

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

236+checkExhaustive

237+ :: forall m

238+ . (MonadWriter MultipleErrors m)

239+ => Environment

240+ -> ModuleName

241+ -> Int

242+ -> [CaseAlternative]

243+ -> Expr

244+ -> m Expr

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

234246 where

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

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

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

246258 )

247259 )

248260

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

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

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

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

252− unless (null bss') tellRedundant

263+ do unless (null bss') tellRedundant

253264 case rr of

254− Left Incomplete -> unless hasConstraint tellIncomplete

265+ Left Incomplete -> tellIncomplete

255266 _ -> return ()

267+ if null bss

268+ then return expr

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

256270 where

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

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

259− tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

260−

261−-- |

262−-- Exhaustivity checking over a list of declarations

263−--

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

265−checkExhaustiveDecls env mn = mapM_ onDecl

266− where

267− onDecl :: Declaration -> m ()

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

269− where

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

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

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

272+ tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck

273+

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

275+ --

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

277+ --

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

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

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

281+ addPartialConstraint (bss, complete) e =

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

298283 where

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

300− go qname

301− | qname == partialClass = True

302− | otherwise =

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

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

305− _ -> False

306− partialClass :: Qualified (ProperName 'ClassName)

307− partialClass = primName "Partial"

308− hasPartialConstraint _ = False

284+ partial :: Declaration

285+ partial = ValueDeclaration (Ident C.__unused)

286+ Private

287+ []

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

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

290+ ty))

291+

292+ ty :: Type

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

309301

310302-- |

311−-- Exhaustivity checking over a single module

303+-- Exhaustivity checking

312304--

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

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

305+checkExhaustiveExpr

306+ :: forall m

307+ . MonadWriter MultipleErrors m

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

158158 progress $ CompilingModule moduleName

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

160160 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

162162 [desugared] <- desugar externs [m]

163163 runCheck' env $ typeCheckModule desugared

164− checkExhaustiveModule env' checked

165164 regrouped <- createBindingGroups moduleName . collapseBindingGroups $ elaborated

166165 let mod' = Module ss coms moduleName regrouped exps

167166 corefn = CF.moduleToCoreFn env' mod'

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

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

184184 return $ TypeClassDeclaration className idents implies members

185185

186186parseConstraint :: TokenParser Constraint

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

187+parseConstraint = Constraint <$> parseQualified properName

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

189+ <*> pure Nothing

188190

189191parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

190192parseInstanceDeclaration = do

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

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

7575 className <- parseQualified properName

7676 indented

7777 ty <- P.many parseTypeAtom

78− return (className, ty)

78+ return (Constraint className ty Nothing)

7979

8080

8181parseAnyType :: TokenParser Type

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

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

4242 match _ = Nothing

4343

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

45−constraintsAsBox [(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)

45+constraintsAsBox [(Constraint pn tys _)] ty = text "(" <> constraintAsBox pn tys <> 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)

4747

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

4949constraintAsBox 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

1414import Language.PureScript.Names

1515import Language.PureScript.Pretty.Common

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

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

1718

1819import Text.PrettyPrint.Boxes

1920

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

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

5859prettyPrintValue d (Do els) =

5960 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

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

6263prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

6364 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 =

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

148148 usedNames (ConstrainedType constraints _) =

149149 flip mapMaybe constraints $ \case

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

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

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

152152 _ -> Nothing

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

251251 updateType t = return t

252252

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

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

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

255+ Constraint <$> updateClassName name pos

256+ <*> traverse (updateTypesEverywhere pos) ts

257+ <*> pure info)

255258

256259 updateTypeName

257260 :: Qualified (ProperName 'TypeName)

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

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

280280 ty' <- goType' pos ty

281281 return (pos, ExternDeclaration name ty')

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

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

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

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

285285 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

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

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

289289 goDecl pos (TypeSynonymDeclaration name args ty) = do

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

296296

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

298298 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

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

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

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

302302 goExpr pos (SuperClassDictionary cls tys) = do

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

304304 return (pos, SuperClassDictionary cls tys')

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

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

5252desugarTypeClasses externs = flip evalStateT initialState . traverse desugarModule

5353 where

5454 initialState :: MemberMap

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

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

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

5657

5758 fromExternsDecl

5859 :: ModuleName

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

233234typeClassDictionaryDeclaration name args implies members =

234235 let superclassTypes = superClassDictionaryNames implies `zip`

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

236− | (superclass, tyArgs) <- implies

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

237238 ]

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

239240 mtys = members' ++ superclassTypes

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

249250 let className = Qualified (Just mn) name

250251 in ValueDeclaration ident Private [] $ Right $

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

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

254255 PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d

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

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

293294 -- The dictionary itself is an object literal.

294295 let superclasses = superClassDictionaryNames implies `zip`

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

296− | (superclass, suTyArgs) <- implies

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

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

298299 ]

299300

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

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

331332superClassDictionaryNames supers =

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

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

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

334335 ]

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

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

3636import Language.PureScript.Environment

3737import Language.PureScript.Errors

3838import Language.PureScript.Kinds

39+import Language.PureScript.Linter

3940import Language.PureScript.Names

41+import Language.PureScript.Traversals

4042import Language.PureScript.TypeClassDictionaries

4143import Language.PureScript.Types

4244

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

228230 addTypeSynonym moduleName name args' ty kind

229231 return $ TypeSynonymDeclaration name args ty

230232 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

232235 warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do

236+ val' <- checkExhaustiveExpr env moduleName val

233237 valueIsNotDefined moduleName name

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

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

235239 addValue moduleName name ty nameKind

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

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

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

238− go (BindingGroupDeclaration vals) =

242+ go (BindingGroupDeclaration vals) = do

243+ env <- getEnv

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

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

241− valueIsNotDefined moduleName name

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

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

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

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

246− , name == name'

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

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

246+ valueIsNotDefined moduleName ident

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

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

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

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

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

252+ , name == name'

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

248254 addValue moduleName name ty nameKind

249255 return (name, nameKind, val)

250− return $ BindingGroupDeclaration vals'

256+ return $ BindingGroupDeclaration vals''

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

252258 env <- getEnv

253259 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

268274 return d

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

270276 traverse_ (checkTypeClassInstance moduleName) tys

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

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

272278 checkOrphanInstance dictName className tys

273279 _ <- traverseTypeInstanceBody checkInstanceMembers body

274280 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

415421 findClasses :: Type -> [DeclarationRef]

416422 findClasses = everythingOnTypes (++) go

417423 where

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

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

419425 go _ = []

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

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

1414import Data.Maybe (maybeToList, mapMaybe)

1515import qualified Data.Map as M

1616

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

1817import Control.Monad.State

1918import Control.Monad.Writer

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

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

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

8281

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

84− solve (className, tys) = do

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

83+ solve con = do

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

8685 return (dictionaryValueToValue dict, unsolved)

8786 where

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

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

90− go work className' tys' = do

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

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

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

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

9291 inferred <- get

9392 let instances = do

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

104103 (mkDictionary (tcdName tcd) args)

105104 (tcdPath tcd)

106105 return (match, unsolved)

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

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

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

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

110109 let qident = Qualified Nothing ident

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

117116 where

118117

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

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

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

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

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

122121 unique [a] = return $ Left a

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

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

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

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

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

150149 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

152151 let (dicts, unsolved) = unzip zipped

153152 return (Just dicts, concat unsolved)

154153

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

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

262262 unifyKinds k2 (Row k1)

263263 return $ Row k1

264264 go (ConstrainedType deps ty) = do

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

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

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

267267 unifyKinds k Star

268268 k <- go ty

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

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

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

5555 checkDups (ForAll _ t _) = checkDups t

5656 checkDups (ConstrainedType args t) = do

57− mapM_ checkDups $ concatMap snd args

57+ mapM_ checkDups $ concatMap constraintArgs args

5858 checkDups t

5959 checkDups r@RCons{} =

6060 let (ls, _) = rowToList r in

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

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

9898 $ CannotGeneralizeRecursiveFunction ident generalized

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

100100 -- unknown in the inferred type.

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

102− let constraintTypeVars = nub $ foldMap unknownsInType classTys

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

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

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

104− throwError . errorMessage $ NoInstanceFound className classTys

104+ throwError . errorMessage $ NoInstanceFound con

105105

106106 -- Check skolem variables did not escape their scope

107107 skolemEscapeCheck val'

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

204204 where

205205 g :: Expr -> Expr

206206 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

208208 g other = other

209209

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

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

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

320320infer' (SuperClassDictionary className tys) = do

321321 dicts <- getTypeClassDictionaries

322− return $ TypeClassDictionary (className, tys) dicts

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

323323infer' (TypedValue checkType val ty) = do

324324 Just moduleName <- checkCurrentModule <$> get

325325 (kind, args) <- kindOfWithScopedVars ty

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

527527 val' <- check skVal sk

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

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

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

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

531531 freshIdent ("dict" ++ className)

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

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

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

538538 newDictionaries

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

540540 -> Qualified Ident

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

541+ -> Constraint

542542 -> m [TypeClassDictionaryInScope]

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

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

544544 tcs <- gets (typeClasses . checkEnv)

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

547547 newDictionaries ((supName, index) : path)

548548 name

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

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

550550 ) superclasses [0..]

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

552552

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

599599 -- declaration gets desugared.

600600 -}

601601 dicts <- getTypeClassDictionaries

602− return $ TypeClassDictionary (className, tys) dicts

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

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

604604 Just moduleName <- checkCurrentModule <$> get

605605 (kind, args) <- kindOfWithScopedVars ty1

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

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

1414import qualified Data.Aeson as A

1515import qualified Data.Aeson.TH as A

1616

17−import Control.Arrow (second)

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

1918

2019import Language.PureScript.Names

2120import Language.PureScript.Kinds

22−import Language.PureScript.Traversals

2321import Language.PureScript.AST.SourcePos

2422

2523-- |

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

109107 | ParensInType Type

110108 deriving (Show, Read, Eq, Ord)

111109

112−-- |

113−-- A typeclass constraint

114−--

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

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+

120+-- | A typeclass constraint

121+data Constraint = Constraint

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)

116135

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

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

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

118139

119140-- |

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

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

169190 where

170191 keys = map fst m

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

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

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

175196 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 []

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

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

203224 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

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

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

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

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

249270 where

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

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

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

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

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

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

264285 where

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

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

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

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

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

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

279300 where

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

281302 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

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

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

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

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

294315 where

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

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

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

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

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

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

309330 where

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

311332 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

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

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

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

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

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

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

327348 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

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

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

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

tests/TestCompiler.hs+1−1

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

197197 case result of

198198 Just (ExitSuccess, out, err)

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

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

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

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

tests/TestDocs.hs+1−1

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

197197 False

198198 where

199199 matches className =

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

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

201201

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

203203runAssertionIO assertion mdl = do

tests/TestUtils.hs+2

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

7575 , "Data.Show"

7676 , "Data.Unit"

7777 , "Data.Void"

78+ , "Partial"

79+ , "Partial.Unsafe"

7880 , "Prelude"

7981 , "Test.Assert"

8082 ]

tests/support/bower.json+2−1

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

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

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

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

1011 }

1112}