Skip to content

Commit e6a61b0

Browse files
garybgaryb
committed
Merge pull request purescript#1704 from purescript/partial-constraint
Add native Partial constraint
2 parents 6fee613 + 8114b6e commit e6a61b0

6 files changed

Lines changed: 79 additions & 50 deletions

File tree

‎examples/passing/EmptyTypeClass.purs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -2,11 +2,11 @@ module Main where
22

33
import Prelude
44

5-
class Partial
5+
class PartialP
66

7-
head :: forall a. (Partial) => Array a -> a
7+
head :: forall a. (PartialP) => Array a -> a
88
head [x] = x
99

10-
instance allowPartials :: Partial
10+
instance allowPartials :: PartialP
1111

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

‎examples/passing/NakedConstraint.purs‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,6 @@ module Main where
22

33
import Control.Monad.Eff.Console
44

5-
class Partial
6-
75
data List a = Nil | Cons a (List a)
86

97
head :: (Partial) => List Int -> Int

‎src/Language/PureScript/Environment.hs‎

Lines changed: 25 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -66,7 +66,7 @@ data Environment = Environment {
6666
-- The initial environment with no values and only the default javascript types defined
6767
--
6868
initEnvironment :: Environment
69-
initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
69+
initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses
7070

7171
-- |
7272
-- The visibility of a name in scope
@@ -236,17 +236,32 @@ function :: Type -> Type -> Type
236236
function t1 = TypeApp (TypeApp tyFunction t1)
237237

238238
-- |
239-
-- The primitive types in the external javascript environment with their associated kinds.
239+
-- The primitive types in the external javascript environment with their
240+
-- associated kinds. There is also a pseudo `Partial` type that corresponds to
241+
-- the class with the same name.
240242
--
241243
primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
242-
primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
243-
, (primName "Array" , (FunKind Star Star, ExternData))
244-
, (primName "Object" , (FunKind (Row Star) Star, ExternData))
245-
, (primName "String" , (Star, ExternData))
246-
, (primName "Char" , (Star, ExternData))
247-
, (primName "Number" , (Star, ExternData))
248-
, (primName "Int" , (Star, ExternData))
249-
, (primName "Boolean" , (Star, ExternData)) ]
244+
primTypes =
245+
M.fromList
246+
[ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
247+
, (primName "Array", (FunKind Star Star, ExternData))
248+
, (primName "Object", (FunKind (Row Star) Star, ExternData))
249+
, (primName "String", (Star, ExternData))
250+
, (primName "Char", (Star, ExternData))
251+
, (primName "Number", (Star, ExternData))
252+
, (primName "Int", (Star, ExternData))
253+
, (primName "Boolean", (Star, ExternData))
254+
, (primName "Partial", (Star, ExternData))
255+
]
256+
257+
-- |
258+
-- The primitive class map. This just contains to `Partial` class, used as a
259+
-- kind of magic constraint for partial functions.
260+
--
261+
primClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
262+
primClasses =
263+
M.fromList
264+
[ (primName "Partial", ([], [], [])) ]
250265

251266
-- |
252267
-- Finds information about data constructors from the current environment.

‎src/Language/PureScript/Errors.hs‎

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -773,9 +773,12 @@ prettyPrintSingleError full level e = do
773773
renderSimpleErrorMessage (NotExhaustivePattern bs b) =
774774
paras $ [ line "A case expression could not be determined to cover all inputs."
775775
, line "The following additional cases are required to cover all inputs:\n"
776-
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
777-
] ++
778-
[ line "..." | not b ]
776+
, indent $ paras $
777+
[ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
778+
++ [ line "..." | not b ]
779+
, line "Or alternatively, add a Partial constraint to the type of the enclosing value."
780+
, line "Non-exhaustive patterns for values without a `Partial` constraint will be disallowed in PureScript 0.9."
781+
]
779782
renderSimpleErrorMessage (OverlappingPattern bs b) =
780783
paras $ [ line "A case expression contains unreachable cases:\n"
781784
, Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))

‎src/Language/PureScript/Linter/Exhaustive.hs‎

Lines changed: 41 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -19,10 +19,7 @@
1919
{-# LANGUAGE FlexibleContexts #-}
2020
{-# LANGUAGE ScopedTypeVariables #-}
2121

22-
module Language.PureScript.Linter.Exhaustive
23-
( checkExhaustive
24-
, checkExhaustiveModule
25-
) where
22+
module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
2623

2724
import Prelude ()
2825
import Prelude.Compat
@@ -48,7 +45,7 @@ import Language.PureScript.Errors
4845

4946
-- | There are two modes of failure for the redudancy check:
5047
--
51-
-- 1. Exhaustivity was incomeplete due to too many cases, so we couldn't determine redundancy.
48+
-- 1. Exhaustivity was incomplete due to too many cases, so we couldn't determine redundancy.
5249
-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
5350
--
5451
-- We want to warn the user in the first case.
@@ -239,8 +236,8 @@ missingAlternative env mn ca uncovered
239236
-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
240237
-- Then, returns the uncovered set of case alternatives.
241238
--
242-
checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
243-
checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
239+
checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
240+
checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
244241
where
245242
step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
246243
step (uncovered, (nec, redundant)) ca =
@@ -258,13 +255,13 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
258255

259256
makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
260257
makeResult (bss, (rr, bss')) =
261-
do unless (null bss) tellExhaustive
258+
do unless (hasConstraint || null bss) tellNonExhaustive
262259
unless (null bss') tellRedundant
263260
case rr of
264-
Left Incomplete -> tellIncomplete
261+
Left Incomplete -> unless hasConstraint tellIncomplete
265262
_ -> return ()
266263
where
267-
tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
264+
tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
268265
tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
269266
tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
270267

@@ -279,29 +276,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl
279276
where
280277
convert :: (Ident, NameKind, Expr) -> Declaration
281278
convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
282-
onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr e)
279+
onDecl (ValueDeclaration name _ _ (Right e)) = censor (addHint (ErrorInValueDeclaration name)) (onExpr False e)
283280
onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
284281
onDecl _ = return ()
285282

286-
onExpr :: Expr -> m ()
287-
onExpr (UnaryMinus e) = onExpr e
288-
onExpr (ArrayLiteral es) = mapM_ onExpr es
289-
onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
290-
onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
291-
onExpr (Accessor _ e) = onExpr e
292-
onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
293-
onExpr (Abs _ e) = onExpr e
294-
onExpr (App e1 e2) = onExpr e1 >> onExpr e2
295-
onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
296-
onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
297-
onExpr (TypedValue _ e _) = onExpr e
298-
onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
299-
onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
300-
onExpr _ = return ()
301-
302-
onCaseAlternative :: CaseAlternative -> m ()
303-
onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
304-
onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
283+
onExpr :: Bool -> Expr -> m ()
284+
onExpr isP (UnaryMinus e) = onExpr isP e
285+
onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
286+
onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
287+
onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
288+
onExpr isP (Accessor _ e) = onExpr isP e
289+
onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
290+
onExpr isP (Abs _ e) = onExpr isP e
291+
onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2
292+
onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3
293+
onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas
294+
onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e
295+
onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e
296+
onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)
297+
onExpr _ _ = return ()
298+
299+
onCaseAlternative :: Bool -> CaseAlternative -> m ()
300+
onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es
301+
onCaseAlternative isP (CaseAlternative _ (Right e)) = onExpr isP e
302+
303+
hasPartialConstraint :: Type -> Bool
304+
hasPartialConstraint (ConstrainedType cs _) = any (go . fst) cs
305+
where
306+
go :: Qualified ProperName -> Bool
307+
go qname
308+
| qname == partialClass = True
309+
| otherwise =
310+
case qname `M.lookup` typeClasses env of
311+
Just ([], _, cs') -> any (go . fst) cs'
312+
_ -> False
313+
partialClass :: Qualified ProperName
314+
partialClass = primName "Partial"
315+
hasPartialConstraint _ = False
305316

306317
-- |
307318
-- Exhaustivity checking over a single module

‎src/Language/PureScript/Sugar/Names/Env.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ module Language.PureScript.Sugar.Names.Env
2020

2121
import Data.Function (on)
2222
import Data.List (groupBy, sortBy, nub)
23+
import Data.Maybe (fromJust)
2324
import qualified Data.Map as M
2425

2526
import Control.Monad
@@ -121,9 +122,10 @@ envModuleExports (_, _, exps) = exps
121122
-- The exported types from the @Prim@ module
122123
--
123124
primExports :: Exports
124-
primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
125+
primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
125126
where
126-
mkTypeEntry (Qualified _ name) = ((name, []), ModuleName [ProperName "Prim"])
127+
mkTypeEntry (Qualified mn name) = ((name, []), fromJust mn)
128+
mkClassEntry (Qualified mn name) = (name, fromJust mn)
127129

128130
-- | Environment which only contains the Prim module.
129131
primEnv :: Env

0 commit comments

Comments
 (0)