c7f8746 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

on golang help sign in

Pretty printer for let expressions. Only show first and last errors when not using -v

c7f8746Phil Freeman13 years ago

src/Language/PureScript/Pretty/Values.hs+18−11

compare with golang

unifiedsplit

@@ -26,10 +26,9 @@ import Control.PatternArrows

26import Control.Monad.State

27import Control.Applicative

29−import Language.PureScript.Types

30import Language.PureScript.Declarations

29import Language.PureScript.Declarations

31import Language.PureScript.Pretty.Common

30import Language.PureScript.Pretty.Common

32−import Language.PureScript.Pretty.Types

31+import Language.PureScript.Pretty.Types (prettyPrintType)

34literals :: Pattern PrinterState Value String

33literals :: Pattern PrinterState Value String

35literals = mkPattern' match

34literals = mkPattern' match

@@ -44,6 +43,7 @@ literals = mkPattern' match

44 , withIndent $ prettyPrintMany prettyPrintValue' xs

43 , withIndent $ prettyPrintMany prettyPrintValue' xs

45 , return " ]"

44 , return " ]"

46 ]

45 ]

46+ match (ObjectLiteral []) = return "{}"

47 match (ObjectLiteral ps) = fmap concat $ sequence

48 [ return "{\n"

49 , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

@@ -58,8 +58,12 @@ literals = mkPattern' match

58 , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

59 , currentIndent

60 ]

61− match (Let _ val) = fmap concat $ sequence

61+ match (Let ds val) = fmap concat $ sequence

62− [ return "let ... in " -- TODO

62+ [ return "let\n"

63+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds

64+ , return "\n"

65+ , currentIndent

66+ , return "in "

63 , prettyPrintValue' val

67 , prettyPrintValue' val

64 ]

68 ]

65 match (Var ident) = return $ show ident

69 match (Var ident) = return $ show ident

@@ -69,9 +73,19 @@ literals = mkPattern' match

69 , currentIndent

73 , currentIndent

70 ]

74 ]

71 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

75 match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"

76+ match (TypedValue _ val _) = prettyPrintValue' val

72 match (PositionedValue _ val) = prettyPrintValue' val

77 match (PositionedValue _ val) = prettyPrintValue' val

73 match _ = mzero

78 match _ = mzero

80+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

81+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

82+prettyPrintDeclaration (ValueDeclaration ident _ [] Nothing val) = fmap concat $ sequence

83+ [ return $ show ident ++ " = "

84+ , prettyPrintValue' val

85+ ]

86+prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d

87+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

88+

75prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

89prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

76prettyPrintCaseAlternative (CaseAlternative binders grd val) =

90prettyPrintCaseAlternative (CaseAlternative binders grd val) =

77 fmap concat $ sequence

91 fmap concat $ sequence

@@ -129,12 +143,6 @@ lam = mkPattern match

129 match (Abs (Left arg) val) = Just (show arg, val)

143 match (Abs (Left arg) val) = Just (show arg, val)

130 match _ = Nothing

144 match _ = Nothing

131

145

132−typed :: Pattern PrinterState Value (Type, Value)

133−typed = mkPattern match

134− where

135− match (TypedValue _ val ty) = Just (ty, val)

136− match _ = Nothing

137−

138-- |

146-- |

139-- Generate a pretty-printed string representing an expression

147-- Generate a pretty-printed string representing an expression

140--

148--

@@ -153,7 +161,6 @@ prettyPrintValue' = runKleisli $ runPattern matchValue

153 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

161 , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

154 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

162 , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

155 , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

163 , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

156− , [ Wrap typed $ \ty val -> val ++ " :: " ++ prettyPrintType ty ]

157 ]

164 ]

158

165

159prettyPrintBinderAtom :: Pattern PrinterState Binder String

166prettyPrintBinderAtom :: Pattern PrinterState Binder String

src/Language/PureScript/TypeChecker/Monad.hs+3−21

@@ -91,27 +91,9 @@ prettyPrintUnifyErrorStack opts (UnifyErrorStack es) =

91 | otherwise =

92 let

93 es' = filter isErrorNonEmpty es

94− errorsWithValues = filter (isJust . unifyErrorValue) es'

94+ in case length es' of

95− mostSpecificError = last es'

96− in case (length errorsWithValues, isJust (unifyErrorValue mostSpecificError)) of

97− (0, _) -> showError mostSpecificError

98− (1, True) -> showError mostSpecificError

95+ 1 -> showError (head es')

99− (1, False) ->

96+ _ -> showError (head es') ++ "\n" ++ showError (last es')

100− let errorWithValue = head errorsWithValues

101− in showError errorWithValue ++ "\n" ++

102− showError mostSpecificError

103− (_, True) ->

104− let errorWithValue = head errorsWithValues

105− in showError errorWithValue ++ "\n" ++

106− showError mostSpecificError

107− (_, False) ->

108− let

109− leastSpecificErrorWithValue = head errorsWithValues

110− mostSpecificErrorWithValue = last errorsWithValues

111− in

112− showError leastSpecificErrorWithValue ++ "\n" ++

113− showError mostSpecificErrorWithValue ++ "\n" ++

114− showError mostSpecificError

115

116isErrorNonEmpty :: UnifyError -> Bool

98isErrorNonEmpty :: UnifyError -> Bool

117isErrorNonEmpty = not . null . unifyErrorMessage

99isErrorNonEmpty = not . null . unifyErrorMessage