git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Added typelevel string functions (#2280)
2146080Simon Van Casteren
examples/failing/ProgrammableTypeErrorsTypeString.pursnew file+18
compare with golang
unifiedsplit
@@ -0,0 +1,18 @@
1+-- @shouldFailWith NoInstanceFound
2+
3+module Main where
4+
5+import Prelude
6+import Control.Monad.Eff (Eff)
7+import Control.Monad.Eff.Console (log)
8+
9+newtype MyType a = MyType a
10+
11+instance cannotShowFunctions :: Fail ("Don't want to show " <> TypeString (MyType a) <> " because.") => Show (MyType a) where
12+ show _ = "unreachable"
13+
14+infixl 6 type TypeConcat as <>
15+
16+main :: Eff _ _
17+main = do
18+ log $ show (MyType 2)
src/Language/PureScript/Environment.hs+2
@@ -241,6 +241,8 @@ primTypes =
241 , (primName "Boolean", (Star, ExternData))
241 , (primName "Boolean", (Star, ExternData))
242 , (primName "Partial", (Star, ExternData))
242 , (primName "Partial", (Star, ExternData))
243 , (primName "Fail", (FunKind Symbol Star, ExternData))
243 , (primName "Fail", (FunKind Symbol Star, ExternData))
244+ , (primName "TypeString", (FunKind Star Symbol, ExternData))
245+ , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData))
244 ]
246 ]
245
247
246-- |
248-- |
src/Language/PureScript/Errors.hs+12−2
@@ -25,6 +25,7 @@ import qualified Data.Map as M
25
25
26import Language.PureScript.AST
26import Language.PureScript.AST
27import Language.PureScript.Crash
27import Language.PureScript.Crash
28+import Language.PureScript.Environment
28import Language.PureScript.Names
29import Language.PureScript.Names
29import Language.PureScript.Pretty
30import Language.PureScript.Pretty
30import Language.PureScript.Traversals
31import Language.PureScript.Traversals
@@ -32,6 +33,7 @@ import Language.PureScript.Types
32import Language.PureScript.Pretty.Common (endWith)
33import Language.PureScript.Pretty.Common (endWith)
33import qualified Language.PureScript.Bundle as Bundle
34import qualified Language.PureScript.Bundle as Bundle
34import qualified Language.PureScript.Constants as C
35import qualified Language.PureScript.Constants as C
36+import Language.PureScript.Pretty.Common (before)
35
37
36import qualified System.Console.ANSI as ANSI
38import qualified System.Console.ANSI as ANSI
37
39
@@ -594,9 +596,9 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
594 , line "They may be disallowed completely in a future version of the compiler."
596 , line "They may be disallowed completely in a future version of the compiler."
595 ]
597 ]
596 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
598 renderSimpleErrorMessage OverlappingInstances{} = internalError "OverlappingInstances: empty instance list"
597− renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ TypeLevelString message ] _)) =
599+ renderSimpleErrorMessage (NoInstanceFound (Constraint C.Fail [ ty ] _)) | Just box <- toTypelevelString ty =
598 paras [ line "A custom type error occurred while solving type class constraints:"
600 paras [ line "A custom type error occurred while solving type class constraints:"
599− , indent . paras . map line . lines $ message
601+ , indent box
600 ]
602 ]
601 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
603 renderSimpleErrorMessage (NoInstanceFound (Constraint C.Partial
602 _
604 _
@@ -1203,6 +1205,14 @@ renderBox = unlines
1203 dropWhileEnd p = reverse . dropWhile p . reverse
1205 dropWhileEnd p = reverse . dropWhile p . reverse
1204 whiteSpace = all isSpace
1206 whiteSpace = all isSpace
1205
1207
1208+toTypelevelString :: Type -> Maybe Box.Box
1209+toTypelevelString (TypeLevelString s) = Just $ Box.text s
1210+toTypelevelString (TypeApp (TypeConstructor f) x)
1211+ | f == primName "TypeString" = Just $ typeAsBox x
1212+toTypelevelString (TypeApp (TypeApp (TypeConstructor f) x) ret)
1213+ | f == primName "TypeConcat" = before <$> (toTypelevelString x) <*> (toTypelevelString ret)
1214+toTypelevelString _ = Nothing
1215+
1206-- |
1216-- |
1207-- Rethrow an error with a more detailed error message in the case of failure
1217-- Rethrow an error with a more detailed error message in the case of failure
1208--
1218--
src/Language/PureScript/Parser/Declarations.hs−1
@@ -192,7 +192,6 @@ parseConstraint :: TokenParser Constraint
192parseConstraint = Constraint <$> parseQualified properName
192parseConstraint = Constraint <$> parseQualified properName
193 <*> P.many (noWildcards parseTypeAtom)
193 <*> P.many (noWildcards parseTypeAtom)
194 <*> pure Nothing
194 <*> pure Nothing
195−
196parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
195parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
197parseInstanceDeclaration = do
196parseInstanceDeclaration = do
198 reserved "instance"
197 reserved "instance"