diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ $ cat path/to/sourcefile.hs | hindent > outfile.hs - hindent: arguments: --style [fundamental|chris-done|johan-tibell|gibiansky] + hindent: arguments: --style [fundamental|chris-done|johan-tibell|gibiansky|cramer] ## Emacs @@ -211,6 +211,23 @@ putStrLn "yay" return 1) bill -- Etc + where + potato Cakes{} = 2 * x foo * bar / 5 +``` + +### Enno Cramer + +``` haskell +foo = do + print "OK, go" + foo (foo bar) + (if bar then bob else pif) + (case mu {- cool -} zot of + Just x -> return () + Nothing -> do + putStrLn "yay" + return 1) + bill -- Etc where potato Cakes{} = 2 * x foo * bar / 5 ``` diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 4.6.1 +version: 4.6.2 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -41,7 +41,9 @@ HIndent.Styles.ChrisDone HIndent.Styles.JohanTibell HIndent.Styles.Gibiansky + HIndent.Styles.Cramer build-depends: base >= 4.7 && <5 + , containers , data-default , haskell-src-exts >= 1.17 , monad-loops @@ -83,3 +85,17 @@ , text , hspec , directory + +benchmark hindent-bench + type: exitcode-stdio-1.0 + hs-source-dirs: src/main + ghc-options: -Wall -O2 -rtsopts + main-is: Benchmark.hs + build-depends: base >= 4 && < 5 + , hindent + , text + , haskell-src-exts + , ghc-prim + , directory + , criterion + , deepseq diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -15,25 +15,32 @@ ,johanTibell ,fundamental ,gibiansky + ,cramer -- * Testing ,test ,testFile ,testAll ,testAst + ,defaultExtensions ) where import HIndent.Comments import HIndent.Pretty import HIndent.Styles.ChrisDone (chrisDone) +import HIndent.Styles.Cramer (cramer) import HIndent.Styles.Fundamental (fundamental) import HIndent.Styles.Gibiansky (gibiansky) import HIndent.Styles.JohanTibell (johanTibell) import HIndent.Types +import Control.Applicative ((<$>)) import Control.Monad.State.Strict import Control.Monad.Trans.Maybe +import Data.Function (on) import Data.Functor.Identity +import Data.List +import Data.List (groupBy, intersperse) import Data.Maybe (fromMaybe) import Data.Monoid import qualified Data.Text.IO as ST @@ -43,9 +50,6 @@ import qualified Data.Text.Lazy.Builder as T import qualified Data.Text.Lazy.IO as T import Language.Haskell.Exts.Annotated hiding (Style, prettyPrint, Pretty, style, parse) -import Data.Function (on) -import Data.List (groupBy, intersperse) -import Control.Applicative ((<$>)) data CodeBlock = HaskellSource Text | CPPDirectives Text @@ -228,4 +232,20 @@ -- | Styles list, useful for programmatically choosing. styles :: [Style] styles = - [fundamental,chrisDone,johanTibell,gibiansky] + [fundamental,chrisDone,johanTibell,gibiansky,cramer] + +-- | Default extensions. +defaultExtensions :: [Extension] +defaultExtensions = + [e | e@EnableExtension{} <- knownExtensions] \\ + map EnableExtension badExtensions + +-- | Extensions which steal too much syntax. +badExtensions :: [KnownExtension] +badExtensions = + [Arrows -- steals proc + ,TransformListComp -- steals the group keyword + ,XmlSyntax, RegularPatterns -- steals a-b + ,UnboxedTuples -- breaks (#) lens operator + -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break + ] diff --git a/src/HIndent/Comments.hs b/src/HIndent/Comments.hs --- a/src/HIndent/Comments.hs +++ b/src/HIndent/Comments.hs @@ -5,106 +5,114 @@ module HIndent.Comments where +import Control.Applicative ((<|>)) +import Control.Arrow (first, second) import Control.Monad.State.Strict import Data.Data -import Data.Function +import qualified Data.Map.Strict as M import Data.Traversable import HIndent.Types import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) +-- Order by start of span, larger spans before smaller spans. +newtype OrderByStart = + OrderByStart SrcSpan + deriving (Eq) + +instance Ord OrderByStart where + compare (OrderByStart l) (OrderByStart r) = + compare (srcSpanStartLine l) + (srcSpanStartLine r) `mappend` + compare (srcSpanStartColumn l) + (srcSpanStartColumn r) `mappend` + compare (srcSpanEndLine r) + (srcSpanEndLine l) `mappend` + compare (srcSpanEndColumn r) + (srcSpanEndColumn l) + +-- Order by end of span, smaller spans before larger spans. +newtype OrderByEnd = + OrderByEnd SrcSpan + deriving (Eq) + +instance Ord OrderByEnd where + compare (OrderByEnd l) (OrderByEnd r) = + compare (srcSpanEndLine l) + (srcSpanEndLine r) `mappend` + compare (srcSpanEndColumn l) + (srcSpanEndColumn r) `mappend` + compare (srcSpanStartLine r) + (srcSpanStartLine l) `mappend` + compare (srcSpanStartColumn r) + (srcSpanStartColumn l) + -- | Annotate the AST with comments. -annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast) +annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast,Show (ast NodeInfo)) => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) annotateComments src comments = - let - -- Make sure to process comments top to bottom. - reversed = reverse comments - - -- Replace source spans with node infos in the AST. - src' = fmap (\n -> NodeInfo n []) src - - -- Add all comments to the ast. - (cominfos, src'') = foldr processComment ([], src') reversed + evalState (do _ <- traverse assignComment comments + cis <- gets fst + ast <- traverse transferComments src + return (cis,ast)) + ([],nodeinfos) + where + nodeinfos :: M.Map SrcSpanInfo NodeInfo + nodeinfos = foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty src - in -- Reverse order of comments at each node. - (cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'') + -- Assign a single comment to the right AST node + assignComment :: Comment -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) () + assignComment comment@(Comment _ cspan _) = + -- Find the biggest AST node directly in front of this comment. + case nodeBefore comment of + -- Comments before any AST node are handled separately. + Nothing -> modify $ first $ (:) (ComInfo comment Nothing) - where processComment :: Comment - -> ([ComInfo],ast NodeInfo) - -> ([ComInfo],ast NodeInfo) - -- Add in a single comment to the ast. - processComment c@(Comment _ cspan _) (cs,ast) = - -- Try to find the node after which this comment lies. - case execState (traverse (collect After c) ast) Nothing of - -- When no node is found, the comment is on its own line. - Nothing -> (ComInfo c Nothing : cs, ast) + Just ssi -> + -- Comments on the same line as the AST node belong to this node. + if sameline (srcInfoSpan ssi) cspan + then insertComment After ssi + else do nodeinfo <- gets ((M.! ssi) . snd) + case nodeinfo of + -- We've already collected comments for this + -- node and this comment is a continuation. + NodeInfo _ ((ComInfo c' _):_) + | aligned c' comment -> insertComment After ssi - -- We found the node that this comment follows. - -- Check whether the node is on the same line. - Just (NodeInfo l coms) - -- If it's on a different line than the node, but the node has an - -- EOL comment, and the EOL comment and this comment are aligned, - -- attach this comment to the preceding node. - | ownLine && alignedWithPrevious -> insertedBefore + -- The comment does not belong to this node. + -- If there is a node following this comment, + -- assign it to that node, else keep it here, + -- anyway. + _ -> + case nodeAfter comment of + Nothing -> insertComment After ssi + Just ssi' -> insertComment Before ssi' + where + sameline :: SrcSpan -> SrcSpan -> Bool + sameline before after = srcSpanEndLine before == srcSpanStartLine after - -- If it's on a different line than the node, look for the following node to attach it to. - | ownLine -> - case execState (traverse (collect Before c) ast) Nothing of - -- If we don't find a node after the comment, leave it with the previous node. - Nothing -> insertedBefore - Just (NodeInfo node _) -> - (cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False) + aligned :: Comment -> Comment -> Bool + aligned (Comment _ before _) (Comment _ after _) = + srcSpanEndLine before == srcSpanStartLine after - 1 && + srcSpanStartColumn before == srcSpanStartColumn after - -- If it's on the same line, insert this comment into that node. - | otherwise -> insertedBefore - where - ownLine = srcSpanStartLine cspan /= srcSpanEndLine (srcInfoSpan l) - insertedBefore = (cs, evalState (traverse (insert l (ComInfo c $ Just After)) ast) False) - alignedWithPrevious - | null coms = False - | otherwise = case last coms of - -- Require single line comment after the node. - ComInfo (Comment False prevSpan _) (Just After) -> - srcSpanStartLine prevSpan == srcSpanStartLine cspan - 1 && - srcSpanStartColumn prevSpan == srcSpanStartColumn cspan - _ -> False + insertComment :: ComInfoLocation -> SrcSpanInfo -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) () + insertComment l ssi = modify $ second $ M.adjust (addComment (ComInfo comment (Just l))) ssi - -- For a comment, check whether the comment is after the node. - -- If it is, store it in the state; otherwise do nothing. - -- The location specifies where the comment should lie relative to the node. - collect :: ComInfoLocation -> Comment -> NodeInfo -> State (Maybe NodeInfo) NodeInfo - collect loc' c ni@(NodeInfo newL _) = - do when (commentLocated loc' ni c) - (modify (maybe (Just ni) - (\oldni@(NodeInfo oldL _) -> - Just (if (spanTest loc' `on` srcInfoSpan) oldL newL - then ni - else oldni)))) - return ni + addComment :: ComInfo -> NodeInfo -> NodeInfo + addComment x (NodeInfo s xs) = NodeInfo s (x : xs) - -- Insert the comment into the ast. Find the right node and add it to the - -- comments of that node. Do nothing afterwards. - insert :: SrcSpanInfo -> ComInfo -> NodeInfo -> State Bool NodeInfo - insert al c ni@(NodeInfo bl cs) = - do done <- get - if not done && al == bl - then do put True - return (ni {nodeInfoComments = c : cs}) - else return ni + -- Transfer collected comments into the AST. + transferComments :: SrcSpanInfo -> State ([ComInfo],M.Map SrcSpanInfo NodeInfo) NodeInfo + transferComments ssi = + do ni <- gets ((M.! ssi) . snd) + -- Sometimes, there are multiple AST nodes with the same + -- SrcSpan. Make sure we assign comments to only one of + -- them. + modify $ second $ M.adjust (\(NodeInfo s _) -> NodeInfo s []) ssi + return ni { nodeInfoComments = reverse $ nodeInfoComments ni } --- | Is the comment after the node? -commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool -commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) = - spanTest loc' n c + nodeBefore (Comment _ ss _) = fmap snd $ (OrderByEnd ss) `M.lookupLT` spansByEnd + nodeAfter (Comment _ ss _) = fmap snd $ (OrderByStart ss) `M.lookupGT` spansByStart --- | For @After@, does the first span end before the second starts? --- For @Before@, does the first span start after the second ends? -spanTest :: ComInfoLocation -> SrcSpan -> SrcSpan -> Bool -spanTest loc' first second = - (srcSpanStartLine after > srcSpanEndLine before) || - ((srcSpanStartLine after == srcSpanEndLine before) && - (srcSpanStartColumn after > srcSpanEndColumn before)) - where (before,after) = - case loc' of - After -> (first,second) - Before -> (second,first) + spansByStart = foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi) M.empty src + spansByEnd = foldr (\ssi -> M.insert (OrderByEnd $ srcInfoSpan ssi) ssi) M.empty src diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -284,7 +284,7 @@ maker st <- get col <- gets psColumn - if state' /= st + if psLine state' /= psLine st || psColumn state' /= psColumn st then column col dependent else dependent @@ -296,7 +296,7 @@ v <- maker st <- get col <- gets psColumn - if state' /= st + if psLine state' /= psLine st || psColumn state' /= psColumn st then column col (dependent v) else (dependent v) @@ -573,7 +573,7 @@ pretty right TyEquals _ left right -> do pretty left - write " == " + write " ~ " pretty right ty@TyPromoted{} -> pretty' ty TySplice{} -> error "FIXME: No implementation for TySplice." @@ -702,18 +702,13 @@ write " .. ") (pretty f))) exp (ListComp _ e qstmt) = - brackets (depend (do pretty e - unless (null qstmt) - (write " |")) - (do space - prefixedLined - "," - (map (\(i,x) -> - depend (if i == 0 - then return () - else space) - (pretty x)) - (zip [0 :: Integer ..] qstmt)))) + brackets (do pretty e + unless (null qstmt) + (do newline + indented (-1) + (write "|") + prefixedLined "," + (map pretty qstmt))) exp (ExpTypeSig _ e t) = depend (do pretty e write " :: ") @@ -1267,6 +1262,12 @@ write "'" string rep write "'#" + -- We print the original notation (because HSE doesn't track Hex + -- vs binary vs decimal notation). + prettyInternal (Int _l _i originalString) = + string originalString + prettyInternal (Frac _l _r originalString) = + string originalString prettyInternal x = pretty' x instance Pretty Name where diff --git a/src/HIndent/Styles/ChrisDone.hs b/src/HIndent/Styles/ChrisDone.hs --- a/src/HIndent/Styles/ChrisDone.hs +++ b/src/HIndent/Styles/ChrisDone.hs @@ -51,7 +51,8 @@ ,Extender rhs ,Extender contextualGuardedRhs ,Extender stmt - ,Extender decl] + ,Extender decl + ,Extender types] ,styleDefConfig = defaultConfig {configMaxColumns = 80 ,configIndentSpaces = 2} @@ -60,6 +61,22 @@ -------------------------------------------------------------------------------- -- Extenders +types :: Type NodeInfo -> Printer s () +types (TyTuple _ boxed tys) = + depend (write (case boxed of + Unboxed -> "(#" + Boxed -> "(")) + (do (fits,_) <- fitsOnOneLine p + if fits + then p + else prefixedLined "," + (map pretty tys) + write (case boxed of + Unboxed -> "#)" + Boxed -> ")")) + where p = commas (map pretty tys) +types e = prettyNoExt e + -- | Pretty print type signatures like -- -- foo :: (Show x,Read x) @@ -69,6 +86,15 @@ -- -> IO () -- decl :: Decl NodeInfo -> Printer s () +decl (TypeDecl _ head ty) = + do write "type " + pretty head + write " = " + (fits,st) <- fitsOnOneLine (pretty ty) + if fits + then put st + else do newline + indented 2 (pretty ty) decl (TypeSig _ names ty') = do (fitting,st) <- isSmallFitting dependent if fitting @@ -303,6 +329,27 @@ let overflow = psColumn st > columnLimit single = psLine st == line return (not overflow && single) +exp (ListComp _ e qstmt) = + brackets (do pretty e + unless (null qstmt) (do (ok,st) <- sandbox oneLiner + if ok + then put st + else lined)) + where oneLiner = do line <- gets psLine + write "|" + commas (map pretty qstmt) + st <- get + columnLimit <- getColumnLimit + let overflow = psColumn st > columnLimit + single = psLine st == line + return (not overflow && single) + lined = + do newline + indented (-1) + (write "|") + prefixedLined + "," + (map pretty qstmt) exp e = prettyNoExt e -------------------------------------------------------------------------------- diff --git a/src/HIndent/Styles/Cramer.hs b/src/HIndent/Styles/Cramer.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/Cramer.hs @@ -0,0 +1,888 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Enno Cramer's Style. + +module HIndent.Styles.Cramer (cramer) where + +import Control.Monad (forM_, replicateM_, unless, when) +import Control.Monad.State.Strict (MonadState, get, gets, put) + +import Data.List (intersperse, sortOn) +import Data.Maybe (catMaybes, isJust, mapMaybe) + +import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts.Comments +import Language.Haskell.Exts.SrcLoc +import Language.Haskell.Exts (prettyPrint) + +import HIndent.Pretty hiding (inter, spaced) +import HIndent.Types + +-- | Line breaking mode for syntactical constructs. +data LineBreak + = Free -- ^ Break whenever + | Single -- ^ Force single line (if possible) + | Multi -- ^ Force multiple lines + deriving (Eq,Enum,Show) + +-- | Printer state. +data State = + State {cramerLineBreak :: LineBreak -- ^ Current line breaking mode + ,cramerLangPragmaLength :: Int -- ^ Padding length for pragmas + ,cramerModuleImportLength :: Int -- ^ Padding length for module imports + ,cramerRecordFieldLength :: Int -- ^ Padding length for record fields + } + deriving (Show) + +-- | Syntax shortcut for Extenders. +type Extend f = f NodeInfo -> Printer State () + +-- | Style definition. +cramer :: Style +cramer = + Style {styleName = "cramer" + ,styleAuthor = "Enno Cramer" + ,styleDescription = "Enno Cramer's style" + ,styleInitialState = + State {cramerLineBreak = Free + ,cramerLangPragmaLength = 0 + ,cramerModuleImportLength = 0 + ,cramerRecordFieldLength = 0} + ,styleExtenders = + [Extender extModule + ,Extender extModulePragma + ,Extender extModuleHead + ,Extender extExportSpecList + ,Extender extImportDecl + ,Extender extDecl + ,Extender extDeclHead + ,Extender extConDecl + ,Extender extFieldDecl + ,Extender extDeriving + ,Extender extRhs + ,Extender extContext + ,Extender extType + ,Extender extPat + ,Extender extExp + ,Extender extStmt + ,Extender extMatch + ,Extender extBinds + ,Extender extFieldUpdate] + ,styleDefConfig = + defaultConfig {configMaxColumns = 80 + ,configIndentSpaces = 4 + ,configClearEmptyLines = True} + ,styleCommentPreprocessor = return} + +-------------------------------------------------------------------------------- +-- Helper + +-- | Return an ast node's SrcSpan. +nodeSrcSpan :: Annotated a => a NodeInfo -> SrcSpan +nodeSrcSpan = srcInfoSpan . nodeInfoSpan . ann + +-- | Turn a Name into a String +nameStr :: Name a -> String +nameStr (Ident _ s) = s +nameStr (Symbol _ s) = "(" ++ s ++ ")" + +-- | The difference between current column and indent level to force a +-- line break in reduceIndent. +maxDependOverhead :: Integral a => a +maxDependOverhead = 20 + +-- | Extract the name as a String from a ModuleName +moduleName :: ModuleName a -> String +moduleName (ModuleName _ s) = s + +-- | Extract the names of a ModulePragma +pragmaNames :: ModulePragma a -> [String] +pragmaNames (LanguagePragma _ names) = map nameStr names +pragmaNames _ = [] + +-- | Return whether a data type has only empty constructors. +isEnum :: Decl NodeInfo -> Bool +isEnum (DataDecl _ (DataType _) Nothing (DHead _ _) constructors _) = + all isSimple constructors + where isSimple (QualConDecl _ Nothing Nothing (ConDecl _ _ [])) = True + isSimple _ = False +isEnum _ = False + +-- | Return whether a data type has only zero or one constructor. +isSingletonType :: Decl NodeInfo -> Bool +isSingletonType (DataDecl _ _ Nothing (DHead _ _) [] _) = True +isSingletonType (DataDecl _ _ Nothing (DHead _ _) [ _ ] _) = True +isSingletonType _ = False + +-- | If the given String is smaller than the given length, pad on +-- right with spaces until the length matches. +padRight :: Int -> String -> String +padRight l s = take (max l (length s)) (s ++ repeat ' ') + +-- | Return comments with matching location. +filterComments :: Annotated a => (Maybe ComInfoLocation -> Bool) -> a NodeInfo -> [ComInfo] +filterComments f = filter (f . comInfoLocation) . nodeInfoComments . ann + +-- | Copy comments marked After from one AST node to another. +copyComments :: (Annotated ast1,Annotated ast2) + => ComInfoLocation + -> ast1 NodeInfo + -> ast2 NodeInfo + -> ast2 NodeInfo +copyComments loc from to = amap updateComments to + where updateComments info = info { nodeInfoComments = oldComments ++ newComments } + oldComments = filterComments (/= Just loc) to + newComments = filterComments (== Just loc) from + +-- | Return the number of line breaks between AST nodes. +lineDelta + :: (Annotated ast1,Annotated ast2) + => ast1 NodeInfo -> ast2 NodeInfo -> Int +lineDelta prev next = nextLine - prevLine + where prevLine = maximum (prevNodeLine : prevCommentLines) + nextLine = minimum (nextNodeLine : nextCommentLines) + prevNodeLine = srcSpanEndLine . nodeSrcSpan $ prev + nextNodeLine = srcSpanStartLine . nodeSrcSpan $ next + prevCommentLines = + map (srcSpanEndLine . commentSrcSpan) $ + filterComments (== Just After) prev + nextCommentLines = + map (srcSpanStartLine . commentSrcSpan) $ + filterComments (== Just Before) next + commentSrcSpan = annComment . comInfoComment + annComment (Comment _ sp _) = sp + +-- | Specialized forM_ for Maybe. +maybeM_ :: Monad m + => Maybe a -> (a -> m ()) -> m () +maybeM_ = forM_ + +-- | Simplified HIndent.Pretty.inter that does not modify the indent level. +inter :: MonadState (PrintState s) m + => m () -> [m ()] -> m () +inter sep = sequence_ . intersperse sep + +-- | Simplified HIndent.Pretty.spaced that does not modify the indent level. +spaced :: MonadState (PrintState s) m + => [m ()] -> m () +spaced = inter space + +-- | Indent one level. +indentFull :: MonadState (PrintState s) m + => m a -> m a +indentFull p = getIndentSpaces >>= flip indented p + +-- | Indent a half level. +indentHalf :: MonadState (PrintState s) m + => m a -> m a +indentHalf p = getIndentSpaces >>= flip indented p . (`div` 2) + +-- | Set indentation level to current column. +align :: MonadState (PrintState s) m + => m a -> m a +align p = + do col <- getColumn + indent <- gets psIndentLevel + column (max col indent) p + +-- | Update the line breaking mode and restore afterwards. +withLineBreak + :: LineBreak -> Printer State a -> Printer State a +withLineBreak lb p = + do old <- gets (cramerLineBreak . psUserState) + modifyState $ \s -> s {cramerLineBreak = lb} + result <- p + modifyState $ \s -> s {cramerLineBreak = old} + return result + +-- | Use the first printer if it fits on a single line within the +-- column limit, otherwise use the second. +attemptSingleLine + :: Printer State a -> Printer State a -> Printer State a +attemptSingleLine single multi = + do prevState <- get + case cramerLineBreak . psUserState $ prevState of + Single -> single + Multi -> multi + Free -> + do result <- withLineBreak Single single + col <- getColumn + row <- getLineNum + if row == psLine prevState && + col <= configMaxColumns (psConfig prevState) + then return result + else do put prevState + multi + +-- | Same as attemptSingleLine, but execute the second printer in Multi +-- mode. Used in type signatures to force either a single line or +-- have each `->` on a line by itself. +attemptSingleLineType + :: Printer State a -> Printer State a -> Printer State a +attemptSingleLineType single multi = + attemptSingleLine single + (withLineBreak Multi multi) + +-- | Format a list-like structure on a single line. +listSingleLine :: Pretty a + => String + -> String + -> String + -> [a NodeInfo] + -> Printer State () +listSingleLine open close _ [] = + do string open + space + string close +listSingleLine open close sep xs = + do string open + space + inter (string sep >> space) $ map pretty xs + space + string close + +-- | Format a list-like structure with each element on a line by +-- itself. +listMultiLine + :: Pretty a + => String -> String -> String -> [a NodeInfo] -> Printer State () +listMultiLine open close _ [] = + align $ + do string open + newline + string close +listMultiLine open close sep xs = + align $ + do string open + space + inter (newline >> string sep >> space) $ map pretty xs + newline + string close + +-- | Format a list-like structure on a single line, if possible, or +-- each element on a line by itself. +listAttemptSingleLine :: Pretty a + => String + -> String + -> String + -> [a NodeInfo] + -> Printer State () +listAttemptSingleLine open close sep xs = + attemptSingleLine (listSingleLine open close sep xs) + (listMultiLine open close sep xs) + +-- | Format a list-like structure, automatically breaking lines when +-- the next separator and item do not fit within the column limit. +listAutoWrap + :: Pretty a + => String -> String -> String -> [a NodeInfo] -> Printer State () +listAutoWrap open close sep ps = + align $ + do string open + unless (null ps) $ + do space + pretty $ head ps + forM_ (map (\p -> string sep >> space >> pretty p) + (tail ps)) $ + \p -> + do fits <- fitsColumnLimit p + unless fits newline + p + space + string close + where fitsColumnLimit p = + fmap fst . sandbox $ + do _ <- p + col <- getColumn + limit <- gets (configMaxColumns . psConfig) + return $ col < limit + +-- | Like `inter newline . map pretty`, but preserve empty lines +-- between elements. +preserveLineSpacing + :: (Pretty ast,Annotated ast) + => [ast NodeInfo] -> Printer State () +preserveLineSpacing [] = return () +preserveLineSpacing asts@(first:rest) = + do pretty first + forM_ (zip asts rest) $ + \(prev,cur) -> + do replicateM_ (max 1 $ lineDelta prev cur) + newline + pretty cur + +-- | `reduceIndent short long printer` produces either `short printer` +-- or `newline >> indentFull (long printer)`, depending on whether the +-- current column is sufficiently near to the current indentation depth. +-- +-- The function is used to avoid overly big dependent indentation by +-- heuristically breaking and non-dependently indenting. +reduceIndent :: (Printer State () -> Printer State ()) + -> (Printer State () -> Printer State ()) + -> Printer State () + -> Printer State () +reduceIndent short long printer = + do linebreak <- gets (cramerLineBreak . psUserState) + case linebreak of + Single -> single + Multi -> multi + Free -> + do curCol <- getColumn + curIndent <- gets psIndentLevel + indentSpaces <- gets (configIndentSpaces . psConfig) + if (curCol - curIndent - indentSpaces) < maxDependOverhead + then single + else multi + where single = short printer + multi = newline >> indentFull (long printer) + +-------------------------------------------------------------------------------- +-- Printer for reused syntactical constructs + +whereBinds :: Binds NodeInfo -> Printer State () +whereBinds binds = + do newline + indentHalf $ + do write "where" + newline + indentHalf $ pretty binds + +rhsExpr :: Exp NodeInfo -> Printer State () +-- No line break before do +rhsExpr expr@Do{} = + do space + rhsSeparator + space + pretty expr +rhsExpr expr = + do space + rhsSeparator + attemptSingleLine single multi + where single = space >> pretty expr + multi = reduceIndent (\p -> space >> p) id (pretty expr) + +guardedRhsExpr + :: GuardedRhs NodeInfo -> Printer State () +guardedRhsExpr (GuardedRhs _ guards expr) = + depend (write "| ") $ + do inter (write ", ") $ map pretty guards + rhsExpr expr + +-- | Pretty print a name for being an infix operator. +prettyInfixOp :: MonadState (PrintState s) m + => QName NodeInfo -> m () +prettyInfixOp op = + case op of + Qual{} -> + do write "`" + pretty' op + write "`" + UnQual _ n -> + case n of + Ident _ i -> string ("`" ++ i ++ "`") + Symbol _ s -> string s + Special _ s -> pretty s + +tupleExpr + :: Pretty ast + => Boxed -> [ast NodeInfo] -> Printer State () +tupleExpr boxed exprs = attemptSingleLine single multi + where single = + do string open + inter (write ", ") $ map pretty exprs + string close + multi = listMultiLine open close "," exprs + (open,close) = + case boxed of + Unboxed -> ("(#","#)") + Boxed -> ("(",")") + +listExpr :: Pretty ast + => [ast NodeInfo] -> Printer State () +listExpr [] = write "[]" +listExpr xs = listAttemptSingleLine "[" "]" "," xs + +recordExpr + :: (Pretty ast,Pretty ast') + => ast NodeInfo -> [ast' NodeInfo] -> Printer State () +recordExpr expr updates = + do pretty expr + space + listAttemptSingleLine "{" "}" "," updates + +ifExpr :: (Printer State () -> Printer State ()) + -> Exp NodeInfo + -> Exp NodeInfo + -> Exp NodeInfo + -> Printer State () +ifExpr indent cond true false = attemptSingleLine single multi + where single = spaced [if',then',else'] + multi = + align $ + do if' + indent $ + do newline + then' + newline + else' + if' = write "if " >> pretty cond + then' = write "then " >> pretty true + else' = write "else " >> pretty false + +letExpr + :: Binds NodeInfo -> Printer State () -> Printer State () +letExpr binds expr = + align $ + do depend (write "let ") $ pretty binds + newline + write "in" + expr + +infixExpr :: Exp NodeInfo -> Printer State () +-- No line break before do +infixExpr (InfixApp _ arg1 op arg2@Do{}) = + spaced [pretty arg1,pretty op,pretty arg2] +-- Try to preserve existing line break before and after infix ops +infixExpr (InfixApp _ arg1 op arg2) + | deltaBefore /= 0 && deltaAfter /= 0 = + align $ inter newline [pretty arg1,pretty op,pretty arg2] + | deltaBefore /= 0 || deltaAfter /= 0 = + pretty arg1 >> + spaceOrIndent + deltaBefore + (pretty op >> + spaceOrIndent deltaAfter + (pretty arg2)) + | otherwise = attemptSingleLine single multi + where single = spaced [pretty arg1,pretty op,pretty arg2] + multi = + do pretty arg1 + space + pretty op + newline + indentFull $ pretty arg2 + spaceOrIndent delta p = + if delta > 0 + then newline >> indentFull p + else space >> p + deltaBefore = lineDelta arg1 op + deltaAfter = lineDelta op arg2 +infixExpr _ = error "not an InfixApp" + +applicativeExpr :: Exp NodeInfo + -> [(QOp NodeInfo,Exp NodeInfo)] + -> Printer State () +applicativeExpr ctor args = attemptSingleLine single multi + where single = spaced (pretty ctor : map prettyArg args) + multi = + do pretty ctor + depend space $ inter newline $ map prettyArg args + prettyArg (op,arg) = pretty op >> space >> pretty arg + +typeSig :: Type NodeInfo -> Printer State () +typeSig ty = + attemptSingleLineType (write ":: " >> pretty ty) + (align $ write ":: " >> pretty ty) + +typeInfixExpr + :: Type NodeInfo -> Printer State () +-- As HIndent does not know about operator precedence, preserve +-- existing line breaks, but do not add new ones. +typeInfixExpr (TyInfix _ arg1 op arg2) + | deltaBefore /= 0 && deltaAfter /= 0 = + align $ inter newline [pretty arg1,prettyInfixOp op,pretty arg2] + | deltaBefore /= 0 || deltaAfter /= 0 = + pretty arg1 >> + spaceOrIndent + deltaBefore + (prettyInfixOp op >> + spaceOrIndent deltaAfter + (pretty arg2)) + | otherwise = spaced [pretty arg1,prettyInfixOp op,pretty arg2] + where spaceOrIndent delta p = + if delta > 0 + then newline >> indentFull p + else space >> p + deltaBefore = lineDelta arg1 op + deltaAfter = lineDelta op arg2 +typeInfixExpr _ = error "not a TyInfix" + +-------------------------------------------------------------------------------- +-- Extenders + +extModule :: Extend Module +extModule (Module _ mhead pragmas imports decls) = + do modifyState $ \s -> s {cramerLangPragmaLength = pragLen + ,cramerModuleImportLength = modLen} + inter (newline >> newline) $ + catMaybes [unless' (null pragmas) $ preserveLineSpacing pragmas + ,pretty <$> mhead + ,unless' (null imports) $ preserveLineSpacing imports + ,unless' (null decls) $ + do forM_ (init decls) $ + \decl -> + do pretty decl + newline + unless (skipNewline decl) newline + pretty (last decls)] + where pragLen = maximum $ map length $ concatMap pragmaNames pragmas + modLen = maximum $ map (length . moduleName . importModule) imports + unless' cond expr = + if not cond + then Just expr + else Nothing + skipNewline TypeSig{} = True + skipNewline _ = False +extModule other = prettyNoExt other + +-- Align closing braces of pragmas +extModulePragma :: Extend ModulePragma +extModulePragma (LanguagePragma _ names) = + do namelen <- gets (cramerLangPragmaLength . psUserState) + forM_ names $ + \name -> + do write "{-# LANGUAGE " + string $ padRight namelen $ nameStr name + write " #-}" +-- Avoid increasing whitespace after OPTIONS string +extModulePragma (OptionsPragma _ mtool opt) = + do write "{-# OPTIONS" + maybeM_ mtool $ \tool -> do write "_" + string $ prettyPrint tool + space + string $ trim opt + write " #-}" + where trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ') +extModulePragma other = prettyNoExt other + +-- Empty or single item export list on one line, otherwise one item +-- per line with parens and comma aligned +extModuleHead :: Extend ModuleHead +extModuleHead (ModuleHead _ name mwarn mexports) = + do mapM_ pretty mwarn + write "module " + pretty name + maybeM_ mexports $ \exports -> pretty exports + write " where" + +-- Align export list, one item per line +extExportSpecList :: Extend ExportSpecList +extExportSpecList (ExportSpecList _ exports) = + case exports of + [] -> write " ( )" + [e] + | not (hasComments e) -> write " ( " >> pretty e >> write " )" + (first:rest) -> + do newline + indentFull $ + do write "( " + commentCol <- getColumn + align $ prettyExportSpec "" commentCol first + forM_ rest $ + \export -> + do newline + prettyExportSpec ", " commentCol export + newline + write ")" + where hasComments = any (not . null . nodeInfoComments) + printCommentsSimple loc ast = + let rawComments = filterComments (== Just loc) ast + in do preprocessor <- gets psCommentPreprocessor + comments <- preprocessor $ map comInfoComment rawComments + forM_ comments $ + printComment (Just $ nodeSrcSpan ast) + prettyExportSpec prefix col spec = + do column col $ printCommentsSimple Before spec + string prefix + prettyNoExt spec + printCommentsSimple After spec + +-- Align import statements +extImportDecl :: Extend ImportDecl +extImportDecl ImportDecl{..} = + do if importQualified + then write "import qualified " + else write "import " + namelen <- gets (cramerModuleImportLength . psUserState) + if isJust importAs || isJust importSpecs + then string $ padRight namelen $ moduleName importModule + else string $ moduleName importModule + maybeM_ importAs $ + \name -> + do write " as " + pretty name + maybeM_ importSpecs $ + \(ImportSpecList _ importHiding specs) -> + do space + when importHiding $ write "hiding " + listAutoWrap "(" ")" "," $ sortOn prettyPrint specs + +extDecl :: Extend Decl +-- No dependent indentation for type decls +extDecl (TypeDecl _ declhead ty) = + do write "type " + pretty declhead + write " = " + indentFull $ pretty ty +-- Fix whitespace before 'where' in class decl +extDecl (ClassDecl _ mcontext declhead fundeps mdecls) = + do depend (write "class ") $ + depend (maybeCtx mcontext) $ + depend (pretty declhead) $ + depend (unless (null fundeps) $ + write " | " >> inter (write ", ") (map pretty fundeps)) $ + when (isJust mdecls) $ write " where" + maybeM_ mdecls $ + \decls -> + do newline + indentFull $ lined $ map pretty decls +-- Align data constructors +extDecl decl@(DataDecl _ dataOrNew mcontext declHead constructors mderiv) = + do mapM_ pretty mcontext + pretty dataOrNew + space + pretty declHead + write " =" + if isEnum decl || isSingletonType decl + then attemptSingleLine single multi + else multi + maybeM_ mderiv $ \deriv -> indentFull $ newline >> pretty deriv + where single = + do space + inter (write " | ") $ map pretty constructors + multi = + reduceIndent + (depend space . indented (-2)) + (\p -> write " " >> p) + (inter (newline >> write "| ") $ map pretty constructors) +-- Type signature either on a single line or split at arrows, aligned with '::' +extDecl (TypeSig _ names ty) = + do inter (write ", ") $ map pretty names + space + typeSig ty +-- Half-indent for where clause, half-indent binds +extDecl (PatBind _ pat rhs mbinds) = + do pretty pat + withCaseContext False $ pretty rhs + maybeM_ mbinds whereBinds +extDecl other = prettyNoExt other + +-- Do not modify indent level +extDeclHead :: Extend DeclHead +extDeclHead (DHApp _ dhead var) = + do pretty dhead + space + pretty var +extDeclHead other = prettyNoExt other + +extConDecl :: Extend ConDecl +-- No extra space after empty constructor +extConDecl (ConDecl _ name []) = pretty name +extConDecl (ConDecl _ name tys) = attemptSingleLine single multi + where single = spaced $ pretty name : map pretty tys + multi = depend (pretty name >> space) $ lined $ map pretty tys +-- Align record fields +extConDecl (RecDecl _ name fields) = + do modifyState $ \s -> s {cramerRecordFieldLength = fieldLen} + pretty name + space + case fields of + [] -> write "{ }" + [_] -> listAttemptSingleLine "{" "}" "," fields + _ -> listMultiLine "{" "}" "," fields + where fieldLen = maximum $ map (length . nameStr) fnames + fnames = + mapMaybe (\(FieldDecl _ ns _) -> + case ns of + [n] -> Just n + _ -> Nothing) + fields +extConDecl other = prettyNoExt other + +extFieldDecl :: Extend FieldDecl +extFieldDecl (FieldDecl _ [name] ty) = + do namelen <- gets (cramerRecordFieldLength . psUserState) + string $ padRight namelen $ nameStr name + space + typeSig ty +extFieldDecl other = prettyNoExt other + +-- Derived instances separated by comma and space, no line breaking +extDeriving :: Extend Deriving +extDeriving (Deriving _ instHeads) = + do write "deriving " + case instHeads of + [x] -> pretty x + xs -> parens $ inter (write ", ") $ map pretty xs + +extRhs :: Extend Rhs +extRhs (UnGuardedRhs _ expr) = rhsExpr expr +extRhs (GuardedRhss _ [rhs]) = space >> guardedRhsExpr rhs +extRhs (GuardedRhss _ rhss) = + forM_ rhss $ + \rhs -> + do newline + indentFull $ guardedRhsExpr rhs + +-- Type constraints on a single line +extContext :: Extend Context +extContext (CxTuple _ ctxs) = parens $ inter (write ", ") $ map pretty ctxs +extContext other = prettyNoExt other + +extType :: Extend Type +extType (TyForall _ mforall mcontext ty) = attemptSingleLine single multi + where single = + do maybeM_ mforall $ \vars -> prettyForall vars >> space + maybeM_ mcontext $ \context -> pretty context >> write " => " + pretty ty + multi = + do maybeM_ mforall $ \vars -> prettyForall vars >> newline + maybeM_ mcontext $ + \context -> pretty context >> newline >> write "=> " + pretty ty + prettyForall vars = + do write "forall " + spaced $ map pretty vars + write "." +-- Type signature should line break at each arrow if necessary +extType (TyFun _ from to) = + attemptSingleLineType (pretty from >> write " -> " >> pretty to) + (pretty from >> newline >> write "-> " >> pretty to) +-- Parentheses reset forced line breaking +extType (TyParen _ ty) = withLineBreak Free $ parens $ pretty ty +-- Tuple types on one line, with space after comma +extType (TyTuple _ boxed tys) = withLineBreak Free $ tupleExpr boxed tys +-- Infix application +extType expr@TyInfix{} = typeInfixExpr expr +extType other = prettyNoExt other + +extPat :: Extend Pat +-- Infix application with space around operator +extPat (PInfixApp _ arg1 op arg2) = + do pretty arg1 + space + prettyInfixOp op + space + pretty arg2 +-- Tuple patterns on one line, with space after comma +extPat (PTuple _ boxed pats) = withLineBreak Single $ tupleExpr boxed pats +-- List patterns on one line, with space after comma +extPat (PList _ pats) = withLineBreak Single $ listExpr pats +extPat other = prettyNoExt other + +extExp :: Extend Exp +-- Function application on a single line or align arguments +extExp expr@(App _ fun arg) = attemptSingleLine single multi + where single = pretty fun >> space >> pretty arg + multi = + pretty fun' >> space >> align (lined $ map pretty $ reverse args') + (fun',args') = collectArgs expr + collectArgs + :: Exp NodeInfo -> (Exp NodeInfo,[Exp NodeInfo]) + collectArgs app@(App _ g y) = + let (f,args) = collectArgs g + in (f,copyComments After app y : args) + collectArgs nonApp = (nonApp,[]) +-- Infix application on a single line or indented rhs +extExp expr@InfixApp{} = + if all (isApplicativeOp . fst) opArgs && isFmap (fst $ head opArgs) + then applicativeExpr firstArg opArgs + else infixExpr expr + where (firstArg,opArgs) = collectOpExps expr + collectOpExps + :: Exp NodeInfo -> (Exp NodeInfo,[(QOp NodeInfo,Exp NodeInfo)]) + collectOpExps app@(InfixApp _ left op right) = + let (ctorLeft,argsLeft) = collectOpExps left + (ctorRight,argsRight) = collectOpExps right + in (ctorLeft,argsLeft ++ [(op,copyComments After app ctorRight)] ++ argsRight) + collectOpExps e = (e,[]) + isApplicativeOp :: QOp NodeInfo -> Bool + isApplicativeOp (QVarOp _ (UnQual _ (Symbol _ s))) = + head s == '<' && last s == '>' + isApplicativeOp _ = False + isFmap :: QOp NodeInfo -> Bool + isFmap (QVarOp _ (UnQual _ (Symbol _ "<$>"))) = True + isFmap _ = False +-- No space after lambda +extExp (Lambda _ pats expr) = + do write "\\" + maybeSpace + spaced $ map pretty pats + write " ->" + -- No line break before do + case expr of + Do{} -> single + _ -> attemptSingleLine single multi + where single = space >> pretty expr + multi = newline >> indentFull (pretty expr) + maybeSpace = + case pats of + PBangPat{}:_ -> space + PIrrPat{}:_ -> space + _ -> return () +-- If-then-else on one line or newline and indent before then and else +extExp (If _ cond true false) = ifExpr id cond true false +-- Newline before in +extExp (Let _ binds expr@Do{}) = letExpr binds $ space >> pretty expr +extExp (Let _ binds expr) = letExpr binds $ newline >> indentFull (pretty expr) +-- Tuples on a single line (no space inside parens but after comma) or +-- one element per line with parens and comma aligned +extExp (Tuple _ boxed exprs) = tupleExpr boxed exprs +-- List on a single line or one item per line with aligned brackets and comma +extExp (List _ exprs) = listExpr exprs +-- Record construction and update on a single line or one line per +-- field with aligned braces and comma +extExp (RecConstr _ qname updates) = recordExpr qname updates +extExp (RecUpdate _ expr updates) = recordExpr expr updates +-- Line break and indent after do +extExp (Do _ stmts) = + do write "do" + newline + indentFull $ preserveLineSpacing stmts +extExp (ListComp _ e qstmt) = + brackets (do space + pretty e + unless (null qstmt) + (do newline + indented (-1) + (write "|") + prefixedLined "," + (map (\x -> do space + pretty x + space) + qstmt))) +-- Type signatures like toplevel decl +extExp (ExpTypeSig _ expr ty) = + do pretty expr + space + typeSig ty +extExp other = prettyNoExt other + +extStmt :: Extend Stmt +extStmt (Qualifier _ (If _ cond true false)) = ifExpr indentFull cond true false +extStmt other = prettyNoExt other + +extMatch :: Extend Match +-- Indent where same as for top level decl +extMatch (Match _ name pats rhs mbinds) = + do pretty name + space + spaced $ map pretty pats + withCaseContext False $ pretty rhs + maybeM_ mbinds whereBinds +extMatch other = prettyNoExt other + +-- Preserve empty lines between bindings +extBinds :: Extend Binds +extBinds (BDecls _ decls) = preserveLineSpacing decls +extBinds other = prettyNoExt other + +-- No line break after equal sign +extFieldUpdate :: Extend FieldUpdate +extFieldUpdate (FieldUpdate _ qname expr) = + do pretty qname + write " = " + pretty expr +extFieldUpdate other = prettyNoExt other diff --git a/src/HIndent/Styles/Gibiansky.hs b/src/HIndent/Styles/Gibiansky.hs --- a/src/HIndent/Styles/Gibiansky.hs +++ b/src/HIndent/Styles/Gibiansky.hs @@ -4,7 +4,7 @@ module HIndent.Styles.Gibiansky where import Data.Foldable -import Control.Applicative ((<$>)) +-- import Control.Applicative ((<$>)) import Data.Maybe import Data.List (unfoldr, isPrefixOf) import Control.Monad.Trans.Maybe @@ -411,6 +411,18 @@ exprs (RecUpdate _ exp updates) = recUpdateExpr updates (pretty exp) (map prettyCommentCallbacks updates) exprs (RecConstr _ qname updates) = recUpdateExpr updates (pretty qname) (map prettyCommentCallbacks updates) exprs (Tuple _ _ exps) = parens $ inter (write ", ") $ map pretty exps +exprs (ListComp _ e qstmt) = + brackets (do space + pretty e + unless (null qstmt) + (do newline + indented (-1) + (write "|") + prefixedLined "," + (map (\x -> do space + pretty x + space) + qstmt))) exprs exp = prettyNoExt exp multiIfExpr :: Exp NodeInfo -> Printer State () diff --git a/src/HIndent/Styles/JohanTibell.hs b/src/HIndent/Styles/JohanTibell.hs --- a/src/HIndent/Styles/JohanTibell.hs +++ b/src/HIndent/Styles/JohanTibell.hs @@ -257,6 +257,18 @@ newline indented (-4) (depend (write "in ") (pretty e))) +exp (ListComp _ e qstmt) = + brackets (do space + pretty e + unless (null qstmt) + (do newline + indented (-1) + (write "|") + prefixedLined "," + (map (\x -> do space + pretty x + space) + qstmt))) exp e = prettyNoExt e match :: Match NodeInfo -> Printer s () diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -54,10 +54,6 @@ ,psCommentPreprocessor :: forall m. MonadState (PrintState s) m => [Comment] -> m [Comment] -- ^ Preprocessor applied to comments on an AST before printing. } -instance Eq (PrintState s) where - PrintState ilevel out newline col line _ _ _ eolc inc _pm _ == PrintState ilevel' out' newline' col' line' _ _ _ eolc' inc' _pm' _ = - (ilevel,out,newline,col,line,eolc, inc) == (ilevel',out',newline',col',line',eolc', inc') - -- | A printer extender. Takes as argument the user state that the -- printer was run with, and the current node to print. Use -- 'prettyNoExt' to fallback to the built-in printer. diff --git a/src/main/Benchmark.hs b/src/main/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/main/Benchmark.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Benchmark the pretty printer. + +module Main where + +import Control.DeepSeq +import Criterion +import Criterion.Main +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy.IO as LT +import qualified Data.Text.Lazy.Builder as T +import HIndent + +-- | Main benchmarks. +main :: IO () +main = + defaultMain + [env setupEnv + (\ ~bigDecls -> + bgroup "Main" + [bgroup "BigDeclarations" + [bench ("HIndent.reformat: " ++ + show (styleName style)) + (nf (either error T.toLazyText . + reformat style (Just defaultExtensions)) + bigDecls)|style <- styles]])] + +-- | Setup the environment for the benchmarks. +setupEnv :: IO Text +setupEnv = do + bigDecls <- LT.readFile "benchmarks/BigDeclarations.hs" + let !decls = force bigDecls + return decls diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -108,19 +108,3 @@ case classifyExtension x of UnknownExtension _ -> Nothing x' -> Just x' - --- | Default extensions. -defaultExtensions :: [Extension] -defaultExtensions = - [e | e@EnableExtension{} <- knownExtensions] \\ - map EnableExtension badExtensions - --- | Extensions which steal too much syntax. -badExtensions :: [KnownExtension] -badExtensions = - [Arrows -- steals proc - ,TransformListComp -- steals the group keyword - ,XmlSyntax, RegularPatterns -- steals a-b - ,UnboxedTuples -- breaks (#) lens operator - -- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break - ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,7 +15,7 @@ import qualified HIndent styles :: [FilePath] -styles = ["fundamental", "gibiansky", "chris-done", "johan-tibell"] +styles = ["fundamental", "gibiansky", "chris-done", "johan-tibell", "cramer"] testDir, expectedDir :: String testDir = "tests"