Programmable type errors (purescript#2155)

paf31 · paf31 · commit c9f0839625f7 · 2016-05-30T10:30:01.000-07:00
* Programmable type errors

* update unifiesWith and typeHeadsAreEqual
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
@@ -327,6 +327,9 @@ partial = "Partial"
 pattern Partial :: Qualified (ProperName 'ClassName)
 pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")
 
+pattern Fail :: Qualified (ProperName 'ClassName)
+pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")
+
 -- Code Generation
 
 __superclass_ :: String
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
@@ -240,6 +240,7 @@ primTypes =
     , (primName "Int",      (Star, ExternData))
     , (primName "Boolean",  (Star, ExternData))
     , (primName "Partial",  (Star, ExternData))
+    , (primName "Fail",     (FunKind Symbol Star, ExternData))
     ]
 
 -- |
@@ -249,7 +250,9 @@ primTypes =
 primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
 primClasses =
   M.fromList
-    [ (primName "Partial", ([], [], [])) ]
+    [ (primName "Partial", ([], [], []))
+    , (primName "Fail",    ([("message", Just Symbol)], [], []))
+    ]
 
 -- |
 -- Finds information about data constructors from the current environment.
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
@@ -713,6 +713,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
             , line "They may be disallowed completely in a future version of the compiler."
             ]
     renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
+    renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
+      paras [ line "A custom type error occurred while solving type class constraints:"
+            , indent . paras . map line . lines $ message
+            ]
     renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
                                                           _
                                                           (Just (PartialConstraintData bs b)))) =
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
@@ -6,30 +6,20 @@ import Prelude.Compat
 
 import qualified Data.Aeson.TH as A
 
--- |
--- The data type of kinds
---
+-- | The data type of kinds
 data Kind
-  -- |
-  -- Unification variable of type Kind
-  --
+  -- | Unification variable of type Kind
   = KUnknown Int
-  -- |
-  -- The kind of types
-  --
+  -- | The kind of types
   | Star
-  -- |
-  -- The kind of effects
-  --
+  -- | The kind of effects
   | Bang
-  -- |
-  -- Kinds for labelled, unordered rows without duplicates
-  --
+  -- | Kinds for labelled, unordered rows without duplicates
   | Row Kind
-  -- |
-  -- Function kinds
-  --
+  -- | Function kinds
   | FunKind Kind Kind
+  -- | Type-level strings
+  | Symbol
   deriving (Show, Read, Eq, Ord)
 
 $(A.deriveJSON A.defaultOptions ''Kind)
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
@@ -18,10 +18,14 @@ parseStar = const Star <$> symbol' "*"
 parseBang :: TokenParser Kind
 parseBang = const Bang <$> symbol' "!"
 
+parseSymbol :: TokenParser Kind
+parseSymbol = const Symbol <$> uname' "Symbol"
+
 parseTypeAtom :: TokenParser Kind
 parseTypeAtom = indented *> P.choice
             [ parseStar
             , parseBang
+            , parseSymbol
             , parens parseKind
             ]
 -- |
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
@@ -26,6 +26,9 @@ parseFunction = parens rarrow >> return tyFunction
 parseObject :: TokenParser Type
 parseObject = braces $ TypeApp tyRecord <$> parseRow
 
+parseTypeLevelString :: TokenParser Type
+parseTypeLevelString = TypeLevelString <$> stringLiteral
+
 parseTypeWildcard :: TokenParser Type
 parseTypeWildcard = do
   start <- P.getPosition
@@ -53,6 +56,7 @@ parseTypeAtom :: TokenParser Type
 parseTypeAtom = indented *> P.choice
             [ P.try parseConstrainedType
             , P.try parseFunction
+            , parseTypeLevelString
             , parseObject
             , parseTypeWildcard
             , parseForAll
diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs
@@ -21,6 +21,7 @@ typeLiterals = mkPattern match
   where
   match Star = Just "*"
   match Bang = Just "!"
+  match Symbol = Just "Symbol"
   match (KUnknown u) = Just $ 'u' : show u
   match _ = Nothing
 
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
@@ -32,6 +32,7 @@ typeLiterals = mkPattern match
   where
   match TypeWildcard{} = Just $ text "_"
   match (TypeVar var) = Just $ text var
+  match (TypeLevelString s) = Just . text $ show s
   match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
   match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
   match (TUnknown u) = Just $ text $ 't' : show u
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
@@ -147,6 +147,7 @@ checkTypeClassInstance
   -> Type
   -> m ()
 checkTypeClassInstance _ (TypeVar _) = return ()
+checkTypeClassInstance _ (TypeLevelString _) = return ()
 checkTypeClassInstance _ (TypeConstructor ctor) = do
   env <- getEnv
   when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -184,6 +184,7 @@ typeHeadsAreEqual _ (TUnknown u1)        (TUnknown u2)        | u1 == u2 = Just
 typeHeadsAreEqual _ (Skolem _ s1 _ _)    (Skolem _ s2 _ _)    | s1 == s2 = Just []
 typeHeadsAreEqual _ t                    (TypeVar v)                     = Just [(v, t)]
 typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
+typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just []
 typeHeadsAreEqual m (TypeApp h1 t1)      (TypeApp h2 t2)                 = (++) <$> typeHeadsAreEqual m h1 h2
                                                                                 <*> typeHeadsAreEqual m t1 t2
 typeHeadsAreEqual _ REmpty REmpty = Just []
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -87,6 +87,7 @@ unifyKinds k1 k2 = do
   go k (KUnknown u) = solveKind u k
   go Star Star = return ()
   go Bang Bang = return ()
+  go Symbol Symbol = return ()
   go (Row k1') (Row k2') = go k1' k2'
   go (FunKind k1' k2') (FunKind k3 k4) = do
     go k1' k3
@@ -230,6 +231,7 @@ infer' other = (, []) <$> go other
     unifyKinds k k'
     return k'
   go TypeWildcard{} = freshKind
+  go (TypeLevelString _) = return Symbol
   go (TypeVar v) = do
     Just moduleName <- checkCurrentModule <$> get
     lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -153,13 +153,14 @@ unifyRows r1 r2 =
 -- Check that two types unify
 --
 unifiesWith :: Type -> Type -> Bool
-unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
-unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True
-unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
-unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
-unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
-unifiesWith REmpty REmpty = True
-unifiesWith r1@RCons{} r2@RCons{} =
+unifiesWith (TUnknown u1)        (TUnknown u2)        = u1 == u2
+unifiesWith (Skolem _ s1 _ _)    (Skolem _ s2 _ _)    = s1 == s2
+unifiesWith (TypeVar v1)         (TypeVar v2)         = v1 == v2
+unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
+unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
+unifiesWith (TypeApp h1 t1)      (TypeApp h2 t2)      = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
+unifiesWith REmpty               REmpty               = True
+unifiesWith r1@RCons{}           r2@RCons{} =
   let (s1, r1') = rowToList r1
       (s2, r2') = rowToList r2
 
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
@@ -29,79 +29,47 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
 -- The type of types
 --
 data Type
-  -- |
-  -- A unification variable of type Type
-  --
+  -- | A unification variable of type Type
   = TUnknown Int
-  -- |
-  -- A named type variable
-  --
+  -- | A named type variable
   | TypeVar String
-  -- |
-  -- A type wildcard, as would appear in a partial type synonym
-  --
+  -- | A type-level string
+  | TypeLevelString String
+  -- | A type wildcard, as would appear in a partial type synonym
   | TypeWildcard SourceSpan
-  -- |
-  -- A type constructor
-  --
+  -- | A type constructor
   | TypeConstructor (Qualified (ProperName 'TypeName))
-  -- |
-  -- A type operator. This will be desugared into a type constructor during the
+  -- | A type operator. This will be desugared into a type constructor during the
   -- "operators" phase of desugaring.
-  --
   | TypeOp (Qualified (OpName 'TypeOpName))
-  -- |
-  -- A type application
-  --
+  -- | A type application
   | TypeApp Type Type
-  -- |
-  -- Forall quantifier
-  --
+  -- | Forall quantifier
   | ForAll String Type (Maybe SkolemScope)
-  -- |
-  -- A type with a set of type class constraints
-  --
+  -- | A type with a set of type class constraints
   | ConstrainedType [Constraint] Type
-  -- |
-  -- A skolem constant
-  --
+  -- | A skolem constant
   | Skolem String Int SkolemScope (Maybe SourceSpan)
-  -- |
-  -- An empty row
-  --
+  -- | An empty row
   | REmpty
-  -- |
-  -- A non-empty row
-  --
+  -- | A non-empty row
   | RCons String Type Type
-  -- |
-  -- A type with a kind annotation
-  --
+  -- | A type with a kind annotation
   | KindedType Type Kind
-  -- |
-  -- A placeholder used in pretty printing
-  --
+  -- | A placeholder used in pretty printing
   | PrettyPrintFunction Type Type
-  -- |
-  -- A placeholder used in pretty printing
-  --
+  -- | A placeholder used in pretty printing
   | PrettyPrintObject Type
-  -- |
-  -- A placeholder used in pretty printing
-  --
+  -- | A placeholder used in pretty printing
   | PrettyPrintForAll [String] Type
-  -- |
-  -- Binary operator application. During the rebracketing phase of desugaring,
+  -- | Binary operator application. During the rebracketing phase of desugaring,
   -- this data constructor will be removed.
-  --
   | BinaryNoParensType Type Type Type
-  -- |
-  -- Explicit parentheses. During the rebracketing phase of desugaring, this
+  -- | Explicit parentheses. During the rebracketing phase of desugaring, this
   -- data constructor will be removed.
   --
   -- Note: although it seems this constructor is not used, it _is_ useful,
   -- since it prevents certain traversals from matching.
-  --
   | ParensInType Type
   deriving (Show, Read, Eq, Ord)
 

Original file line number	Diff line number	Diff line change
`@@ -713,6 +713,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS`
`713`	`713`	`, line "They may be disallowed completely in a future version of the compiler."`
`714`	`714`	`]`
`715`	`715`	`renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"`
	`716`	`+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =`
	`717`	`+ paras [ line "A custom type error occurred while solving type class constraints:"`
	`718`	`+ , indent . paras . map line . lines $ message`
	`719`	`+ ]`
`716`	`720`	`renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial`
`717`	`721`	`_`
`718`	`722`	`(Just (PartialConstraintData bs b)))) =`