Permalink
Browse files

Utrecht wrapping (WIP)

  • Loading branch information...
1 parent 9ce6434 commit 80cba59ab7905e567e0a82d86163098f459f9a83 @jaspervdj committed Nov 20, 2012
@@ -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.
@@ -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
@@ -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
@@ -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
@@ -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
--------------------------------------------------------------------------------
@@ -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
Oops, something went wrong.

0 comments on commit 80cba59

Please sign in to comment.