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

LiamGoodacre · paf31 · commit b70aabf1f4b7 · 2017-01-14T17:00:02.000-08:00
* Add support for user defined warnings via the Warn type class

* Deal with failing to print the type string
diff --git a/examples/warning/CustomWarning.purs b/examples/warning/CustomWarning.purs
@@ -0,0 +1,9 @@
+-- @shouldWarnWith UserDefinedWarning
+module Main where
+
+foo :: forall t. Warn (TypeConcat "Custom warning " (TypeString t)) => t -> t
+foo x = x
+
+bar :: Int
+bar = foo 42
+
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
@@ -141,6 +141,8 @@ data SimpleErrorMessage
   | CannotUseBindWithDo
   -- | instance name, type class, expected argument count, actual argument count
   | ClassInstanceArityMismatch Ident (Qualified (ProperName 'ClassName)) Int Int
+  -- | a user-defined warning raised by using the Warn type class
+  | UserDefinedWarning Type
   deriving (Show)
 
 -- | Error message hints, providing more detailed information about failure.
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
@@ -369,6 +369,9 @@ pattern Partial = Qualified (Just Prim) (ProperName "Partial")
 pattern Fail :: Qualified (ProperName 'ClassName)
 pattern Fail = Qualified (Just Prim) (ProperName "Fail")
 
+pattern Warn :: Qualified (ProperName 'ClassName)
+pattern Warn = Qualified (Just Prim) (ProperName "Warn")
+
 typ :: forall a. (IsString a) => a
 typ = "Type"
 
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
@@ -24,6 +24,7 @@ primDocsModule = Module
       , boolean
       , partial
       , fail
+      , warn
       , typeConcat
       , typeString
       , kindType
@@ -225,6 +226,14 @@ fail = primClass "Fail" $ T.unlines
   , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
   ]
 
+warn :: Declaration
+warn = primClass "Warn" $ T.unlines
+  [ "The Warn type class allows a custom compiler warning to be displayed."
+  , ""
+  , "For more information, see"
+  , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)."
+  ]
+
 typeConcat :: Declaration
 typeConcat = primType "TypeConcat" $ T.unlines
   [ "The TypeConcat type constructor concatenates two Symbols in a custom type"
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -347,7 +347,7 @@ primKinds =
 
 -- |
 -- The primitive types in the external javascript environment with their
--- associated kinds. There are also pseudo `Fail` and `Partial` types
+-- associated kinds. There are also pseudo `Fail`, `Warn`, and `Partial` types
 -- that correspond to the classes with the same names.
 --
 primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind)
@@ -363,20 +363,23 @@ primTypes =
     , (primName "Boolean",    (kindType, ExternData))
     , (primName "Partial",    (kindType, ExternData))
     , (primName "Fail",       (FunKind kindSymbol kindType, ExternData))
+    , (primName "Warn",       (FunKind kindSymbol kindType, ExternData))
     , (primName "TypeString", (FunKind kindType kindSymbol, ExternData))
     , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData))
     ]
 
 -- |
--- The primitive class map. This just contains the `Fail` and `Partial`
+-- The primitive class map. This just contains the `Fail`, `Warn`, and `Partial`
 -- classes. `Partial` is used as a kind of magic constraint for partial
--- functions. `Fail` is used for user-defined type errors.
+-- functions. `Fail` is used for user-defined type errors. `Warn` for
+-- user-defined warnings.
 --
 primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData
 primClasses =
   M.fromList
     [ (primName "Partial", (makeTypeClassData [] [] [] []))
     , (primName "Fail",    (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
+    , (primName "Warn",    (makeTypeClassData [("message", Just kindSymbol)] [] [] []))
     ]
 
 -- |
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -173,6 +173,7 @@ errorCode em = case unwrapErrorMessage em of
   ExpectedWildcard{} -> "ExpectedWildcard"
   CannotUseBindWithDo{} -> "CannotUseBindWithDo"
   ClassInstanceArityMismatch{} -> "ClassInstanceArityMismatch"
+  UserDefinedWarning{} -> "UserDefinedWarning"
 
 -- |
 -- A stack trace for an error
@@ -889,6 +890,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
                      T.pack (show actual) <> "."
             ]
 
+    renderSimpleErrorMessage (UserDefinedWarning msgTy) =
+      let msg = fromMaybe (typeAsBox msgTy) (toTypelevelString msgTy) in
+      paras [ line "A custom warning occurred while solving type class constraints:"
+            , indent msg
+            ]
+
     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
     renderHint (ErrorUnifyingTypes t1 t2) detail =
       paras [ detail
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -45,6 +45,8 @@ import qualified Language.PureScript.Constants as C
 data Evidence
   = NamedInstance (Qualified Ident)
   -- ^ An existing named instance
+  | WarnInstance Type
+  -- ^ Computed instance of the Warn type class with a user-defined warning message
   | IsSymbolInstance PSString
   -- ^ Computed instance of the IsSymbol type class for a given Symbol literal
   | CompareSymbolInstance
@@ -144,6 +146,8 @@ entails SolverOptions{..} constraint context hints =
     solve constraint
   where
     forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict]
+    forClassName _ C.Warn [msg] =
+      [TypeClassDictionaryInScope (WarnInstance msg) [] C.Warn [msg] Nothing]
     forClassName _ C.IsSymbol [TypeLevelString sym] =
       [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing]
     forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] =
@@ -216,8 +220,9 @@ entails SolverOptions{..} constraint context hints =
                 let subst'' = fmap (substituteType currentSubst') subst'
                 -- Solve any necessary subgoals
                 args <- solveSubgoals subst'' (tcdDependencies tcd)
+                initDict <- lift . lift $ mkDictionary (tcdValue tcd) args
                 let match = foldr (\(superclassName, index) dict -> subclassDictionaryValue dict superclassName index)
-                                  (mkDictionary (tcdValue tcd) args)
+                                  initDict
                                   (tcdPath tcd)
                 return match
               Unsolved unsolved -> do
@@ -308,15 +313,18 @@ entails SolverOptions{..} constraint context hints =
               Just <$> traverse (go (work + 1) . mapConstraintArgs (map (replaceAllTypeVars (M.toList subst)))) subgoals
 
             -- Make a dictionary from subgoal dictionaries by applying the correct function
-            mkDictionary :: Evidence -> Maybe [Expr] -> Expr
-            mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args)
+            mkDictionary :: Evidence -> Maybe [Expr] -> m Expr
+            mkDictionary (NamedInstance n) args = return $ foldl App (Var n) (fold args)
+            mkDictionary (WarnInstance msg) _ = do
+              tell . errorMessage $ UserDefinedWarning msg
+              return $ TypeClassDictionaryConstructorApp C.Warn (Literal (ObjectLiteral []))
             mkDictionary (IsSymbolInstance sym) _ =
               let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in
-              TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
+              return $ TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields))
             mkDictionary CompareSymbolInstance _ =
-              TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
+              return $ TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral []))
             mkDictionary AppendSymbolInstance _ =
-              TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))
+              return $ TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral []))
 
         -- Turn a DictionaryValue into a Expr
         subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr
