b70aabf · rowtype-yoga/purescript-native

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

Add support for user defined warnings via the Warn type class (#2569)

* Add support for user defined warnings via the Warn type class * Deal with failing to print the type string

commitb70aabf1f4b75efb151ca2eabdd45d8d600db0b1 authorLiam Goodacre <goodacre.liam@gmail.com> dateSun 15 Jan 2017, 01:00 (10 years ago) parent1bb6acd

7 files changed+50−9

compare with golang

unifiedsplit

examples/warning/CustomWarning.purs+9 src/Language/PureScript/AST/Declarations.hs+2 src/Language/PureScript/Constants.hs+3 src/Language/PureScript/Docs/Prim.hs+9 src/Language/PureScript/Environment.hs+6−3 src/Language/PureScript/Errors.hs+7 src/Language/PureScript/TypeChecker/Entailment.hs+14−6

examples/warning/CustomWarning.pursnew file+9

@@ -0,0 +1,9 @@

1+-- @shouldWarnWith UserDefinedWarning

2+module Main where

4+foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t

5+foo x = x

7+bar :: Int

8+bar = foo 42

src/Language/PureScript/AST/Declarations.hs+2

@@ -141,6 +141,8 @@ data SimpleErrorMessage

141141 | CannotUseBindWithDo

142142 -- | instance name, type class, expected argument count, actual argument count

143143 | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int

144+ -- | a user-defined warning raised by using the Warn type class

145+ | UserDefinedWarning Type

144146 deriving (Show)

145147

146148-- | Error message hints, providing more detailed information about failure.

src/Language/PureScript/Constants.hs+3

@@ -369,6 +369,9 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial")

369369pattern Fail :: Qualified (ProperName 'ClassName)

370370pattern Fail = Qualified (Just Prim) (ProperName "Fail")

371371

372+pattern Warn :: Qualified (ProperName 'ClassName)

373+pattern Warn = Qualified (Just Prim) (ProperName "Warn")

374+

372375typ :: forall a. (IsString a) => a

373376typ = "Type"

374377

src/Language/PureScript/Docs/Prim.hs+9

@@ -24,6 +24,7 @@ primDocsModule = Module

2424 , boolean

2525 , partial

2626 , fail

27+ , warn

2728 , typeConcat

2829 , typeString

2930 , kindType

@@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines

225226 , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

226227 ]

227228

229+warn :: Declaration

230+warn = primClass "Warn" $ T.unlines

231+ [ "The Warn type class allows a custom compiler warning to be displayed."

232+ , ""

233+ , "For more information, see"

234+ , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."

235+ ]

236+

228237typeConcat :: Declaration

229238typeConcat = primType "TypeConcat" $ T.unlines

230239 [ "The TypeConcat type constructor concatenates two Symbols in a custom type"

src/Language/PureScript/Environment.hs+6−3

@@ -347,7 +347,7 @@ primKinds =

347347

348348-- |

349349-- The primitive types in the external javascript environment with their

350−-- associated kinds. There are also pseudo `Fail` and `Partial` types

350+-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types

351351-- that correspond to the classes with the same names.

352352--

353353primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)

@@ -363,20 +363,23 @@ primTypes =

363363 , (primName "Boolean", (kindType, ExternData))

364364 , (primName "Partial", (kindType, ExternData))

365365 , (primName "Fail", (FunKind kindSymbol kindType, ExternData))

366+ , (primName "Warn", (FunKind kindSymbol kindType, ExternData))

366367 , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))

367368 , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))

368369 ]

369370

370371-- |

371−-- The primitive class map. This just contains the `Fail` and `Partial`

372+-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`

372373-- classes. `Partial` is used as a kind of magic constraint for partial

373−-- functions. `Fail` is used for user-defined type errors.

374+-- functions. `Fail` is used for user-defined type errors. `Warn` for

375+-- user-defined warnings.

374376--

375377primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData

376378primClasses =

377379 M.fromList

378380 [ (primName "Partial", (makeTypeClassData [] [] [] []))

379381 , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

382+ , (primName "Warn", (makeTypeClassData [("message", Just kindSymbol)] [] [] []))

380383 ]

381384

382385-- |

src/Language/PureScript/Errors.hs+7

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

173173 ExpectedWildcard{} -> "ExpectedWildcard"

174174 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

175175 ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"

176+ UserDefinedWarning{} -> "UserDefinedWarning"

176177

177178-- |

178179-- A stack trace for an error

@@ -889,6 +890,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS

889890 T.pack (show actual) <> "."

890891 ]

891892

893+ renderSimpleErrorMessage (UserDefinedWarning msgTy) =

894+ let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in

895+ paras [ line "A custom warning occurred while solving type class constraints:"

896+ , indent msg

897+ ]

898+

892899 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

893900 renderHint (ErrorUnifyingTypes t1 t2) detail =

894901 paras [ detail

src/Language/PureScript/TypeChecker/Entailment.hs+14−6

@@ -45,6 +45,8 @@ import qualified Language.PureScript.Constants as C

4545data Evidence

4646 = NamedInstance (Qualified Ident)

4747 -- ^ An existing named instance

48+ | WarnInstance Type

49+ -- ^ Computed instance of the Warn type class with a user-defined warning message

4850 | IsSymbolInstance PSString

4951 -- ^ Computed instance of the IsSymbol type class for a given Symbol literal

5052 | CompareSymbolInstance

@@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints =

144146 solve constraint

145147 where

146148 forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]

149+ forClassName _ C.Warn [msg] =

150+ [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]

147151 forClassName _ C.IsSymbol [TypeLevelString sym] =

148152 [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]

149153 forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =

@@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints =

216220 let subst'' = fmap (substituteType currentSubst') subst'

217221 -- Solve any necessary subgoals

218222 args <- solveSubgoals subst'' (tcdDependencies tcd)

223+ initDict <- lift . lift $ mkDictionary (tcdValue tcd) args

219224 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)

220− (mkDictionary (tcdValue tcd) args)

225+ initDict

221226 (tcdPath tcd)

222227 return match

223228 Unsolved unsolved -> do

@@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints =

308313 Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals

309314

310315 -- Make a dictionary from subgoal dictionaries by applying the correct function

311− mkDictionary :: Evidence -> Maybe [Expr] -> Expr

312− mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)

316+ mkDictionary :: Evidence -> Maybe [Expr] -> m Expr

317+ mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args)

318+ mkDictionary (WarnInstance msg) _ = do

319+ tell . errorMessage $ UserDefinedWarning msg

320+ return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral []))

313321 mkDictionary (IsSymbolInstance sym) _ =

314322 let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in

315− TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))

323+ return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))

316324 mkDictionary CompareSymbolInstance _ =

317− TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

325+ return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))

318326 mkDictionary AppendSymbolInstance _ =

319− TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

327+ return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))

320328

321329 -- Turn a DictionaryValue into a Expr

322330 subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr