07e8adc · rowtype-yoga/purescript-native

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

on golang help sign in

Merge pull request #1616 from purescript/1590

07e8adcPhil Freeman11 years ago

src/Language/PureScript/Errors.hs+14−10

compare with golang

unifiedsplit

@@ -513,7 +513,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

513 renderSimpleErrorMessage (EscapedSkolem binding) =

514 paras $ [ line "A type variable has escaped its scope." ]

515 <> foldMap (\expr -> [ line "Relevant expression: "

516− , indent $ prettyPrintValue expr

516+ , indent $ prettyPrintValue valueDepth expr

517 ]) binding

518 renderSimpleErrorMessage (TypesDoNotUnify t1 t2)

519 = paras [ line "Could not match type"

@@ -568,7 +568,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

568 renderSimpleErrorMessage (DuplicateLabel l expr) =

569 paras $ [ line $ "Label " ++ show l ++ " appears more than once in a row type." ]

570 <> foldMap (\expr' -> [ line "Relevant expression: "

571− , indent $ prettyPrintValue expr'

571+ , indent $ prettyPrintValue valueDepth expr'

572 ]) expr

573 renderSimpleErrorMessage (DuplicateTypeArgument name) =

574 line $ "Type argument " ++ show name ++ " appears more than once."

@@ -594,7 +594,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

594 line $ "Data constructor " ++ showQualified runProperName nm ++ " was given the wrong number of arguments in a case expression."

595 renderSimpleErrorMessage (ExprDoesNotHaveType expr ty) =

596 paras [ line "Expression"

597− , indent $ prettyPrintValue expr

597+ , indent $ prettyPrintValue valueDepth expr

598 , line "does not have type"

599 , indent $ typeAsBox ty

600 ]

@@ -606,7 +606,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

606 paras [ line "A function of type"

607 , indent $ typeAsBox fn

608 , line "can not be applied to the argument"

609− , indent $ prettyPrintValue arg

609+ , indent $ prettyPrintValue valueDepth arg

610 ]

611 renderSimpleErrorMessage TypeSynonymInstance =

612 line "Type class instances for type synonyms are disallowed."

@@ -693,7 +693,7 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

693 renderHint (ErrorInExpression expr) detail =

694 paras [ detail

695 , Box.hsep 1 Box.top [ Box.text "in the expression"

696− , prettyPrintValue expr

696+ , prettyPrintValue valueDepth expr

697 ]

698 ]

699 renderHint (ErrorInModule mn) detail =

@@ -729,13 +729,13 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

729 renderHint (ErrorInferringType expr) detail =

730 paras [ detail

731 , Box.hsep 1 Box.top [ line "while inferring the type of"

732− , prettyPrintValue expr

732+ , prettyPrintValue valueDepth expr

733 ]

734 ]

735 renderHint (ErrorCheckingType expr ty) detail =

736 paras [ detail

737 , Box.hsep 1 Box.top [ line "while checking that expression"

738− , prettyPrintValue expr

738+ , prettyPrintValue valueDepth expr

739 ]

740 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "has type"

741 , typeAsBox ty

@@ -744,19 +744,19 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

744 renderHint (ErrorCheckingAccessor expr prop) detail =

745 paras [ detail

746 , Box.hsep 1 Box.top [ line "while checking type of property accessor"

747− , prettyPrintValue (Accessor prop expr)

747+ , prettyPrintValue valueDepth (Accessor prop expr)

748 ]

749 ]

750 renderHint (ErrorInApplication f t a) detail =

751 paras [ detail

752 , Box.hsep 1 Box.top [ line "while applying a function"

753− , prettyPrintValue f

753+ , prettyPrintValue valueDepth f

754 ]

755 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "of type"

756 , typeAsBox t

757 ]

758 , Box.moveRight 2 $ Box.hsep 1 Box.top [ line "to argument"

759− , prettyPrintValue a

759+ , prettyPrintValue valueDepth a

760 ]

761 ]

762 renderHint (ErrorInDataConstructor nm) detail =

@@ -796,6 +796,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError

796 , detail

797 ]

798

799+ valueDepth :: Int

800+ valueDepth | full = 1000

801+ | otherwise = 3

802+

799 levelText :: String

803 levelText :: String

800 levelText = case level of

804 levelText = case level of

801 Error -> "error"

805 Error -> "error"

src/Language/PureScript/Pretty/Values.hs+74−68

@@ -38,101 +38,107 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl

38 where

39 toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a

41+ellipsis :: Box

42+ellipsis = text "..."

43+

41−prettyPrintObject :: [(String, Maybe Expr)] -> Box

44+prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box

42−prettyPrintObject = list '{' '}' prettyPrintObjectProperty

45+prettyPrintObject d = list '{' '}' prettyPrintObjectProperty

43 where

46 where

44 prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

47 prettyPrintObjectProperty :: (String, Maybe Expr) -> Box

45− prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") prettyPrintValue value

48+ prettyPrintObjectProperty (key, value) = text (prettyPrintObjectKey key ++ ": ") <> maybe (text "_") (prettyPrintValue (d - 1)) value

47-- | Pretty-print an expression

50-- | Pretty-print an expression

48−prettyPrintValue :: Expr -> Box

51+prettyPrintValue :: Int -> Expr -> Box

49−prettyPrintValue (IfThenElse cond th el) =

52+prettyPrintValue d _ | d < 0 = text "..."

53+prettyPrintValue d (IfThenElse cond th el) =

50− (text "if " <> prettyPrintValueAtom cond)

54+ (text "if " <> prettyPrintValueAtom (d - 1) cond)

51− // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th

55+ // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th

52− , text "else " <> prettyPrintValueAtom el

56+ , text "else " <> prettyPrintValueAtom (d - 1) el

53 ])

57 ])

54−prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop)

58+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)

55−prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps

59+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) val) ps

56−prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps

60+prettyPrintValue d (ObjectUpdater o ps) = maybe (text "_") (prettyPrintValueAtom (d - 1)) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") (prettyPrintValue (d - 1)) val) ps

57−prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg

61+prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg

58−prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val)

62+prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)

59−prettyPrintValue (TypeClassDictionaryConstructorApp className ps) =

63+prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =

60− text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps

64+ text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps

61−prettyPrintValue (Case values binders) =

65+prettyPrintValue d (Case values binders) =

62− (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") //

66+ (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //

63− moveRight 2 (vcat left (map prettyPrintCaseAlternative binders))

67+ moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))

64−prettyPrintValue (Let ds val) =

68+prettyPrintValue d (Let ds val) =

65 text "let" //

69 text "let" //

66− moveRight 2 (vcat left (map prettyPrintDeclaration ds)) //

70+ moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //

67− (text "in " <> prettyPrintValue val)

71+ (text "in " <> prettyPrintValue (d - 1) val)

68−prettyPrintValue (Do els) =

72+prettyPrintValue d (Do els) =

69− text "do " <> vcat left (map prettyPrintDoNotationElement els)

73+ text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

70−prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

74+prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys

71−prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

75+prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)

72−prettyPrintValue (TypedValue _ val _) = prettyPrintValue val

76+prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

73−prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val

77+prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val

74−prettyPrintValue expr = prettyPrintValueAtom expr

78+prettyPrintValue d expr = prettyPrintValueAtom d expr

76-- | Pretty-print an atomic expression, adding parentheses if necessary.

80-- | Pretty-print an atomic expression, adding parentheses if necessary.

77−prettyPrintValueAtom :: Expr -> Box

81+prettyPrintValueAtom :: Int -> Expr -> Box

78−prettyPrintValueAtom (NumericLiteral n) = text $ either show show n

82+prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n

79−prettyPrintValueAtom (StringLiteral s) = text $ show s

83+prettyPrintValueAtom _ (StringLiteral s) = text $ show s

80−prettyPrintValueAtom (CharLiteral c) = text $ show c

84+prettyPrintValueAtom _ (CharLiteral c) = text $ show c

81−prettyPrintValueAtom (BooleanLiteral True) = text "true"

85+prettyPrintValueAtom _ (BooleanLiteral True) = text "true"

82−prettyPrintValueAtom (BooleanLiteral False) = text "false"

86+prettyPrintValueAtom _ (BooleanLiteral False) = text "false"

83−prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs

87+prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs

84−prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps

88+prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps

85−prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps

89+prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps

86−prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop

90+prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop

87−prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)

91+prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)

88−prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)

92+prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)

89−prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"

93+prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"

90−prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"

94+prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"

91−prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val

95+prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val

92−prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val

96+prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val

93−prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"

97+prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"

94−

98+

95−prettyPrintDeclaration :: Declaration -> Box

99+prettyPrintDeclaration :: Int -> Declaration -> Box

96−prettyPrintDeclaration (TypeDeclaration ident ty) =

100+prettyPrintDeclaration d _ | d < 0 = ellipsis

101+prettyPrintDeclaration _ (TypeDeclaration ident ty) =

97 text (showIdent ident ++ " :: ") <> typeAsBox ty

102 text (showIdent ident ++ " :: ") <> typeAsBox ty

98−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) =

103+prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =

99− text (showIdent ident ++ " = ") <> prettyPrintValue val

104+ text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val

100−prettyPrintDeclaration (BindingGroupDeclaration ds) =

105+prettyPrintDeclaration d (BindingGroupDeclaration ds) =

101− vsep 1 left (map (prettyPrintDeclaration . toDecl) ds)

106+ vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)

102 where

107 where

103 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

108 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)

104−prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

109+prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl

105−prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration"

110+prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"

106

111

107−prettyPrintCaseAlternative :: CaseAlternative -> Box

112+prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box

108−prettyPrintCaseAlternative (CaseAlternative binders result) =

113+prettyPrintCaseAlternative d _ | d < 0 = ellipsis

114+prettyPrintCaseAlternative d (CaseAlternative binders result) =

109 text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

115 text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result

110 where

116 where

111 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

117 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box

112 prettyPrintResult (Left gs) =

118 prettyPrintResult (Left gs) =

113 vcat left (map prettyPrintGuardedValue gs)

119 vcat left (map prettyPrintGuardedValue gs)

114− prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v

120+ prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v

115

121

116 prettyPrintGuardedValue :: (Guard, Expr) -> Box

122 prettyPrintGuardedValue :: (Guard, Expr) -> Box

117 prettyPrintGuardedValue (grd, val) = foldl1 before

123 prettyPrintGuardedValue (grd, val) = foldl1 before

118 [ text " | "

124 [ text " | "

119− , prettyPrintValue grd

125+ , prettyPrintValue (d - 1) grd

120 , text " -> "

126 , text " -> "

121− , prettyPrintValue val

127+ , prettyPrintValue (d - 1) val

122 ]

128 ]

123

129

124−prettyPrintDoNotationElement :: DoNotationElement -> Box

130+prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box

125−prettyPrintDoNotationElement (DoNotationValue val) =

131+prettyPrintDoNotationElement d _ | d < 0 = ellipsis

132+prettyPrintDoNotationElement d (DoNotationValue val) =

126− prettyPrintValue val

133+ prettyPrintValue d val

127−prettyPrintDoNotationElement (DoNotationBind binder val) =

134+prettyPrintDoNotationElement d (DoNotationBind binder val) =

128− text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val

135+ text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val

129−prettyPrintDoNotationElement (DoNotationLet ds) =

136+prettyPrintDoNotationElement d (DoNotationLet ds) =

130 text "let" //

137 text "let" //

131− moveRight 2 (vcat left (map prettyPrintDeclaration ds))

138+ moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))

132−prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

139+prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el

133

140

134prettyPrintBinderAtom :: Binder -> String

141prettyPrintBinderAtom :: Binder -> String

135−

136prettyPrintBinderAtom NullBinder = "_"

142prettyPrintBinderAtom NullBinder = "_"

137prettyPrintBinderAtom (StringBinder str) = show str

143prettyPrintBinderAtom (StringBinder str) = show str

138prettyPrintBinderAtom (CharBinder c) = show c

144prettyPrintBinderAtom (CharBinder c) = show c