fmt-signature: fix wrapping for indented continued lines

Author: elaforge

TODO

@@ -9,7 +9,15 @@ fmt-signature
     . Break input into lines without comments and wrap each section
       separately.  The only wrinkle is that only the first line of the first
       section isn't indented.
+  - wrap inside ()s
+    . I want one indent per (, and to wrap at the lowest indent.
+    . This is what Util.Format does, so maybe I should try to extract and use
+      it.
+    . But it has bugs.  Or can I do a simpler one?  Or maybe the bugs are just
+      in Util.Format?
   - configure indentation
+  - format non-toplevel declarations
+    . I think I just need to preserve leading indent.
   - can I get vim to expand the selection to the whole signature?
 
 
@@ -33,6 +41,28 @@ string-literal
         \ blah"
       , ...
       )
+  - How can I support embedded operators?  E.g.
+    . "blah blah "
+      <> x <> "blah\
+      \ blah"
+      =>
+      blah blah
+      <> x <> blah
+      blah
+
+    . "blah" <> blah
+      <> "e..."
+    . For stripping, I can just not strip if it's not a \.  But once I strip,
+      it becomes ambiguous.
+    . I could try to make it non-ambiguous, by replacing quotes with some
+      magic symbol.
+    . Hm, I could even remember wrapped or not by using a different symbol.
+    . It should be typeable, because I want to write these inline:
+      . •blah blah
+        blah blah•
+        <> x <> •blah blah
+        blah•
+
   - Also I could ignore non-indented leading lines, e.g.
       variable =
         "blah blah"

src/FmtSignature.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+-- | Format type signature declarations.
 module FmtSignature where
 import Control.Applicative ((<|>))
 import qualified Control.Arrow as Arrow
@@ -22,34 +24,14 @@ main = do
     args <- System.Environment.getArgs
     case args of
         [width] | Just width <- Read.readMaybe width ->
-            interact $ \s -> maybe s id (fmt indent width s)
+            interact $ \s -> maybe s id (fmt width s)
         _ -> IO.hPutStrLn IO.stderr usage >> System.Exit.exitFailure
 
-Just t0 = parse "a -> b"
-Just t1 = parse "a => (bb->c)"
+indentSpaces :: Int
+indentSpaces = 4
 
-indent :: String
-indent = "    "
-
-{-
-forall y z. X y => A -> IO z
-
-(a -> b) -> c
-
-leave lines with comments on them alone.  What about
-a -> (b -- hi
--> c)
-
--}
-
-fmt :: String -> Int -> String -> Maybe String
-fmt indent width =
-    fmap (List.intercalate "\n" . indented . wrap (width - length indent)
-        . toWords)
-    . parse
-    where
-    indented (x : xs) = x : map (indent++) xs
-    indented [] = []
+fmt :: Int -> String -> Maybe String
+fmt width = fmap (List.intercalate "\n" . wrap width . toWords) . parse
 
 toWords :: [Parsed] -> [String]
 toWords = map (strip . concat) . splitWith (`elem` ["->", "=>"]) . map unparse
@@ -59,13 +41,26 @@ toWords = map (strip . concat) . splitWith (`elem` ["->", "=>"]) . map unparse
 -- In fact, this is basically just Util.Format, so I should use that, after
 -- I extract it.
 wrap :: Int -> [String] -> [String]
-wrap width = map unwords . split
+wrap width = mapTail (indent<>) . go (width : repeat (width - indentSpaces))
+    where
+    indent = replicate indentSpaces ' '
+    go (width : widths) words
+        | null pre = []
+        | otherwise = unwords pre : go widths post
+        where (pre, post) = wrap1 width words
+    go [] _ = [] -- unreachable, widths is infinite
+
+mapTail :: (a -> a) -> [a] -> [a]
+mapTail f (x : xs) = x : map f xs
+mapTail _ [] = []
+
+wrap1 :: Int -> [String] -> ([String], [String])
+wrap1 width words
+    | null words = ([], [])
+    | null pre = (take 1 post, drop 1 post)
+    | otherwise = (pre, post)
     where
-    split words
-        | null words = []
-        | null pre = take 1 post : split (drop 1 post)
-        | otherwise = pre : split post
-        where (pre, post) = breakAccum (>width) accum (-1) words
+    (pre, post) = breakAccum (>width) accum (-1) words
     accum w word = w + 1 + length word
 
 -- * parse

src/FmtSignature_test.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts #-}
-import Data.Monoid ((<>))
 import qualified GHC.Stack as Stack
 import qualified Test.Tasty as Tasty
 import qualified Test.Tasty.HUnit as HUnit
@@ -9,8 +8,8 @@ import qualified FmtSignature
 
 
 main :: IO ()
-main = Tasty.defaultMain $ Tasty.testGroup "tests"
-    [ test_fmt
+main = run $ Tasty.testGroup "tests"
+    [ test_fmt, test_wrap
     ]
 
 run :: Tasty.TestTree -> IO ()
@@ -19,16 +18,26 @@ run = Tasty.defaultMain
 test_fmt :: Tasty.TestTree
 test_fmt = Tasty.testGroup "fmt"
     [ "a -> b" ==> Just "a -> b"
-    , "aaa -> bbb -> ccc" ==> Just "aaa -> bbb\n____-> ccc"
-    , "aaa -> () -> bbb" ==> Just "aaa -> ()\n____-> bbb"
-    , "a -> b -> c -> d" ==> Just "a -> b\n____-> c\n____-> d"
-    -- , "a -> b -> c -> d"
+    , "abc1234567890 -> a" ==> Just "abc1234567890\n    -> a"
+    , "aaa -> bbb -> ccc" ==> Just "aaa -> bbb\n    -> ccc"
+    , "aaa -> () -> bbb" ==> Just "aaa -> ()\n    -> bbb"
+    , "a -> b -> c -> d" ==> Just "a -> b -> c\n    -> d"
+    -- ()s don't break
+    , "a -> (b -> c) -> d" ==> Just "a\n    -> (b -> c)\n    -> d"
     ]
     where
-    f = FmtSignature.fmt "____" 12
+    f = FmtSignature.fmt 12
     (==>) :: Stack.HasCallStack => String -> Maybe String -> Tasty.TestTree
     (==>) = test f
 
+test_wrap :: Tasty.TestTree
+test_wrap = Tasty.testGroup "wrap"
+    [ ["aaa", "-> bbb", "-> ccc"] ==> ["aaa -> bbb", "    -> ccc"]
+    ]
+    where
+    (==>) :: Stack.HasCallStack => [String] -> [String] -> Tasty.TestTree
+    (==>) = test (FmtSignature.wrap 12)
+
 test :: (Stack.HasCallStack, Show a, Eq b, Show b) => (a -> b) -> a -> b
     -> Tasty.TestTree
 test f x expected = HUnit.testCase (take 70 $ show x) $ f x HUnit.@?= expected

src/StringLiteral.hs

@@ -22,8 +22,7 @@ usage =
     "string-literal [ --wrapped --{add,remove,toggle}-{backslash,lines} ]\n\
     \\n\
     \Convert between plain text and either backslash-continued string\n\
-    \literals, or list of lines style strings.  This is to work around\n\
-    \haskell's lack of multi-line string literals.  Bind the toggle variant\n\
+    \literals, or list of lines style strings.  Bind the toggle variant\n\
     \to a vim key to switch between raw text and haskell string literal.\n\
     \\n\
     \It assumes a single level of indent for the strings, and leaves the\n\
@@ -40,8 +39,8 @@ usage =
     \preserve your own leading spaces.  If you are doing explicit formatting\n\
     \then don't use --wrapped.\n\
     \\n\
-    \Standard CPP doesn't like Haskell string-gap syntax.  You can either use\n\
-    \cpphs via -pgmP 'cpphs --cpp', or use lines mode, which is more\n\
+    \Standard CPP doesn't like Haskell string-gap syntax.  You can either\n\
+    \use cpphs via -pgmP 'cpphs --cpp', or use lines mode, which is more\n\
     \cluttered but doesn't make CPP mad.  Presumably you have a unlines or\n\
     \Text.unlines call at the front of the list.\n"