fix list pretty-printing bug

TODO.md

@@ -1,30 +1,8 @@
 TO DO list for Express
 ======================
 
-* Investigate the list pretty-printing bug described below.
-
 * Improve pretty-printing (see TODO items in `test/show.hs`)
 
 * use `enumFromTo` in `u-conjure.hs`?
 
 * Release new version
-
-
-## List pretty-printing bug
-
-	> xx -:- yy -:- nil -++- yy -:- nil
-	[x,y,] ++ [y] :: [Int]
-
-	> xx -:- (yy -:- (nil -++- (yy -:- nil)))
-	[x,y,] ++ [y] :: [Int]
-
-There's a dangling comma.  This ought to be displayed as:
-
-	x:y:([] ++ [y])
-
-The second argument of `++` does not really matter to expose the bug:
-
-	> xx -:- yy -:- nil -++- is_
-	[x,y,] ++ _ :: [Int]
-
-A couple commented-out tests have been added to `test/show.hs`.

bench/sort.txt

@@ -4315,7 +4315,7 @@ sort $ take 5040 $ list  ::  [ Expr ]  =
   , tail (id _:_:_) :: [Int]
   , _:tail (id _:_) :: [Int]
   , _:_:(_ ++ []) :: [Int]
-  , [_,_,] ++ _ :: [Int]
+  , _:_:([] ++ _) :: [Int]
   , _:0:(_ ++ _) :: [Int]
   , _:id _:tail _ :: [Int]
   , _:id (abs _):_ :: [Int]
@@ -9167,7 +9167,7 @@ sortBy compareLexicographically $ take 5040 $ list  ::  [ Expr ]  =
   , _:_:(_ ++ []) :: [Int]
   , _:_:(_ ++ (_:_)) :: [Int]
   , _:_:(xs ++ _) :: [Int]
-  , [_,_,] ++ _ :: [Int]
+  , _:_:([] ++ _) :: [Int]
   , _:_:((_:_) ++ _) :: [Int]
   , _:x:_ :: [Int]
   , _:x:xs :: [Int]
@@ -14300,7 +14300,7 @@ sortBy compareQuickly $ take 5040 $ list  ::  [ Expr ]  =
   , _:_:head _:_ :: [Int]
   , _:_:_ + _:_ :: [Int]
   , _:_:insert _ _ :: [Int]
-  , [_,_,] ++ _ :: [Int]
+  , _:_:([] ++ _) :: [Int]
   , _:_:(_ ++ []) :: [Int]
   , _:_:(_ ++ _) :: [Int]
   , _:_:(_ ++ xs) :: [Int]

bench/tiers.txt

@@ -2769,7 +2769,7 @@ tiers :: [[ Expr ]]  =
     , _:_:(_ ++ []) :: [Int]
     , _:_:(_ ++ (_:_)) :: [Int]
     , _:_:(xs ++ _) :: [Int]
-    , [_,_,] ++ _ :: [Int]
+    , _:_:([] ++ _) :: [Int]
     , _:_:((_:_) ++ _) :: [Int]
     , _:_:sort _ :: [Int]
     , _:_:insert _ _ :: [Int]

src/Data/Express/Core.hs

@@ -452,18 +452,26 @@ showsPrecExpr d (Value s _) | isInfixedPrefix s = showString $ toPrefix s
 showsPrecExpr d (Value s _) | isNegativeLiteral s = showParen (d > 0) $ showString s
 showsPrecExpr d (Value s _) = showParen sp $ showString s
   where sp = if atomic s then isInfix s else maybe True (d >) $ outernmostPrec s
-showsPrecExpr d (Value ":" _ :$ e1 :$ e2)
-  | isConst e1 && mtyp e1 == Just (typeOf (undefined :: Char)) =
-  case showsTailExpr e2 "" of
-    '\"':cs  -> showString ("\"" ++ (init . tail) (showsPrecExpr 0 e1 "") ++ cs)
-    cs -> showParen (d > prec ":")
-        $ showsOpExpr ":" e1 . showString ":" . showString cs
-showsPrecExpr d (Value ":" _ :$ e1 :$ e2) =
-  case showsTailExpr e2 "" of
-    "[]" -> showString "[" . showsPrecExpr 0 e1 . showString "]"
-    '[':cs -> showString "[" . showsPrecExpr 0 e1 . showString "," . showString cs
-    cs -> showParen (d > prec ":")
-        $ showsOpExpr ":" e1 . showString ":" . showString cs
+showsPrecExpr d e@(Value ":" _ :$ _ :$ _) =
+  case unfoldEnd e of
+  (es,Value "[]" _) -> showString "["
+                     . foldr (.) id (intersperse (showString ",") [showsPrecExpr 0 e | e <- es])
+                     . showString "]"
+  (es,Value ('[':cs) _) -> showString "["
+                         . foldr (.) id (intersperse (showString ",") [showsPrecExpr 0 e | e <- es])
+                         . showString (',':cs)
+  (es,Value "\"\"" _)
+    | hasConstTail es -> let (cs,etc) = span isConst (reverse es)
+                         in showParen (not (null etc) && d > prec ":")
+                          $ foldr (.) id (intersperse (showString ":") $ [showsOpExpr ":" e | e <- reverse etc])
+                          . showString [':' | not (null etc)]
+                          . showString "\""
+                          . foldr (.) id [showString . init . tail $ s | Value s _ <- reverse cs]
+                          . showString "\""
+  (es,end) -> showParen (d > prec ":")
+            $ foldr (.) id (intersperse (showString ":") $ [showsOpExpr ":" e | e <- es++[end]])
+  where
+  hasConstTail  =  not . null . takeWhile isConst . reverse
 showsPrecExpr d ee | isTuple ee = showParen True
                                 $ foldr1 (\s1 s2 -> s1 . showString "," . s2)
                                          (showsPrecExpr 0 `map` unfoldTuple ee)
@@ -528,20 +536,6 @@ dotdot :: Expr -> Bool
 dotdot (Value (c:_) _)  =  isNumber c || isLower c || c == '_' || c == '\''
 dotdot _  =  False
 
--- bad smell here, repeated code!
-showsTailExpr :: Expr -> String -> String
-showsTailExpr (Value ":" _ :$ e1 :$ e2)
-  | isConst e1 && mtyp e1 == Just (typeOf (undefined :: Char)) =
-  case showsPrecExpr 0 e2 "" of
-    '\"':cs  -> showString ("\"" ++ (init . tail) (showsPrecExpr 0 e1 "") ++ cs)
-    cs -> showsOpExpr ":" e1 . showString ":" . showsTailExpr e2
-showsTailExpr (Value ":" _ :$ e1 :$ e2) =
-  case showsPrecExpr 0 e2 "" of
-    "[]" -> showString "[" . showsPrecExpr 0 e1 . showString "]"
-    '[':cs -> showString "[" . showsPrecExpr 0 e1 . showString "," . showString cs
-    cs -> showsOpExpr ":" e1 . showString ":" . showsTailExpr e2
-showsTailExpr e = showsOpExpr ":" e
-
 showsOpExpr :: String -> Expr -> String -> String
 showsOpExpr op = showsPrecExpr (prec op + 1)
 
@@ -752,6 +746,22 @@ unfoldTuple = u . unfoldApp
   u (Value cs _:es) | not (null es) && cs == replicate (length es - 1) ',' = es
   u _   = []
 
+-- | /O(n)/.
+-- Unfold a list 'Expr' into a list of values and a terminator.
+--
+-- This works for lists "terminated" by an arbitrary expression.
+-- One can later check the second value of the return tuple
+-- to see if it is a proper list or string by comparing the
+-- string representation with @[]@ or @""@.
+--
+-- This is used in the implementation of 'showsPrecExpr'.
+unfoldEnd :: Expr -> ([Expr],Expr)
+unfoldEnd (Value ":"  _ :$ e :$ es)  =  (e:) `first` unfoldEnd es
+                                        where  first f (x,y)  =  (f x, y)
+unfoldEnd e                          =  ([],e)
+
+-- | /O(1)/.
+-- Checks if a given expression is a tuple.
 isTuple :: Expr -> Bool
 isTuple = not . null . unfoldTuple
 

test/show.hs

@@ -43,8 +43,8 @@ tests n =
   , show (space -:- emptyString) == "\" \" :: [Char]"
   , show (space -:- ccs)         == "' ':cs :: [Char]"
   , show (ae -:- bee -:- emptyString) == "\"ab\" :: [Char]"
-  , show (ae -:- bee -:- nilChar) == "'a':'b':[] :: [Char]" -- TODO: change to ['a','b']
-  , show (ae -:- cc -:- nilChar) == "'a':[c] :: [Char]" -- TODO: change to ['a',c]
+  , show (ae -:- bee -:- nilChar) == "['a','b'] :: [Char]"
+  , show (ae -:- cc -:- nilChar) == "['a',c] :: [Char]"
   , show (ae -:- bee -:- ccs)         == "'a':'b':cs :: [Char]"
   , show (ae -:- space -:- bee -:- lineBreak -:- emptyString) == "\"a b\\n\" :: [Char]"
   , show (cc -:- space -:- dd -:- lineBreak -:- emptyString)  == "c:' ':d:\"\\n\" :: [Char]"
@@ -151,10 +151,10 @@ tests n =
   , show (value "id" (id :: [A] -> [A]) :$ var "xs" (undefined :: [A])) == "id xs :: [A]"
 
   , show (xx -:- nil -++- is_) == "x:([] ++ _) :: [Int]"
---, show (xx -:- yy -:- nil -++- is_) == "x:y:([] ++ _) :: [Int]" -- TODO: FIXME: failing test!
+  , show (xx -:- yy -:- nil -++- is_) == "x:y:([] ++ _) :: [Int]"
 
   , show (cc -:- emptyString -++- cs_) == "c:(\"\" ++ _) :: [Char]"
   , show (cc -:- dd -:- emptyString -++- cs_) == "c:d:(\"\" ++ _) :: [Char]"
---, show (ae -:- bee -:- emptyString -++- cs_) == "'a':'b':(\"\" ++ _) :: [Char]" -- TODO: FIXME: failing test!
+  , show (ae -:- bee -:- emptyString -++- cs_) == "'a':'b':(\"\" ++ _) :: [Char]"
 
   ]