hindent 2.4 → 3.0
raw patch · 8 files changed
+456/−107 lines, 8 filesdep ~basedep ~data-defaultdep ~mtl
Dependency ranges changed: base, data-default, mtl, text
Files
- hindent.cabal +1/−2
- src/HIndent.hs +23/−13
- src/HIndent/Pretty.hs +10/−9
- src/HIndent/Styles/ChrisDone.hs +58/−47
- src/HIndent/Styles/JohanTibell.hs +358/−2
- src/HIndent/Styles/MichaelSnoyman.hs +0/−28
- src/HIndent/Types.hs +5/−5
- src/main/Main.hs +1/−1
hindent.cabal view
@@ -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
src/HIndent.hs view
@@ -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)
src/HIndent/Pretty.hs view
@@ -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) =
src/HIndent/Styles/ChrisDone.hs view
@@ -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)
src/HIndent/Styles/JohanTibell.hs view
@@ -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: <https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>" ,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
− src/HIndent/Styles/MichaelSnoyman.hs
@@ -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}}
src/HIndent/Types.hs view
@@ -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)
src/main/Main.hs view
@@ -21,7 +21,7 @@ ["--style",findStyle -> Just style] -> T.interact (either error T.toLazyText .- reformat (styleDefConfig style) style)+ reformat style) _ -> error ("arguments: --style [" ++ intercalate "|"