git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Show human readable types in type errors
73a773ePhil Freeman
PureScript.cabal+21−18
compare with golang
unifiedsplit
@@ -11,30 +11,33 @@ synopsis: PureScript Programming Language Compiler
11description: A small compile-to-JS language with extensible records and type-safe blocks
11description: A small compile-to-JS language with extensible records and type-safe blocks
12author: Phil Freeman <paf31@cantab.net>
12author: Phil Freeman <paf31@cantab.net>
13data-dir: ""
13data-dir: ""
14−
14+
15library
15library
16− build-depends: base -any, syb -any,
16+ build-depends: base -any, syb -any, cmdtheline -any,
17− cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
17+ containers -any, mtl -any, transformers -any, parsec -any,
18 utf8-string -any
18 utf8-string -any
19− exposed-modules: PureScript PureScript.Declarations
19+ exposed-modules: PureScript.CodeGen.Pretty.Types PureScript
20+ PureScript.Declarations PureScript.Names
20− PureScript.Names PureScript.TypeChecker.Synonyms
21+ PureScript.TypeChecker.Synonyms PureScript.CodeGen.Externs
21− PureScript.CodeGen.Externs PureScript.CodeGen.JS
22− PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
22+ PureScript.CodeGen.JS PureScript.CodeGen.Common.Gen
23− PureScript.CodeGen PureScript.Kinds PureScript.Parser
23+ PureScript.CodeGen.Common Main PureScript.CodeGen PureScript.Kinds
24− PureScript.TypeChecker PureScript.Types PureScript.Values
24+ PureScript.Parser PureScript.TypeChecker PureScript.Types
25+ PureScript.Values PureScript.Parser.Common
25− PureScript.Parser.Common PureScript.Parser.Declarations
26+ PureScript.Parser.Declarations PureScript.Parser.Types
26− PureScript.Parser.Types PureScript.Parser.Values
27− PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
27+ PureScript.Parser.Values PureScript.TypeChecker.Kinds
28+ PureScript.TypeChecker.Monad PureScript.TypeChecker.Types
28− PureScript.TypeChecker.Types PureScript.Parser.State
29+ PureScript.Parser.State
29 exposed: True
30 exposed: True
30 buildable: True
31 buildable: True
31 hs-source-dirs: src
32 hs-source-dirs: src
32−
33+ other-modules: PureScript.CodeGen.Pretty.Kinds
34+
33executable psc
35executable psc
34− build-depends: base -any,
36+ build-depends: base -any, cmdtheline -any, containers -any,
35− cmdtheline -any, containers -any, mtl -any, transformers -any, parsec -any,
37+ mtl -any, transformers -any, parsec -any, utf8-string -any
36− utf8-string -any
37 main-is: Main.hs
38 main-is: Main.hs
38 buildable: True
39 buildable: True
39 hs-source-dirs: src
40 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 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15−{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
16−
17module PureScript.CodeGen.Externs (
15module PureScript.CodeGen.Externs (
18 externToPs
16 externToPs
19) where
17) where
20
18
21−import Data.Maybe (fromMaybe)
22−import Data.List (intersperse, intercalate)
19+import Data.List (intercalate)
23−import qualified Control.Arrow as A
24−import Control.Arrow ((<+>))
25import qualified Data.Map as M
20import qualified Data.Map as M
26−import Control.Applicative
27−
28−import PureScript.Values
29−import PureScript.Types
30−import PureScript.Names
31import PureScript.Declarations
21import PureScript.Declarations
32import PureScript.TypeChecker.Monad
22import PureScript.TypeChecker.Monad
33−import PureScript.CodeGen.Common
23+import PureScript.CodeGen.Pretty.Types
34
24
35externToPs :: Environment -> Declaration -> Maybe String
25externToPs :: Environment -> Declaration -> Maybe String
36externToPs env (ValueDeclaration name _) = do
26externToPs env (ValueDeclaration name _) = do
37 (ty, _) <- M.lookup name $ names env
27 (ty, _) <- M.lookup name $ names env
38− return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
28+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
39externToPs env (ExternDeclaration name ty) =
29externToPs env (ExternDeclaration name ty) =
40− return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
30+ return $ "extern " ++ show name ++ " :: " ++ prettyPrintPolyType ty
41externToPs env (TypeSynonymDeclaration name args ty) =
31externToPs env (TypeSynonymDeclaration name args ty) =
42− return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ typeToPs ty
32+ return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ prettyPrintType ty
43externToPs _ _ = Nothing
33externToPs _ _ = 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
27import PureScript.Kinds
27import PureScript.Kinds
28import PureScript.Declarations
28import PureScript.Declarations
29import PureScript.TypeChecker.Monad
29import PureScript.TypeChecker.Monad
30+import PureScript.CodeGen.Pretty.Kinds
30
31
31import Control.Monad.State
32import Control.Monad.State
32import Control.Monad.Error
33import Control.Monad.Error
@@ -160,7 +161,7 @@ unifyKinds (FunKind k1 k2) (FunKind k3 k4) = do
160 cs1 <- unifyKinds k1 k3
161 cs1 <- unifyKinds k1 k3
161 cs2 <- unifyKinds k2 k4
162 cs2 <- unifyKinds k2 k4
162 return $ cs1 ++ cs2
163 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 ++ "."
164
165
165kindOccursCheck :: Bool -> Int -> Kind -> Bool
166kindOccursCheck :: Bool -> Int -> Kind -> Bool
166kindOccursCheck b u (KUnknown u') | u == u' = b
167kindOccursCheck b u (KUnknown u') | u == u' = b
src/PureScript/TypeChecker/Types.hs+10−8
@@ -30,6 +30,8 @@ import PureScript.Names
30import PureScript.TypeChecker.Monad
30import PureScript.TypeChecker.Monad
31import PureScript.TypeChecker.Kinds
31import PureScript.TypeChecker.Kinds
32import PureScript.TypeChecker.Synonyms
32import PureScript.TypeChecker.Synonyms
33+import PureScript.CodeGen.Pretty.Types
34+import PureScript.CodeGen.Pretty.Kinds
33
35
34import Control.Monad.State
36import Control.Monad.State
35import Control.Monad.Error
37import Control.Monad.Error
@@ -51,7 +53,7 @@ emptyTypeSolution = TypeSolution (TUnknown, RUnknown)
51
53
52typeOf :: Ident -> Value -> Check PolyType
54typeOf :: Ident -> Value -> Check PolyType
53typeOf name val = do
55typeOf name val = do
54− (cs, n) <- case val of
56+ (cs, n) <- case val of
55 Abs _ _ -> do
57 Abs _ _ -> do
56 me <- fresh
58 me <- fresh
57 (cs, n) <- typeConstraints (M.singleton name me) val
59 (cs, n) <- typeConstraints (M.singleton name me) val
@@ -77,7 +79,7 @@ allUnknownsBecameQuantified cs solution ty = do
77 TypeConstraint _ t -> findUnknownRows t
79 TypeConstraint _ t -> findUnknownRows t
78 RowConstraint u r -> u : findUnknownRows r
80 RowConstraint u r -> u : findUnknownRows r
79 unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
81 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
81
83
82findUnknownTypes :: (Data d) => d -> [Int]
84findUnknownTypes :: (Data d) => d -> [Int]
83findUnknownTypes = everything (++) (mkQ [] f)
85findUnknownTypes = everything (++) (mkQ [] f)
@@ -166,11 +168,11 @@ replaceRow n r = everywhere (mkT go)
166
168
167typeOccursCheck :: Int -> Type -> Check ()
169typeOccursCheck :: Int -> Type -> Check ()
168typeOccursCheck u (TUnknown _) = return ()
170typeOccursCheck 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
170
172
171rowOccursCheck :: Int -> Row -> Check ()
173rowOccursCheck :: Int -> Row -> Check ()
172rowOccursCheck u (RUnknown _) = return ()
174rowOccursCheck 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
174
176
175occursCheck :: (Data d) => Int -> d -> Bool
177occursCheck :: (Data d) => Int -> d -> Bool
176occursCheck u = everything (||) $ flip extQ g $ mkQ False f
178occursCheck u = everything (||) $ flip extQ g $ mkQ False f
@@ -273,7 +275,7 @@ typeConstraints m (IfThenElse cond th el) = do
273 return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)
275 return (TypeConstraint n1 Boolean : TypeConstraint n2 (TUnknown n3) : cs1 ++ cs2 ++ cs3, n2)
274typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
276typeConstraints m (TypedValue val poly@(PolyType idents ty)) = do
275 kind <- kindOf poly
277 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
277 desugared <- replaceAllTypeSynonyms ty
279 desugared <- replaceAllTypeSynonyms ty
278 (cs, n1) <- typeConstraints m val
280 (cs, n1) <- typeConstraints m val
279 return (TypeConstraint n1 desugared : cs, n1)
281 return (TypeConstraint n1 desugared : cs, n1)
@@ -534,7 +536,7 @@ unifyTypes (TypeApp t1 t2) (TypeApp t3 t4) = do
534 cs1 <- unifyTypes t1 t3
536 cs1 <- unifyTypes t1 t3
535 cs2 <- unifyTypes t2 t4
537 cs2 <- unifyTypes t2 t4
536 return $ cs1 ++ cs2
538 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 ++ "."
538
540
539unifyRows :: Row -> Row -> Check [TypeConstraint]
541unifyRows :: Row -> Row -> Check [TypeConstraint]
540unifyRows r1 r2 =
542unifyRows r1 r2 =
@@ -544,7 +546,7 @@ unifyRows r1 r2 =
544 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
546 int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
545 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]
547 sd1 = [ (name, t1) | (name, t1) <- s1, not (elem name (map fst s2)) ]
546 sd2 = [ (name, t2) | (name, t2) <- s2, not (elem name (map fst s1)) ]
548 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
548 cs1 <- fmap concat $ mapM (uncurry unifyTypes) int
550 cs1 <- fmap concat $ mapM (uncurry unifyTypes) int
549 cs2 <- unifyRows' sd1 r1' sd2 r2'
551 cs2 <- unifyRows' sd1 r1' sd2 r2'
550 return $ cs1 ++ cs2
552 return $ cs1 ++ cs2
@@ -561,7 +563,7 @@ unifyRows r1 r2 =
561 cs <- unifyRows' row r others (RUnknown u')
563 cs <- unifyRows' row r others (RUnknown u')
562 return (RowConstraint u (RCons name ty (RUnknown u')) : cs)
564 return (RowConstraint u (RCons name ty (RUnknown u')) : cs)
563 unifyRows' [] REmpty [] REmpty = return []
565 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)) ++ "."
565 toList :: Row -> ([(String, Type)], Row)
567 toList :: Row -> ([(String, Type)], Row)
566 toList (RCons name ty row) = let (tys, rest) = toList row
568 toList (RCons name ty row) = let (tys, rest) = toList row
567 in ((name, ty):tys, rest)
569 in ((name, ty):tys, rest)