git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Programmable type errors (#2155)

* Programmable type errors * update unifiesWith and typeHeadsAreEqual

commitc9f0839625f7d410eaeecb4a4e268b6750e33c50 authorPhil Freeman <paf31@cantab.net> dateMon 30 May 2016, 10:30 (10 years ago) parentde8ab59
13 files changed+60−77
src/Language/PureScript/Constants.hs+3 src/Language/PureScript/Environment.hs+4−1 src/Language/PureScript/Errors.hs+4 src/Language/PureScript/Kinds.hs+8−18 src/Language/PureScript/Parser/Kinds.hs+4 src/Language/PureScript/Parser/Types.hs+4 src/Language/PureScript/Pretty/Kinds.hs+1 src/Language/PureScript/Pretty/Types.hs+1 src/Language/PureScript/TypeChecker.hs+1 src/Language/PureScript/TypeChecker/Entailment.hs+1 src/Language/PureScript/TypeChecker/Kinds.hs+2 src/Language/PureScript/TypeChecker/Unify.hs+8−7 src/Language/PureScript/Types.hs+19−51
src/Language/PureScript/Constants.hs+3
@@ -327,6 +327,9 @@ partial = "Partial"
327327pattern Partial :: Qualified (ProperName 'ClassName)
328328pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial")
329329
330+pattern Fail :: Qualified (ProperName 'ClassName)
331+pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail")
332+
330333-- Code Generation
331334
332335__superclass_ :: String
src/Language/PureScript/Environment.hs+4−1
@@ -240,6 +240,7 @@ primTypes =
240240 , (primName "Int", (Star, ExternData))
241241 , (primName "Boolean", (Star, ExternData))
242242 , (primName "Partial", (Star, ExternData))
243+ , (primName "Fail", (FunKind Symbol Star, ExternData))
243244 ]
244245
245246-- |
@@ -249,7 +250,9 @@ primTypes =
249250primClasses :: M.Map (Qualified (ProperName 'ClassName)) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
250251primClasses =
251252 M.fromList
252− [ (primName "Partial", ([], [], [])) ]
253+ [ (primName "Partial", ([], [], []))
254+ , (primName "Fail", ([("message", Just Symbol)], [], []))
255+ ]
253256
254257-- |
255258-- Finds information about data constructors from the current environment.
src/Language/PureScript/Errors.hs+4
@@ -713,6 +713,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
713713 , line "They may be disallowed completely in a future version of the compiler."
714714 ]
715715 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+ ]
716720 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
717721 _
718722 (Just (PartialConstraintData bs b)))) =
src/Language/PureScript/Kinds.hs+8−18
@@ -6,30 +6,20 @@ import Prelude.Compat
66
77import qualified Data.Aeson.TH as A
88
9−-- |
10−-- The data type of kinds
11−--
9+-- | The data type of kinds
1210data Kind
13− -- |
14− -- Unification variable of type Kind
15− --
11+ -- | Unification variable of type Kind
1612 = KUnknown Int
17− -- |
18− -- The kind of types
19− --
13+ -- | The kind of types
2014 | Star
21− -- |
22− -- The kind of effects
23− --
15+ -- | The kind of effects
2416 | Bang
25− -- |
26− -- Kinds for labelled, unordered rows without duplicates
27− --
17+ -- | Kinds for labelled, unordered rows without duplicates
2818 | Row Kind
29− -- |
30− -- Function kinds
31− --
19+ -- | Function kinds
3220 | FunKind Kind Kind
21+ -- | Type-level strings
22+ | Symbol
3323 deriving (Show, Read, Eq, Ord)
3424
3525$(A.deriveJSON A.defaultOptions ''Kind)
src/Language/PureScript/Parser/Kinds.hs+4
@@ -18,10 +18,14 @@ parseStar = const Star <$> symbol' "*"
1818parseBang :: TokenParser Kind
1919parseBang = const Bang <$> symbol' "!"
2020
21+parseSymbol :: TokenParser Kind
22+parseSymbol = const Symbol <$> uname' "Symbol"
23+
2124parseTypeAtom :: TokenParser Kind
2225parseTypeAtom = indented *> P.choice
2326 [ parseStar
2427 , parseBang
28+ , parseSymbol
2529 , parens parseKind
2630 ]
2731-- |
src/Language/PureScript/Parser/Types.hs+4
@@ -26,6 +26,9 @@ parseFunction = parens rarrow >> return tyFunction
2626parseObject :: TokenParser Type
2727parseObject = braces $ TypeApp tyRecord <$> parseRow
2828
29+parseTypeLevelString :: TokenParser Type
30+parseTypeLevelString = TypeLevelString <$> stringLiteral
31+
2932parseTypeWildcard :: TokenParser Type
3033parseTypeWildcard = do
3134 start <- P.getPosition
@@ -53,6 +56,7 @@ parseTypeAtom :: TokenParser Type
5356parseTypeAtom = indented *> P.choice
5457 [ P.try parseConstrainedType
5558 , P.try parseFunction
59+ , parseTypeLevelString
5660 , parseObject
5761 , parseTypeWildcard
5862 , parseForAll
src/Language/PureScript/Pretty/Kinds.hs+1
@@ -21,6 +21,7 @@ typeLiterals = mkPattern match
2121 where
2222 match Star = Just "*"
2323 match Bang = Just "!"
24+ match Symbol = Just "Symbol"
2425 match (KUnknown u) = Just $ 'u' : show u
2526 match _ = Nothing
2627
src/Language/PureScript/Pretty/Types.hs+1
@@ -32,6 +32,7 @@ typeLiterals = mkPattern match
3232 where
3333 match TypeWildcard{} = Just $ text "_"
3434 match (TypeVar var) = Just $ text var
35+ match (TypeLevelString s) = Just . text $ show s
3536 match (PrettyPrintObject row) = Just $ prettyPrintRowWith '{' '}' row
3637 match (TypeConstructor ctor) = Just $ text $ runProperName $ disqualify ctor
3738 match (TUnknown u) = Just $ text $ 't' : show u
src/Language/PureScript/TypeChecker.hs+1
@@ -147,6 +147,7 @@ checkTypeClassInstance
147147 -> Type
148148 -> m ()
149149checkTypeClassInstance _ (TypeVar _) = return ()
150+checkTypeClassInstance _ (TypeLevelString _) = return ()
150151checkTypeClassInstance _ (TypeConstructor ctor) = do
151152 env <- getEnv
152153 when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
src/Language/PureScript/TypeChecker/Entailment.hs+1
@@ -184,6 +184,7 @@ typeHeadsAreEqual _ (TUnknown u1) (TUnknown u2) | u1 == u2 = Just
184184typeHeadsAreEqual _ (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = Just []
185185typeHeadsAreEqual _ t (TypeVar v) = Just [(v, t)]
186186typeHeadsAreEqual _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
187+typeHeadsAreEqual _ (TypeLevelString s1) (TypeLevelString s2) | s1 == s2 = Just []
187188typeHeadsAreEqual m (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m h1 h2
188189 <*> typeHeadsAreEqual m t1 t2
189190typeHeadsAreEqual _ REmpty REmpty = Just []
src/Language/PureScript/TypeChecker/Kinds.hs+2
@@ -87,6 +87,7 @@ unifyKinds k1 k2 = do
8787 go k (KUnknown u) = solveKind u k
8888 go Star Star = return ()
8989 go Bang Bang = return ()
90+ go Symbol Symbol = return ()
9091 go (Row k1') (Row k2') = go k1' k2'
9192 go (FunKind k1' k2') (FunKind k3 k4) = do
9293 go k1' k3
@@ -230,6 +231,7 @@ infer' other = (, []) <$> go other
230231 unifyKinds k k'
231232 return k'
232233 go TypeWildcard{} = freshKind
234+ go (TypeLevelString _) = return Symbol
233235 go (TypeVar v) = do
234236 Just moduleName <- checkCurrentModule <$> get
235237 lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
src/Language/PureScript/TypeChecker/Unify.hs+8−7
@@ -153,13 +153,14 @@ unifyRows r1 r2 =
153153-- Check that two types unify
154154--
155155unifiesWith :: Type -> Type -> Bool
156−unifiesWith (TUnknown u1) (TUnknown u2) | u1 == u2 = True
157−unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = True
158−unifiesWith (TypeVar v1) (TypeVar v2) | v1 == v2 = True
159−unifiesWith (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = True
160−unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
161−unifiesWith REmpty REmpty = True
162−unifiesWith r1@RCons{} r2@RCons{} =
156+unifiesWith (TUnknown u1) (TUnknown u2) = u1 == u2
157+unifiesWith (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2
158+unifiesWith (TypeVar v1) (TypeVar v2) = v1 == v2
159+unifiesWith (TypeLevelString s1) (TypeLevelString s2) = s1 == s2
160+unifiesWith (TypeConstructor c1) (TypeConstructor c2) = c1 == c2
161+unifiesWith (TypeApp h1 t1) (TypeApp h2 t2) = h1 `unifiesWith` h2 && t1 `unifiesWith` t2
162+unifiesWith REmpty REmpty = True
163+unifiesWith r1@RCons{} r2@RCons{} =
163164 let (s1, r1') = rowToList r1
164165 (s2, r2') = rowToList r2
165166
src/Language/PureScript/Types.hs+19−51
@@ -29,79 +29,47 @@ newtype SkolemScope = SkolemScope { runSkolemScope :: Int }
2929-- The type of types
3030--
3131data Type
32− -- |
33− -- A unification variable of type Type
34− --
32+ -- | A unification variable of type Type
3533 = TUnknown Int
36− -- |
37− -- A named type variable
38− --
34+ -- | A named type variable
3935 | TypeVar String
40− -- |
41− -- A type wildcard, as would appear in a partial type synonym
42− --
36+ -- | A type-level string
37+ | TypeLevelString String
38+ -- | A type wildcard, as would appear in a partial type synonym
4339 | TypeWildcard SourceSpan
44− -- |
45− -- A type constructor
46− --
40+ -- | A type constructor
4741 | TypeConstructor (Qualified (ProperName 'TypeName))
48− -- |
49− -- A type operator. This will be desugared into a type constructor during the
42+ -- | A type operator. This will be desugared into a type constructor during the
5043 -- "operators" phase of desugaring.
51− --
5244 | TypeOp (Qualified (OpName 'TypeOpName))
53− -- |
54− -- A type application
55− --
45+ -- | A type application
5646 | TypeApp Type Type
57− -- |
58− -- Forall quantifier
59− --
47+ -- | Forall quantifier
6048 | ForAll String Type (Maybe SkolemScope)
61− -- |
62− -- A type with a set of type class constraints
63− --
49+ -- | A type with a set of type class constraints
6450 | ConstrainedType [Constraint] Type
65− -- |
66− -- A skolem constant
67− --
51+ -- | A skolem constant
6852 | Skolem String Int SkolemScope (Maybe SourceSpan)
69− -- |
70− -- An empty row
71− --
53+ -- | An empty row
7254 | REmpty
73− -- |
74− -- A non-empty row
75− --
55+ -- | A non-empty row
7656 | RCons String Type Type
77− -- |
78− -- A type with a kind annotation
79− --
57+ -- | A type with a kind annotation
8058 | KindedType Type Kind
81− -- |
82− -- A placeholder used in pretty printing
83− --
59+ -- | A placeholder used in pretty printing
8460 | PrettyPrintFunction Type Type
85− -- |
86− -- A placeholder used in pretty printing
87− --
61+ -- | A placeholder used in pretty printing
8862 | PrettyPrintObject Type
89− -- |
90− -- A placeholder used in pretty printing
91− --
63+ -- | A placeholder used in pretty printing
9264 | PrettyPrintForAll [String] Type
93− -- |
94− -- Binary operator application. During the rebracketing phase of desugaring,
65+ -- | Binary operator application. During the rebracketing phase of desugaring,
9566 -- this data constructor will be removed.
96− --
9767 | BinaryNoParensType Type Type Type
98− -- |
99− -- Explicit parentheses. During the rebracketing phase of desugaring, this
68+ -- | Explicit parentheses. During the rebracketing phase of desugaring, this
10069 -- data constructor will be removed.
10170 --
10271 -- Note: although it seems this constructor is not used, it _is_ useful,
10372 -- since it prevents certain traversals from matching.
104− --
10573 | ParensInType Type
10674 deriving (Show, Read, Eq, Ord)
10775