diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 3.0 +version: 3.1 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -27,6 +27,7 @@ build-depends: base >= 4 && <5 , data-default , haskell-src-exts >= 1.15.0 + , monad-loops , mtl , text diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -25,7 +25,7 @@ import HIndent.Styles.JohanTibell import HIndent.Types -import Control.Monad.State +import Control.Monad.State.Strict import Data.Data import Data.Monoid import qualified Data.Text.IO as ST diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -37,6 +37,7 @@ , indented , column , depend + , dependBind , swing , getIndentSpaces , getColumnLimit @@ -73,7 +74,7 @@ -- * Pretty printing class -- | Pretty printing class. -class (Annotated ast,Typeable1 ast) => Pretty ast where +class (Annotated ast,Typeable ast) => Pretty ast where prettyInternal :: ast NodeInfo -> Printer () -- | Pretty print using extenders. @@ -91,7 +92,7 @@ case cast a of Just v -> Just (f s v) Nothing -> Nothing - makePrinter s (CatchAll f) = Just (f s a) + makePrinter s (CatchAll f) = (f s a) -- | Run the basic printer for the given node without calling an -- extension hook for this node, but do allow extender hooks in child @@ -108,7 +109,7 @@ -- | Pretty print a comment. printComment :: ComInfo -> Printer () printComment (ComInfo (Comment inline _ str) own) = - do st <- sandbox (write "") + do (_,st) <- sandbox (write "") if own then newline else unless (psColumn st == 0) space @@ -207,6 +208,18 @@ then column col dependent else dependent +-- | Make the latter's indentation depend upon the end column of the +-- former. +dependBind :: Printer a -> (a -> Printer b) -> Printer b +dependBind maker dependent = + do state' <- get + v <- maker + st <- get + col <- gets psColumn + if state' /= st + then column col (dependent v) + else (dependent v) + -- | Wrap in parens. parens :: Printer a -> Printer a parens p = @@ -289,13 +302,13 @@ -- | Play with a printer and then restore the state to what it was -- before. sandbox :: MonadState s m - => m a -> m s + => m a -> m (a,s) sandbox p = do orig <- get - _ <- p + a <- p new <- get put orig - return new + return (a,new) -- | No binds? nullBinds :: Binds NodeInfo -> Bool 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 @@ -12,6 +12,8 @@ import HIndent.Pretty import HIndent.Types +import Control.Monad +import Control.Monad.Loops import Control.Monad.State.Class import Data.Int import Language.Haskell.Exts.Annotated.Syntax @@ -174,7 +176,7 @@ -- 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 "")) + do col <- fmap (psColumn . snd) (sandbox (write "")) infixApp e a op b (Just col) stmt _ e = prettyNoExt e @@ -190,27 +192,23 @@ -- If the head is short we depend, otherwise we swing. 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 <- isOverflowMax (spaced (map pretty args)) - if singleLiner && - ((headIsShort && flatish) || - all id flats) && - not overflow - then spaced (map pretty args) - else do allSingleLiners <- fmap (all id) - (mapM (isSingleLiner . pretty) args) - if headIsShort || allSingleLiners - then lined (map pretty args) - else do newline - indentSpaces <- getIndentSpaces - column (orig + indentSpaces) - (lined (map pretty args))) + dependBind + (do (short,st) <- isShort f + put st + space + return short) + (\headIsShort -> + do let flats = map isFlat args + flatish = + length (filter not flats) < + 2 + if (headIsShort && flatish) || + all id flats + then do ((singleLiner,overflow),st) <- sandboxNonOverflowing args + if singleLiner && not overflow + then put st + else multi orig args headIsShort + else multi orig args headIsShort) where (f,args) = flatten op [a] flatten :: Exp NodeInfo -> [Exp NodeInfo] @@ -242,70 +240,117 @@ Boxed -> ")")) where p = commas (map pretty exps) exp _ (List _ es) = - do single <- isSingleLiner p - underflow <- fmap not (isOverflow p) - if single && underflow - then p + do (ok,st) <- sandbox renderFlat + if ok + then put st else brackets (prefixedLined "," (map pretty es)) - where p = brackets (commas (map pretty es)) + where renderFlat = + do line <- gets psLine + brackets (commas (map pretty es)) + st <- get + columnLimit <- getColumnLimit + let overflow = psColumn st > columnLimit + single = psLine st == line + return (not overflow && single) exp _ e = prettyNoExt e -------------------------------------------------------------------------------- +-- Indentation helpers + +-- | Sandbox and render the nodes on multiple lines, returning whether +-- each is a single line. +sandboxSingles :: Pretty ast + => [ast NodeInfo] -> Printer (Bool,PrintState) +sandboxSingles args = + sandbox (allM (\(i,arg) -> + do when (i /= (0::Int)) newline + line <- gets psLine + pretty arg + st <- get + return (psLine st == line)) + (zip [0 ..] args)) + +-- | Render multi-line nodes. +multi :: Pretty ast + => Int64 -> [ast NodeInfo] -> Bool -> Printer () +multi orig args headIsShort = + if headIsShort + then lined (map pretty args) + else do (allAreSingle,st) <- sandboxSingles args + if allAreSingle + then put st + else do newline + indentSpaces <- getIndentSpaces + column (orig + indentSpaces) + (lined (map pretty args)) + +-- | Sandbox and render the node on a single line, return whether it's +-- on a single line and whether it's overflowing. +sandboxNonOverflowing :: Pretty ast + => [ast NodeInfo] -> Printer ((Bool,Bool),PrintState) +sandboxNonOverflowing args = + sandbox (do line <- gets psLine + columnLimit <- getColumnLimit + singleLineRender + st <- get + return (psLine st == line,psColumn st > columnLimit + 20)) + where singleLineRender = + spaced (map pretty args) + +-------------------------------------------------------------------------------- -- Predicates -- | Is the expression "short"? Used for app heads. isShort :: (Pretty ast) - => ast NodeInfo -> Printer Bool + => ast NodeInfo -> Printer (Bool,PrintState) isShort p = do line <- gets psLine - orig <- fmap psColumn (sandbox (write "")) - st <- sandbox (pretty p) + orig <- fmap (psColumn . snd) (sandbox (write "")) + (_,st) <- sandbox (pretty p) return (psLine st == line && - (psColumn st < orig + shortName)) + (psColumn st < orig + shortName),st) -- | Is the given expression "small"? I.e. does it fit on one line and -- under 'smallColumnLimit' columns. isSmall :: MonadState PrintState m - => m a -> m Bool + => m a -> m (Bool,PrintState) isSmall p = do line <- gets psLine - st <- sandbox p - return (psLine st == line && psColumn st < smallColumnLimit) + (_,st) <- sandbox p + return (psLine st == line && psColumn st < smallColumnLimit,st) -- | Is an expression flat? -isFlat :: Exp NodeInfo -> Printer Bool +isFlat :: Exp NodeInfo -> Bool isFlat (Lambda _ _ e) = isFlat e isFlat (App _ a b) = - return (isName a && isName b) + 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 a && isFlat 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 VarQuote{} = True +isFlat TypQuote{} = True +isFlat (List _ []) = True +isFlat Var{} = True +isFlat Lit{} = True +isFlat Con{} = True isFlat (LeftSection _ e _) = isFlat e isFlat (RightSection _ _ e) = isFlat e -isFlat _ = return False +isFlat _ = False -- | Does printing the given thing overflow column limit? (e.g. 80) isOverflow :: Printer a -> Printer Bool isOverflow p = - do st <- sandbox p + do (_,st) <- sandbox p columnLimit <- getColumnLimit return (psColumn st > columnLimit) -- | Does printing the given thing overflow column limit? (e.g. 80) isOverflowMax :: Printer a -> Printer Bool isOverflowMax p = - do st <- sandbox p + do (_,st) <- sandbox p columnLimit <- getColumnLimit return (psColumn st > columnLimit + 20) @@ -314,7 +359,7 @@ => m a -> m Bool isSingleLiner p = do line <- gets psLine - st <- sandbox p + (_,st) <- sandbox p return (psLine st == line) -------------------------------------------------------------------------------- @@ -328,7 +373,7 @@ -> Maybe Int64 -> Printer () infixApp e a op b indent = - do is <- isFlat e + do let is = isFlat e overflow <- isOverflow (depend (do pretty a space @@ -359,10 +404,12 @@ -> (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) + do if isFlat right + then renderDependent + else do (small,st) <- isSmall renderDependent + if small + then put st + else do left + newline + (f right) + where renderDependent = depend left (f right) diff --git a/src/HIndent/Styles/Fundamental.hs b/src/HIndent/Styles/Fundamental.hs --- a/src/HIndent/Styles/Fundamental.hs +++ b/src/HIndent/Styles/Fundamental.hs @@ -10,7 +10,7 @@ import HIndent.Types import Data.Default -import Prelude hiding (exp) + -- | Empty state. data State = 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 @@ -4,6 +4,12 @@ -- | Stub module for Johan Tibell's style. -- -- Documented here: +-- +-- Questions: +-- +-- How to indent after a guarded alt/rhs? +-- How to indent let? +-- How to indent large ADT constructors types? module HIndent.Styles.JohanTibell (johanTibell) @@ -289,7 +295,7 @@ -- | Does printing the given thing overflow column limit? (e.g. 80) isOverflow :: Printer a -> Printer Bool isOverflow p = - do st <- sandbox p + do (_,st) <- sandbox p columnLimit <- getColumnLimit return (psColumn st > columnLimit) @@ -298,16 +304,16 @@ => m a -> m Bool isSingleLiner p = do line <- gets psLine - st <- sandbox p + (_,st) <- sandbox p return (psLine st == line) -- | Is the expression "short"? Used for app heads. isShort :: (Pretty ast) - => ast NodeInfo -> Printer Bool + => ast NodeInfo -> Printer (Bool) isShort p = do line <- gets psLine - orig <- fmap psColumn (sandbox (write "")) - st <- sandbox (pretty p) + orig <- fmap (psColumn . snd) (sandbox (write "")) + (_,st) <- sandbox (pretty p) return (psLine st == line && (psColumn st < orig + shortName)) diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs --- a/src/HIndent/Types.hs +++ b/src/HIndent/Types.hs @@ -2,7 +2,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | All types. @@ -17,7 +16,8 @@ ,ComInfo(..)) where -import Control.Monad.State (MonadState(..),State) +import Control.Applicative +import Control.Monad.State.Strict (MonadState(..),State) import Data.Data import Data.Default import Data.Int (Int64) @@ -29,7 +29,7 @@ -- | A pretty printing monad. newtype Printer a = Printer {runPrinter :: State PrintState a} - deriving (Monad,Functor,MonadState PrintState) + deriving (Applicative,Monad,Functor,MonadState PrintState) -- | The state of the pretty printer. data PrintState = @@ -53,7 +53,7 @@ -- 'prettyNoExt' to fallback to the built-in printer. data Extender s where Extender :: forall s a. (Typeable a) => (s -> a -> Printer ()) -> Extender s - CatchAll :: forall s. (forall a. Typeable a => s -> a -> Printer ()) -> Extender s + CatchAll :: forall s. (forall a. Typeable a => s -> a -> Maybe (Printer ())) -> Extender s -- | A printer style. data Style =