b70aabf · rowtype-yoga/purescript-native

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

on golang help sign in

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

b70aabfLiam Goodacre10 years ago

examples/warning/CustomWarning.pursnew file+9

compare with golang

unifiedsplit

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

141 | CannotUseBindWithDo

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

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

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

145+ | UserDefinedWarning Type

144 deriving (Show)

146 deriving (Show)

145

147

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

148-- | 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")

369pattern Fail :: Qualified (ProperName 'ClassName)

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

371

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

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

374+

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

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

373typ = "Type"

376typ = "Type"

374

377

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

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

24 , boolean

25 , partial

26 , fail

27+ , warn

27 , typeConcat

28 , typeConcat

28 , typeString

29 , typeString

29 , kindType

30 , kindType

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

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

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

226 ]

227 ]

227

228

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+

228typeConcat :: Declaration

237typeConcat :: Declaration

229typeConcat = primType "TypeConcat" $ T.unlines

238typeConcat = primType "TypeConcat" $ T.unlines

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

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

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

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

347

348-- |

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

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

352--

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

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

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

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

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

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

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

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

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

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

368 ]

369 ]

369

370

370-- |

371-- |

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`

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

373-- 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.

374--

376--

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

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

376primClasses =

378primClasses =

377 M.fromList

379 M.fromList

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

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

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

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

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

380 ]

383 ]

381

384

382-- |

385-- |

src/Language/PureScript/Errors.hs+7

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

173 ExpectedWildcard{} -> "ExpectedWildcard"

174 CannotUseBindWithDo{} -> "CannotUseBindWithDo"

175 ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"

176+ UserDefinedWarning{} -> "UserDefinedWarning"

176

177

177-- |

178-- |

178-- A stack trace for an error

179-- A stack trace for an error

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

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

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

890 ]

891 ]

891

892

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+

892 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

899 renderHint :: ErrorMessageHint -> Box.Box -> Box.Box

893 renderHint (ErrorUnifyingTypes t1 t2) detail =

900 renderHint (ErrorUnifyingTypes t1 t2) detail =

894 paras [ detail

901 paras [ detail

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

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

45data Evidence

46 = NamedInstance (Qualified Ident)

47 -- ^ An existing named instance

48+ | WarnInstance Type

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

48 | IsSymbolInstance PSString

50 | IsSymbolInstance PSString

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

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

50 | CompareSymbolInstance

52 | CompareSymbolInstance

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

144 solve constraint

146 solve constraint

145 where

147 where

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

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

149+ forClassName _ C.Warn [msg] =

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

147 forClassName _ C.IsSymbol [TypeLevelString sym] =

151 forClassName _ C.IsSymbol [TypeLevelString sym] =

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

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

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

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

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

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

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

217 -- Solve any necessary subgoals

221 -- Solve any necessary subgoals

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

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

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

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

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

220− (mkDictionary (tcdValue tcd) args)

225+ initDict

221 (tcdPath tcd)

226 (tcdPath tcd)

222 return match

227 return match

223 Unsolved unsolved -> do

228 Unsolved unsolved -> do

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

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

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

309

314

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

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

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

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

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

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

313 mkDictionary (IsSymbolInstance sym) _ =

321 mkDictionary (IsSymbolInstance sym) _ =

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

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

316 mkDictionary CompareSymbolInstance _ =

324 mkDictionary CompareSymbolInstance _ =

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

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

318 mkDictionary AppendSymbolInstance _ =

326 mkDictionary AppendSymbolInstance _ =

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

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

320

328

321 -- Turn a DictionaryValue into a Expr

329 -- Turn a DictionaryValue into a Expr

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

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