Utrecht wrapping (WIP)

haskell · Nov 20, 2012 · 80cba59 · 80cba59
1 parent 9ce6434
commit 80cba59
Show file tree

Hide file tree

Showing 8 changed files with 143 additions and 67 deletions.
diff --git a/data/stylish-haskell.yaml b/data/stylish-haskell.yaml
@@ -64,6 +64,15 @@ steps:
 # to. Different steps take this into account. Default: 80.
 columns: 80
 
+# How most things are wrapped.
+#
+# - regular: Default style, trailing commas
+#
+# - utrecht: Leading commas
+#
+# Default: regular.
+wrap_style: regular
+
 # Sometimes, language extensions are specified in a cabal file or from the
 # command line instead of using language pragmas in the file. stylish-haskell
 # needs to be aware of these, so it can parse the file correctly.

diff --git a/src/Language/Haskell/Stylish.hs b/src/Language/Haskell/Stylish.hs
@@ -10,6 +10,7 @@ module Language.Haskell.Stylish
     , trailingWhitespace
     , unicodeSyntax
       -- ** Data types
+    , WrapStyle (..)
     , Imports.Align (..)
     , LanguagePragmas.Style (..)
       -- ** Helpers
@@ -34,6 +35,7 @@ import Language.Haskell.Stylish.Config
 import Language.Haskell.Stylish.Step
 import Language.Haskell.Stylish.Verbose
 import Language.Haskell.Stylish.Parse
+import Language.Haskell.Stylish.Wrap
 import Paths_stylish_haskell  (version)
 import qualified Language.Haskell.Stylish.Step.Imports as Imports
 import qualified Language.Haskell.Stylish.Step.LanguagePragmas as LanguagePragmas
@@ -44,14 +46,16 @@ import qualified Language.Haskell.Stylish.Step.UnicodeSyntax as UnicodeSyntax
 
 
 --------------------------------------------------------------------------------
-imports :: Int -- ^ columns
+imports :: WrapStyle
+        -> Int -- ^ columns
         -> Imports.Align
         -> Step
 imports = Imports.step
 
 
 --------------------------------------------------------------------------------
-languagePragmas :: Int -- ^ columns
+languagePragmas :: WrapStyle
+                -> Int -- ^ columns
                 -> LanguagePragmas.Style
                 -> Bool -- ^ remove redundant?
                 -> Step

diff --git a/src/Language/Haskell/Stylish/Config.hs b/src/Language/Haskell/Stylish/Config.hs
@@ -35,6 +35,7 @@ import qualified Language.Haskell.Stylish.Step.Tabs               as Tabs
 import qualified Language.Haskell.Stylish.Step.TrailingWhitespace as TrailingWhitespace
 import qualified Language.Haskell.Stylish.Step.UnicodeSyntax      as UnicodeSyntax
 import           Language.Haskell.Stylish.Verbose
+import           Language.Haskell.Stylish.Wrap
 
 
 --------------------------------------------------------------------------------
@@ -45,6 +46,7 @@ type Extensions = [String]
 data Config = Config
     { configSteps              :: [Step]
     , configColumns            :: Int
+    , configWrapStyle          :: WrapStyle
     , configLanguageExtensions :: [String]
     }
 
@@ -56,7 +58,7 @@ instance FromJSON Config where
 
 --------------------------------------------------------------------------------
 emptyConfig :: Config
-emptyConfig = Config [] 80 []
+emptyConfig = Config [] 80 Regular []
 
 
 --------------------------------------------------------------------------------
@@ -116,12 +118,19 @@ parseConfig (A.Object o) = do
     -- First load the config without the actual steps
     config <- Config
         <$> pure []
-        <*> (o A..:? "columns"             A..!= 80)
+        <*> (o A..:? "columns" A..!= 80)
+        <*> (o A..:? "wrap_style" >>= parseEnum wrapStyles Regular)
         <*> (o A..:? "language_extensions" A..!= [])
 
     -- Then fill in the steps based on the partial config we already have
     steps <- (o A..:  "steps" >>= fmap concat . mapM (parseSteps config))
     return config {configSteps = steps}
+  where
+    wrapStyles =
+        [ ("regular", Regular)
+        , ("utrecht", Utrecht)
+        ]
+
 parseConfig _            = mzero
 
 
@@ -159,7 +168,8 @@ parseEnum strs _   (Just k) = case lookup k strs of
 --------------------------------------------------------------------------------
 parseImports :: Config -> A.Object -> A.Parser Step
 parseImports config o = Imports.step
-    <$> pure (configColumns config)
+    <$> pure (configWrapStyle config)
+    <*> pure (configColumns config)
     <*> (o A..:? "align" >>= parseEnum aligns Imports.Global)
   where
     aligns =
@@ -173,7 +183,8 @@ parseImports config o = Imports.step
 --------------------------------------------------------------------------------
 parseLanguagePragmas :: Config -> A.Object -> A.Parser Step
 parseLanguagePragmas config o = LanguagePragmas.step
-    <$> pure (configColumns config)
+    <$> pure (configWrapStyle config)
+    <*> pure (configColumns config)
     <*> (o A..:? "style" >>= parseEnum styles LanguagePragmas.Vertical)
     <*> o A..:? "remove_redundant" A..!= True
   where

diff --git a/src/Language/Haskell/Stylish/Step/Imports.hs b/src/Language/Haskell/Stylish/Step/Imports.hs
@@ -111,16 +111,17 @@ prettyImportSpec x                      = H.prettyPrint x
 
 
 --------------------------------------------------------------------------------
-prettyImport :: Int -> Bool -> Bool -> Int -> H.ImportDecl l -> [String]
-prettyImport columns padQualified padName longest imp =
-    regularWrap columns (length base + 2) $
+prettyImport :: WrapStyle -> Int -> Bool -> Bool -> Int -> H.ImportDecl l
+             -> [String]
+prettyImport wrapStyle columns padQualified padName longest imp =
+    wrapWith wrapStyle columns $
         case importSpecs of
-            Nothing -> [Open base]                     -- Import everything
-            Just [] -> [Open base, Space, Close "()"]  -- Instance only imports
+            Nothing -> [String base]                      -- Import everything
+            Just [] -> [String base, Space, String "()"]  -- Instance only
             Just is ->
-                [Open base, Space, String "("] ++
+                [String (base ++ " (")] ++
                 intersperse Comma (map (String . prettyImportSpec) is) ++
-                [Close ")"]
+                [String ")"]
   where
     base = unwords $ concat
          [ ["import"]
@@ -145,10 +146,10 @@ prettyImport columns padQualified padName longest imp =
 
 
 --------------------------------------------------------------------------------
-prettyImportGroup :: Int -> Align -> Bool -> Int -> [H.ImportDecl LineBlock]
-                  -> Lines
-prettyImportGroup columns align fileAlign longest imps =
-    concatMap (prettyImport columns padQual padName longest') $
+prettyImportGroup :: WrapStyle -> Int -> Align -> Bool -> Int
+                  -> [H.ImportDecl LineBlock] -> Lines
+prettyImportGroup wrapStyle columns align fileAlign longest imps =
+    concatMap (prettyImport wrapStyle columns padQual padName longest') $
     sortBy compareImports imps
   where
     longest' = case align of
@@ -165,15 +166,15 @@ prettyImportGroup columns align fileAlign longest imps =
 
 
 --------------------------------------------------------------------------------
-step :: Int -> Align -> Step
-step columns = makeStep "Imports" . step' columns
+step :: WrapStyle -> Int -> Align -> Step
+step wrapStyle columns = makeStep "Imports" . step' wrapStyle columns
 
 
 --------------------------------------------------------------------------------
-step' :: Int -> Align -> Lines -> Module -> Lines
-step' columns align ls (module', _) = flip applyChanges ls
+step' :: WrapStyle -> Int -> Align -> Lines -> Module -> Lines
+step' wrapStyle columns align ls (module', _) = flip applyChanges ls
     [ change block $ const $
-        prettyImportGroup columns align fileAlign longest importGroup
+        prettyImportGroup wrapStyle columns align fileAlign longest importGroup
     | (block, importGroup) <- groups
     ]
   where

diff --git a/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs b/src/Language/Haskell/Stylish/Step/LanguagePragmas.hs
@@ -52,27 +52,28 @@ verticalPragmas pragmas' =
 
 
 --------------------------------------------------------------------------------
-compactPragmas :: Int -> [String] -> Lines
-compactPragmas columns pragmas' = regularWrap columns 13 $
-    [Open "{-# LANGUAGE"] ++
+compactPragmas :: WrapStyle -> Int -> [String] -> Lines
+compactPragmas wrapStyle columns pragmas' = wrapWith wrapStyle columns $
+    [String "{-# LANGUAGE", Space] ++
     intersperse Comma (map String pragmas') ++
-    [Space, Close "#-}"]
+    [Space, String "#-}"]
 
 
 --------------------------------------------------------------------------------
-prettyPragmas :: Int -> Style -> [String] -> Lines
-prettyPragmas _       Vertical = verticalPragmas
-prettyPragmas columns Compact  = compactPragmas columns
+prettyPragmas :: WrapStyle -> Int -> Style -> [String] -> Lines
+prettyPragmas _         _       Vertical = verticalPragmas
+prettyPragmas wrapStyle columns Compact  = compactPragmas wrapStyle columns
 
 
 --------------------------------------------------------------------------------
-step :: Int -> Style -> Bool -> Step
-step columns style = makeStep "LanguagePragmas" . step' columns style
+step :: WrapStyle -> Int -> Style -> Bool -> Step
+step wrapStyle columns style = makeStep "LanguagePragmas" .
+    step' wrapStyle columns style
 
 
 --------------------------------------------------------------------------------
-step' :: Int -> Style -> Bool -> Lines -> Module -> Lines
-step' columns style removeRedundant ls (module', _)
+step' :: WrapStyle -> Int -> Style -> Bool -> Lines -> Module -> Lines
+step' wrapStyle columns style removeRedundant ls (module', _)
     | null pragmas' = ls
     | otherwise     = applyChanges changes ls
   where
@@ -84,7 +85,8 @@ step' columns style removeRedundant ls (module', _)
     uniques  = filterRedundant $ nub $ sort $ snd =<< pragmas'
     loc      = firstLocation pragmas'
     deletes  = map (delete . fst) pragmas'
-    changes  = insert loc (prettyPragmas columns style uniques) : deletes
+    changes  =
+        insert loc (prettyPragmas wrapStyle columns style uniques) : deletes
 
 
 --------------------------------------------------------------------------------

diff --git a/src/Language/Haskell/Stylish/Wrap.hs b/src/Language/Haskell/Stylish/Wrap.hs
@@ -1,7 +1,10 @@
 --------------------------------------------------------------------------------
 module Language.Haskell.Stylish.Wrap
-    ( Wrap (..)
+    ( WrapStyle (..)
+    , Wrap (..)
+    , wrapWith
     , regularWrap
+    , utrechtWrap
     ) where
 
 
@@ -10,45 +13,88 @@ import           Language.Haskell.Stylish.Step
 import           Language.Haskell.Stylish.Util
 
 
+--------------------------------------------------------------------------------
+data WrapStyle
+    = Regular
+    | Utrecht
+    deriving (Show)
+
+
 --------------------------------------------------------------------------------
 data Wrap
-    = Open String
-    | Close String
-    | String String
+    = String String
     | Space
     | Comma
     deriving (Show)
 
 
+--------------------------------------------------------------------------------
+wrapWith :: WrapStyle  -- ^ Wrapping style to use
+         -> Int        -- ^ Maximum line width
+         -> [Wrap]     -- ^ Stuff to wrap
+         -> Lines      -- ^ Resulting lines
+wrapWith Regular = regularWrap
+wrapWith Utrecht = utrechtWrap
+
+
 --------------------------------------------------------------------------------
 regularWrap :: Int     -- ^ Maximum line width
-            -> Int     -- ^ Indentation
             -> [Wrap]  -- ^ Stuff to wrap
             -> Lines   -- ^ Resulting lines
-regularWrap maxWidth indentation wraps =
-    let (leading, strs) = regularJoin wraps
-    in wrap " " maxWidth indentation leading strs
+regularWrap maxWidth wraps =
+    let (leading : strs) = regularJoin wraps
+    in wrap " " maxWidth (length leading) leading strs
 
 
 --------------------------------------------------------------------------------
-regularJoin :: [Wrap] -> (String, [String])
-regularJoin wraps = case wraps of
-    (Open x : xs) -> (x, go xs)
-    _             -> error $ "Language.Haskell.Stylish.Wrap.regularJoin: " ++
-        "wrap spec should start with Open but got: " ++ show wraps
+regularJoin :: [Wrap] -> [String]
+regularJoin wraps = go wraps
   where
     go (String x : String y : xs) = go (String (x ++ y) : xs)
     go (String x : Comma : xs)    = (x ++ ",") : go xs
-    go (String x : Space : xs)    = x : go xs
-    go (String x : Close y : [])  = [x ++ y]
-    go (Close x : [])             = [x]
+    go (String x : xs)            = x : go xs
     go (Space : xs)               = go xs
     go []                         = []
     go ws                         = error $
         "Language.Haskell.Stylish.Wrap.regularJoin: go: " ++
         show ws ++ " is invalid, in: " ++ show wraps
 
 
+--------------------------------------------------------------------------------
+utrechtWrap :: Int      -- ^ Maximum line width
+            -> [Wrap]   -- ^ Stuff to wrap
+            -> Lines    -- ^ Resulting lines
+utrechtWrap maxWidth wraps =
+    -- If we can put everything on one line, we use regular wrapping
+    case regularWrap maxWidth wraps of
+        [line]                    -> [line]
+        xs
+            | length utrechts < 3 -> xs  -- Should not happen!
+            | otherwise           ->
+                let (leading : strs) = utrechts
+                in wrap "" maxWidth (length leading - 1)
+                    (leading ++ " ") (init strs) ++
+                    [replicate (length leading - 1) ' ' ++ last strs]
+  where
+    utrechts = utrechtJoin wraps
+
+
+--------------------------------------------------------------------------------
+utrechtJoin :: [Wrap] -> [String]
+utrechtJoin wraps = case wraps of
+    (String x : xs) -> x : go xs  -- Never join first string in utrecht style
+    _               -> go wraps   -- Should this ever happen?
+  where
+    go (Space : xs)               = go xs
+    go (String x : String y : xs) = go (String (x ++ y) : xs)
+    go (Comma : String x : xs)    = (", " ++ x ) : go xs
+    go (String x : xs)            = x : go xs
+    go []                         = []
+    go ws                         = error $
+        "Language.Haskell.Stylish.Wrap.regularJoin: go: " ++
+        show ws ++ " is invalid, in: " ++ show wraps
+
+
 --------------------------------------------------------------------------------
 wrap :: String    -- ^ Optional space string
      -> Int       -- ^ Maximum line width