|
| 1 | +{-# LANGUAGE OverloadedStrings #-} |
| 2 | +module FmtSignature where |
| 3 | +import Control.Applicative ((<|>)) |
| 4 | +import qualified Control.Arrow as Arrow |
| 5 | +import qualified Data.Char as Char |
| 6 | +import qualified Data.List as List |
| 7 | +import qualified System.Environment |
| 8 | +import qualified System.Exit |
| 9 | +import qualified System.IO as IO |
| 10 | + |
| 11 | +import qualified Text.ParserCombinators.ReadP as ReadP |
| 12 | +import Text.ParserCombinators.ReadP (ReadP) |
| 13 | +import Text.ParserCombinators.ReadP ((<++)) |
| 14 | +import qualified Text.Read as Read |
| 15 | + |
| 16 | + |
| 17 | +usage :: String |
| 18 | +usage = "fmt-signature width" |
| 19 | + |
| 20 | +main :: IO () |
| 21 | +main = do |
| 22 | + args <- System.Environment.getArgs |
| 23 | + case args of |
| 24 | + [width] | Just width <- Read.readMaybe width -> |
| 25 | + interact $ \s -> maybe s id (fmt indent width s) |
| 26 | + _ -> IO.hPutStrLn IO.stderr usage >> System.Exit.exitFailure |
| 27 | + |
| 28 | +Just t0 = parse "a -> b" |
| 29 | +Just t1 = parse "a => (bb->c)" |
| 30 | + |
| 31 | +indent :: String |
| 32 | +indent = " " |
| 33 | + |
| 34 | +{- |
| 35 | +forall y z. X y => A -> IO z |
| 36 | +
|
| 37 | +(a -> b) -> c |
| 38 | +
|
| 39 | +leave lines with comments on them alone. What about |
| 40 | +a -> (b -- hi |
| 41 | +-> c) |
| 42 | +
|
| 43 | +-} |
| 44 | + |
| 45 | +fmt :: String -> Int -> String -> Maybe String |
| 46 | +fmt indent width = |
| 47 | + fmap (List.intercalate "\n" . indented . wrap (width - length indent) |
| 48 | + . toWords) |
| 49 | + . parse |
| 50 | + where |
| 51 | + indented (x : xs) = x : map (indent++) xs |
| 52 | + indented [] = [] |
| 53 | + |
| 54 | +toWords :: [Parsed] -> [String] |
| 55 | +toWords = map (strip . concat) . splitWith (`elem` ["->", "=>"]) . map unparse |
| 56 | + |
| 57 | +-- | I treat a Parens as a single word and don't wrap it. In the future |
| 58 | +-- I should wrap in there if necessary, but with an extra indent. |
| 59 | +-- In fact, this is basically just Util.Format, so I should use that, after |
| 60 | +-- I extract it. |
| 61 | +wrap :: Int -> [String] -> [String] |
| 62 | +wrap width = map unwords . split |
| 63 | + where |
| 64 | + split words |
| 65 | + | null words = [] |
| 66 | + | null pre = take 1 post : split (drop 1 post) |
| 67 | + | otherwise = pre : split post |
| 68 | + where (pre, post) = breakAccum (>width) accum (-1) words |
| 69 | + accum w word = w + 1 + length word |
| 70 | + |
| 71 | +-- * parse |
| 72 | + |
| 73 | +-- | Parse type signature into a minimal form needed for typechecking. |
| 74 | +-- |
| 75 | +-- This still seems like way overkill, but it still seemed like the simplest |
| 76 | +-- way make sure parens are balanced accurately. |
| 77 | +data Parsed = Word !String | Arrow !String | Parens ![Parsed] |
| 78 | + deriving (Show) |
| 79 | + |
| 80 | +unparse :: Parsed -> String |
| 81 | +unparse (Word s) = s |
| 82 | +unparse (Arrow s) = s |
| 83 | +unparse (Parens ps) = "(" ++ concatMap unparse ps ++ ")" |
| 84 | + |
| 85 | +parse :: String -> Maybe [Parsed] |
| 86 | +parse = fmap collect . run (ReadP.many tokenP) |
| 87 | + |
| 88 | +-- It's not like ReadP is great, but it works and is in base. |
| 89 | +run :: ReadP a -> String -> Maybe a |
| 90 | +run p s = case ReadP.readP_to_S (p <* ReadP.eof) s of |
| 91 | + (a, "") : _ -> Just a |
| 92 | + _ -> Nothing |
| 93 | + |
| 94 | +collect :: [Parsed] -> [Parsed] |
| 95 | +collect (p:ps) = case p of |
| 96 | + Word c -> Word (concat (c:pre)) : collect post |
| 97 | + where (pre, post) = spanWhile isWord ps |
| 98 | + Parens subs -> Parens (collect subs) : collect ps |
| 99 | + _ -> p : collect ps |
| 100 | + where |
| 101 | + isWord (Word c) = Just c |
| 102 | + isWord _ = Nothing |
| 103 | +collect [] = [] |
| 104 | + |
| 105 | +tokenP :: ReadP Parsed |
| 106 | +tokenP = parensP <++ arrowP <++ wordP |
| 107 | + |
| 108 | +arrowP :: ReadP Parsed |
| 109 | +arrowP = Arrow <$> (ReadP.string "->" <|> ReadP.string "=>") |
| 110 | + |
| 111 | +wordP :: ReadP Parsed |
| 112 | +wordP = Word . (:[]) <$> (ReadP.satisfy (const True)) |
| 113 | + |
| 114 | +parensP :: ReadP Parsed |
| 115 | +parensP = ReadP.char '(' *> (Parens <$> ReadP.many tokenP) <* ReadP.char ')' |
| 116 | + |
| 117 | + |
| 118 | +-- * util |
| 119 | + |
| 120 | +-- More copy paste from my library. I should put it on hackage. |
| 121 | + |
| 122 | +strip :: String -> String |
| 123 | +strip = reverse . dropWhile Char.isSpace . reverse . dropWhile Char.isSpace |
| 124 | + |
| 125 | +-- | Like 'span', but it can transform the spanned sublist. |
| 126 | +spanWhile :: (a -> Maybe b) -> [a] -> ([b], [a]) |
| 127 | +spanWhile f = go |
| 128 | + where |
| 129 | + go [] = ([], []) |
| 130 | + go (a:as) = case f a of |
| 131 | + Just b -> Arrow.first (b:) (go as) |
| 132 | + Nothing -> ([], a : as) |
| 133 | + |
| 134 | +splitWith :: (a -> Bool) -> [a] -> [[a]] |
| 135 | + -- ^ output is non-null, and the contents are also, except the first one |
| 136 | +splitWith f xs = map reverse (go f xs []) |
| 137 | + where |
| 138 | + go _ [] collect = [collect] |
| 139 | + go f (x:xs) collect |
| 140 | + | f x = collect : go f xs [x] |
| 141 | + | otherwise = go f xs (x:collect) |
| 142 | + |
| 143 | +breakAccum :: (state -> Bool) -> (state -> a -> state) -> state -> [a] |
| 144 | + -> ([a], [a]) |
| 145 | +breakAccum done accum = go |
| 146 | + where |
| 147 | + go _ [] = ([], []) |
| 148 | + go state (x:xs) |
| 149 | + | done state2 = ([], x : xs) |
| 150 | + | otherwise = Arrow.first (x:) (go state2 xs) |
| 151 | + where |
| 152 | + state2 = accum state x |
0 commit comments