git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Show human readable types in type errors
commit73a773eaaa28aae62e340547f985b1afa14e7c5f authorPhil Freeman <paf31@cantab.net> dateTue 29 Oct 2013, 15:30 (13 years ago) parenta9905bf
9 files changed+185−104
compare with golang
unifiedsplit
PureScript.cabal+21−18 examples/failing/KindError.ps+1 examples/ReadShow.ps → examples/failing/ReadShow.ps examples/failing/TypeError.ps+1 src/PureScript/CodeGen/Externs.hs+5−77 src/PureScript/CodeGen/Pretty/Kinds.hs+50 src/PureScript/CodeGen/Pretty/Types.hs+95 src/PureScript/TypeChecker/Kinds.hs+2−1 src/PureScript/TypeChecker/Types.hs+10−8
PureScript.cabal+21−18
@@ -11,30 +11,33 @@ synopsis: PureScript Programming Language Compiler
1111description: A small compile-to-JS language with extensible records and type-safe blocks
1212author: Phil Freeman <paf31@cantab.net>
1313data-dir: ""
14−
14+
1515library
16− build-depends: base -any, syb -any,
17− cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
16+ build-depends: base -any, syb -any, cmdtheline -any,
17+ containers -any, mtl -any, transformers -any, parsec -any,
1818 utf8-string -any
19− exposed-modules: PureScript PureScript.Declarations
20− PureScript.Names PureScript.TypeChecker.Synonyms
21− PureScript.CodeGen.Externs PureScript.CodeGen.JS
22− PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
23− PureScript.CodeGen PureScript.Kinds PureScript.Parser
24− PureScript.TypeChecker PureScript.Types PureScript.Values
25− PureScript.Parser.Common PureScript.Parser.Declarations
26− PureScript.Parser.Types PureScript.Parser.Values
27− PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
28− PureScript.TypeChecker.Types PureScript.Parser.State
19+ exposed-modules: PureScript.CodeGen.Pretty.Types PureScript
20+ PureScript.Declarations PureScript.Names
21+ PureScript.TypeChecker.Synonyms PureScript.CodeGen.Externs
22+ PureScript.CodeGen.JS PureScript.CodeGen.Common.Gen
23+ PureScript.CodeGen.Common Main PureScript.CodeGen PureScript.Kinds
24+ PureScript.Parser PureScript.TypeChecker PureScript.Types
25+ PureScript.Values PureScript.Parser.Common
26+ PureScript.Parser.Declarations PureScript.Parser.Types
27+ PureScript.Parser.Values PureScript.TypeChecker.Kinds
28+ PureScript.TypeChecker.Monad PureScript.TypeChecker.Types
29+ PureScript.Parser.State
2930 exposed: True
3031 buildable: True
3132 hs-source-dirs: src
32−
33+ other-modules: PureScript.CodeGen.Pretty.Kinds
34+
3335executable psc
34− build-depends: base -any,
35− cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
36− utf8-string -any
36+ build-depends: base -any, cmdtheline -any, containers -any,
37+ mtl -any, transformers -any, parsec -any, utf8-string -any
3738 main-is: Main.hs
3839 buildable: True
3940 hs-source-dirs: src
40−
41+ other-modules: PureScript.CodeGen.Pretty.Kinds
42+ PureScript.CodeGen.Pretty.Types
43+
examples/failing/KindError.psnew file+1
@@ -0,0 +1 @@
1+data KindError f g a = One f a | Two f
examples/ReadShow.ps → examples/failing/ReadShow.psrenamed

The content is the same.

examples/failing/TypeError.psnew file+1
@@ -0,0 +1 @@
1+test = \f -> \x, y, z -> f x y + f x y z
src/PureScript/CodeGen/Externs.hs+5−77
@@ -12,94 +12,22 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
16−
1715module PureScript.CodeGen.Externs (
1816 externToPs
1917) where
2018
21−import Data.Maybe (fromMaybe)
22−import Data.List (intersperse, intercalate)
23−import qualified Control.Arrow as A
24−import Control.Arrow ((<+>))
19+import Data.List (intercalate)
2520import qualified Data.Map as M
26−import Control.Applicative
27−
28−import PureScript.Values
29−import PureScript.Types
30−import PureScript.Names
3121import PureScript.Declarations
3222import PureScript.TypeChecker.Monad
33−import PureScript.CodeGen.Common
23+import PureScript.CodeGen.Pretty.Types
3424
3525externToPs :: Environment -> Declaration -> Maybe String
3626externToPs env (ValueDeclaration name _) = do
3727 (ty, _) <- M.lookup name $ names env
38− return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
28+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
3929externToPs env (ExternDeclaration name ty) =
40− return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
30+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
4131externToPs env (TypeSynonymDeclaration name args ty) =
42− return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ typeToPs ty
32+ return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty
4333externToPs _ _ = Nothing
44−
45−typeLiterals :: Pattern Type String
46−typeLiterals = Pattern $ A.Kleisli match
47− where
48− match Number = Just "Number"
49− match String = Just "String"
50− match Boolean = Just "Boolean"
51− match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"
52− match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"
53− match (TypeVar var) = Just var
54− match (TypeConstructor ctor) = Just ctor
55− match (TUnknown u) = Just $ show u
56− match _ = Nothing
57−
58−rowToPs :: Row -> String
59−rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
60− where
61− nameAndTypeToPs :: String -> Type -> String
62− nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty
63− tailToPs :: Row -> String
64− tailToPs REmpty = ""
65− tailToPs (RUnknown u) = show u
66− tailToPs (RowVar var) = " | " ++ var
67− toList :: Row -> ([(String, Type)], Row)
68− toList (RCons name ty row) = let (tys, rest) = toList row
69− in ((name, ty):tys, rest)
70− toList r = ([], r)
71−
72−typeApp :: Pattern Type (Type, Type)
73−typeApp = Pattern $ A.Kleisli match
74− where
75− match (TypeApp f x) = Just (f, x)
76− match _ = Nothing
77−
78−singleArgumentFunction :: Pattern Type (Type, Type)
79−singleArgumentFunction = Pattern $ A.Kleisli match
80− where
81− match (Function [arg] ret) = Just (arg, ret)
82− match _ = Nothing
83−
84−function :: Pattern Type ([Type], Type)
85−function = Pattern $ A.Kleisli match
86− where
87− match (Function args ret) = Just (args, ret)
88− match _ = Nothing
89−
90−typeToPs :: Type -> String
91−typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType
92− where
93− matchType :: Pattern Type String
94− matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
95− operators :: OperatorTable Type String
96− operators =
97− OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
98− , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
99− , Wrap function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ ret
100− ]
101− ]
102−
103−polyTypeToPs :: PolyType -> String
104−polyTypeToPs (PolyType [] ty) = typeToPs ty
105−polyTypeToPs (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ typeToPs ty
src/PureScript/CodeGen/Pretty/Kinds.hsnew file+50
@@ -0,0 +1,50 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Pretty.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module PureScript.CodeGen.Pretty.Kinds (
16+ prettyPrintKind
17+) where
18+
19+import Data.Maybe (fromMaybe)
20+import Data.List (intersperse, intercalate)
21+import qualified Control.Arrow as A
22+import Control.Arrow ((<+>))
23+import qualified Data.Map as M
24+import Control.Applicative
25+
26+import PureScript.Kinds
27+import PureScript.CodeGen.Common
28+
29+typeLiterals :: Pattern Kind String
30+typeLiterals = Pattern $ A.Kleisli match
31+ where
32+ match Star = Just "*"
33+ match Row = Just "ρ"
34+ match (KUnknown u) = Just $ "u" ++ show u
35+ match _ = Nothing
36+
37+funKind :: Pattern Kind (Kind, Kind)
38+funKind = Pattern $ A.Kleisli match
39+ where
40+ match (FunKind arg ret) = Just (arg, ret)
41+ match _ = Nothing
42+
43+prettyPrintKind :: Kind -> String
44+prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind
45+ where
46+ matchKind :: Pattern Kind String
47+ matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
48+ operators :: OperatorTable Kind String
49+ operators =
50+ OperatorTable $ [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/PureScript/CodeGen/Pretty/Types.hsnew file+95
@@ -0,0 +1,95 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Pretty.Types
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module PureScript.CodeGen.Pretty.Types (
16+ prettyPrintType,
17+ prettyPrintRow,
18+ prettyPrintPolyType
19+) where
20+
21+import Data.Maybe (fromMaybe)
22+import Data.List (intersperse, intercalate)
23+import qualified Control.Arrow as A
24+import Control.Arrow ((<+>))
25+import qualified Data.Map as M
26+import Control.Applicative
27+
28+import PureScript.Values
29+import PureScript.Types
30+import PureScript.Names
31+import PureScript.Declarations
32+import PureScript.TypeChecker.Monad
33+import PureScript.CodeGen.Common
34+
35+typeLiterals :: Pattern Type String
36+typeLiterals = Pattern $ A.Kleisli match
37+ where
38+ match Number = Just "Number"
39+ match String = Just "String"
40+ match Boolean = Just "Boolean"
41+ match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
42+ match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
43+ match (TypeVar var) = Just var
44+ match (TypeConstructor ctor) = Just ctor
45+ match (TUnknown u) = Just $ "u" ++ show u
46+ match _ = Nothing
47+
48+prettyPrintRow :: Row -> String
49+prettyPrintRow = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
50+ where
51+ nameAndTypeToPs :: String -> Type -> String
52+ nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
53+ tailToPs :: Row -> String
54+ tailToPs REmpty = ""
55+ tailToPs (RUnknown u) = show u
56+ tailToPs (RowVar var) = " | " ++ var
57+ toList :: Row -> ([(String, Type)], Row)
58+ toList (RCons name ty row) = let (tys, rest) = toList row
59+ in ((name, ty):tys, rest)
60+ toList r = ([], r)
61+
62+typeApp :: Pattern Type (Type, Type)
63+typeApp = Pattern $ A.Kleisli match
64+ where
65+ match (TypeApp f x) = Just (f, x)
66+ match _ = Nothing
67+
68+singleArgumentFunction :: Pattern Type (Type, Type)
69+singleArgumentFunction = Pattern $ A.Kleisli match
70+ where
71+ match (Function [arg] ret) = Just (arg, ret)
72+ match _ = Nothing
73+
74+function :: Pattern Type ([Type], Type)
75+function = Pattern $ A.Kleisli match
76+ where
77+ match (Function args ret) = Just (args, ret)
78+ match _ = Nothing
79+
80+prettyPrintType :: Type -> String
81+prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType
82+ where
83+ matchType :: Pattern Type String
84+ matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
85+ operators :: OperatorTable Type String
86+ operators =
87+ OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
88+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
89+ , Wrap function $ \args ret -> "(" ++ intercalate ", " (map prettyPrintType args) ++ ") -> " ++ ret
90+ ]
91+ ]
92+
93+prettyPrintPolyType :: PolyType -> String
94+prettyPrintPolyType (PolyType [] ty) = prettyPrintType ty
95+prettyPrintPolyType (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ prettyPrintType ty
src/PureScript/TypeChecker/Kinds.hs+2−1
@@ -27,6 +27,7 @@ import PureScript.Types
2727import PureScript.Kinds
2828import PureScript.Declarations
2929import PureScript.TypeChecker.Monad
30+import PureScript.CodeGen.Pretty.Kinds
3031
3132import Control.Monad.State
3233import Control.Monad.Error
@@ -160,7 +161,7 @@ unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do
160161 cs1 <- unifyKinds k1 k3
161162 cs2 <- unifyKinds k2 k4
162163 return $ cs1 ++ cs2
163−unifyKinds k1 k2 = throwError $ "Cannot unify " ++ show k1 ++ " with " ++ show k2 ++ "."
164+unifyKinds k1 k2 = throwError $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
164165
165166kindOccursCheck :: Bool -> Int -> Kind -> Bool
166167kindOccursCheck b u (KUnknown u') | u == u' = b
src/PureScript/TypeChecker/Types.hs+10−8
@@ -30,6 +30,8 @@ import PureScript.Names
3030import PureScript.TypeChecker.Monad
3131import PureScript.TypeChecker.Kinds
3232import PureScript.TypeChecker.Synonyms
33+import PureScript.CodeGen.Pretty.Types
34+import PureScript.CodeGen.Pretty.Kinds
3335
3436import Control.Monad.State
3537import Control.Monad.Error
@@ -51,7 +53,7 @@ emptyTypeSolution = TypeSolution (TUnknown, RUnknown)
5153
5254typeOf :: Ident -> Value -> Check PolyType
5355typeOf name val = do
54− (cs, n) <- case val of
56+ (cs, n) <- case val of
5557 Abs _ _ -> do
5658 me <- fresh
5759 (cs, n) <- typeConstraints (M.singleton name me) val
@@ -77,7 +79,7 @@ allUnknownsBecameQuantified cs solution ty = do
7779 TypeConstraint _ t -> findUnknownRows t
7880 RowConstraint u r -> u : findUnknownRows r
7981 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
80− guardWith ("Unsolved row variable" ++ show (unsolvedRows \\ rowsMentioned) ++ ", " ++ show cs) $ null $ unsolvedRows \\ rowsMentioned
82+ guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
8183
8284findUnknownTypes :: (Data d) => d -> [Int]
8385findUnknownTypes = everything (++) (mkQ [] f)
@@ -166,11 +168,11 @@ replaceRow n r = everywhere (mkT go)
166168
167169typeOccursCheck :: Int -> Type -> Check ()
168170typeOccursCheck u (TUnknown _) = return ()
169−typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ show t
171+typeOccursCheck u t = when (occursCheck u t) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintType t
170172
171173rowOccursCheck :: Int -> Row -> Check ()
172174rowOccursCheck u (RUnknown _) = return ()
173−rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ show r
175+rowOccursCheck u r = when (occursCheck u r) $ throwError $ "Occurs check failed: " ++ show u ++ " = " ++ prettyPrintRow r
174176
175177occursCheck :: (Data d) => Int -> d -> Bool
176178occursCheck u = everything (||) $ flip extQ g $ mkQ False f
@@ -273,7 +275,7 @@ typeConstraints m (IfThenElse cond th el) = do
273275 return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)
274276typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
275277 kind <- kindOf poly
276− guardWith ("Expected type of kind *, was " ++ show kind) $ kind == Star
278+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
277279 desugared <- replaceAllTypeSynonyms ty
278280 (cs, n1) <- typeConstraints m val
279281 return (TypeConstraint n1 desugared : cs, n1)
@@ -534,7 +536,7 @@ unifyTypes (TypeApp t1 t2) (TypeApp t3 t4) = do
534536 cs1 <- unifyTypes t1 t3
535537 cs2 <- unifyTypes t2 t4
536538 return $ cs1 ++ cs2
537−unifyTypes t1 t2 = throwError $ "Cannot unify " ++ show t1 ++ " with " ++ show t2 ++ "."
539+unifyTypes t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
538540
539541unifyRows :: Row -> Row -> Check [TypeConstraint]
540542unifyRows r1 r2 =
@@ -544,7 +546,7 @@ unifyRows r1 r2 =
544546 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
545547 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]
546548 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]
547− in rethrow (\e -> "Cannot unify " ++ show r1 ++ " with " ++ show r2 ++ ": " ++ e) $ do
549+ in rethrow (\e -> "Cannot unify " ++ prettyPrintRow r1 ++ " with " ++ prettyPrintRow r2 ++ ": " ++ e) $ do
548550 cs1 <- fmap concat $ mapM (uncurry unifyTypes) int
549551 cs2 <- unifyRows' sd1 r1' sd2 r2'
550552 return $ cs1 ++ cs2
@@ -561,7 +563,7 @@ unifyRows r1 r2 =
561563 cs <- unifyRows' row r others (RUnknown u')
562564 return (RowConstraint u (RCons name ty (RUnknown u')) : cs)
563565 unifyRows' [] REmpty [] REmpty = return []
564− unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ show (fromList (sd1, r1)) ++ " with " ++ show (fromList (sd2, r2)) ++ "."
566+ unifyRows' sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (fromList (sd1, r1)) ++ " with " ++ prettyPrintRow (fromList (sd2, r2)) ++ "."
565567 toList :: Row -> ([(String, Type)], Row)
566568 toList (RCons name ty row) = let (tys, rest) = toList row
567569 in ((name, ty):tys, rest)