diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 2.4 +version: 3.0 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -23,7 +23,6 @@ HIndent.Pretty HIndent.Styles.Fundamental HIndent.Styles.ChrisDone - HIndent.Styles.MichaelSnoyman HIndent.Styles.JohanTibell build-depends: base >= 4 && <5 , data-default diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} + -- | Haskell indenter. module HIndent @@ -9,11 +11,11 @@ -- * Style ,styles ,chrisDone - ,michaelSnoyman ,johanTibell ,fundamental -- * Testing - ,test) + ,test + ,testAll) where import Data.Function @@ -21,12 +23,12 @@ import HIndent.Styles.ChrisDone import HIndent.Styles.Fundamental import HIndent.Styles.JohanTibell -import HIndent.Styles.MichaelSnoyman import HIndent.Types import Control.Monad.State import Data.Data import Data.Monoid +import qualified Data.Text.IO as ST import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T import Data.Text.Lazy.Builder (Builder) @@ -36,26 +38,25 @@ import Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse) -- | Format the given source. -reformat :: Config -> Style -> Text -> Either String Builder -reformat config style x = +reformat :: Style -> Text -> Either String Builder +reformat style x = case parseDeclWithComments parseMode (T.unpack x) of ParseOk (v,comments) -> case annotateComments v comments of (cs,ast) -> Right (prettyPrint - config style (do mapM_ printComment cs pretty ast)) ParseFailed _ e -> Left e -- | Pretty print the given printable thing. -prettyPrint :: Config -> Style -> Printer () -> Builder -prettyPrint config style m = +prettyPrint :: Style -> Printer () -> Builder +prettyPrint style m = psOutput (execState (runPrinter m) (case style of - Style _name _author _desc st extenders _defconfig -> + Style _name _author _desc st extenders config -> PrintState 0 mempty False 0 1 st extenders config False)) -- | Parse mode, includes all extensions, doesn't assume any fixities. @@ -69,15 +70,24 @@ isDisabledExtention _ = True -- | Test with the given style, prints to stdout. -test :: Config -> Style -> Text -> IO () -test config style = +test :: Style -> Text -> IO () +test style = either error (T.putStrLn . T.toLazyText) . - reformat config style + reformat style +-- | Test with the given style, prints to stdout. +testAll :: Text -> IO () +testAll i = + forM_ styles + (\style -> + do ST.putStrLn ("-- " <> styleName style <> ":") + test style i + ST.putStrLn "") + -- | Styles list, useful for programmatically choosing. styles :: [Style] styles = - [fundamental,chrisDone,michaelSnoyman,johanTibell] + [fundamental,chrisDone,johanTibell] -- | Annotate the AST with comments. annotateComments :: (Data (ast NodeInfo),Traversable ast,Annotated ast) diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -519,8 +519,8 @@ depend (write (case boxed of Unboxed -> "(#" Boxed -> "(")) - (do parens (prefixedLined "," - (map pretty exps)) + (do prefixedLined "," + (map pretty exps) write (case boxed of Unboxed -> "#)" Boxed -> ")")) @@ -676,8 +676,8 @@ decl :: Decl NodeInfo -> Printer () decl (PatBind _ pat mty rhs mbinds) = case mty of - Just{} -> - error "Unimplemented (Maybe Type) in PatBind." + Just e -> + error ("Unimplemented (Maybe Type) in PatBind." ++ show e) Nothing -> do pretty pat pretty rhs @@ -877,11 +877,12 @@ InfixConDecl l a f b -> pretty (ConDecl l f [a,b]) RecDecl _ name fields -> - depend (pretty name) - (do space - indentSpaces <- getIndentSpaces - braces (prefixedLined "," - (map (indented indentSpaces . pretty) fields))) + depend (do pretty name + write " ") + (do depend (write "{") + (prefixedLined "," + (map pretty fields)) + write "}") instance Pretty FieldDecl where prettyInternal (FieldDecl _ names ty) = 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 @@ -17,6 +17,9 @@ import Language.Haskell.Exts.Annotated.Syntax import Prelude hiding (exp) +-------------------------------------------------------------------------------- +-- Style configuration + -- | A short function name. shortName :: Int64 shortName = 10 @@ -48,6 +51,9 @@ Config {configMaxColumns = 80 ,configIndentSpaces = 2}} +-------------------------------------------------------------------------------- +-- Extenders + -- | Pretty print type signatures like -- -- foo :: (Show x,Read x) @@ -110,7 +116,6 @@ pretty _ -> prettyNoExt e - -- | Right-hand sides are dependent. rhs :: State -> Rhs NodeInfo -> Printer () rhs _ (UnGuardedRhs _ e) = @@ -246,37 +251,8 @@ 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) +-------------------------------------------------------------------------------- +-- Predicates -- | Is the expression "short"? Used for app heads. isShort :: (Pretty ast) @@ -297,21 +273,6 @@ st <- sandbox p return (psLine st == line && psColumn st < smallColumnLimit) --- | Make the right hand side dependent if it's flat, otherwise --- newline it. -dependOrNewline :: Printer () - -> Exp NodeInfo - -> (Exp NodeInfo -> Printer ()) - -> Printer () -dependOrNewline left right f = - do flat <- isFlat right - small <- isSmall (depend left (f right)) - if flat || small - then depend left (f right) - else do left - newline - (f right) - -- | Is an expression flat? isFlat :: Exp NodeInfo -> Printer Bool isFlat (Lambda _ _ e) = isFlat e @@ -355,3 +316,53 @@ do line <- gets psLine st <- sandbox p return (psLine st == line) + +-------------------------------------------------------------------------------- +-- Helpers + +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) + +-- | Make the right hand side dependent if it's flat, otherwise +-- newline it. +dependOrNewline :: Printer () + -> Exp NodeInfo + -> (Exp NodeInfo -> Printer ()) + -> Printer () +dependOrNewline left right f = + do flat <- isFlat right + small <- isSmall (depend left (f right)) + if flat || small + then depend left (f right) + else do left + newline + (f right) 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | Stub module for Johan Tibell's style. @@ -8,12 +9,26 @@ (johanTibell) where +import Control.Monad +import Control.Monad.State.Class +import Data.Int +import Data.Maybe +import HIndent.Pretty import HIndent.Types +import Language.Haskell.Exts.Annotated.Syntax import Prelude hiding (exp) +-------------------------------------------------------------------------------- +-- Style configuration + +-- | A short function name. +shortName :: Int64 +shortName = 10 + -- | Empty state. -data State = State +data State = + State -- | The printer style. johanTibell :: Style @@ -22,7 +37,348 @@ ,styleAuthor = "Chris Done" ,styleDescription = "Style modeled from Johan's style guide here: " ,styleInitialState = State - ,styleExtenders = [] + ,styleExtenders = + [Extender decl + ,Extender conDecl + ,Extender exp + ,Extender guardedRhs + ,Extender rhs + ,Extender ifAlt + ,Extender alts + ,Extender guardedAlt] ,styleDefConfig = Config {configMaxColumns = 80 ,configIndentSpaces = 4}} + +-------------------------------------------------------------------------------- +-- Extenders + +-- | Handle do specially and also space out guards more. +rhs :: t -> Rhs NodeInfo -> Printer () +rhs _ x = + case x of + UnGuardedRhs _ (Do _ dos) -> + swing (write " = do") + (lined (map pretty dos)) + GuardedRhss _ gas -> + do newline + indentSpaces <- getIndentSpaces + indented indentSpaces + (lined (map (\p -> + do write "|" + pretty p) + gas)) + _ -> prettyNoExt x + +-- | Case alts. +alts :: t -> GuardedAlts NodeInfo -> Printer () +-- | Handle do specially. +alts _ x = + case x of + UnGuardedAlt _ (Do _ dos) -> + swing (write " -> do") + (lined (map pretty dos)) + GuardedAlts _ gas -> + do newline + indentSpaces <- getIndentSpaces + indented indentSpaces + (lined (map (\p -> + do write "|" + pretty p) + gas)) + _ -> prettyNoExt x + +-- | Handle do specially. +guardedAlt _ x = + case x of + GuardedAlt _ stmts (Do _ dos) -> + do indented 1 + (do (prefixedLined + "," + (map (\p -> + do space + pretty p) + stmts))) + swing (write " -> do ") + (lined (map pretty dos)) + _ -> prettyNoExt x + +-- | Handle do specially. +ifAlt _ (IfAlt _ cond (Do _ dos)) = + do pretty cond + swing (write " -> do") + (lined (map pretty dos)) +ifAlt _ e = prettyNoExt e + +-- | Implement dangling right-hand-sides. +guardedRhs :: t -> GuardedRhs NodeInfo -> Printer () +-- | Handle do specially. +guardedRhs _ (GuardedRhs _ stmts (Do _ dos)) = + do indented 1 + (do prefixedLined + "," + (map (\p -> + do space + pretty p) + stmts)) + swing (write " = do") + (lined (map pretty dos)) +guardedRhs _ e = prettyNoExt e + +-- | Expression customizations. +exp :: t -> Exp NodeInfo -> Printer () +-- | Space out tuples. +exp _ (Tuple _ boxed exps) = + depend (write (case boxed of + Unboxed -> "(#" + Boxed -> "(")) + (do single <- isSingleLiner p + underflow <- fmap not (isOverflow p) + if single && underflow + then p + else prefixedLined "," + (map (depend space . pretty) exps) + write (case boxed of + Unboxed -> "#)" + Boxed -> ")")) + where p = inter (write ", ") (map pretty exps) +-- | Space out tuples. +exp _ (TupleSection _ boxed mexps) = + depend (write (case boxed of + Unboxed -> "(#" + Boxed -> "(")) + (do inter (write ", ") (map (maybe (return ()) pretty) mexps) + write (case boxed of + Unboxed -> "#)" + Boxed -> ")")) +-- | Infix apps, same algorithm as ChrisDone at the moment. +exp _ e@(InfixApp _ a op b) = + infixApp e a op b Nothing +-- | If bodies are indented 4 spaces. Handle also do-notation. +exp _ (If _ if' then' else') = + do depend (write "if ") + (pretty if') + newline + indentSpaces <- getIndentSpaces + indented indentSpaces + (do branch "then " then' + newline + branch "else " else') + -- Special handling for do. + where branch string e = + case e of + Do _ stmts -> + do write string + write "do" + newline + indentSpaces <- getIndentSpaces + indented indentSpaces (lined (map pretty stmts)) + _ -> + depend (write string) + (pretty e) +-- | App algorithm similar to ChrisDone algorithm, but with no +-- parent-child alignment. +exp _ (App _ op a) = + do orig <- gets psIndentLevel + headIsShort <- isShort f + depend (do pretty f + space) + (do flats <- mapM isFlat args + flatish <- fmap ((< 2) . length . filter not) + (return flats) + singleLiner <- isSingleLiner (spaced (map pretty args)) + overflow <- isOverflow (spaced (map pretty args)) + if singleLiner && + ((headIsShort && flatish) || + all id flats) && + not overflow + then spaced (map pretty args) + else do newline + indentSpaces <- getIndentSpaces + column (orig + indentSpaces) + (lined (map pretty args))) + where (f,args) = flatten op [a] + flatten :: Exp NodeInfo + -> [Exp NodeInfo] + -> (Exp NodeInfo,[Exp NodeInfo]) + flatten (App _ f' a') b = + flatten f' (a' : b) + flatten f' as = (((f',as))) +-- | Space out commas in list. +exp _ (List _ es) = + do single <- isSingleLiner p + underflow <- fmap not (isOverflow p) + if single && underflow + then p + else brackets (prefixedLined "," + (map (depend space . pretty) es)) + where p = + brackets (inter (write ", ") + (map pretty es)) +exp _ e = prettyNoExt e + +-- | Specially format records. Indent where clauses only 2 spaces. +decl :: t -> Decl NodeInfo -> Printer () +decl _ (PatBind _ pat mty rhs mbinds) = + case mty of + Just e -> + error ("Unimplemented (Maybe Type) in PatBind." ++ show e) + Nothing -> + do pretty pat + pretty rhs + indentSpaces <- getIndentSpaces + case mbinds of + Nothing -> return () + Just binds -> + do newline + indented 2 + (do write "where " + newline + indented 2 (pretty binds)) +-- | Handle records specially for a prettier display (see guide). +decl _ (DataDecl _ dataornew ctx dhead condecls@[_] mderivs) + | any isRecord condecls = + do depend (do pretty dataornew + unless (null condecls) space) + (depend (maybeCtx ctx) + (do pretty dhead + multiCons condecls)) + case mderivs of + Nothing -> return () + Just derivs -> pretty derivs + where multiCons xs = + depend (write " =") + (inter (write "|") + (map (depend space . qualConDecl) xs)) +decl _ e = prettyNoExt e + +-- | Use special record display, used by 'dataDecl' in a record scenario. +qualConDecl :: QualConDecl NodeInfo -> Printer () +qualConDecl x = + case x of + QualConDecl _ tyvars ctx d -> + depend + (unless + (null (fromMaybe [] tyvars)) + (do write "forall " + spaced (map pretty (fromMaybe [] tyvars)) + write ". ")) + (depend + (maybeCtx ctx) + (recDecl d)) + +-- | Fields are preceded with a space. +conDecl :: t -> ConDecl NodeInfo -> Printer () +conDecl _ (RecDecl _ name fields) = + depend (do pretty name + write " ") + (do depend (write "{") + (prefixedLined "," + (map (depend space . pretty) fields)) + write "}") +conDecl _ e = prettyNoExt e + +-------------------------------------------------------------------------------- +-- Predicates + +-- | Is the decl a record? +isRecord :: QualConDecl t -> Bool +isRecord (QualConDecl _ _ _ RecDecl{}) = True +isRecord _ = False + +-- | Does printing the given thing overflow column limit? (e.g. 80) +isOverflow :: Printer a -> Printer Bool +isOverflow p = + do st <- sandbox p + columnLimit <- getColumnLimit + return (psColumn st > columnLimit) + +-- | Is the given expression a single-liner when printed? +isSingleLiner :: MonadState PrintState m + => m a -> m Bool +isSingleLiner p = + do line <- gets psLine + st <- sandbox p + return (psLine st == line) + +-- | Is the expression "short"? Used for app heads. +isShort :: (Pretty ast) + => ast NodeInfo -> Printer Bool +isShort p = + do line <- gets psLine + orig <- fmap psColumn (sandbox (write "")) + st <- sandbox (pretty p) + return (psLine st == line && + (psColumn st < orig + shortName)) + +-- | Is an expression flat? +isFlat :: Exp NodeInfo -> Printer Bool +isFlat (Lambda _ _ e) = isFlat e +isFlat (App _ a b) = + return (isName a && isName b) + where isName (Var{}) = True + isName _ = False +isFlat (InfixApp _ a _ b) = + do a' <- isFlat a + b' <- isFlat b + return (a' && b') +isFlat (NegApp _ a) = isFlat a +isFlat VarQuote{} = return True +isFlat TypQuote{} = return True +isFlat (List _ []) = return True +isFlat Var{} = return True +isFlat Lit{} = return True +isFlat Con{} = return True +isFlat (LeftSection _ e _) = isFlat e +isFlat (RightSection _ _ e) = isFlat e +isFlat _ = return False + +-------------------------------------------------------------------------------- +-- Helpers + +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) + +-- | Record decls are formatted like: Foo +-- { bar :: X +-- } +recDecl :: ConDecl NodeInfo -> Printer () +recDecl (RecDecl _ name fields) = + do pretty name + indentSpaces <- getIndentSpaces + newline + column indentSpaces + (do depend (write "{") + (prefixedLined "," + (map (depend space . pretty) fields)) + write "} ") +recDecl r = prettyNoExt r diff --git a/src/HIndent/Styles/MichaelSnoyman.hs b/src/HIndent/Styles/MichaelSnoyman.hs deleted file mode 100644 --- a/src/HIndent/Styles/MichaelSnoyman.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Stub module for Michael Snoyman's style. --- --- Modelled from existing codebases. - -module HIndent.Styles.MichaelSnoyman - (michaelSnoyman) - where - -import HIndent.Types - -import Prelude hiding (exp) - --- | Empty state. -data State = State - --- | The printer style. -michaelSnoyman :: Style -michaelSnoyman = - Style {styleName = "michael-snoyman" - ,styleAuthor = "Chris Done" - ,styleDescription = "Style modelled from existing (Yesod, Conduit, etc.) codebases." - ,styleInitialState = State - ,styleExtenders = [] - ,styleDefConfig = - Config {configMaxColumns = 120 - ,configIndentSpaces = 4}} diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -42,7 +42,7 @@ ,psExtenders :: ![Extender s] -- ^ Extenders. ,psConfig :: !Config -- ^ Config which styles may or may not pay attention to. ,psEolComment :: !Bool -- ^ An end of line comment has just been outputted. - } + } instance Eq PrintState where PrintState ilevel out newline col line _ _ _ eolc == PrintState ilevel' out' newline' col' line' _ _ _ eolc' = @@ -63,14 +63,14 @@ ,styleInitialState :: !s -- ^ User state, if needed. ,styleExtenders :: ![Extender s] -- ^ Extenders to the printer. ,styleDefConfig :: !Config -- ^ Default config to use for this style. - } + } -- | Configurations shared among the different styles. Styles may pay -- attention to or completely disregard this configuration. data Config = Config {configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally. ,configIndentSpaces :: !Int64 -- ^ How many spaces to indent? - } + } instance Default Config where def = @@ -81,12 +81,12 @@ data NodeInfo = 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 -- ^ The normal comment type. ,comInfoOwnLine :: !Bool -- ^ Does the comment rest on its own line? - } + } 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 @@ -21,7 +21,7 @@ ["--style",findStyle -> Just style] -> T.interact (either error T.toLazyText . - reformat (styleDefConfig style) style) + reformat style) _ -> error ("arguments: --style [" ++ intercalate "|"