improve repetition in $pretty* function definitions

kadoban · kadoban · commit ef9b3c9108c2 · 2017-08-23T00:39:03.000-07:00
There's still some repetition, but I think it's quite a bit better repetition. At least it's shorter, and hopefully easier to see bugs/discepencies as these things possibly change later. Thanks @mgsloan for the TH help (any horribleness in applying it is my own fault :) p.s. I'm not usually a fan of the whole "align all the things" style, but here I think it's warranted to more easily see correspondences between the different line at a glance.
diff --git a/src/Stack/PrettyPrint.hs b/src/Stack/PrettyPrint.hs
@@ -55,70 +55,41 @@ displayWithColor x = do
 
 -- TODO: switch to using implicit callstacks once 7.8 support is dropped
 
-prettyDebug :: Q Exp
-prettyDebug = do
+prettyWith :: LogLevel -> ExpQ -> Q Exp
+prettyWith level f = do
     loc <- location
-    [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor |]
-
-prettyInfo :: Q Exp
-prettyInfo = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor |]
-
-prettyWarn :: Q Exp
-prettyWarn = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningColor "Warning:" <+>) . indentAfterLabel |]
-
-prettyError :: Q Exp
-prettyError = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorColor "Error:" <+>) . indentAfterLabel |]
-
--- TODO: Figure out how to collapse these to use the same implementation
---       as the above ones!
-
-prettyDebugL :: Q Exp
-prettyDebugL = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor . fillSep|]
-
-prettyInfoL :: Q Exp
-prettyInfoL = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor . fillSep|]
-
-prettyWarnL :: Q Exp
-prettyWarnL = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningColor "Warning:" <+>) . indentAfterLabel . fillSep|]
-
-prettyErrorL :: Q Exp
-prettyErrorL = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorColor "Error:" <+>) . indentAfterLabel . fillSep|]
-
-prettyDebugS :: Q Exp
-prettyDebugS = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelDebug <=< displayWithColor . flow|]
-
-prettyInfoS :: Q Exp
-prettyInfoS = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelInfo <=< displayWithColor . flow|]
-
-prettyWarnS :: Q Exp
-prettyWarnS = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelWarn <=< displayWithColor . (line <>) . (warningColor "Warning:" <+>) . indentAfterLabel . flow|]
-
-prettyErrorS :: Q Exp
-prettyErrorS = do
-    loc <- location
-    [e| monadLoggerLog loc "" LevelError <=< displayWithColor . (line <>) . (errorColor "Error:" <+>) . indentAfterLabel . flow|]
-
--- End of duplicates
+    [e| monadLoggerLog loc "" level <=< displayWithColor . $f |]
+
+-- Note: I think keeping this section aligned helps spot errors, might be
+-- worth keeping the alignment in place.
+prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith :: ExpQ -> Q Exp
+prettyDebugWith   = prettyWith LevelDebug
+prettyInfoWith    = prettyWith LevelInfo
+prettyWarnWith  f = prettyWith LevelWarn
+                        [| (line <>) . (warningColor "Warning:" <+>) .
+                           indentAfterLabel . $f |]
+prettyErrorWith f = prettyWith LevelError
+                        [| (line <>) . (errorColor   "Error:" <+>) .
+                           indentAfterLabel . $f |]
+
+prettyDebug, prettyInfo, prettyWarn, prettyError :: Q Exp
+prettyDebug  = prettyDebugWith [| id |]
+prettyInfo   = prettyInfoWith  [| id |]
+prettyWarn   = prettyWarnWith  [| id |]
+prettyError  = prettyErrorWith [| id |]
+
+prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL :: Q Exp
+prettyDebugL = prettyDebugWith [| fillSep |]
+prettyInfoL  = prettyInfoWith  [| fillSep |]
+prettyWarnL  = prettyWarnWith  [| fillSep |]
+prettyErrorL = prettyErrorWith [| fillSep |]
+
+prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS :: Q Exp
+prettyDebugS = prettyDebugWith [| flow |]
+prettyInfoS  = prettyInfoWith  [| flow |]
+prettyWarnS  = prettyWarnWith  [| flow |]
+prettyErrorS = prettyErrorWith [| flow |]
+-- End of aligned section
 
 indentAfterLabel :: Doc a -> Doc a
 indentAfterLabel = align
