@@ -38,101 +38,107 @@ list open close f xs = vcat left (zipWith toLine [0 :: Int ..] xs ++ [ text [ cl
3838 where
3939 toLine i a = text [ if i == 0 then open else ',', ' ' ] <> f a
4040
41−prettyPrintObject :: [(String, Maybe Expr)] -> Box
42−prettyPrintObject = list '{' '}' prettyPrintObjectProperty
41+ellipsis :: Box
42+ellipsis = text "..."
43+
44+prettyPrintObject :: Int -> [(String, Maybe Expr)] -> Box
45+prettyPrintObject d = list '{' '}' prettyPrintObjectProperty
4346 where
4447 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
4649
4750-- | Pretty-print an expression
48−prettyPrintValue :: Expr -> Box
49−prettyPrintValue (IfThenElse cond th el) =
50− (text "if " <> prettyPrintValueAtom cond)
51− // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom th
52− , text "else " <> prettyPrintValueAtom el
51+prettyPrintValue :: Int -> Expr -> Box
52+prettyPrintValue d _ | d < 0 = text "..."
53+prettyPrintValue d (IfThenElse cond th el) =
54+ (text "if " <> prettyPrintValueAtom (d - 1) cond)
55+ // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th
56+ , text "else " <> prettyPrintValueAtom (d - 1) el
5357 ])
54−prettyPrintValue (Accessor prop val) = prettyPrintValueAtom val <> text ("." ++ show prop)
55−prettyPrintValue (ObjectUpdate o ps) = prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue val) ps
56−prettyPrintValue (ObjectUpdater o ps) = maybe (text "_") prettyPrintValueAtom o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> maybe (text "_") prettyPrintValue val) ps
57−prettyPrintValue (App val arg) = prettyPrintValueAtom val `beforeWithSpace` prettyPrintValueAtom arg
58−prettyPrintValue (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue val)
59−prettyPrintValue (TypeClassDictionaryConstructorApp className ps) =
60− text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom ps
61−prettyPrintValue (Case values binders) =
62− (text "case " <> foldl1 beforeWithSpace (map prettyPrintValueAtom values) <> text " of") //
63− moveRight 2 (vcat left (map prettyPrintCaseAlternative binders))
64−prettyPrintValue (Let ds val) =
58+prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> text ("." ++ show prop)
59+prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> text (key ++ " = ") <> prettyPrintValue (d - 1) 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
61+prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg
62+prettyPrintValue d (Abs (Left arg) val) = text ('\\' : showIdent arg ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val)
63+prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) =
64+ text (runProperName (disqualify className) ++ " ") <> prettyPrintValueAtom (d - 1) ps
65+prettyPrintValue d (Case values binders) =
66+ (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") //
67+ moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders))
68+prettyPrintValue d (Let ds val) =
6569 text "let" //
66− moveRight 2 (vcat left (map prettyPrintDeclaration ds)) //
67− (text "in " <> prettyPrintValue val)
68−prettyPrintValue (Do els) =
69− text "do " <> vcat left (map prettyPrintDoNotationElement els)
70−prettyPrintValue (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
71−prettyPrintValue (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
72−prettyPrintValue (TypedValue _ val _) = prettyPrintValue val
73−prettyPrintValue (PositionedValue _ _ val) = prettyPrintValue val
74−prettyPrintValue expr = prettyPrintValueAtom expr
70+ moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds)) //
71+ (text "in " <> prettyPrintValue (d - 1) val)
72+prettyPrintValue d (Do els) =
73+ text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
74+prettyPrintValue _ (TypeClassDictionary (name, tys) _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
75+prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
76+prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val
77+prettyPrintValue d (PositionedValue _ _ val) = prettyPrintValue d val
78+prettyPrintValue d expr = prettyPrintValueAtom d expr
7579
7680-- | Pretty-print an atomic expression, adding parentheses if necessary.
77−prettyPrintValueAtom :: Expr -> Box
78−prettyPrintValueAtom (NumericLiteral n) = text $ either show show n
79−prettyPrintValueAtom (StringLiteral s) = text $ show s
80−prettyPrintValueAtom (CharLiteral c) = text $ show c
81−prettyPrintValueAtom (BooleanLiteral True) = text "true"
82−prettyPrintValueAtom (BooleanLiteral False) = text "false"
83−prettyPrintValueAtom (ArrayLiteral xs) = list '[' ']' prettyPrintValue xs
84−prettyPrintValueAtom (ObjectLiteral ps) = prettyPrintObject $ second Just `map` ps
85−prettyPrintValueAtom (ObjectConstructor ps) = prettyPrintObject ps
86−prettyPrintValueAtom (ObjectGetter prop) = text $ "_." ++ show prop
87−prettyPrintValueAtom (Constructor name) = text $ runProperName (disqualify name)
88−prettyPrintValueAtom (Var ident) = text $ showIdent (disqualify ident)
89−prettyPrintValueAtom (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue op) `beforeWithSpace` prettyPrintValue val) `before` text ")"
90−prettyPrintValueAtom (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue val) `beforeWithSpace` prettyPrintValue op) `before` text ")"
91−prettyPrintValueAtom (TypedValue _ val _) = prettyPrintValueAtom val
92−prettyPrintValueAtom (PositionedValue _ _ val) = prettyPrintValueAtom val
93−prettyPrintValueAtom expr = (text "(" <> prettyPrintValue expr) `before` text ")"
94−
95−prettyPrintDeclaration :: Declaration -> Box
96−prettyPrintDeclaration (TypeDeclaration ident ty) =
81+prettyPrintValueAtom :: Int -> Expr -> Box
82+prettyPrintValueAtom _ (NumericLiteral n) = text $ either show show n
83+prettyPrintValueAtom _ (StringLiteral s) = text $ show s
84+prettyPrintValueAtom _ (CharLiteral c) = text $ show c
85+prettyPrintValueAtom _ (BooleanLiteral True) = text "true"
86+prettyPrintValueAtom _ (BooleanLiteral False) = text "false"
87+prettyPrintValueAtom d (ArrayLiteral xs) = list '[' ']' (prettyPrintValue (d - 1)) xs
88+prettyPrintValueAtom d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ second Just `map` ps
89+prettyPrintValueAtom d (ObjectConstructor ps) = prettyPrintObject (d - 1) ps
90+prettyPrintValueAtom _ (ObjectGetter prop) = text $ "_." ++ show prop
91+prettyPrintValueAtom _ (Constructor name) = text $ runProperName (disqualify name)
92+prettyPrintValueAtom _ (Var ident) = text $ showIdent (disqualify ident)
93+prettyPrintValueAtom d (OperatorSection op (Right val)) = ((text "(" <> prettyPrintValue (d - 1) op) `beforeWithSpace` prettyPrintValue (d - 1) val) `before` text ")"
94+prettyPrintValueAtom d (OperatorSection op (Left val)) = ((text "(" <> prettyPrintValue (d - 1) val) `beforeWithSpace` prettyPrintValue (d - 1) op) `before` text ")"
95+prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val
96+prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val
97+prettyPrintValueAtom d expr = (text "(" <> prettyPrintValue d expr) `before` text ")"
98+
99+prettyPrintDeclaration :: Int -> Declaration -> Box
100+prettyPrintDeclaration d _ | d < 0 = ellipsis
101+prettyPrintDeclaration _ (TypeDeclaration ident ty) =
97102 text (showIdent ident ++ " :: ") <> typeAsBox ty
98−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) =
99− text (showIdent ident ++ " = ") <> prettyPrintValue val
100−prettyPrintDeclaration (BindingGroupDeclaration ds) =
101− vsep 1 left (map (prettyPrintDeclaration . toDecl) ds)
103+prettyPrintDeclaration d (ValueDeclaration ident _ [] (Right val)) =
104+ text (showIdent ident ++ " = ") <> prettyPrintValue (d - 1) val
105+prettyPrintDeclaration d (BindingGroupDeclaration ds) =
106+ vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds)
102107 where
103108 toDecl (nm, t, e) = ValueDeclaration nm t [] (Right e)
104−prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d
105−prettyPrintDeclaration _ = internalError "Invalid argument to prettyPrintDeclaration"
109+prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl
110+prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration"
106111
107−prettyPrintCaseAlternative :: CaseAlternative -> Box
108−prettyPrintCaseAlternative (CaseAlternative binders result) =
112+prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box
113+prettyPrintCaseAlternative d _ | d < 0 = ellipsis
114+prettyPrintCaseAlternative d (CaseAlternative binders result) =
109115 text (unwords (map prettyPrintBinderAtom binders)) <> prettyPrintResult result
110116 where
111117 prettyPrintResult :: Either [(Guard, Expr)] Expr -> Box
112118 prettyPrintResult (Left gs) =
113119 vcat left (map prettyPrintGuardedValue gs)
114− prettyPrintResult (Right v) = text " -> " <> prettyPrintValue v
120+ prettyPrintResult (Right v) = text " -> " <> prettyPrintValue (d - 1) v
115121
116122 prettyPrintGuardedValue :: (Guard, Expr) -> Box
117123 prettyPrintGuardedValue (grd, val) = foldl1 before
118124 [ text " | "
119− , prettyPrintValue grd
125+ , prettyPrintValue (d - 1) grd
120126 , text " -> "
121− , prettyPrintValue val
127+ , prettyPrintValue (d - 1) val
122128 ]
123129
124−prettyPrintDoNotationElement :: DoNotationElement -> Box
125−prettyPrintDoNotationElement (DoNotationValue val) =
126− prettyPrintValue val
127−prettyPrintDoNotationElement (DoNotationBind binder val) =
128− text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue val
129−prettyPrintDoNotationElement (DoNotationLet ds) =
130+prettyPrintDoNotationElement :: Int -> DoNotationElement -> Box
131+prettyPrintDoNotationElement d _ | d < 0 = ellipsis
132+prettyPrintDoNotationElement d (DoNotationValue val) =
133+ prettyPrintValue d val
134+prettyPrintDoNotationElement d (DoNotationBind binder val) =
135+ text (prettyPrintBinder binder ++ " <- ") <> prettyPrintValue d val
136+prettyPrintDoNotationElement d (DoNotationLet ds) =
130137 text "let" //
131− moveRight 2 (vcat left (map prettyPrintDeclaration ds))
132−prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
138+ moveRight 2 (vcat left (map (prettyPrintDeclaration (d - 1)) ds))
139+prettyPrintDoNotationElement d (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement d el
133140
134141prettyPrintBinderAtom :: Binder -> String
135−
136142prettyPrintBinderAtom NullBinder = "_"
137143prettyPrintBinderAtom (StringBinder str) = show str
138144prettyPrintBinderAtom (CharBinder c) = show c