8114b6e · rowtype-yoga/purescript-native

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

Add native Partial constraint

commit8114b6e2d9712c7ccc958baa412950228b298d38 authorGary Burgess <gary.burgess@gmail.com> dateSat 12 Dec 2015, 01:54 (11 years ago) parent6fee613

6 files changed+79−50

compare with golang

unifiedsplit

examples/passing/EmptyTypeClass.purs+3−3 examples/passing/NakedConstraint.purs−2 src/Language/PureScript/Environment.hs+25−10 src/Language/PureScript/Errors.hs+6−3 src/Language/PureScript/Linter/Exhaustive.hs+41−30 src/Language/PureScript/Sugar/Names/Env.hs+4−2

examples/passing/EmptyTypeClass.purs+3−3

@@ -2,11 +2,11 @@ module Main where

33import Prelude

5−class Partial

5+class PartialP

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

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

88head [x] = x

10−instance allowPartials :: Partial

10+instance allowPartials :: PartialP

1111

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

examples/passing/NakedConstraint.purs−2

@@ -2,8 +2,6 @@ module Main where

33import Control.Monad.Eff.Console

5−class Partial

6−

75data List a = Nil | Cons a (List a)

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

src/Language/PureScript/Environment.hs+25−10

@@ -66,7 +66,7 @@ data Environment = Environment {

6666-- The initial environment with no values and only the default javascript types defined

6767--

6868initEnvironment :: 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

236236function 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--

241243primTypes :: 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+6−3

@@ -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+41−30

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

2724import Prelude ()

2825import 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+4−2

@@ -20,6 +20,7 @@ module Language.PureScript.Sugar.Names.Env

2020

2121import Data.Function (on)

2222import Data.List (groupBy, sortBy, nub)

23+import Data.Maybe (fromJust)

2324import qualified Data.Map as M

2425

2526import Control.Monad

@@ -121,9 +122,10 @@ envModuleExports (_, _, exps) = exps

121122-- The exported types from the @Prim@ module

122123--

123124primExports :: 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.

129131primEnv :: Env