git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add native Partial constraint
8114b6eGary Burgess
examples/passing/EmptyTypeClass.purs+3−3
compare with golang
unifiedsplit
@@ -2,11 +2,11 @@ module Main where
2
2
3import Prelude
3import Prelude
4
4
5−class Partial
5+class PartialP
6
6
7−head :: forall a. (Partial) => Array a -> a
7+head :: forall a. (PartialP) => Array a -> a
8head [x] = x
8head [x] = x
9
9
10−instance allowPartials :: Partial
10+instance allowPartials :: PartialP
11
11
12main = Control.Monad.Eff.Console.log $ head ["Done"]
12main = Control.Monad.Eff.Console.log $ head ["Done"]
examples/passing/NakedConstraint.purs−2
@@ -2,8 +2,6 @@ module Main where
2
2
3import Control.Monad.Eff.Console
3import Control.Monad.Eff.Console
4
4
5−class Partial
6−
7data List a = Nil | Cons a (List a)
5data List a = Nil | Cons a (List a)
8
6
9head :: (Partial) => List Int -> Int
7head :: (Partial) => List Int -> Int
src/Language/PureScript/Environment.hs+25−10
@@ -66,7 +66,7 @@ data Environment = Environment {
66-- The initial environment with no values and only the default javascript types defined
66-- The initial environment with no values and only the default javascript types defined
67--
67--
68initEnvironment :: Environment
68initEnvironment :: 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
70
70
71-- |
71-- |
72-- The visibility of a name in scope
72-- The visibility of a name in scope
@@ -236,17 +236,32 @@ function :: Type -> Type -> Type
236function t1 = TypeApp (TypeApp tyFunction t1)
236function t1 = TypeApp (TypeApp tyFunction t1)
237
237
238-- |
238-- |
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.
240--
242--
241primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
243primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
244+primTypes =
245+ M.fromList
242−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
246+ [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData))
243− , (primName "Array" , (FunKind Star Star, ExternData))
247+ , (primName "Array", (FunKind Star Star, ExternData))
244− , (primName "Object" , (FunKind (Row Star) Star, ExternData))
248+ , (primName "Object", (FunKind (Row Star) Star, ExternData))
245− , (primName "String" , (Star, ExternData))
249+ , (primName "String", (Star, ExternData))
246− , (primName "Char" , (Star, ExternData))
250+ , (primName "Char", (Star, ExternData))
247− , (primName "Number" , (Star, ExternData))
251+ , (primName "Number", (Star, ExternData))
248− , (primName "Int" , (Star, ExternData))
252+ , (primName "Int", (Star, ExternData))
249− , (primName "Boolean" , (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", ([], [], [])) ]
250
265
251-- |
266-- |
252-- Finds information about data constructors from the current environment.
267-- Finds information about data constructors from the current environment.
src/Language/PureScript/Errors.hs+6−3
@@ -773,9 +773,12 @@ prettyPrintSingleError full level e = do
773 renderSimpleErrorMessage (NotExhaustivePattern bs b) =
773 renderSimpleErrorMessage (NotExhaustivePattern bs b) =
774 paras $ [ line "A case expression could not be determined to cover all inputs."
774 paras $ [ line "A case expression could not be determined to cover all inputs."
775 , line "The following additional cases are required to cover all inputs:\n"
775 , line "The following additional cases are required to cover all inputs:\n"
776+ , indent $ paras $
776− , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
777+ [ Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs)) ]
777− ] ++
778− [ line "..." | not b ]
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+ ]
779 renderSimpleErrorMessage (OverlappingPattern bs b) =
782 renderSimpleErrorMessage (OverlappingPattern bs b) =
780 paras $ [ line "A case expression contains unreachable cases:\n"
783 paras $ [ line "A case expression contains unreachable cases:\n"
781 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
784 , Box.hsep 1 Box.left (map (paras . map (line . prettyPrintBinderAtom)) (transpose bs))
src/Language/PureScript/Linter/Exhaustive.hs+41−30
@@ -19,10 +19,7 @@
19{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE FlexibleContexts #-}
20{-# LANGUAGE ScopedTypeVariables #-}
20{-# LANGUAGE ScopedTypeVariables #-}
21
21
22−module Language.PureScript.Linter.Exhaustive
22+module Language.PureScript.Linter.Exhaustive (checkExhaustiveModule) where
23− ( checkExhaustive
24− , checkExhaustiveModule
25− ) where
26
23
27import Prelude ()
24import Prelude ()
28import Prelude.Compat
25import Prelude.Compat
@@ -48,7 +45,7 @@ import Language.PureScript.Errors
48
45
49-- | There are two modes of failure for the redudancy check:
46-- | There are two modes of failure for the redudancy check:
50--
47--
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.
52-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
49-- 2. We didn't attempt to determine redundancy for a binder, e.g. an integer binder.
53--
50--
54-- We want to warn the user in the first case.
51-- We want to warn the user in the first case.
@@ -239,8 +236,8 @@ missingAlternative env mn ca uncovered
239-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
236-- it partitions that set with the new uncovered cases, until it consumes the whole set of clauses.
240-- Then, returns the uncovered set of case alternatives.
237-- Then, returns the uncovered set of case alternatives.
241--
238--
242−checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
239+checkExhaustive :: forall m. (MonadWriter MultipleErrors m) => Bool -> Environment -> ModuleName -> Int -> [CaseAlternative] -> m ()
243−checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
240+checkExhaustive hasConstraint env mn numArgs cas = makeResult . first nub $ foldl' step ([initialize numArgs], (pure True, [])) cas
244 where
241 where
245 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
242 step :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedudancyError Bool, [[Binder]]))
246 step (uncovered, (nec, redundant)) ca =
243 step (uncovered, (nec, redundant)) ca =
@@ -258,13 +255,13 @@ checkExhaustive env mn numArgs cas = makeResult . first nub $ foldl' step ([init
258
255
259 makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
256 makeResult :: ([[Binder]], (Either RedudancyError Bool, [[Binder]])) -> m ()
260 makeResult (bss, (rr, bss')) =
257 makeResult (bss, (rr, bss')) =
261− do unless (null bss) tellExhaustive
258+ do unless (hasConstraint || null bss) tellNonExhaustive
262 unless (null bss') tellRedundant
259 unless (null bss') tellRedundant
263 case rr of
260 case rr of
264− Left Incomplete -> tellIncomplete
261+ Left Incomplete -> unless hasConstraint tellIncomplete
265 _ -> return ()
262 _ -> return ()
266 where
263 where
267− tellExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
264+ tellNonExhaustive = tell . errorMessage . uncurry NotExhaustivePattern . second null . splitAt 5 $ bss
268 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
265 tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss'
269 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
266 tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck
270
267
@@ -279,29 +276,43 @@ checkExhaustiveDecls env mn = mapM_ onDecl
279 where
276 where
280 convert :: (Ident, NameKind, Expr) -> Declaration
277 convert :: (Ident, NameKind, Expr) -> Declaration
281 convert (name, nk, e) = ValueDeclaration name nk [] (Right e)
278 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)
283 onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
280 onDecl (PositionedDeclaration pos _ dec) = censor (addHint (PositionedError pos)) (onDecl dec)
284 onDecl _ = return ()
281 onDecl _ = return ()
285
282
286− onExpr :: Expr -> m ()
283+ onExpr :: Bool -> Expr -> m ()
287− onExpr (UnaryMinus e) = onExpr e
284+ onExpr isP (UnaryMinus e) = onExpr isP e
288− onExpr (ArrayLiteral es) = mapM_ onExpr es
285+ onExpr isP (ArrayLiteral es) = mapM_ (onExpr isP) es
289− onExpr (ObjectLiteral es) = mapM_ (onExpr . snd) es
286+ onExpr isP (ObjectLiteral es) = mapM_ (onExpr isP . snd) es
290− onExpr (TypeClassDictionaryConstructorApp _ e) = onExpr e
287+ onExpr isP (TypeClassDictionaryConstructorApp _ e) = onExpr isP e
291− onExpr (Accessor _ e) = onExpr e
288+ onExpr isP (Accessor _ e) = onExpr isP e
292− onExpr (ObjectUpdate o es) = onExpr o >> mapM_ (onExpr . snd) es
289+ onExpr isP (ObjectUpdate o es) = onExpr isP o >> mapM_ (onExpr isP . snd) es
293− onExpr (Abs _ e) = onExpr e
290+ onExpr isP (Abs _ e) = onExpr isP e
294− onExpr (App e1 e2) = onExpr e1 >> onExpr e2
291+ onExpr isP (App e1 e2) = onExpr isP e1 >> onExpr isP e2
295− onExpr (IfThenElse e1 e2 e3) = onExpr e1 >> onExpr e2 >> onExpr e3
292+ onExpr isP (IfThenElse e1 e2 e3) = onExpr isP e1 >> onExpr isP e2 >> onExpr isP e3
296− onExpr (Case es cas) = checkExhaustive env mn (length es) cas >> mapM_ onExpr es >> mapM_ onCaseAlternative cas
293+ onExpr isP (Case es cas) = checkExhaustive isP env mn (length es) cas >> mapM_ (onExpr isP) es >> mapM_ (onCaseAlternative isP) cas
297− onExpr (TypedValue _ e _) = onExpr e
294+ onExpr isP (TypedValue _ e ty) = onExpr (isP || hasPartialConstraint ty) e
298− onExpr (Let ds e) = mapM_ onDecl ds >> onExpr e
295+ onExpr isP (Let ds e) = mapM_ onDecl ds >> onExpr isP e
299− onExpr (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr e)
296+ onExpr isP (PositionedValue pos _ e) = censor (addHint (PositionedError pos)) (onExpr isP e)
300− onExpr _ = return ()
297+ onExpr _ _ = return ()
301−
298+
302− onCaseAlternative :: CaseAlternative -> m ()
299+ onCaseAlternative :: Bool -> CaseAlternative -> m ()
303− onCaseAlternative (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr e >> onExpr g) es
300+ onCaseAlternative isP (CaseAlternative _ (Left es)) = mapM_ (\(e, g) -> onExpr isP e >> onExpr isP g) es
304− onCaseAlternative (CaseAlternative _ (Right e)) = onExpr e
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
305
316
306-- |
317-- |
307-- Exhaustivity checking over a single module
318-- Exhaustivity checking over a single module
src/Language/PureScript/Sugar/Names/Env.hs+4−2
@@ -20,6 +20,7 @@ module Language.PureScript.Sugar.Names.Env
20
20
21import Data.Function (on)
21import Data.Function (on)
22import Data.List (groupBy, sortBy, nub)
22import Data.List (groupBy, sortBy, nub)
23+import Data.Maybe (fromJust)
23import qualified Data.Map as M
24import qualified Data.Map as M
24
25
25import Control.Monad
26import Control.Monad
@@ -121,9 +122,10 @@ envModuleExports (_, _, exps) = exps
121-- The exported types from the @Prim@ module
122-- The exported types from the @Prim@ module
122--
123--
123primExports :: Exports
124primExports :: Exports
124−primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
125+primExports = Exports (mkTypeEntry `map` M.keys primTypes) (mkClassEntry `map` M.keys primClasses) []
125 where
126 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)
127
129
128-- | Environment which only contains the Prim module.
130-- | Environment which only contains the Prim module.
129primEnv :: Env
131primEnv :: Env