diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 1.0 +version: 2.0 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -43,8 +43,11 @@ ParseOk (v,comments) -> case annotateComments v comments of (cs,ast) -> - Right (prettyPrint config style (do mapM_ printComment cs - pretty ast)) + Right (prettyPrint + config + style + (do mapM_ printComment cs + pretty ast)) ParseFailed _ e -> Left e -- | Pretty print the given printable thing. @@ -77,13 +80,21 @@ [fundamental,chrisDone,michaelSnoyman,johanTibell] -- | Annotate the AST with comments. -annotateComments :: (Data (ast NodeInfo),Traversable ast,Annotated ast) => ast SrcSpanInfo -> [Comment] -> ([Comment],ast NodeInfo) +annotateComments :: (Data (ast NodeInfo),Traversable ast,Annotated ast) + => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) annotateComments = - foldr (\c (cs,ast) -> + foldr (\c@(Comment _ cspan _) (cs,ast) -> case execState (traverse (collect c) ast) Nothing of - Nothing -> (c : cs,ast) + Nothing -> + (ComInfo c True : + cs + ,ast) Just l -> - (cs,evalState (traverse (insert l c) ast) False)) . + let ownLine = + srcSpanStartLine cspan /= + srcSpanEndLine (srcInfoSpan l) + in (cs + ,evalState (traverse (insert l (ComInfo c ownLine)) ast) False)) . ([],) . fmap (\n -> NodeInfo n []) where collect c ni@(NodeInfo l _) = diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -49,16 +49,15 @@ ) where -import Data.Char - import HIndent.Types -import Language.Haskell.Exts.Comments +import Language.Haskell.Exts.Comments import Control.Monad.State hiding (state) import Data.Int import Data.List import Data.Maybe import Data.Monoid +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (Builder) @@ -78,7 +77,8 @@ prettyInternal :: ast NodeInfo -> Printer () -- | Pretty print using extenders. -pretty :: (Pretty ast) => ast NodeInfo -> Printer () +pretty :: (Pretty ast) + => ast NodeInfo -> Printer () pretty a = do st <- get case st of @@ -94,16 +94,19 @@ -- | Run the basic printer for the given node without calling an -- extension hook for this node, but do allow extender hooks in child -- nodes. Also auto-inserts comments. -prettyNoExt :: (Pretty ast) => ast NodeInfo -> Printer () +prettyNoExt :: (Pretty ast) + => ast NodeInfo -> Printer () prettyNoExt a = do prettyInternal a mapM_ printComment (nodeInfoComments (ann a)) -- | Pretty print a comment. -printComment :: Comment -> Printer () -printComment (Comment inline _ str) = +printComment :: ComInfo -> Printer () +printComment (ComInfo (Comment inline _ str) own) = do st <- sandbox (write "") - unless (psColumn st == 0) space + if own + then newline + else unless (psColumn st == 0) space if inline then do write "{-" string str @@ -115,7 +118,8 @@ -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's. -pretty' :: (P.Pretty (ast SrcSpanInfo),Functor ast) => ast NodeInfo -> Printer () +pretty' :: (P.Pretty (ast SrcSpanInfo),Functor ast) + => ast NodeInfo -> Printer () pretty' = write . T.fromText . T.pack . P.prettyPrint . fmap nodeInfoSpan -------------------------------------------------------------------------------- @@ -157,16 +161,16 @@ -- | Print all the printers separated newlines and optionally a line -- prefix. -prefixedLined :: Char -> [Printer ()] -> Printer () +prefixedLined :: Text -> [Printer ()] -> Printer () prefixedLined pref ps' = case ps' of [] -> return () (p:ps) -> do p - indented (-1) + indented (fromIntegral (T.length pref * (-1))) (mapM_ (\p' -> do newline - depend (string [pref]) p') + depend (write (T.fromText pref)) p') ps) -- | Set the (newline-) indent level to the given column for the given @@ -503,7 +507,7 @@ depend (write (case boxed of Unboxed -> "(#" Boxed -> "(")) - (do parens (prefixedLined ',' + (do parens (prefixedLined "," (map pretty exps)) write (case boxed of Unboxed -> "#)" @@ -517,7 +521,7 @@ Unboxed -> "#)" Boxed -> ")")) exp (List _ es) = - brackets (prefixedLined ',' (map pretty es)) + brackets (prefixedLined "," (map pretty es)) exp (LeftSection _ e op) = parens (depend (do pretty e space) @@ -530,13 +534,13 @@ do indentSpaces <- getIndentSpaces depend (do pretty n space) - (braces (prefixedLined ',' + (braces (prefixedLined "," (map (indented indentSpaces . pretty) fs))) exp (RecUpdate _ n fs) = do indentSpaces <- getIndentSpaces depend (do pretty n space) - (braces (prefixedLined ',' + (braces (prefixedLined "," (map (indented indentSpaces . pretty) fs))) exp (EnumFrom _ e) = brackets (do pretty e @@ -562,7 +566,7 @@ (write " |")) (do space prefixedLined - ',' + "," (map (\(i,x) -> depend (if i == 0 then return () @@ -715,7 +719,7 @@ indentSpaces <- getIndentSpaces column indentSpaces (depend (write "=") - (prefixedLined '|' + (prefixedLined "|" (map (depend space . pretty) xs))) decl GDataDecl{} = error "FIXME: No implementation for GDataDecl." @@ -850,7 +854,7 @@ (do space indentSpaces <- getIndentSpaces braces (prefixedLined - ',' + "," (map (indented indentSpaces . prettyPair) (concatMap (\(FieldDecl _ names ty) -> map (,ty) names) @@ -896,7 +900,7 @@ GuardedAlt _ stmts e -> do indented 1 (do (prefixedLined - ',' + "," (map (\p -> do space pretty p) @@ -910,7 +914,7 @@ GuardedRhs _ stmts e -> do indented 1 (do prefixedLined - ',' + "," (map (\p -> do space pretty p) 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 @@ -41,11 +41,63 @@ ,Extender rhs ,Extender guardedrhs ,Extender guardedalt - ,Extender unguardedalt] + ,Extender unguardedalt + ,Extender stmt + ,Extender decl] ,styleDefConfig = Config {configMaxColumns = 80 ,configIndentSpaces = 2}} +-- | Pretty print type signatures like +-- +-- foo :: (Show x,Read x) +-- => (Foo -> Bar) +-- -> Maybe Int +-- -> (Char -> X -> Y) +-- -> IO () +-- +decl :: t -> Decl NodeInfo -> Printer () +decl _ (TypeSig _ names ty') = + depend (do inter (write ", ") + (map pretty names) + write " :: ") + (declTy ty') + where declTy dty = + case dty of + TyForall _ mbinds mctx ty -> + do case mbinds of + Nothing -> return () + Just ts -> + do write "forall " + spaced (map pretty ts) + write ". " + newline + case mctx of + Nothing -> prettyTy ty + Just ctx -> + do pretty ctx + newline + indented (-3) + (depend (write "=> ") + (prettyTy ty)) + _ -> prettyTy dty + collapseFaps (TyFun _ arg result) = arg : collapseFaps result + collapseFaps e = [e] + prettyTy ty = + do small <- isSmall' ty + if small + then pretty ty + else case collapseFaps ty of + [] -> pretty ty + tys -> + prefixedLined "-> " + (map pretty tys) + isSmall' p = + do overflows <- isOverflow (pretty p) + oneLine <- isSingleLiner (pretty p) + return (not overflows && oneLine) +decl _ e = prettyNoExt e + -- | I want field updates to be dependent or newline. fieldupdate :: t -> FieldUpdate NodeInfo -> Printer () fieldupdate _ e = @@ -59,6 +111,7 @@ _ -> prettyNoExt e +-- | Right-hand sides are dependent. rhs :: State -> Rhs NodeInfo -> Printer () rhs _ (UnGuardedRhs _ e) = do indentSpaces <- getIndentSpaces @@ -73,7 +126,7 @@ guardedrhs _ (GuardedRhs _ stmts e) = indented 1 (do prefixedLined - ',' + "," (map (\p -> do space pretty p) @@ -89,7 +142,7 @@ guardedalt _ (GuardedAlt _ stmts e) = indented 1 (do (prefixedLined - ',' + "," (map (\p -> do space pretty p) @@ -110,30 +163,23 @@ pretty) unguardedalt _ e = prettyNoExt e +-- Do statements need to handle infix expression indentation specially because +-- do x * +-- y +-- is two invalid statements, not one valid infix op. +stmt :: State -> Stmt NodeInfo -> Printer () +stmt _ (Qualifier _ e@(InfixApp _ a op b)) = + do col <- fmap psColumn (sandbox (write "")) + infixApp e a op b (Just col) +stmt _ e = prettyNoExt e + -- | Expressions exp :: State -> Exp NodeInfo -> Printer () -- Infix applications will render on one line if possible, otherwise -- if any of the arguments are not "flat" then that expression is -- line-separated. exp _ e@(InfixApp _ a op b) = - do is <- isFlat e - overflow <- isOverflow - (depend (do pretty a - space - pretty op - space) - (do pretty b)) - if is && not overflow - then do depend (do pretty a - space - pretty op - space) - (do pretty b) - else do pretty a - space - pretty op - newline - pretty b + infixApp e a op b Nothing -- | We try to render everything on a flat line. More than one of the -- arguments are not flat and it wouldn't be a single liner. -- If the head is short we depend, otherwise we swing. @@ -149,7 +195,8 @@ overflow <- isOverflowMax (spaced (map pretty args)) if singleLiner && ((headIsShort && flatish) || - all id flats) && not overflow + all id flats) && + not overflow then spaced (map pretty args) else do allSingleLiners <- fmap (all id) (mapM (isSingleLiner . pretty) args) @@ -181,7 +228,8 @@ underflow <- fmap not (isOverflow p) if single && underflow then p - else parens (prefixedLined ',' (map pretty exps)) + else prefixedLined "," + (map pretty exps) write (case boxed of Unboxed -> "#)" Boxed -> ")")) @@ -191,11 +239,43 @@ underflow <- fmap not (isOverflow p) if single && underflow then p - else brackets (prefixedLined ',' + else brackets (prefixedLined "," (map pretty es)) where p = brackets (commas (map pretty es)) exp _ e = prettyNoExt e +infixApp :: (Pretty ast,Pretty ast1,Pretty ast2) + => Exp NodeInfo + -> ast NodeInfo + -> ast1 NodeInfo + -> ast2 NodeInfo + -> Maybe Int64 + -> Printer () +infixApp e a op b indent = + do is <- isFlat e + overflow <- isOverflow + (depend (do pretty a + space + pretty op + space) + (do pretty b)) + if is && not overflow + then do depend (do pretty a + space + pretty op + space) + (do pretty b) + else do pretty a + space + pretty op + newline + case indent of + Nothing -> pretty b + Just col -> + do indentSpaces <- getIndentSpaces + column (col + indentSpaces) + (pretty b) + -- | Is the expression "short"? Used for app heads. isShort :: (Pretty ast) => ast NodeInfo -> Printer Bool isShort p = @@ -221,7 +301,10 @@ -- | Make the right hand side dependent if it's flat, otherwise -- newline it. -dependOrNewline :: Printer () -> Exp NodeInfo -> (Exp NodeInfo -> Printer ()) -> Printer () +dependOrNewline :: Printer () + -> Exp NodeInfo + -> (Exp NodeInfo -> Printer ()) + -> Printer () dependOrNewline left right f = do flat <- isFlat right small <- isSmall (depend left (f right)) diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -11,7 +11,8 @@ ,Extender(..) ,Style(..) ,Config(..) - ,NodeInfo(..)) + ,NodeInfo(..) + ,ComInfo(..)) where import Control.Monad.State (MonadState(..),State) @@ -74,7 +75,13 @@ -- | Information for each node in the AST. data NodeInfo = - NodeInfo {nodeInfoSpan :: SrcSpanInfo -- ^ Location info from the parser. - ,nodeInfoComments :: [Comment] -- ^ Comments which follow this node. + NodeInfo {nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser. + ,nodeInfoComments :: ![ComInfo] -- ^ Comments which follow this node. } deriving (Typeable,Show,Data) + +-- | Comment with some more info. +data ComInfo = + ComInfo {comInfoComment :: !Comment + ,comInfoOwnLine :: !Bool} + deriving (Show,Typeable,Data) diff --git a/src/main/Main.hs b/src/main/Main.hs --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -24,7 +24,8 @@ reformat (styleDefConfig style) style) _ -> error ("arguments: --style [" ++ - intercalate "|" (map (T.unpack . styleName) styles) ++ + intercalate "|" + (map (T.unpack . styleName) styles) ++ "]") where findStyle name = find ((== T.pack name) . styleName) styles