hindent-5.3.4/elisp/0000755000000000000000000000000014261446771012472 5ustar0000000000000000hindent-5.3.4/src/0000755000000000000000000000000014261446771012145 5ustar0000000000000000hindent-5.3.4/src/HIndent/0000755000000000000000000000000014261446771013476 5ustar0000000000000000hindent-5.3.4/src/main/0000755000000000000000000000000014261456624013067 5ustar0000000000000000hindent-5.3.4/src/main/Path/0000755000000000000000000000000014261446771013765 5ustar0000000000000000hindent-5.3.4/src/HIndent.hs0000644000000000000000000003734014261446771014041 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings, ScopedTypeVariables, PatternGuards #-} -- | Haskell indenter. module HIndent (-- * Formatting functions. reformat ,prettyPrint ,parseMode -- * Testing ,test ,testFile ,testAst ,testFileAst ,defaultExtensions ,getExtensions ) where import Control.Monad.State.Strict import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Unsafe as S import Data.Char import Data.Foldable (foldr') import Data.Either import Data.Function import Data.Functor.Identity import Data.List import Data.Maybe import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Traversable hiding (mapM) import HIndent.CodeBlock import HIndent.Pretty import HIndent.Types import qualified Language.Haskell.Exts as Exts import Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) import Prelude -- | Format the given source. reformat :: Config -> Maybe [Extension] -> Maybe FilePath -> ByteString -> Either String Builder reformat config mexts mfilepath = preserveTrailingNewline (fmap (mconcat . intersperse "\n") . mapM processBlock . cppSplitBlocks) where processBlock :: CodeBlock -> Either String Builder processBlock (Shebang text) = Right $ S.byteString text processBlock (CPPDirectives text) = Right $ S.byteString text processBlock (HaskellSource line text) = let ls = S8.lines text prefix = findPrefix ls code = unlines' (map (stripPrefix prefix) ls) exts = readExtensions (UTF8.toString code) mode'' = case exts of Nothing -> mode' Just (Nothing, exts') -> mode' { extensions = exts' ++ configExtensions config ++ extensions mode' } Just (Just lang, exts') -> mode' { baseLanguage = lang , extensions = exts' ++ configExtensions config ++ extensions mode' } in case parseModuleWithComments mode'' (UTF8.toString code) of ParseOk (m, comments) -> fmap (S.lazyByteString . addPrefix prefix . S.toLazyByteString) (prettyPrint config m comments) ParseFailed loc e -> Left (Exts.prettyPrint (loc {srcLine = srcLine loc + line}) ++ ": " ++ e) unlines' = S.concat . intersperse "\n" unlines'' = L.concat . intersperse "\n" addPrefix :: ByteString -> L8.ByteString -> L8.ByteString addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines stripPrefix :: ByteString -> ByteString -> ByteString stripPrefix prefix line = if S.null (S8.dropWhile (== '\n') line) then line else fromMaybe (error "Missing expected prefix") . s8_stripPrefix prefix $ line findPrefix :: [ByteString] -> ByteString findPrefix = takePrefix False . findSmallestPrefix . dropNewlines dropNewlines :: [ByteString] -> [ByteString] dropNewlines = filter (not . S.null . S8.dropWhile (== '\n')) takePrefix :: Bool -> ByteString -> ByteString takePrefix bracketUsed txt = case S8.uncons txt of Nothing -> "" Just ('>', txt') -> if not bracketUsed then S8.cons '>' (takePrefix True txt') else "" Just (c, txt') -> if c == ' ' || c == '\t' then S8.cons c (takePrefix bracketUsed txt') else "" findSmallestPrefix :: [ByteString] -> ByteString findSmallestPrefix [] = "" findSmallestPrefix ("":_) = "" findSmallestPrefix (p:ps) = let first = S8.head p startsWithChar c x = S8.length x > 0 && S8.head x == c in if all (startsWithChar first) ps then S8.cons first (findSmallestPrefix (S.tail p : map S.tail ps)) else "" mode' = let m = case mexts of Just exts -> parseMode { extensions = exts } Nothing -> parseMode in m { parseFilename = fromMaybe "" mfilepath } preserveTrailingNewline f x = if S8.null x || S8.all isSpace x then return mempty else if hasTrailingLine x || configTrailingNewline config then fmap (\x' -> if hasTrailingLine (L.toStrict (S.toLazyByteString x')) then x' else x' <> "\n") (f x) else f x -- | Does the strict bytestring have a trailing newline? hasTrailingLine :: ByteString -> Bool hasTrailingLine xs = if S8.null xs then False else S8.last xs == '\n' -- | Print the module. prettyPrint :: Config -> Module SrcSpanInfo -> [Comment] -> Either a Builder prettyPrint config m comments = let ast = evalState (collectAllComments (fromMaybe m (applyFixities baseFixities m))) comments in Right (runPrinterStyle config (pretty ast)) -- | Pretty print the given printable thing. runPrinterStyle :: Config -> Printer () -> Builder runPrinterStyle config m = maybe (error "Printer failed with mzero call.") psOutput (runIdentity (runMaybeT (execStateT (runPrinter m) (PrintState { psIndentLevel = 0 , psOutput = mempty , psNewline = False , psColumn = 0 , psLine = 1 , psConfig = config , psInsideCase = False , psFitOnOneLine = False , psEolComment = False })))) -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode parseMode = defaultParseMode {extensions = allExtensions ,fixities = Nothing} where allExtensions = filter isDisabledExtension knownExtensions isDisabledExtension (DisableExtension _) = False isDisabledExtension _ = True -- | Test the given file. testFile :: FilePath -> IO () testFile fp = S.readFile fp >>= test -- | Test the given file. testFileAst :: FilePath -> IO () testFileAst fp = S.readFile fp >>= print . testAst -- | Test with the given style, prints to stdout. test :: ByteString -> IO () test = either error (L8.putStrLn . S.toLazyByteString) . reformat defaultConfig Nothing Nothing -- | Parse the source and annotate it with comments, yielding the resulting AST. testAst :: ByteString -> Either String (Module NodeInfo) testAst x = case parseModuleWithComments parseMode (UTF8.toString x) of ParseOk (m,comments) -> Right (let ast = evalState (collectAllComments (fromMaybe m (applyFixities baseFixities m))) comments in ast) ParseFailed _ e -> Left e -- | 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 ,PatternSynonyms -- steals the pattern keyword ,RecursiveDo -- steals the rec keyword ,DoRec -- same ,TypeApplications -- since GHC 8 and haskell-src-exts-1.19 ] s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString s8_stripPrefix bs1@(S.PS _ _ l1) bs2 | bs1 `S.isPrefixOf` bs2 = Just (S.unsafeDrop l1 bs2) | otherwise = Nothing -------------------------------------------------------------------------------- -- Extensions stuff stolen from hlint -- | Consume an extensions list from arguments. getExtensions :: [Text] -> [Extension] getExtensions = foldl f defaultExtensions . map T.unpack where f _ "Haskell98" = [] f a ('N':'o':x) | Just x' <- readExtension x = delete x' a f a x | Just x' <- readExtension x = x' : delete x' a f _ x = error $ "Unknown extension: " ++ x -------------------------------------------------------------------------------- -- Comments -- | Traverse the structure backwards. traverseInOrder :: (Monad m, Traversable t, Functor m) => (b -> b -> Ordering) -> (b -> m b) -> t b -> m (t b) traverseInOrder cmp f ast = do indexed <- fmap (zip [0 :: Integer ..] . reverse) (execStateT (traverse (modify . (:)) ast) []) let sorted = sortBy (\(_,x) (_,y) -> cmp x y) indexed results <- mapM (\(i,m) -> do v <- f m return (i, v)) sorted evalStateT (traverse (const (do i <- gets head modify tail case lookup i results of Nothing -> error "traverseInOrder" Just x -> return x)) ast) [0 ..] -- | Collect all comments in the module by traversing the tree. Read -- this from bottom to top. collectAllComments :: Module SrcSpanInfo -> State [Comment] (Module NodeInfo) collectAllComments = shortCircuit (traverseBackwards -- Finally, collect backwards comments which come after each node. (collectCommentsBy CommentAfterLine (\nodeSpan commentSpan -> fst (srcSpanStart commentSpan) >= fst (srcSpanEnd nodeSpan)))) <=< shortCircuit addCommentsToTopLevelWhereClauses <=< shortCircuit (traverse -- Collect forwards comments which start at the end line of a -- node: Does the start line of the comment match the end-line -- of the node? (collectCommentsBy CommentSameLine (\nodeSpan commentSpan -> fst (srcSpanStart commentSpan) == fst (srcSpanEnd nodeSpan)))) <=< shortCircuit (traverseBackwards -- Collect backwards comments which are on the same line as a -- node: Does the start line & end line of the comment match -- that of the node? (collectCommentsBy CommentSameLine (\nodeSpan commentSpan -> fst (srcSpanStart commentSpan) == fst (srcSpanStart nodeSpan) && fst (srcSpanStart commentSpan) == fst (srcSpanEnd nodeSpan)))) <=< shortCircuit (traverse -- First, collect forwards comments for declarations which both -- start on column 1 and occur before the declaration. (collectCommentsBy CommentBeforeLine (\nodeSpan commentSpan -> (snd (srcSpanStart nodeSpan) == 1 && snd (srcSpanStart commentSpan) == 1) && fst (srcSpanStart commentSpan) < fst (srcSpanStart nodeSpan)))) . fmap nodify where nodify s = NodeInfo s mempty -- Sort the comments by their end position. traverseBackwards = traverseInOrder (\x y -> on (flip compare) (srcSpanEnd . srcInfoSpan . nodeInfoSpan) x y) -- Stop traversing if all comments have been consumed. shortCircuit m v = do comments <- get if null comments then return v else m v -- | Collect comments by satisfying the given predicate, to collect a -- comment means to remove it from the pool of available comments in -- the State. This allows for a multiple pass approach. collectCommentsBy :: (SrcSpan -> SomeComment -> NodeComment) -> (SrcSpan -> SrcSpan -> Bool) -> NodeInfo -> State [Comment] NodeInfo collectCommentsBy cons predicate nodeInfo@(NodeInfo (SrcSpanInfo nodeSpan _) _) = do comments <- get let (others, mine) = partitionEithers (map (\comment@(Comment _ commentSpan _) -> if predicate nodeSpan commentSpan then Right comment else Left comment) comments) put others return $ addCommentsToNode cons mine nodeInfo -- | Reintroduce comments which were immediately above declarations in where clauses. -- Affects where clauses of top level declarations only. addCommentsToTopLevelWhereClauses :: Module NodeInfo -> State [Comment] (Module NodeInfo) addCommentsToTopLevelWhereClauses (Module x x' x'' x''' topLevelDecls) = Module x x' x'' x''' <$> traverse addCommentsToWhereClauses topLevelDecls where addCommentsToWhereClauses :: Decl NodeInfo -> State [Comment] (Decl NodeInfo) addCommentsToWhereClauses (PatBind x x' x'' (Just (BDecls x''' whereDecls))) = do newWhereDecls <- traverse addCommentsToPatBind whereDecls return $ PatBind x x' x'' (Just (BDecls x''' newWhereDecls)) addCommentsToWhereClauses other = return other addCommentsToPatBind :: Decl NodeInfo -> State [Comment] (Decl NodeInfo) addCommentsToPatBind (PatBind bindInfo (PVar x (Ident declNodeInfo declString)) x' x'') = do bindInfoWithComments <- addCommentsBeforeNode bindInfo return $ PatBind bindInfoWithComments (PVar x (Ident declNodeInfo declString)) x' x'' addCommentsToPatBind other = return other addCommentsBeforeNode :: NodeInfo -> State [Comment] NodeInfo addCommentsBeforeNode nodeInfo = do comments <- get let (notAbove, above) = partitionAboveNotAbove comments nodeInfo put notAbove return $ addCommentsToNode CommentBeforeLine above nodeInfo partitionAboveNotAbove :: [Comment] -> NodeInfo -> ([Comment], [Comment]) partitionAboveNotAbove cs (NodeInfo (SrcSpanInfo nodeSpan _) _) = fst $ foldr' (\comment@(Comment _ commentSpan _) ((ls, rs), lastSpan) -> if comment `isAbove` lastSpan then ((ls, comment : rs), commentSpan) else ((comment : ls, rs), lastSpan)) (([], []), nodeSpan) cs isAbove :: Comment -> SrcSpan -> Bool isAbove (Comment _ commentSpan _) span = let (_, commentColStart) = srcSpanStart commentSpan (commentLnEnd, _) = srcSpanEnd commentSpan (lnStart, colStart) = srcSpanStart span in commentColStart == colStart && commentLnEnd + 1 == lnStart addCommentsToTopLevelWhereClauses other = return other addCommentsToNode :: (SrcSpan -> SomeComment -> NodeComment) -> [Comment] -> NodeInfo -> NodeInfo addCommentsToNode mkNodeComment newComments nodeInfo@(NodeInfo (SrcSpanInfo _ _) existingComments) = nodeInfo {nodeInfoComments = existingComments <> map mkBeforeNodeComment newComments} where mkBeforeNodeComment :: Comment -> NodeComment mkBeforeNodeComment (Comment multiLine commentSpan commentString) = mkNodeComment commentSpan ((if multiLine then MultiLine else EndOfLine) commentString) hindent-5.3.4/src/HIndent/Types.hs0000644000000000000000000001063714261446771015145 0ustar0000000000000000{-# OPTIONS_GHC -cpp #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} -- | All types. module HIndent.Types (Printer(..) ,PrintState(..) ,Config(..) ,readExtension ,defaultConfig ,NodeInfo(..) ,NodeComment(..) ,SomeComment(..) ) where import Control.Applicative import Control.Monad import Control.Monad.State.Strict (MonadState(..),StateT) import Control.Monad.Trans.Maybe import Data.ByteString.Builder import Data.Functor.Identity import Data.Int (Int64) import Data.Maybe import Data.Yaml (FromJSON(..)) import qualified Data.Yaml as Y import Language.Haskell.Exts hiding (Style, prettyPrint, Pretty, style, parse) -- | A pretty printing monad. newtype Printer a = Printer {runPrinter :: StateT PrintState (MaybeT Identity) a} deriving (Applicative,Monad,Functor,MonadState PrintState,MonadPlus,Alternative) -- | The state of the pretty printer. data PrintState = PrintState { psIndentLevel :: !Int64 -- ^ Current indentation level, i.e. every time there's a -- new-line, output this many spaces. , psOutput :: !Builder -- ^ The current output bytestring builder. , psNewline :: !Bool -- ^ Just outputted a newline? , psColumn :: !Int64 -- ^ Current column. , psLine :: !Int64 -- ^ Current line number. , psConfig :: !Config -- ^ Configuration of max colums and indentation style. , psInsideCase :: !Bool -- ^ Whether we're in a case statement, used for Rhs printing. , psFitOnOneLine :: !Bool -- ^ Bail out if we need to print beyond the current line or -- the maximum column. , psEolComment :: !Bool } -- | 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? , configTrailingNewline :: !Bool -- ^ End with a newline. , configSortImports :: !Bool -- ^ Sort imports in groups. , configLineBreaks :: [String] -- ^ Break line when meets these operators. , configExtensions :: [Extension] -- ^ Extra language extensions enabled by default. } -- | Parse an extension. #if __GLASGOW_HASKELL__ >= 808 readExtension :: (Monad m, MonadFail m) => String -> m Extension #else readExtension :: Monad m => String -> m Extension #endif readExtension x = case classifyExtension x -- Foo of UnknownExtension _ -> fail ("Unknown extension: " ++ x) x' -> return x' instance FromJSON Config where parseJSON (Y.Object v) = Config <$> fmap (fromMaybe (configMaxColumns defaultConfig)) (v Y..:? "line-length") <*> fmap (fromMaybe (configIndentSpaces defaultConfig)) (v Y..:? "indent-size" <|> v Y..:? "tab-size") <*> fmap (fromMaybe (configTrailingNewline defaultConfig)) (v Y..:? "force-trailing-newline") <*> fmap (fromMaybe (configSortImports defaultConfig)) (v Y..:? "sort-imports") <*> fmap (fromMaybe (configLineBreaks defaultConfig)) (v Y..:? "line-breaks") <*> (traverse readExtension =<< fmap (fromMaybe []) (v Y..:? "extensions")) parseJSON _ = fail "Expected Object for Config value" -- | Default style configuration. defaultConfig :: Config defaultConfig = Config { configMaxColumns = 80 , configIndentSpaces = 2 , configTrailingNewline = True , configSortImports = True , configLineBreaks = [] , configExtensions = [] } -- | Some comment to print. data SomeComment = EndOfLine String | MultiLine String deriving (Show, Ord, Eq) -- | Comment associated with a node. -- 'SrcSpan' is the original source span of the comment. data NodeComment = CommentSameLine SrcSpan SomeComment | CommentAfterLine SrcSpan SomeComment | CommentBeforeLine SrcSpan SomeComment deriving (Show, Ord, Eq) -- | Information for each node in the AST. data NodeInfo = NodeInfo { nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser. , nodeInfoComments :: ![NodeComment] -- ^ Comments attached to this node. } instance Show NodeInfo where show (NodeInfo _ []) = "" show (NodeInfo _ s) = "{- " ++ show s ++ " -}" hindent-5.3.4/src/HIndent/Pretty.hs0000644000000000000000000020357514261446771015335 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} -- | Pretty printing. module HIndent.Pretty (pretty) where import Control.Applicative import Control.Monad.State.Strict hiding (state) import qualified Data.ByteString.Builder as S import Data.Foldable (for_, forM_, traverse_) import Data.Int import Data.List import Data.Maybe import Data.Monoid ((<>)) import Data.Typeable import HIndent.Types import qualified Language.Haskell.Exts as P import Language.Haskell.Exts.SrcLoc import Language.Haskell.Exts.Syntax import Prelude hiding (exp) -------------------------------------------------------------------------------- -- * Pretty printing class -- | Pretty printing class. class (Annotated ast,Typeable ast) => Pretty ast where prettyInternal :: ast NodeInfo -> Printer () -- | Pretty print including comments. pretty :: (Pretty ast,Show (ast NodeInfo)) => ast NodeInfo -> Printer () pretty a = do mapM_ (\c' -> do case c' of CommentBeforeLine _ c -> do case c of EndOfLine s -> write ("--" ++ s) MultiLine s -> write ("{-" ++ s ++ "-}") newline _ -> return ()) comments prettyInternal a mapM_ (\(i, c') -> do case c' of CommentSameLine spn c -> do col <- gets psColumn if col == 0 then do -- write comment keeping original indentation let col' = fromIntegral $ srcSpanStartColumn spn - 1 column col' $ writeComment c else do space writeComment c CommentAfterLine spn c -> do when (i == 0) newline -- write comment keeping original indentation let col = fromIntegral $ srcSpanStartColumn spn - 1 column col $ writeComment c _ -> return ()) (zip [0 :: Int ..] comments) where comments = nodeInfoComments (ann a) writeComment = \case EndOfLine cs -> do write ("--" ++ cs) modify (\s -> s { psEolComment = True }) MultiLine cs -> do write ("{-" ++ cs ++ "-}") modify (\s -> s { psEolComment = True }) -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's. pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo)) => ast NodeInfo -> Printer () pretty' = write . P.prettyPrint . fmap nodeInfoSpan -------------------------------------------------------------------------------- -- * Combinators -- | Increase indentation level by n spaces for the given printer. indented :: Int64 -> Printer a -> Printer a indented i p = do level <- gets psIndentLevel modify (\s -> s {psIndentLevel = level + i}) m <- p modify (\s -> s {psIndentLevel = level}) return m indentedBlock :: Printer a -> Printer a indentedBlock p = do indentSpaces <- getIndentSpaces indented indentSpaces p -- | Print all the printers separated by spaces. spaced :: [Printer ()] -> Printer () spaced = inter space -- | Print all the printers separated by commas. commas :: [Printer ()] -> Printer () commas = inter (write ", ") -- | Print all the printers separated by sep. inter :: Printer () -> [Printer ()] -> Printer () inter sep ps = foldr (\(i,p) next -> depend (do p if i < length ps then sep else return ()) next) (return ()) (zip [1 ..] ps) -- | Print all the printers separated by newlines. lined :: [Printer ()] -> Printer () lined ps = sequence_ (intersperse newline ps) -- | Print all the printers separated newlines and optionally a line -- prefix. prefixedLined :: String -> [Printer ()] -> Printer () prefixedLined pref ps' = case ps' of [] -> return () (p:ps) -> do p indented (fromIntegral (length pref * (-1))) (mapM_ (\p' -> do newline depend (write pref) p') ps) -- | Set the (newline-) indent level to the given column for the given -- printer. column :: Int64 -> Printer a -> Printer a column i p = do level <- gets psIndentLevel modify (\s -> s {psIndentLevel = i}) m <- p modify (\s -> s {psIndentLevel = level}) return m -- | Output a newline. newline :: Printer () newline = do write "\n" modify (\s -> s {psNewline = True}) -- | Set the context to a case context, where RHS is printed with -> . withCaseContext :: Bool -> Printer a -> Printer a withCaseContext bool pr = do original <- gets psInsideCase modify (\s -> s {psInsideCase = bool}) result <- pr modify (\s -> s {psInsideCase = original}) return result -- | Get the current RHS separator, either = or -> . rhsSeparator :: Printer () rhsSeparator = do inCase <- gets psInsideCase if inCase then write "->" else write "=" -- | Make the latter's indentation depend upon the end column of the -- former. depend :: Printer () -> Printer b -> Printer b depend maker dependent = do state' <- get maker st <- get col <- gets psColumn if psLine state' /= psLine st || psColumn state' /= psColumn st then column col dependent else dependent -- | Wrap. wrap :: String -> String -> Printer a -> Printer a wrap open close p = depend (write open) $ p <* write close -- | Wrap in parens. parens :: Printer a -> Printer a parens = wrap "(" ")" -- | Wrap in braces. braces :: Printer a -> Printer a braces = wrap "{" "}" -- | Wrap in brackets. brackets :: Printer a -> Printer a brackets = wrap "[" "]" -- | Write a space. space :: Printer () space = write " " -- | Write a comma. comma :: Printer () comma = write "," -- | Write an integral. int :: Integer -> Printer () int = write . show -- | Write out a string, updating the current position information. write :: String -> Printer () write x = do eol <- gets psEolComment hardFail <- gets psFitOnOneLine let addingNewline = eol && x /= "\n" when addingNewline newline state <- get let writingNewline = x == "\n" out :: String out = if psNewline state && not writingNewline then (replicate (fromIntegral (psIndentLevel state)) ' ') <> x else x psColumn' = if additionalLines > 0 then fromIntegral (length (concat (take 1 (reverse srclines)))) else psColumn state + fromIntegral (length out) when hardFail (guard (additionalLines == 0 && (psColumn' <= configMaxColumns (psConfig state)))) modify (\s -> s {psOutput = psOutput state <> S.stringUtf8 out ,psNewline = False ,psLine = psLine state + fromIntegral additionalLines ,psEolComment= False ,psColumn = psColumn'}) where srclines = lines x additionalLines = length (filter (== '\n') x) -- | Write a string. string :: String -> Printer () string = write -- | Indent spaces, e.g. 2. getIndentSpaces :: Printer Int64 getIndentSpaces = gets (configIndentSpaces . psConfig) -- | Play with a printer and then restore the state to what it was -- before. sandbox :: Printer a -> Printer (a,PrintState) sandbox p = do orig <- get a <- p new <- get put orig return (a,new) -- | Render a type with a context, or not. withCtx :: (Pretty ast,Show (ast NodeInfo)) => Maybe (ast NodeInfo) -> Printer b -> Printer b withCtx Nothing m = m withCtx (Just ctx) m = do pretty ctx write " =>" newline m -- | Maybe render an overlap definition. maybeOverlap :: Maybe (Overlap NodeInfo) -> Printer () maybeOverlap = maybe (return ()) (\p -> pretty p >> space) -- | Swing the second printer below and indented with respect to the first. swing :: Printer () -> Printer b -> Printer () swing a b = do orig <- gets psIndentLevel a mst <- fitsOnOneLine (do space b) case mst of Just st -> put st Nothing -> do newline indentSpaces <- getIndentSpaces _ <- column (orig + indentSpaces) b return () -- | Swing the second printer below and indented with respect to the first by -- the specified amount. swingBy :: Int64 -> Printer() -> Printer b -> Printer b swingBy i a b = do orig <- gets psIndentLevel a newline column (orig + i) b -------------------------------------------------------------------------------- -- * Instances instance Pretty Context where prettyInternal ctx@(CxTuple _ asserts) = do mst <- fitsOnOneLine (parens (inter (comma >> space) (map pretty asserts))) case mst of Nothing -> context ctx Just st -> put st prettyInternal ctx = context ctx instance Pretty Pat where prettyInternal x = case x of PLit _ sign l -> pretty sign >> pretty l PNPlusK _ n k -> depend (do pretty n write "+") (int k) PInfixApp _ a op b -> case op of Special{} -> depend (pretty a) (depend (prettyInfixOp op) (pretty b)) _ -> depend (do pretty a space) (depend (do prettyInfixOp op space) (pretty b)) PApp _ f args -> depend (do pretty f unless (null args) space) (spaced (map pretty args)) PTuple _ boxed pats -> depend (write (case boxed of Unboxed -> "(# " Boxed -> "(")) (do commas (map pretty pats) write (case boxed of Unboxed -> " #)" Boxed -> ")")) PList _ ps -> brackets (commas (map pretty ps)) PParen _ e -> parens (pretty e) PRec _ qname fields -> do let horVariant = do pretty qname space braces $ commas $ map pretty fields verVariant = depend (pretty qname >> space) $ do case fields of [] -> write "{}" [field] -> braces $ pretty field _ -> do depend (write "{") $ prefixedLined "," $ map (depend space . pretty) fields newline write "}" horVariant `ifFitsOnOneLineOrElse` verVariant PAsPat _ n p -> depend (do pretty n write "@") (pretty p) PWildCard _ -> write "_" PIrrPat _ p -> depend (write "~") (pretty p) PatTypeSig _ p ty -> depend (do pretty p write " :: ") (pretty ty) PViewPat _ e p -> depend (do pretty e write " -> ") (pretty p) PQuasiQuote _ name str -> quotation name (string str) PBangPat _ p -> depend (write "!") (pretty p) PRPat{} -> pretty' x PXTag{} -> pretty' x PXETag{} -> pretty' x PXPcdata{} -> pretty' x PXPatTag{} -> pretty' x PXRPats{} -> pretty' x PVar{} -> pretty' x PSplice _ s -> pretty s -- | Pretty infix application of a name (identifier or symbol). prettyInfixName :: Name NodeInfo -> Printer () prettyInfixName (Ident _ n) = do write "`"; string n; write "`"; prettyInfixName (Symbol _ s) = string s -- | Pretty print a name for being an infix operator. prettyInfixOp :: QName NodeInfo -> Printer () prettyInfixOp x = case x of Qual _ mn n -> case n of Ident _ i -> do write "`"; pretty mn; write "."; string i; write "`"; Symbol _ s -> do pretty mn; write "."; string s; UnQual _ n -> prettyInfixName n Special _ s -> pretty s prettyQuoteName :: Name NodeInfo -> Printer () prettyQuoteName x = case x of Ident _ i -> string i Symbol _ s -> string ("(" ++ s ++ ")") instance Pretty Type where prettyInternal = typ instance Pretty Exp where prettyInternal = exp -- | Render an expression. exp :: Exp NodeInfo -> Printer () -- | Do after lambda should swing. exp (Lambda _ pats (Do l stmts)) = do mst <- fitsOnOneLine (do write "\\" spaced (map pretty pats) write " -> " pretty (Do l stmts)) case mst of Nothing -> swing (do write "\\" spaced (map pretty pats) write " -> do") (lined (map pretty stmts)) Just st -> put st -- | Space out tuples. exp (Tuple _ boxed exps) = do let horVariant = parensHorB boxed $ inter (write ", ") (map pretty exps) verVariant = parensVerB boxed $ prefixedLined "," (map (depend space . pretty) exps) mst <- fitsOnOneLine horVariant case mst of Nothing -> verVariant Just st -> put st where parensHorB Boxed = parens parensHorB Unboxed = wrap "(# " " #)" parensVerB Boxed = parens parensVerB Unboxed = wrap "(#" "#)" -- | Space out tuples. exp (TupleSection _ boxed mexps) = do let horVariant = parensHorB boxed $ inter (write ", ") (map (maybe (return ()) pretty) mexps) verVariant = parensVerB boxed $ prefixedLined "," (map (maybe (return ()) (depend space . pretty)) mexps) mst <- fitsOnOneLine horVariant case mst of Nothing -> verVariant Just st -> put st where parensHorB Boxed = parens parensHorB Unboxed = wrap "(# " " #)" parensVerB Boxed = parens parensVerB Unboxed = wrap "(#" "#)" exp (UnboxedSum{}) = error "FIXME: No implementation for UnboxedSum." -- | 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 str e = case e of Do _ stmts -> do write str write "do" newline indentSpaces <- getIndentSpaces indented indentSpaces (lined (map pretty stmts)) _ -> depend (write str) (pretty e) -- | Render on one line, or otherwise render the op with the arguments -- listed line by line. exp (App _ op arg) = do let flattened = flatten op ++ [arg] mst <- fitsOnOneLine (spaced (map pretty flattened)) case mst of Nothing -> do let (f:args) = flattened col <- gets psColumn spaces <- getIndentSpaces pretty f col' <- gets psColumn let diff = col' - col - if col == 0 then spaces else 0 if diff + 1 <= spaces then space else newline spaces' <- getIndentSpaces indented spaces' (lined (map pretty args)) Just st -> put st where flatten (App label' op' arg') = flatten op' ++ [amap (addComments label') arg'] flatten x = [x] addComments n1 n2 = n2 { nodeInfoComments = nub (nodeInfoComments n2 ++ nodeInfoComments n1) } -- | Space out commas in list. exp (List _ es) = do mst <- fitsOnOneLine p case mst of Nothing -> do depend (write "[") (prefixedLined "," (map (depend space . pretty) es)) newline write "]" Just st -> put st where p = brackets (inter (write ", ") (map pretty es)) exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates exp (Let _ binds e) = depend (write "let ") (do pretty binds newline indented (-3) (depend (write "in ") (pretty e))) exp (ListComp _ e qstmt) = do let horVariant = brackets $ do pretty e write " | " commas $ map pretty qstmt verVariant = do write "[ " pretty e newline depend (write "| ") $ prefixedLined ", " $ map pretty qstmt newline write "]" horVariant `ifFitsOnOneLineOrElse` verVariant exp (ParComp _ e qstmts) = do let horVariant = brackets $ do pretty e for_ qstmts $ \qstmt -> do write " | " commas $ map pretty qstmt verVariant = do depend (write "[ ") $ pretty e newline for_ qstmts $ \qstmt -> do depend (write "| ") $ prefixedLined ", " $ map pretty qstmt newline write "]" horVariant `ifFitsOnOneLineOrElse` verVariant exp (TypeApp _ t) = do write "@" pretty t exp (NegApp _ e) = depend (write "-") (pretty e) exp (Lambda _ ps e) = do write "\\" spaced [ do case (i, x) of (0, PIrrPat {}) -> space (0, PBangPat {}) -> space _ -> return () pretty x | (i, x) <- zip [0 :: Int ..] ps ] swing (write " ->") $ pretty e exp (Paren _ e) = parens (pretty e) exp (Case _ e alts) = do depend (write "case ") (do pretty e write " of") if null alts then write " {}" else do newline indentedBlock (lined (map (withCaseContext True . pretty) alts)) exp (Do _ stmts) = depend (write "do ") (lined (map pretty stmts)) exp (MDo _ stmts) = depend (write "mdo ") (lined (map pretty stmts)) exp (LeftSection _ e op) = parens (depend (do pretty e space) (pretty op)) exp (RightSection _ e op) = parens (depend (do pretty e space) (pretty op)) exp (EnumFrom _ e) = brackets (do pretty e write " ..") exp (EnumFromTo _ e f) = brackets (depend (do pretty e write " .. ") (pretty f)) exp (EnumFromThen _ e t) = brackets (depend (do pretty e write ",") (do pretty t write " ..")) exp (EnumFromThenTo _ e t f) = brackets (depend (do pretty e write ",") (depend (do pretty t write " .. ") (pretty f))) exp (ExpTypeSig _ e t) = depend (do pretty e write " :: ") (pretty t) exp (VarQuote _ x) = depend (write "'") (pretty x) exp (TypQuote _ x) = depend (write "''") (pretty x) exp (BracketExp _ b) = pretty b exp (SpliceExp _ s) = pretty s exp (QuasiQuote _ n s) = quotation n (string s) exp (LCase _ alts) = do write "\\case" if null alts then write " {}" else do newline indentedBlock (lined (map (withCaseContext True . pretty) alts)) exp (MultiIf _ alts) = withCaseContext True (depend (write "if ") (lined (map (\p -> do write "| " prettyG p) alts))) where prettyG (GuardedRhs _ stmts e) = do indented 1 (do (lined (map (\(i,p) -> do unless (i == 1) space pretty p unless (i == length stmts) (write ",")) (zip [1..] stmts)))) swing (write " " >> rhsSeparator) (pretty e) exp (Lit _ lit) = prettyInternal lit exp (Var _ q) = pretty q exp (IPVar _ q) = pretty q exp (Con _ q) = pretty q exp x@XTag{} = pretty' x exp x@XETag{} = pretty' x exp x@XPcdata{} = pretty' x exp x@XExpTag{} = pretty' x exp x@XChildTag{} = pretty' x exp x@CorePragma{} = pretty' x exp x@SCCPragma{} = pretty' x exp x@GenPragma{} = pretty' x exp x@Proc{} = pretty' x exp x@LeftArrApp{} = pretty' x exp x@RightArrApp{} = pretty' x exp x@LeftArrHighApp{} = pretty' x exp x@RightArrHighApp{} = pretty' x exp x@ParArray{} = pretty' x exp x@ParArrayFromTo{} = pretty' x exp x@ParArrayFromThenTo{} = pretty' x exp x@ParArrayComp{} = pretty' x exp (OverloadedLabel _ label) = string ('#' : label) instance Pretty IPName where prettyInternal = pretty' instance Pretty Stmt where prettyInternal = stmt instance Pretty QualStmt where prettyInternal x = case x of QualStmt _ s -> pretty s ThenTrans _ s -> do write "then " pretty s ThenBy _ s t -> do write "then " pretty s write " by " pretty t GroupBy _ s -> do write "then group by " pretty s GroupUsing _ s -> do write "then group using " pretty s GroupByUsing _ s t -> do write "then group by " pretty s write " using " pretty t instance Pretty Decl where prettyInternal = decl' -- | Render a declaration. decl :: Decl NodeInfo -> Printer () decl (InstDecl _ moverlap dhead decls) = do depend (write "instance ") (depend (maybeOverlap moverlap) (depend (pretty dhead) (unless (null (fromMaybe [] decls)) (write " where")))) unless (null (fromMaybe [] decls)) (do newline indentedBlock (lined (map pretty (fromMaybe [] decls)))) decl (SpliceDecl _ e) = pretty e decl (TypeSig _ names ty) = depend (do inter (write ", ") (map pretty names) write " :: ") (pretty ty) decl (FunBind _ matches) = lined (map pretty matches) decl (ClassDecl _ ctx dhead fundeps decls) = do classHead ctx dhead fundeps decls unless (null (fromMaybe [] decls)) (do newline indentedBlock (lined (map pretty (fromMaybe [] decls)))) decl (TypeDecl _ typehead typ') = do write "type " pretty typehead ifFitsOnOneLineOrElse (depend (write " = ") (pretty typ')) (do newline indentedBlock (depend (write " = ") (pretty typ'))) decl (TypeFamDecl _ declhead result injectivity) = do write "type family " pretty declhead case result of Just r -> do space let sep = case r of KindSig _ _ -> "::" TyVarSig _ _ -> "=" write sep space pretty r Nothing -> return () case injectivity of Just i -> do space pretty i Nothing -> return () decl (ClosedTypeFamDecl _ declhead result injectivity instances) = do write "type family " pretty declhead for_ result $ \r -> do space let sep = case r of KindSig _ _ -> "::" TyVarSig _ _ -> "=" write sep space pretty r for_ injectivity $ \i -> do space pretty i space write "where" newline indentedBlock (lined (map pretty instances)) decl (DataDecl _ dataornew ctx dhead condecls mderivs) = do depend (do pretty dataornew space) (withCtx ctx (do pretty dhead case condecls of [] -> return () [x] -> singleCons x xs -> multiCons xs)) indentSpaces <- getIndentSpaces forM_ mderivs $ \deriv -> newline >> column indentSpaces (pretty deriv) where singleCons x = do write " =" indentSpaces <- getIndentSpaces column indentSpaces (do newline pretty x) multiCons xs = do newline indentSpaces <- getIndentSpaces column indentSpaces (depend (write "=") (prefixedLined "|" (map (depend space . pretty) xs))) decl (GDataDecl _ dataornew ctx dhead mkind condecls mderivs) = do depend (pretty dataornew >> space) (withCtx ctx (do pretty dhead case mkind of Nothing -> return () Just kind -> do write " :: " pretty kind write " where")) indentedBlock $ do case condecls of [] -> return () _ -> do newline lined (map pretty condecls) forM_ mderivs $ \deriv -> newline >> pretty deriv decl (InlineSig _ inline active name) = do write "{-# " unless inline $ write "NO" write "INLINE " case active of Nothing -> return () Just (ActiveFrom _ x) -> write ("[" ++ show x ++ "] ") Just (ActiveUntil _ x) -> write ("[~" ++ show x ++ "] ") pretty name write " #-}" decl (MinimalPragma _ (Just formula)) = wrap "{-# " " #-}" $ do depend (write "MINIMAL ") $ pretty formula decl (ForImp _ callconv maybeSafety maybeName name ty) = do string "foreign import " pretty' callconv >> space case maybeSafety of Just safety -> pretty' safety >> space Nothing -> return () case maybeName of Just namestr -> string (show namestr) >> space Nothing -> return () pretty' name tyline <- fitsOnOneLine $ do string " :: " pretty' ty case tyline of Just line -> put line Nothing -> do newline indentedBlock $ do string ":: " pretty' ty decl (ForExp _ callconv maybeName name ty) = do string "foreign export " pretty' callconv >> space case maybeName of Just namestr -> string (show namestr) >> space Nothing -> return () pretty' name tyline <- fitsOnOneLine $ do string " :: " pretty' ty case tyline of Just line -> put line Nothing -> do newline indentedBlock $ do string ":: " pretty' ty decl x' = pretty' x' classHead :: Maybe (Context NodeInfo) -> DeclHead NodeInfo -> [FunDep NodeInfo] -> Maybe [ClassDecl NodeInfo] -> Printer () classHead ctx dhead fundeps decls = shortHead `ifFitsOnOneLineOrElse` longHead where shortHead = depend (write "class ") (withCtx ctx $ depend (pretty dhead) (depend (unless (null fundeps) (write " | " >> commas (map pretty fundeps))) (unless (null (fromMaybe [] decls)) (write " where")))) longHead = do depend (write "class ") (withCtx ctx $ pretty dhead) newline indentedBlock $ do unless (null fundeps) $ do depend (write "| ") (prefixedLined ", " $ map pretty fundeps) newline unless (null (fromMaybe [] decls)) (write "where") instance Pretty TypeEqn where prettyInternal (TypeEqn _ in_ out_) = do pretty in_ write " = " pretty out_ instance Pretty Deriving where prettyInternal (Deriving _ strategy heads) = depend (write "deriving" >> space >> writeStrategy) $ do let heads' = if length heads == 1 then map stripParens heads else heads maybeDerives <- fitsOnOneLine $ parens (commas (map pretty heads')) case maybeDerives of Nothing -> formatMultiLine heads' Just derives -> put derives where writeStrategy = case strategy of Nothing -> return () Just st -> pretty st >> space stripParens (IParen _ iRule) = stripParens iRule stripParens x = x formatMultiLine derives = do depend (write "( ") $ prefixedLined ", " (map pretty derives) newline write ")" instance Pretty DerivStrategy where prettyInternal x = case x of DerivStock _ -> return () DerivAnyclass _ -> write "anyclass" DerivNewtype _ -> write "newtype" instance Pretty Alt where prettyInternal x = case x of Alt _ p galts mbinds -> do pretty p pretty galts case mbinds of Nothing -> return () Just binds -> do newline indentedBlock (depend (write "where ") (pretty binds)) instance Pretty Asst where prettyInternal x = case x of IParam _ name ty -> do pretty name write " :: " pretty ty ParenA _ asst -> parens (pretty asst) #if MIN_VERSION_haskell_src_exts(1,21,0) TypeA _ ty -> pretty ty #else ClassA _ name types -> spaced (pretty name : map pretty types) i@InfixA {} -> pretty' i EqualP _ a b -> do pretty a write " ~ " pretty b AppA _ name tys -> spaced (pretty name : map pretty tys) WildCardA _ name -> case name of Nothing -> write "_" Just n -> do write "_" pretty n #endif instance Pretty BangType where prettyInternal x = case x of BangedTy _ -> write "!" LazyTy _ -> write "~" NoStrictAnnot _ -> return () instance Pretty Unpackedness where prettyInternal (Unpack _) = write "{-# UNPACK #-}" prettyInternal (NoUnpack _) = write "{-# NOUNPACK #-}" prettyInternal (NoUnpackPragma _) = return () instance Pretty Binds where prettyInternal x = case x of BDecls _ ds -> lined (map pretty ds) IPBinds _ i -> lined (map pretty i) instance Pretty ClassDecl where prettyInternal x = case x of ClsDecl _ d -> pretty d ClsDataFam _ ctx h mkind -> depend (write "data ") (withCtx ctx (do pretty h (case mkind of Nothing -> return () Just kind -> do write " :: " pretty kind))) ClsTyFam _ h msig minj -> depend (write "type ") (depend (pretty h) (depend (traverse_ (\case KindSig _ kind -> write " :: " >> pretty kind TyVarSig _ tyVarBind -> write " = " >> pretty tyVarBind) msig) (traverse_ (\inj -> space >> pretty inj) minj))) ClsTyDef _ (TypeEqn _ this that) -> do write "type " pretty this write " = " pretty that ClsDefSig _ name ty -> do write "default " pretty name write " :: " pretty ty instance Pretty ConDecl where prettyInternal x = conDecl x instance Pretty FieldDecl where prettyInternal (FieldDecl _ names ty) = depend (do commas (map pretty names) write " :: ") (pretty ty) instance Pretty FieldUpdate where prettyInternal x = case x of FieldUpdate _ n e -> swing (do pretty n write " =") (pretty e) FieldPun _ n -> pretty n FieldWildcard _ -> write ".." instance Pretty GuardedRhs where prettyInternal = guardedRhs instance Pretty InjectivityInfo where prettyInternal x = pretty' x instance Pretty InstDecl where prettyInternal i = case i of InsDecl _ d -> pretty d InsType _ name ty -> depend (do write "type " pretty name write " = ") (pretty ty) _ -> pretty' i instance Pretty Match where prettyInternal = match {-case x of Match _ name pats rhs' mbinds -> do depend (do pretty name space) (spaced (map pretty pats)) withCaseContext False (pretty rhs') case mbinds of Nothing -> return () Just binds -> do newline indentedBlock (depend (write "where ") (pretty binds)) InfixMatch _ pat1 name pats rhs' mbinds -> do depend (do pretty pat1 space prettyInfixName name) (do space spaced (map pretty pats)) withCaseContext False (pretty rhs') case mbinds of Nothing -> return () Just binds -> do newline indentedBlock (depend (write "where ") (pretty binds))-} instance Pretty PatField where prettyInternal x = case x of PFieldPat _ n p -> depend (do pretty n write " = ") (pretty p) PFieldPun _ n -> pretty n PFieldWildcard _ -> write ".." instance Pretty QualConDecl where prettyInternal x = case x of QualConDecl _ tyvars ctx d -> depend (unless (null (fromMaybe [] tyvars)) (do write "forall " spaced (map pretty (reverse (fromMaybe [] tyvars))) write ". ")) (withCtx ctx (pretty d)) instance Pretty GadtDecl where #if MIN_VERSION_haskell_src_exts(1,21,0) prettyInternal (GadtDecl _ name _ _ fields t) = #else prettyInternal (GadtDecl _ name fields t) = #endif horVar `ifFitsOnOneLineOrElse` verVar where fields' p = case fromMaybe [] fields of [] -> return () fs -> do depend (write "{") $ do prefixedLined "," (map (depend space . pretty) fs) write "}" p horVar = depend (pretty name >> write " :: ") $ do fields' (write " -> ") declTy t verVar = do pretty name newline indentedBlock $ depend (write ":: ") $ do fields' $ do newline indented (-3) (write "-> ") declTy t instance Pretty Rhs where prettyInternal = rhs instance Pretty Splice where prettyInternal x = case x of IdSplice _ str -> do write "$" string str ParenSplice _ e -> depend (write "$") (parens (pretty e)) instance Pretty InstRule where prettyInternal (IParen _ rule) = parens $ pretty rule prettyInternal (IRule _ mvarbinds mctx ihead) = do case mvarbinds of Nothing -> return () Just xs -> do write "forall " spaced (map pretty xs) write ". " case mctx of Nothing -> pretty ihead Just ctx -> do mst <- fitsOnOneLine (do pretty ctx write " => " pretty ihead write " where") case mst of Nothing -> withCtx mctx (pretty ihead) Just {} -> do pretty ctx write " => " pretty ihead instance Pretty InstHead where prettyInternal x = case x of -- Base cases IHCon _ name -> pretty name IHInfix _ typ' name -> depend (pretty typ') (do space prettyInfixOp name) -- Recursive application IHApp _ ihead typ' -> depend (pretty ihead) (do space pretty typ') -- Wrapping in parens IHParen _ h -> parens (pretty h) instance Pretty DeclHead where prettyInternal x = case x of DHead _ name -> prettyQuoteName name DHParen _ h -> parens (pretty h) DHInfix _ var name -> do pretty var space prettyInfixName name DHApp _ dhead var -> depend (pretty dhead) (do space pretty var) instance Pretty Overlap where prettyInternal (Overlap _) = write "{-# OVERLAP #-}" prettyInternal (Overlapping _) = write "{-# OVERLAPPING #-}" prettyInternal (Overlaps _) = write "{-# OVERLAPS #-}" prettyInternal (Overlappable _) = write "{-# OVERLAPPABLE #-}" prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}" prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}" instance Pretty Sign where prettyInternal (Signless _) = return () prettyInternal (Negative _) = write "-" instance Pretty CallConv where prettyInternal = pretty' instance Pretty Safety where prettyInternal = pretty' -------------------------------------------------------------------------------- -- * Unimplemented or incomplete printers instance Pretty Module where prettyInternal x = case x of Module _ mayModHead pragmas imps decls -> do inter (do newline newline) (mapMaybe (\(isNull,r) -> if isNull then Nothing else Just r) [(null pragmas,inter newline (map pretty pragmas)) ,(case mayModHead of Nothing -> (True,return ()) Just modHead -> (False,pretty modHead)) ,(null imps,formatImports imps) ,(null decls ,interOf newline (map (\case r@TypeSig{} -> (1,pretty r) r@InlineSig{} -> (1, pretty r) r -> (2,pretty r)) decls))]) newline where interOf i ((c,p):ps) = case ps of [] -> p _ -> do p replicateM_ c i interOf i ps interOf _ [] = return () XmlPage{} -> error "FIXME: No implementation for XmlPage." XmlHybrid{} -> error "FIXME: No implementation for XmlHybrid." -- | Format imports, preserving empty newlines between groups. formatImports :: [ImportDecl NodeInfo] -> Printer () formatImports = sequence_ . intersperse (newline >> newline) . map formatImportGroup . groupAdjacentBy atNextLine where atNextLine import1 import2 = let end1 = srcSpanEndLine (srcInfoSpan (nodeInfoSpan (ann import1))) start2 = srcSpanStartLine (srcInfoSpan (nodeInfoSpan (ann import2))) in start2 - end1 <= 1 formatImportGroup imps = do shouldSortImports <- gets $ configSortImports . psConfig let imps1 = if shouldSortImports then sortImports imps else imps sequence_ . intersperse newline $ map formatImport imps1 moduleVisibleName idecl = let ModuleName _ name = importModule idecl in name formatImport = pretty sortImports imps = sortOn moduleVisibleName . map sortImportSpecsOnImport $ imps sortImportSpecsOnImport imp = imp { importSpecs = fmap sortImportSpecs (importSpecs imp) } sortImportSpecs (ImportSpecList l hiding specs) = ImportSpecList l hiding sortedSpecs where sortedSpecs = sortBy importSpecCompare . map sortCNames $ specs sortCNames (IThingWith l2 name cNames) = IThingWith l2 name . sortBy cNameCompare $ cNames sortCNames is = is groupAdjacentBy :: (a -> a -> Bool) -> [a] -> [[a]] groupAdjacentBy _ [] = [] groupAdjacentBy adj items = xs : groupAdjacentBy adj rest where (xs, rest) = spanAdjacentBy adj items spanAdjacentBy :: (a -> a -> Bool) -> [a] -> ([a], [a]) spanAdjacentBy _ [] = ([], []) spanAdjacentBy _ [x] = ([x], []) spanAdjacentBy adj (x:xs@(y:_)) | adj x y = let (xs', rest') = spanAdjacentBy adj xs in (x : xs', rest') | otherwise = ([x], xs) importSpecCompare :: ImportSpec l -> ImportSpec l -> Ordering importSpecCompare (IAbs _ _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IAbs _ _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IAbs _ _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT importSpecCompare (IAbs _ _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2 importSpecCompare (IAbs _ _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT importSpecCompare (IAbs _ _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT importSpecCompare (IAbs _ _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IAbs _ _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT importSpecCompare (IAbs _ _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 importSpecCompare (IAbs _ _ _) (IVar _ _) = LT importSpecCompare (IThingAll _ (Ident _ s1)) (IAbs _ _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IThingAll _ (Ident _ _)) (IAbs _ _ (Symbol _ _)) = GT importSpecCompare (IThingAll _ (Ident _ s1)) (IThingAll _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IThingAll _ (Ident _ _)) (IThingAll _ (Symbol _ _)) = GT importSpecCompare (IThingAll _ (Ident _ s1)) (IThingWith _ (Ident _ s2) _) = compare s1 s2 importSpecCompare (IThingAll _ (Ident _ _)) (IThingWith _ (Symbol _ _) _) = GT importSpecCompare (IThingAll _ (Symbol _ _)) (IAbs _ _ (Ident _ _)) = LT importSpecCompare (IThingAll _ (Symbol _ s1)) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IThingAll _ (Symbol _ _)) (IThingAll _ (Ident _ _)) = LT importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingAll _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IThingAll _ (Symbol _ _)) (IThingWith _ (Ident _ _) _) = LT importSpecCompare (IThingAll _ (Symbol _ s1)) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 importSpecCompare (IThingAll _ _) (IVar _ _) = LT importSpecCompare (IThingWith _ (Ident _ s1) _) (IAbs _ _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IThingWith _ (Ident _ _) _) (IAbs _ _ (Symbol _ _)) = GT importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingAll _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IThingWith _ (Ident _ _) _) (IThingAll _ (Symbol _ _)) = GT importSpecCompare (IThingWith _ (Ident _ s1) _) (IThingWith _ (Ident _ s2) _) = compare s1 s2 importSpecCompare (IThingWith _ (Ident _ _) _) (IThingWith _ (Symbol _ _) _) = GT importSpecCompare (IThingWith _ (Symbol _ _) _) (IAbs _ _ (Ident _ _)) = LT importSpecCompare (IThingWith _ (Symbol _ s1) _) (IAbs _ _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingAll _ (Ident _ _)) = LT importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingAll _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IThingWith _ (Symbol _ _) _) (IThingWith _ (Ident _ _) _) = LT importSpecCompare (IThingWith _ (Symbol _ s1) _) (IThingWith _ (Symbol _ s2) _) = compare s1 s2 importSpecCompare (IThingWith _ _ _) (IVar _ _) = LT importSpecCompare (IVar _ (Ident _ s1)) (IVar _ (Ident _ s2)) = compare s1 s2 importSpecCompare (IVar _ (Ident _ _)) (IVar _ (Symbol _ _)) = GT importSpecCompare (IVar _ (Symbol _ _)) (IVar _ (Ident _ _)) = LT importSpecCompare (IVar _ (Symbol _ s1)) (IVar _ (Symbol _ s2)) = compare s1 s2 importSpecCompare (IVar _ _) _ = GT cNameCompare :: CName l -> CName l -> Ordering cNameCompare (VarName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2 cNameCompare (VarName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT cNameCompare (VarName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2 cNameCompare (VarName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT cNameCompare (VarName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT cNameCompare (VarName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2 cNameCompare (VarName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT cNameCompare (VarName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2 cNameCompare (ConName _ (Ident _ s1)) (VarName _ (Ident _ s2)) = compare s1 s2 cNameCompare (ConName _ (Ident _ _)) (VarName _ (Symbol _ _)) = GT cNameCompare (ConName _ (Ident _ s1)) (ConName _ (Ident _ s2)) = compare s1 s2 cNameCompare (ConName _ (Ident _ _)) (ConName _ (Symbol _ _)) = GT cNameCompare (ConName _ (Symbol _ _)) (VarName _ (Ident _ _)) = LT cNameCompare (ConName _ (Symbol _ s1)) (VarName _ (Symbol _ s2)) = compare s1 s2 cNameCompare (ConName _ (Symbol _ _)) (ConName _ (Ident _ _)) = LT cNameCompare (ConName _ (Symbol _ s1)) (ConName _ (Symbol _ s2)) = compare s1 s2 instance Pretty Bracket where prettyInternal x = case x of ExpBracket _ p -> quotation "" (pretty p) PatBracket _ p -> quotation "p" (pretty p) TypeBracket _ ty -> quotation "t" (pretty ty) d@(DeclBracket _ _) -> pretty' d instance Pretty IPBind where prettyInternal x = case x of IPBind _ name expr -> do pretty name space write "=" space pretty expr instance Pretty BooleanFormula where prettyInternal (VarFormula _ i@(Ident _ _)) = pretty' i prettyInternal (VarFormula _ (Symbol _ s)) = write "(" >> string s >> write ")" prettyInternal (AndFormula _ fs) = do maybeFormulas <- fitsOnOneLine $ inter (write ", ") $ map pretty fs case maybeFormulas of Nothing -> prefixedLined ", " (map pretty fs) Just formulas -> put formulas prettyInternal (OrFormula _ fs) = do maybeFormulas <- fitsOnOneLine $ inter (write " | ") $ map pretty fs case maybeFormulas of Nothing -> prefixedLined "| " (map pretty fs) Just formulas -> put formulas prettyInternal (ParenFormula _ f) = parens $ pretty f -------------------------------------------------------------------------------- -- * Fallback printers instance Pretty DataOrNew where prettyInternal = pretty' instance Pretty FunDep where prettyInternal = pretty' #if !MIN_VERSION_haskell_src_exts(1,21,0) instance Pretty Kind where prettyInternal = pretty' #endif instance Pretty ResultSig where prettyInternal (KindSig _ kind) = pretty kind prettyInternal (TyVarSig _ tyVarBind) = pretty tyVarBind instance Pretty Literal where prettyInternal (String _ _ rep) = do write "\"" string rep write "\"" prettyInternal (Char _ _ rep) = do write "'" string rep write "'" prettyInternal (PrimString _ _ rep) = do write "\"" string rep write "\"#" prettyInternal (PrimChar _ _ rep) = do 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 prettyInternal x = case x of Ident _ _ -> pretty' x -- Identifiers. Symbol _ s -> string s -- Symbols instance Pretty QName where prettyInternal = \case Qual _ mn n -> case n of Ident _ i -> do pretty mn; write "."; string i; Symbol _ s -> do write "("; pretty mn; write "."; string s; write ")"; UnQual _ n -> case n of Ident _ i -> string i Symbol _ s -> do write "("; string s; write ")"; Special _ s@Cons{} -> parens (pretty s) Special _ s@FunCon{} -> parens (pretty s) Special _ s -> pretty s instance Pretty SpecialCon where prettyInternal s = case s of UnitCon _ -> write "()" ListCon _ -> write "[]" FunCon _ -> write "->" TupleCon _ Boxed i -> string ("(" ++ replicate (i - 1) ',' ++ ")") TupleCon _ Unboxed i -> string ("(# " ++ replicate (i - 1) ',' ++ " #)") Cons _ -> write ":" UnboxedSingleCon _ -> write "(##)" ExprHole _ -> write "_" instance Pretty QOp where prettyInternal = pretty' instance Pretty TyVarBind where prettyInternal = pretty' instance Pretty ModuleHead where prettyInternal (ModuleHead _ name mwarnings mexports) = do write "module " pretty name maybe (return ()) pretty mwarnings maybe (return ()) (\exports -> do newline indentSpaces <- getIndentSpaces indented indentSpaces (pretty exports)) mexports write " where" instance Pretty ModulePragma where prettyInternal = pretty' instance Pretty ImportDecl where prettyInternal (ImportDecl _ name qualified source safe mpkg mas mspec) = do write "import" when source $ write " {-# SOURCE #-}" when safe $ write " safe" when qualified $ write " qualified" case mpkg of Nothing -> return () Just pkg -> space >> write ("\"" ++ pkg ++ "\"") space pretty name case mas of Nothing -> return () Just asName -> do space write "as " pretty asName case mspec of Nothing -> return () Just spec -> pretty spec instance Pretty ModuleName where prettyInternal (ModuleName _ name) = write name instance Pretty ImportSpecList where prettyInternal (ImportSpecList _ hiding spec) = do when hiding $ write " hiding" let verVar = do space parens (commas (map pretty spec)) let horVar = do newline indentedBlock (do depend (write "( ") (prefixedLined ", " (map pretty spec)) newline write ")") verVar `ifFitsOnOneLineOrElse` horVar instance Pretty ImportSpec where prettyInternal = pretty' instance Pretty WarningText where prettyInternal (DeprText _ s) = write "{-# DEPRECATED " >> string s >> write " #-}" prettyInternal (WarnText _ s) = write "{-# WARNING " >> string s >> write " #-}" instance Pretty ExportSpecList where prettyInternal (ExportSpecList _ es) = do depend (write "(") (prefixedLined "," (map pretty es)) newline write ")" instance Pretty ExportSpec where prettyInternal x = string " " >> pretty' x -- Do statements need to handle infix expression indentation specially because -- do x * -- y -- is two invalid statements, not one valid infix op. stmt :: Stmt NodeInfo -> Printer () stmt (Qualifier _ e@(InfixApp _ a op b)) = do col <- fmap (psColumn . snd) (sandbox (write "")) infixApp e a op b (Just col) stmt (Generator _ p e) = do indentSpaces <- getIndentSpaces pretty p indented indentSpaces (dependOrNewline (write " <-") space e pretty) stmt x = case x of Generator _ p e -> depend (do pretty p write " <- ") (pretty e) Qualifier _ e -> pretty e LetStmt _ binds -> depend (write "let ") (pretty binds) RecStmt _ es -> depend (write "rec ") (lined (map pretty es)) -- | Make the right hand side dependent if it fits on one line, -- otherwise send it to the next line. dependOrNewline :: Printer () -> Printer () -> Exp NodeInfo -> (Exp NodeInfo -> Printer ()) -> Printer () dependOrNewline left prefix right f = do msg <- fitsOnOneLine renderDependent case msg of Nothing -> do left newline (f right) Just st -> put st where renderDependent = depend left (do prefix; f right) -- | Handle do and case specially and also space out guards more. rhs :: Rhs NodeInfo -> Printer () rhs (UnGuardedRhs _ (Do _ dos)) = do inCase <- gets psInsideCase write (if inCase then " -> " else " = ") indentSpaces <- getIndentSpaces let indentation | inCase = indentSpaces | otherwise = max 2 indentSpaces swingBy indentation (write "do") (lined (map pretty dos)) rhs (UnGuardedRhs _ e) = do msg <- fitsOnOneLine (do write " " rhsSeparator write " " pretty e) case msg of Nothing -> swing (write " " >> rhsSeparator) (pretty e) Just st -> put st rhs (GuardedRhss _ gas) = do newline n <- getIndentSpaces indented n (lined (map (\p -> do write "|" pretty p) gas)) -- | Implement dangling right-hand-sides. guardedRhs :: GuardedRhs NodeInfo -> Printer () -- | Handle do specially. guardedRhs (GuardedRhs _ stmts (Do _ dos)) = do indented 1 (do prefixedLined "," (map (\p -> do space pretty p) stmts)) inCase <- gets psInsideCase write (if inCase then " -> " else " = ") swing (write "do") (lined (map pretty dos)) guardedRhs (GuardedRhs _ stmts e) = do mst <- fitsOnOneLine printStmts case mst of Just st -> do put st mst' <- fitsOnOneLine (do write " " rhsSeparator write " " pretty e) case mst' of Just st' -> put st' Nothing -> swingIt Nothing -> do printStmts swingIt where printStmts = indented 1 (do prefixedLined "," (map (\p -> do space pretty p) stmts)) swingIt = swing (write " " >> rhsSeparator) (pretty e) match :: Match NodeInfo -> Printer () match (Match _ name pats rhs' mbinds) = do depend (do case name of Ident _ _ -> pretty name Symbol _ _ -> do write "(" pretty name write ")" space) (spaced (map pretty pats)) withCaseContext False (pretty rhs') for_ mbinds bindingGroup match (InfixMatch _ pat1 name pats rhs' mbinds) = do depend (do pretty pat1 space prettyInfixName name) (do space spaced (map pretty pats)) withCaseContext False (pretty rhs') for_ mbinds bindingGroup -- | Format contexts with spaces and commas between class constraints. context :: Context NodeInfo -> Printer () context ctx = case ctx of CxSingle _ a -> pretty a CxTuple _ as -> do depend (write "( ") $ prefixedLined ", " (map pretty as) newline write ")" CxEmpty _ -> parens (return ()) typ :: Type NodeInfo -> Printer () typ (TyTuple _ Boxed types) = do let horVar = parens $ inter (write ", ") (map pretty types) let verVar = parens $ prefixedLined "," (map (depend space . pretty) types) horVar `ifFitsOnOneLineOrElse` verVar typ (TyTuple _ Unboxed types) = do let horVar = wrap "(# " " #)" $ inter (write ", ") (map pretty types) let verVar = wrap "(#" " #)" $ prefixedLined "," (map (depend space . pretty) types) horVar `ifFitsOnOneLineOrElse` verVar typ (TyForall _ mbinds ctx ty) = depend (case mbinds of Nothing -> return () Just ts -> do write "forall " spaced (map pretty ts) write ". ") (do indentSpaces <- getIndentSpaces withCtx ctx (indented indentSpaces (pretty ty))) typ (TyFun _ a b) = depend (do pretty a write " -> ") (pretty b) typ (TyList _ t) = brackets (pretty t) typ (TyParArray _ t) = brackets (do write ":" pretty t write ":") typ (TyApp _ f a) = spaced [pretty f, pretty a] typ (TyVar _ n) = pretty n typ (TyCon _ p) = pretty p typ (TyParen _ e) = parens (pretty e) typ (TyInfix _ a promotedop b) = do -- Apply special rules to line-break operators. let isLineBreak' op = case op of PromotedName _ op' -> isLineBreak op' UnpromotedName _ op' -> isLineBreak op' prettyInfixOp' op = case op of PromotedName _ op' -> write "'" >> prettyInfixOp op' UnpromotedName _ op' -> prettyInfixOp op' linebreak <- isLineBreak' promotedop if linebreak then do pretty a newline prettyInfixOp' promotedop space pretty b else do pretty a space prettyInfixOp' promotedop space pretty b typ (TyKind _ ty k) = parens (do pretty ty write " :: " pretty k) typ (TyBang _ bangty unpackty right) = do pretty unpackty pretty bangty pretty right typ (TyEquals _ left right) = do pretty left write " ~ " pretty right typ (TyPromoted _ (PromotedList _ _ ts)) = do write "'[" unless (null ts) $ write " " commas (map pretty ts) write "]" typ (TyPromoted _ (PromotedTuple _ ts)) = do write "'(" unless (null ts) $ write " " commas (map pretty ts) write ")" typ (TyPromoted _ (PromotedCon _ _ tname)) = do write "'" pretty tname typ (TyPromoted _ (PromotedString _ _ raw)) = do do write "\"" string raw write "\"" typ ty@TyPromoted{} = pretty' ty typ (TySplice _ splice) = pretty splice typ (TyWildCard _ name) = case name of Nothing -> write "_" Just n -> do write "_" pretty n typ (TyQuasiQuote _ n s) = quotation n (string s) typ (TyUnboxedSum{}) = error "FIXME: No implementation for TyUnboxedSum." #if MIN_VERSION_haskell_src_exts(1,21,0) typ (TyStar _) = write "*" #endif prettyTopName :: Name NodeInfo -> Printer () prettyTopName x@Ident{} = pretty x prettyTopName x@Symbol{} = parens $ pretty x -- | Specially format records. Indent where clauses only 2 spaces. decl' :: Decl NodeInfo -> Printer () -- | Pretty print type signatures like -- -- foo :: (Show x, Read x) -- => (Foo -> Bar) -- -> Maybe Int -- -> (Char -> X -> Y) -- -> IO () -- decl' (TypeSig _ names ty') = do mst <- fitsOnOneLine (depend (do commas (map prettyTopName names) write " :: ") (declTy ty')) case mst of Nothing -> do commas (map prettyTopName names) indentSpaces <- getIndentSpaces if allNamesLength >= indentSpaces then do write " ::" newline indented indentSpaces (depend (write " ") (declTy ty')) else (depend (write " :: ") (declTy ty')) Just st -> put st where nameLength (Ident _ s) = length s nameLength (Symbol _ s) = length s + 2 allNamesLength = fromIntegral $ sum (map nameLength names) + 2 * (length names - 1) decl' (PatBind _ pat rhs' mbinds) = withCaseContext False $ do pretty pat pretty rhs' for_ mbinds bindingGroup -- | Handle records specially for a prettier display (see guide). decl' e = decl e declTy :: Type NodeInfo -> Printer () declTy dty = case dty of TyForall _ mbinds mctx ty -> case mbinds of Nothing -> do case mctx of Nothing -> prettyTy False ty Just ctx -> do mst <- fitsOnOneLine (do pretty ctx depend (write " => ") (prettyTy False ty)) case mst of Nothing -> do pretty ctx newline indented (-3) (depend (write "=> ") (prettyTy True ty)) Just st -> put st Just ts -> do write "forall " spaced (map pretty ts) write "." case mctx of Nothing -> do mst <- fitsOnOneLine (space >> prettyTy False ty) case mst of Nothing -> do newline prettyTy True ty Just st -> put st Just ctx -> do mst <- fitsOnOneLine (space >> pretty ctx) case mst of Nothing -> do newline pretty ctx newline indented (-3) (depend (write "=> ") (prettyTy True ty)) Just st -> do put st newline indented (-3) (depend (write "=> ") (prettyTy True ty)) _ -> prettyTy False dty where collapseFaps (TyFun _ arg result) = arg : collapseFaps result collapseFaps e = [e] prettyTy breakLine ty = do if breakLine then case collapseFaps ty of [] -> pretty ty tys -> prefixedLined "-> " (map pretty tys) else do mst <- fitsOnOneLine (pretty ty) case mst of Nothing -> case collapseFaps ty of [] -> pretty ty tys -> prefixedLined "-> " (map pretty tys) Just st -> put st -- | Use special record display, used by 'dataDecl' in a record scenario. qualConDecl :: QualConDecl NodeInfo -> Printer () qualConDecl (QualConDecl _ tyvars ctx d) = depend (unless (null (fromMaybe [] tyvars)) (do write "forall " spaced (map pretty (fromMaybe [] tyvars)) write ". ")) (withCtx ctx (recDecl d)) -- | Fields are preceded with a space. conDecl :: ConDecl NodeInfo -> Printer () conDecl (RecDecl _ name fields) = do pretty name newline indentedBlock (do depend (write "{") (prefixedLined "," (map (depend space . pretty) fields)) newline write "}" ) conDecl (ConDecl _ name bangty) = do prettyQuoteName name unless (null bangty) (ifFitsOnOneLineOrElse (do space spaced (map pretty bangty)) (do newline indentedBlock (lined (map pretty bangty)))) conDecl (InfixConDecl _ a f b) = inter space [pretty a, pretty f, 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)) newline write "}") recDecl r = prettyInternal r recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer () recUpdateExpr expWriter updates = do ifFitsOnOneLineOrElse hor $ do expWriter newline indentedBlock (updatesHor `ifFitsOnOneLineOrElse` updatesVer) where hor = do expWriter space updatesHor updatesHor = braces $ commas $ map pretty updates updatesVer = do depend (write "{ ") $ prefixedLined ", " $ map pretty updates newline write "}" -------------------------------------------------------------------------------- -- Predicates -- | Is the decl a record? isRecord :: QualConDecl t -> Bool isRecord (QualConDecl _ _ _ RecDecl{}) = True isRecord _ = False -- | If the given operator is an element of line breaks in configuration. isLineBreak :: QName NodeInfo -> Printer Bool isLineBreak (UnQual _ (Symbol _ s)) = do breaks <- gets (configLineBreaks . psConfig) return $ s `elem` breaks isLineBreak _ = return False -- | Does printing the given thing overflow column limit? (e.g. 80) fitsOnOneLine :: Printer a -> Printer (Maybe PrintState) fitsOnOneLine p = do st <- get put st { psFitOnOneLine = True} ok <- fmap (const True) p <|> return False st' <- get put st guard $ ok || not (psFitOnOneLine st) return (if ok then Just st' { psFitOnOneLine = psFitOnOneLine st } else Nothing) -- | If first printer fits, use it, else use the second one. ifFitsOnOneLineOrElse :: Printer a -> Printer a -> Printer a ifFitsOnOneLineOrElse a b = do stOrig <- get put stOrig{psFitOnOneLine = True} res <- fmap Just a <|> return Nothing case res of Just r -> do modify $ \st -> st{psFitOnOneLine = psFitOnOneLine stOrig} return r Nothing -> do put stOrig guard $ not (psFitOnOneLine stOrig) b bindingGroup :: Binds NodeInfo -> Printer () bindingGroup binds = do newline indented 2 (do write "where" newline indented 2 (pretty binds)) infixApp :: Exp NodeInfo -> Exp NodeInfo -> QOp NodeInfo -> Exp NodeInfo -> Maybe Int64 -> Printer () infixApp e a op b indent = hor `ifFitsOnOneLineOrElse` ver where hor = spaced [ case link of OpChainExp e' -> pretty e' OpChainLink qop -> pretty qop | link <- flattenOpChain e ] ver = do prettyWithIndent a beforeRhs <- case a of Do _ _ -> do indentSpaces <- getIndentSpaces column (fromMaybe 0 indent + indentSpaces + 3) (newline >> pretty op) -- 3 = "do " return space _ -> space >> pretty op >> return newline case b of Lambda{} -> space >> pretty b LCase{} -> space >> pretty b Do _ stmts -> swing (write " do") $ lined (map pretty stmts) _ -> do beforeRhs case indent of Nothing -> do col <- fmap (psColumn . snd) (sandbox (write "")) -- force indent for top-level template haskell expressions, #473. if col == 0 then do indentSpaces <- getIndentSpaces column indentSpaces (prettyWithIndent b) else prettyWithIndent b Just col -> do indentSpaces <- getIndentSpaces column (col + indentSpaces) (prettyWithIndent b) prettyWithIndent e' = case e' of InfixApp _ a' op' b' -> infixApp e' a' op' b' indent _ -> pretty e' -- | A link in a chain of operator applications. data OpChainLink l = OpChainExp (Exp l) | OpChainLink (QOp l) deriving (Show) -- | Flatten a tree of InfixApp expressions into a chain of operator -- links. flattenOpChain :: Exp l -> [OpChainLink l] flattenOpChain (InfixApp _ left op right) = flattenOpChain left <> [OpChainLink op] <> flattenOpChain right flattenOpChain e = [OpChainExp e] -- | Write a Template Haskell quotation or a quasi-quotation. -- -- >>> quotation "t" (string "Foo") -- > [t|Foo|] quotation :: String -> Printer () -> Printer () quotation quoter body = brackets (depend (do string quoter write "|") (do body write "|")) hindent-5.3.4/src/HIndent/CabalFile.hs0000644000000000000000000001326414261446771015642 0ustar0000000000000000{-# LANGUAGE CPP #-} module HIndent.CabalFile ( getCabalExtensionsForSourcePath ) where import Control.Monad import qualified Data.ByteString as BS import Data.List import Data.Maybe import Data.Traversable import Distribution.ModuleName import Distribution.PackageDescription import Distribution.PackageDescription.Configuration #if MIN_VERSION_Cabal(3, 6, 0) import Distribution.Utils.Path (getSymbolicPath) #endif #if MIN_VERSION_Cabal(2, 2, 0) import Distribution.PackageDescription.Parsec #else import Distribution.PackageDescription.Parse #endif import Language.Haskell.Extension import qualified Language.Haskell.Exts.Extension as HSE import System.Directory import System.FilePath import Text.Read data Stanza = MkStanza { _stanzaBuildInfo :: BuildInfo , stanzaIsSourceFilePath :: FilePath -> Bool } -- | Find the relative path of a child path in a parent, if it is a child toRelative :: FilePath -> FilePath -> Maybe FilePath toRelative parent child = let rel = makeRelative parent child in if rel == child then Nothing else Just rel -- | Create a Stanza from `BuildInfo` and names of modules and paths mkStanza :: BuildInfo -> [ModuleName] -> [FilePath] -> Stanza mkStanza bi mnames fpaths = MkStanza bi $ \path -> let modpaths = fmap toFilePath $ otherModules bi ++ mnames inDir dir = case toRelative dir path of Nothing -> False Just relpath -> any (equalFilePath $ dropExtension relpath) modpaths || any (equalFilePath relpath) fpaths in any inDir $ hsSourceDirs' bi where #if MIN_VERSION_Cabal(3, 6, 0) hsSourceDirs' = (map getSymbolicPath) . hsSourceDirs #else hsSourceDirs' = hsSourceDirs #endif -- | Extract `Stanza`s from a package packageStanzas :: PackageDescription -> [Stanza] packageStanzas pd = let libStanza :: Library -> Stanza libStanza lib = mkStanza (libBuildInfo lib) (exposedModules lib) [] exeStanza :: Executable -> Stanza exeStanza exe = mkStanza (buildInfo exe) [] [modulePath exe] testStanza :: TestSuite -> Stanza testStanza ts = mkStanza (testBuildInfo ts) (case testInterface ts of TestSuiteLibV09 _ mname -> [mname] _ -> []) (case testInterface ts of TestSuiteExeV10 _ path -> [path] _ -> []) benchStanza :: Benchmark -> Stanza benchStanza bn = mkStanza (benchmarkBuildInfo bn) [] $ case benchmarkInterface bn of BenchmarkExeV10 _ path -> [path] _ -> [] in mconcat [ maybeToList $ fmap libStanza $ library pd , fmap exeStanza $ executables pd , fmap testStanza $ testSuites pd , fmap benchStanza $ benchmarks pd ] -- | Find cabal files that are "above" the source path findCabalFiles :: FilePath -> FilePath -> IO (Maybe ([FilePath], FilePath)) findCabalFiles dir rel = do names <- getDirectoryContents dir cabalnames <- filterM (doesFileExist . (dir )) $ filter (isSuffixOf ".cabal") names case cabalnames of [] | dir == "/" -> return Nothing [] -> findCabalFiles (takeDirectory dir) (takeFileName dir rel) _ -> return $ Just (fmap (\n -> dir n) cabalnames, rel) getGenericPackageDescription :: FilePath -> IO (Maybe GenericPackageDescription) #if MIN_VERSION_Cabal(2, 2, 0) getGenericPackageDescription cabalPath = do cabaltext <- BS.readFile cabalPath return $ parseGenericPackageDescriptionMaybe cabaltext #else getGenericPackageDescription cabalPath = do cabaltext <- readFile cabalPath case parsePackageDescription cabaltext of ParseOk _ gpd -> return $ Just gpd _ -> return Nothing #endif -- | Find the `Stanza` that refers to this source path getCabalStanza :: FilePath -> IO (Maybe Stanza) getCabalStanza srcpath = do abssrcpath <- canonicalizePath srcpath mcp <- findCabalFiles (takeDirectory abssrcpath) (takeFileName abssrcpath) case mcp of Just (cabalpaths, relpath) -> do stanzass <- for cabalpaths $ \cabalpath -> do genericPackageDescription <- getGenericPackageDescription cabalpath case genericPackageDescription of Nothing -> return [] Just gpd -> do return $ packageStanzas $ flattenPackageDescription gpd return $ case filter (\stanza -> stanzaIsSourceFilePath stanza relpath) $ mconcat stanzass of [] -> Nothing (stanza:_) -> Just stanza -- just pick the first one Nothing -> return Nothing -- | Get (Cabal package) language and extensions from the cabal file for this source path getCabalExtensions :: FilePath -> IO (Language, [Extension]) getCabalExtensions srcpath = do mstanza <- getCabalStanza srcpath return $ case mstanza of Nothing -> (Haskell98, []) Just (MkStanza bi _) -> do (fromMaybe Haskell98 $ defaultLanguage bi, defaultExtensions bi) convertLanguage :: Language -> HSE.Language convertLanguage lang = read $ show lang convertKnownExtension :: KnownExtension -> Maybe HSE.KnownExtension convertKnownExtension ext = case readEither $ show ext of Left _ -> Nothing Right hext -> Just hext convertExtension :: Extension -> Maybe HSE.Extension convertExtension (EnableExtension ke) = fmap HSE.EnableExtension $ convertKnownExtension ke convertExtension (DisableExtension ke) = fmap HSE.DisableExtension $ convertKnownExtension ke convertExtension (UnknownExtension s) = Just $ HSE.UnknownExtension s -- | Get extensions from the cabal file for this source path getCabalExtensionsForSourcePath :: FilePath -> IO [HSE.Extension] getCabalExtensionsForSourcePath srcpath = do (lang, exts) <- getCabalExtensions srcpath return $ fmap HSE.EnableExtension $ HSE.toExtensionList (convertLanguage lang) $ mapMaybe convertExtension exts hindent-5.3.4/src/HIndent/CodeBlock.hs0000644000000000000000000000704214261446771015662 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module HIndent.CodeBlock ( CodeBlock(..) , cppSplitBlocks ) where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Monoid -- | A block of code. data CodeBlock = Shebang ByteString | HaskellSource Int ByteString -- ^ Includes the starting line (indexed from 0) for error reporting | CPPDirectives ByteString deriving (Show, Eq) -- | Break a Haskell code string into chunks, using CPP as a delimiter. -- Lines that start with '#if', '#end', or '#else' are their own chunks, and -- also act as chunk separators. For example, the code -- -- > #ifdef X -- > x = X -- > y = Y -- > #else -- > x = Y -- > y = X -- > #endif -- -- will become five blocks, one for each CPP line and one for each pair of declarations. cppSplitBlocks :: ByteString -> [CodeBlock] cppSplitBlocks inp = modifyLast (inBlock (<> trailing)) . groupLines . classifyLines . zip [0 ..] . S8.lines $ inp where groupLines :: [CodeBlock] -> [CodeBlock] groupLines (line1:line2:remainingLines) = case mergeLines line1 line2 of Just line1And2 -> groupLines (line1And2 : remainingLines) Nothing -> line1 : groupLines (line2 : remainingLines) groupLines xs@[_] = xs groupLines xs@[] = xs mergeLines :: CodeBlock -> CodeBlock -> Maybe CodeBlock mergeLines (CPPDirectives src1) (CPPDirectives src2) = Just $ CPPDirectives (src1 <> "\n" <> src2) mergeLines (Shebang src1) (Shebang src2) = Just $ Shebang (src1 <> "\n" <> src2) mergeLines (HaskellSource lineNumber1 src1) (HaskellSource _lineNumber2 src2) = Just $ HaskellSource lineNumber1 (src1 <> "\n" <> src2) mergeLines _ _ = Nothing shebangLine :: ByteString -> Bool shebangLine = S8.isPrefixOf "#!" cppLine :: ByteString -> Bool cppLine src = any (`S8.isPrefixOf` src) ["#if", "#end", "#else", "#define", "#undef", "#elif", "#include", "#error", "#warning"] -- Note: #ifdef and #ifndef are handled by #if hasEscapedTrailingNewline :: ByteString -> Bool hasEscapedTrailingNewline src = "\\" `S8.isSuffixOf` src classifyLines :: [(Int, ByteString)] -> [CodeBlock] classifyLines allLines@((lineIndex, src):nextLines) | cppLine src = let (cppLines, nextLines') = spanCPPLines allLines in CPPDirectives (S8.intercalate "\n" (map snd cppLines)) : classifyLines nextLines' | shebangLine src = Shebang src : classifyLines nextLines | otherwise = HaskellSource lineIndex src : classifyLines nextLines classifyLines [] = [] spanCPPLines :: [(Int, ByteString)] -> ([(Int, ByteString)], [(Int, ByteString)]) spanCPPLines (line@(_, src):nextLines) | hasEscapedTrailingNewline src = let (cppLines, nextLines') = spanCPPLines nextLines in (line : cppLines, nextLines') | otherwise = ([line], nextLines) spanCPPLines [] = ([], []) -- Hack to work around some parser issues in haskell-src-exts: Some pragmas -- need to have a newline following them in order to parse properly, so we include -- the trailing newline in the code block if it existed. trailing :: ByteString trailing = if S8.isSuffixOf "\n" inp then "\n" else "" modifyLast :: (a -> a) -> [a] -> [a] modifyLast _ [] = [] modifyLast f [x] = [f x] modifyLast f (x:xs) = x : modifyLast f xs inBlock :: (ByteString -> ByteString) -> CodeBlock -> CodeBlock inBlock f (HaskellSource line txt) = HaskellSource line (f txt) inBlock _ dir = dir hindent-5.3.4/src/main/Main.hs0000644000000000000000000001170014261446771014310 0ustar0000000000000000{-# LANGUAGE Unsafe #-} {-# LANGUAGE OverloadedStrings #-} -- | Main entry point to hindent. -- -- hindent module Main (main) where import Control.Applicative import Control.Exception import Control.Monad import qualified Data.ByteString as S import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Maybe import Data.Version (showVersion) import qualified Data.Yaml as Y import Foreign.C.Error import GHC.IO.Exception import HIndent import HIndent.CabalFile import HIndent.Types import Language.Haskell.Exts hiding (Style, style) import Path import qualified Path.Find as Path import qualified Path.IO as Path import Paths_hindent (version) import qualified System.Directory as IO import System.Exit (exitWith) import qualified System.IO as IO import Options.Applicative hiding (action, style) import Data.Monoid ((<>)) import qualified Data.Text as T data Action = Validate | Reformat data RunMode = ShowVersion | Run Config [Extension] Action [FilePath] -- | Main entry point. main :: IO () main = do config <- getConfig runMode <- execParser (info (options config <**> helper) (header "hindent - Reformat Haskell source code")) case runMode of ShowVersion -> putStrLn ("hindent " ++ showVersion version) Run style exts action paths -> if null paths then L8.interact (either error S.toLazyByteString . reformat style (Just exts) Nothing . L8.toStrict) else forM_ paths $ \filepath -> do cabalexts <- getCabalExtensionsForSourcePath filepath text <- S.readFile filepath case reformat style (Just $ cabalexts ++ exts) (Just filepath) text of Left e -> error e Right out -> unless (L8.fromStrict text == S.toLazyByteString out) $ case action of Validate -> do IO.putStrLn $ filepath ++ " is not formatted" exitWith (ExitFailure 1) Reformat -> do tmpDir <- IO.getTemporaryDirectory (fp, h) <- IO.openTempFile tmpDir "hindent.hs" L8.hPutStr h (S.toLazyByteString out) IO.hFlush h IO.hClose h let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV) then IO.copyFile fp filepath >> IO.removeFile fp else throw e IO.copyPermissions filepath fp IO.renameFile fp filepath `catch` exdev -- | Read config from a config file, or return 'defaultConfig'. getConfig :: IO Config getConfig = do cur <- Path.getCurrentDir homeDir <- Path.getHomeDir mfile <- Path.findFileUp cur ((== ".hindent.yaml") . toFilePath . filename) (Just homeDir) case mfile of Nothing -> return defaultConfig Just file -> do result <- Y.decodeFileEither (toFilePath file) case result of Left e -> error (show e) Right config -> return config -- | Program options. options :: Config -> Parser RunMode options config = flag' ShowVersion ( long "version" <> help "Print the version") <|> (Run <$> style <*> exts <*> action <*> files) where style = (makeStyle config <$> lineLen <*> indentSpaces <*> trailingNewline <*> sortImports ) <* optional (strOption (long "style" <> help "Style to print with (historical, now ignored)" <> metavar "STYLE") :: Parser String) exts = fmap getExtensions (many (T.pack <$> strOption (short 'X' <> help "Language extension" <> metavar "GHCEXT"))) indentSpaces = option auto (long "indent-size" <> help "Indentation size in spaces" <> value (configIndentSpaces config) <> showDefault) <|> option auto (long "tab-size" <> help "Same as --indent-size, for compatibility") lineLen = option auto (long "line-length" <> help "Desired length of lines" <> value (configMaxColumns config) <> showDefault ) trailingNewline = not <$> flag (not (configTrailingNewline config)) (configTrailingNewline config) (long "no-force-newline" <> help "Don't force a trailing newline" <> showDefault) sortImports = flag Nothing (Just True) (long "sort-imports" <> help "Sort imports in groups" <> showDefault) <|> flag Nothing (Just False) (long "no-sort-imports" <> help "Don't sort imports") action = flag Reformat Validate (long "validate" <> help "Check if files are formatted without changing them") makeStyle s mlen tabs trailing imports = s { configMaxColumns = mlen , configIndentSpaces = tabs , configTrailingNewline = trailing , configSortImports = fromMaybe (configSortImports s) imports } files = many (strArgument (metavar "FILENAMES")) hindent-5.3.4/src/main/Path/Find.hs0000644000000000000000000000760214261446771015206 0ustar0000000000000000{-# LANGUAGE DataKinds #-} -- | Finding files. -- Lifted from Stack. module Path.Find (findFileUp ,findDirUp ,findFiles ,findInParents) where import Control.Exception (evaluate) import Control.DeepSeq (force) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import System.IO.Error (isPermissionError) import Data.List import Path import Path.IO hiding (findFiles) import System.PosixCompat.Files (getSymbolicLinkStatus, isSymbolicLink) -- | Find the location of a file matching the given predicate. findFileUp :: (MonadIO m,MonadThrow m) => Path Abs Dir -- ^ Start here. -> (Path Abs File -> Bool) -- ^ Predicate to match the file. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs File)) -- ^ Absolute file path. findFileUp = findPathUp snd -- | Find the location of a directory matching the given predicate. findDirUp :: (MonadIO m,MonadThrow m) => Path Abs Dir -- ^ Start here. -> (Path Abs Dir -> Bool) -- ^ Predicate to match the directory. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs Dir)) -- ^ Absolute directory path. findDirUp = findPathUp fst -- | Find the location of a path matching the given predicate. findPathUp :: (MonadIO m,MonadThrow m) => (([Path Abs Dir],[Path Abs File]) -> [Path Abs t]) -- ^ Choose path type from pair. -> Path Abs Dir -- ^ Start here. -> (Path Abs t -> Bool) -- ^ Predicate to match the path. -> Maybe (Path Abs Dir) -- ^ Do not ascend above this directory. -> m (Maybe (Path Abs t)) -- ^ Absolute path. findPathUp pathType dir p upperBound = do entries <- listDir dir case find p (pathType entries) of Just path -> return (Just path) Nothing | Just dir == upperBound -> return Nothing | parent dir == dir -> return Nothing | otherwise -> findPathUp pathType (parent dir) p upperBound -- | Find files matching predicate below a root directory. -- -- NOTE: this skips symbolic directory links, to avoid loops. This may -- not make sense for all uses of file finding. -- -- TODO: write one of these that traverses symbolic links but -- efficiently ignores loops. findFiles :: Path Abs Dir -- ^ Root directory to begin with. -> (Path Abs File -> Bool) -- ^ Predicate to match files. -> (Path Abs Dir -> Bool) -- ^ Predicate for which directories to traverse. -> IO [Path Abs File] -- ^ List of matching files. findFiles dir p traversep = do (dirs,files) <- catchJust (\ e -> if isPermissionError e then Just () else Nothing) (listDir dir) (\ _ -> return ([], [])) filteredFiles <- evaluate $ force (filter p files) filteredDirs <- filterM (fmap not . isSymLink) dirs subResults <- forM filteredDirs (\entry -> if traversep entry then findFiles entry p traversep else return []) return (concat (filteredFiles : subResults)) isSymLink :: Path Abs t -> IO Bool isSymLink = fmap isSymbolicLink . getSymbolicLinkStatus . toFilePath -- | @findInParents f path@ applies @f@ to @path@ and its 'parent's until -- it finds a 'Just' or reaches the root directory. findInParents :: MonadIO m => (Path Abs Dir -> m (Maybe a)) -> Path Abs Dir -> m (Maybe a) findInParents f path = do mres <- f path case mres of Just res -> return (Just res) Nothing -> do let next = parent path if next == path then return Nothing else findInParents f next hindent-5.3.4/src/main/Test.hs0000644000000000000000000001500214261456624014340 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -- | Test the pretty printer. module Main where import Data.Algorithm.Diff import Data.Algorithm.DiffOutput import qualified Data.ByteString as S import qualified Data.ByteString.Builder as S import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import qualified Data.ByteString.Lazy.UTF8 as LUTF8 import qualified Data.ByteString.UTF8 as UTF8 import Data.Function import Data.Monoid import qualified HIndent import HIndent.CodeBlock import HIndent.Types import Markdone import Test.Hspec -- | Main benchmarks. main :: IO () main = do bytes <- S.readFile "TESTS.md" forest <- parse (tokenize bytes) hspec $ do codeBlocksSpec markdoneSpec toSpec forest reformat :: Config -> S.ByteString -> ByteString reformat cfg code = either (("-- " <>) . L8.pack) S.toLazyByteString $ HIndent.reformat cfg (Just HIndent.defaultExtensions) Nothing code -- | Convert the Markdone document to Spec benchmarks. toSpec :: [Markdone] -> Spec toSpec = go where cfg = HIndent.Types.defaultConfig {configTrailingNewline = False} go (Section name children:next) = do describe (UTF8.toString name) (go children) go next go (PlainText desc:CodeFence lang code:next) = case lang of "haskell" -> do it (UTF8.toString desc) $ shouldBeReadable (reformat cfg code) (L.fromStrict code) go next "haskell 4" -> do let cfg' = cfg {configIndentSpaces = 4} it (UTF8.toString desc) $ shouldBeReadable (reformat cfg' code) (L.fromStrict code) go next "haskell given" -> case skipEmptyLines next of CodeFence "haskell expect" codeExpect:next' -> do it (UTF8.toString desc) $ shouldBeReadable (reformat cfg code) (L.fromStrict codeExpect) go next' _ -> error "'haskell given' block must be followed by a 'haskell expect' block" "haskell pending" -> do it (UTF8.toString desc) pending go next _ -> go next go (PlainText {}:next) = go next go (CodeFence {}:next) = go next go [] = return () -- | Version of 'shouldBe' that prints strings in a readable way, -- better for our use-case. shouldBeReadable :: ByteString -> ByteString -> Expectation shouldBeReadable x y = shouldBe (Readable x (Just (diff y x))) (Readable y Nothing) -- | Prints a string without quoting and escaping. data Readable = Readable { readableString :: ByteString , readableDiff :: Maybe String } instance Eq Readable where (==) = on (==) readableString instance Show Readable where show (Readable x d') = "\n" ++ LUTF8.toString x ++ (case d' of Just d -> "\nThe diff:\n" ++ d Nothing -> "") -- | A diff display. diff :: ByteString -> ByteString -> String diff x y = ppDiff (on getGroupedDiff (lines . LUTF8.toString) x y) skipEmptyLines :: [Markdone] -> [Markdone] skipEmptyLines (PlainText "":rest) = rest skipEmptyLines other = other codeBlocksSpec :: Spec codeBlocksSpec = describe "splitting source into code blocks" $ do it "should put just Haskell code in its own block" $ do let input = "this is totally haskell code\n\nit deserves its own block!\n" cppSplitBlocks input `shouldBe` [HaskellSource 0 input] it "should put #if/#endif and Haskell code into separate blocks" $ do cppSplitBlocks "haskell code\n#if DEBUG\ndebug code\n#endif\nmore haskell code\n" `shouldBe` [ HaskellSource 0 "haskell code" , CPPDirectives "#if DEBUG" , HaskellSource 2 "debug code" , CPPDirectives "#endif" , HaskellSource 4 "more haskell code\n" ] it "should put the shebang line into its own block" $ do cppSplitBlocks "#!/usr/bin/env runhaskell\n{-# LANGUAGE OverloadedStrings #-}\n" `shouldBe` [ Shebang "#!/usr/bin/env runhaskell" , HaskellSource 1 "{-# LANGUAGE OverloadedStrings #-}\n" ] it "should put a multi-line #define into its own block" $ do let input = "#define A \\\n macro contents \\\n go here\nhaskell code\n" cppSplitBlocks input `shouldBe` [ CPPDirectives "#define A \\\n macro contents \\\n go here" , HaskellSource 3 "haskell code\n" ] it "should put an unterminated multi-line #define into its own block" $ do cppSplitBlocks "#define A \\" `shouldBe` [CPPDirectives "#define A \\"] cppSplitBlocks "#define A \\\n" `shouldBe` [CPPDirectives "#define A \\"] cppSplitBlocks "#define A \\\n.\\" `shouldBe` [CPPDirectives "#define A \\\n.\\"] markdoneSpec :: Spec markdoneSpec = do describe "markdown tokenizer" $ do it "should tokenize plain text" $ do let input = "this is a line\nthis is another line\n\nthis is a new paragraph\n" tokenize input `shouldBe` [ PlainLine "this is a line" , PlainLine "this is another line" , PlainLine "" , PlainLine "this is a new paragraph" ] it "should tokenize headings" $ do tokenize "# Heading" `shouldBe` [Heading 1 "Heading"] it "should tokenize code fence beginnings with labels" $ do tokenize "``` haskell\n" `shouldBe` [BeginFence "haskell"] tokenize "```haskell expect\n" `shouldBe` [BeginFence "haskell expect"] tokenize "before\n```code\nafter\n" `shouldBe` [PlainLine "before", BeginFence "code", PlainLine "after"] it "should tokenize full code fences" $ do tokenize "```haskell\ncode goes here\n```" `shouldBe` [BeginFence "haskell", PlainLine "code goes here", EndFence] it "should tokenize lines inside code fences as plain text" $ do tokenize "```haskell\n#!/usr/bin/env stack\n```" `shouldBe` [BeginFence "haskell", PlainLine "#!/usr/bin/env stack", EndFence] tokenize "```haskell\n# not a heading\n```" `shouldBe` [BeginFence "haskell", PlainLine "# not a heading", EndFence] describe "markdown parser" $ do it "should parse a heading followed by text as a section" $ do let input = [ Heading 1 "This is a heading" , PlainLine "This is plain text" , PlainLine "split across two lines." ] output <- parse input output `shouldBe` [ Section "This is a heading" [PlainText "This is plain text\nsplit across two lines."] ] hindent-5.3.4/src/main/Markdone.hs0000644000000000000000000000744414261446771015176 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} -- | A subset of markdown that only supports @#headings@ and code -- fences. -- -- All content must be in section headings with proper hierarchy, -- anything else is rejected. module Markdone where import Control.DeepSeq import Control.Monad.Catch import Control.Monad.State.Strict (State, evalState, get, put) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import Data.Char import Data.Typeable import GHC.Generics -- | A markdone token. data Token = Heading !Int !ByteString | PlainLine !ByteString | BeginFence !ByteString | EndFence deriving (Eq, Show) -- | A markdone document. data Markdone = Section !ByteString ![Markdone] | CodeFence !ByteString !ByteString | PlainText !ByteString deriving (Eq,Show,Generic) instance NFData Markdone -- | Parse error. data MarkdownError = NoFenceEnd | ExpectedSection deriving (Typeable,Show) instance Exception MarkdownError data TokenizerMode = Normal | Fenced -- | Tokenize the bytestring. tokenize :: ByteString -> [Token] tokenize input = evalState (mapM token (S8.lines input)) Normal where token :: ByteString -> State TokenizerMode Token token line = do mode <- get case mode of Normal -> if S8.isPrefixOf "#" line then let (hashes,title) = S8.span (== '#') line in return $ Heading (S8.length hashes) (S8.dropWhile isSpace title) else if S8.isPrefixOf "```" line then do put Fenced return $ BeginFence (S8.dropWhile (\c -> c == '`' || c == ' ') line) else return $ PlainLine line Fenced -> if line == "```" then do put Normal return EndFence else return $ PlainLine line -- | Parse into a forest. parse :: (Functor m,MonadThrow m) => [Token] -> m [Markdone] parse = go (0 :: Int) where go level = \case (Heading n label:rest) -> let (children,rest') = span (\case Heading nextN _ -> nextN > n _ -> True) rest in do childs <- go (level + 1) children siblings <- go level rest' return (Section label childs : siblings) (BeginFence label:rest) | level > 0 -> let (content,rest') = (span (\case PlainLine {} -> True _ -> False) rest) in case rest' of (EndFence:rest'') -> fmap (CodeFence label (S8.intercalate "\n" (map getPlain content)) :) (go level rest'') _ -> throwM NoFenceEnd PlainLine p:rest | level > 0 -> let (content,rest') = (span (\case PlainLine {} -> True _ -> False) (PlainLine p : rest)) in fmap (PlainText (S8.intercalate "\n" (filter (not . S8.null) (map getPlain content))) :) (go level rest') [] -> return [] _ -> throwM ExpectedSection getPlain (PlainLine x) = x getPlain _ = "" hindent-5.3.4/src/main/Benchmark.hs0000644000000000000000000000255514261447465015327 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} -- | Benchmark the pretty printer. module Main where import Control.DeepSeq import Criterion import Criterion.Main import qualified Data.ByteString as S import qualified Data.ByteString.Builder as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.UTF8 as UTF8 import HIndent import HIndent.Types import Markdone -- | Main benchmarks. main :: IO () main = do bytes <- S.readFile "BENCHMARKS.md" !forest <- fmap force (parse (tokenize bytes)) defaultMain (toCriterion forest) -- | Convert the Markdone document to Criterion benchmarks. toCriterion :: [Markdone] -> [Benchmark] toCriterion = go where go (Section name children:next) = bgroup (S8.unpack name) (go children) : go next go (PlainText desc:CodeFence lang code:next) = if lang == "haskell" then (bench (UTF8.toString desc) (nf (either error S.toLazyByteString . reformat HIndent.Types.defaultConfig (Just defaultExtensions) Nothing) code)) : go next else go next go (PlainText {}:next) = go next go (CodeFence {}:next) = go next go [] = [] hindent-5.3.4/elisp/hindent.el0000644000000000000000000002605414261446771014454 0ustar0000000000000000;;; hindent.el --- Indent haskell code using the "hindent" program ;; Copyright (c) 2014 Chris Done. All rights reserved. ;; Author: Chris Done ;; URL: https://github.com/chrisdone/hindent ;; Package-Requires: ((cl-lib "0.5")) ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; Provides a minor mode and commands for easily using the "hindent" ;; program to reformat Haskell code. ;; Add `hindent-mode' to your `haskell-mode-hook' and use the provided ;; keybindings as needed. Set `hindent-reformat-buffer-on-save' to ;; `t' globally or in local variables to have your code automatically ;; reformatted. ;;; Code: (require 'cl-lib) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Customization properties (defgroup hindent nil "Integration with the \"hindent\" reformatting program." :prefix "hindent-" :group 'haskell) (defcustom hindent-style nil "The style to use for formatting. For hindent versions lower than 5, you must set this to a non-nil string." :group 'hindent :type 'string :safe #'stringp) (make-obsolete-variable 'hindent-style nil "hindent 5") (defcustom hindent-process-path "hindent" "Location where the hindent executable is located." :group 'hindent :type 'string :safe #'stringp) (defcustom hindent-extra-args nil "Extra arguments to give to hindent" :group 'hindent :type 'sexp :safe #'listp) (defcustom hindent-reformat-buffer-on-save nil "Set to t to run `hindent-reformat-buffer' when a buffer in `hindent-mode' is saved." :group 'hindent :type 'boolean :safe #'booleanp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Minor mode (defvar hindent-mode-map (let ((map (make-sparse-keymap))) (define-key map [remap indent-region] #'hindent-reformat-region) (define-key map [remap fill-paragraph] #'hindent-reformat-decl-or-fill) map) "Keymap for `hindent-mode'.") ;;;###autoload (define-minor-mode hindent-mode "Indent code with the hindent program. Provide the following keybindings: \\{hindent-mode-map}" :init-value nil :keymap hindent-mode-map :lighter " HI" :group 'hindent :require 'hindent (if hindent-mode (add-hook 'before-save-hook 'hindent--before-save nil t) (remove-hook 'before-save-hook 'hindent--before-save t))) (defun hindent--before-save () "Optionally reformat the buffer on save." (when hindent-reformat-buffer-on-save (hindent-reformat-buffer))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Interactive functions ;;;###autoload (defun hindent-reformat-decl () "Re-format the current declaration. The declaration is parsed and pretty printed. Comments are preserved, although placement may be funky." (interactive) (let ((start-end (hindent-decl-points))) (when start-end (let ((beg (car start-end)) (end (cdr start-end))) (hindent-reformat-region beg end t))))) ;;;###autoload (defun hindent-reformat-buffer () "Reformat the whole buffer." (interactive) (hindent-reformat-region (point-min) (point-max))) ;;;###autoload (defun hindent-reformat-decl-or-fill (justify) "Re-format current declaration, or fill paragraph. Fill paragraph if in a comment, otherwise reformat the current declaration. When filling, the prefix argument JUSTIFY will cause the text to be justified, as per `fill-paragraph'." (interactive (progn ;; Copied from `fill-paragraph' (barf-if-buffer-read-only) (list (if current-prefix-arg 'full)))) (if (hindent-in-comment) (fill-paragraph justify t) (hindent-reformat-decl))) ;;;###autoload (defun hindent-reformat-region (beg end &optional drop-newline) "Reformat the region from BEG to END, accounting for indentation. If DROP-NEWLINE is non-nil, don't require a newline at the end of the file." (interactive "r") (let ((inhibit-read-only t)) (if (= (save-excursion (goto-char beg) (line-beginning-position)) beg) (hindent-reformat-region-as-is beg end drop-newline) (let* ((column (- beg (line-beginning-position))) (string (buffer-substring-no-properties beg end)) (new-string (with-temp-buffer (insert (make-string column ? ) string) (hindent-reformat-region-as-is (point-min) (point-max) drop-newline) (delete-region (point-min) (1+ column)) (buffer-substring (point-min) (point-max))))) (save-excursion (goto-char beg) (delete-region beg end) (insert new-string)))))) ;;;###autoload (define-obsolete-function-alias 'hindent/reformat-decl 'hindent-reformat-decl "hindent 5.2.2") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Internal library (defun hindent-reformat-region-as-is (beg end &optional drop-newline) "Reformat the given region from BEG to END as-is. This is the place where hindent is actually called. If DROP-NEWLINE is non-nil, don't require a newline at the end of the file." (let* ((original (current-buffer)) (orig-str (buffer-substring-no-properties beg end))) (with-temp-buffer (let ((temp (current-buffer))) (with-current-buffer original (let ((ret (apply #'call-process-region (append (list beg end hindent-process-path nil ; delete temp ; output nil) (hindent-extra-arguments))))) (cond ((= ret 1) (let ((error-string (with-current-buffer temp (let ((string (progn (goto-char (point-min)) (buffer-substring (line-beginning-position) (line-end-position))))) string)))) (if (string= error-string "hindent: Parse error: EOF") (message "language pragma") (error error-string)))) ((= ret 0) (let* ((last-decl (= end (point-max))) (new-str (with-current-buffer temp (when (and drop-newline (not last-decl)) (goto-char (point-max)) (when (looking-back "\n" (1- (point))) (delete-char -1))) (delete-trailing-whitespace) (buffer-string)))) (if (not (string= new-str orig-str)) (progn (if (fboundp 'replace-region-contents) (replace-region-contents beg end (lambda () temp)) (let ((line (line-number-at-pos)) (col (current-column))) (delete-region beg end) (insert new-str))) (message "Formatted.")) (message "Already formatted."))))))))))) (defun hindent-decl-points () "Get the start and end position of the current declaration. This assumes that declarations start at column zero and that the rest is always indented by one space afterwards, so Template Haskell uses with it all being at column zero are not expected to work." (cond ;; If we're in a block comment spanning multiple lines then let's ;; see if it starts at the beginning of the line (or if any comment ;; is at the beginning of the line, we don't care to treat it as a ;; proper declaration. ((and (hindent-in-comment) (save-excursion (goto-char (line-beginning-position)) (hindent-in-comment))) nil) ((save-excursion (goto-char (line-beginning-position)) (or (looking-at "^-}$") (looking-at "^{-$"))) nil) ;; Otherwise we just do our line-based hack. (t (save-excursion (let ((start (or (cl-letf (((symbol-function 'jump) #'(lambda () (search-backward-regexp "^[^ \n]" nil t 1) (cond ((save-excursion (goto-char (line-beginning-position)) (looking-at "|]")) (jump)) (t (unless (or (looking-at "^-}$") (looking-at "^{-$")) (point))))))) (goto-char (line-end-position)) (jump)) 0)) (end (progn (goto-char (1+ (point))) (or (cl-letf (((symbol-function 'jump) #'(lambda () (when (search-forward-regexp "[\n]+[^ \n]" nil t 1) (cond ((save-excursion (goto-char (line-beginning-position)) (looking-at "|]")) (jump)) (t (forward-char -1) (search-backward-regexp "[^\n ]" nil t) (forward-char) (point))))))) (jump)) (point-max))))) (cons start end)))))) (defun hindent-in-comment () "Are we currently in a comment?" (save-excursion (when (and (= (line-end-position) (point)) (/= (line-beginning-position) (point))) (forward-char -1)) (and (elt (syntax-ppss) 4) ;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as ;; comments, even though they are highlighted as such (not (save-excursion (goto-char (line-beginning-position)) (looking-at "{-# ")))))) (defun hindent-extra-arguments () "Extra command line arguments for the hindent invocation." (append (when (boundp 'haskell-language-extensions) haskell-language-extensions) (when hindent-style (list "--style" hindent-style)) (when hindent-extra-args hindent-extra-args))) (provide 'hindent) ;;; hindent.el ends here hindent-5.3.4/LICENSE.md0000644000000000000000000000264014261446771012764 0ustar0000000000000000Copyright (c) 2014, Chris Done All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of hindent nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL CHRIS DONE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hindent-5.3.4/Setup.hs0000644000000000000000000000005614261446771013013 0ustar0000000000000000import Distribution.Simple main = defaultMain hindent-5.3.4/hindent.cabal0000644000000000000000000000702114261460675013772 0ustar0000000000000000name: hindent version: 5.3.4 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . See the Github page for usage\/explanation: license: BSD3 stability: Unstable license-file: LICENSE.md author: Mihai Maruseac, Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker maintainer: Mihai Maruseac copyright: 2014 Chris Done, 2015 Andrew Gibiansky, 2021 Mihai Maruseac category: Development build-type: Simple cabal-version: >=1.10 homepage: https://github.com/mihaimaruseac/hindent bug-reports: https://github.com/mihaimaruseac/hindent/issues data-files: elisp/hindent.el extra-source-files: README.md CHANGELOG.md BENCHMARKS.md TESTS.md source-repository head type: git location: https://github.com/mihaimaruseac/hindent library hs-source-dirs: src/ ghc-options: -Wall -O2 default-language: Haskell2010 exposed-modules: HIndent HIndent.Types HIndent.Pretty HIndent.CabalFile HIndent.CodeBlock build-depends: base >= 4.7 && <5 , containers , Cabal , filepath , directory , haskell-src-exts >= 1.20 , monad-loops , mtl , bytestring , utf8-string , transformers , exceptions , text , yaml executable hindent hs-source-dirs: src/main ghc-options: -Wall -O2 default-language: Haskell2010 main-is: Main.hs other-modules: Path.Find build-depends: base >= 4 && < 5 , hindent , bytestring , utf8-string , haskell-src-exts , ghc-prim , directory , text , yaml , unix-compat , deepseq , path , path-io , transformers , exceptions , optparse-applicative test-suite hindent-test type: exitcode-stdio-1.0 hs-source-dirs: src/main/ default-language: Haskell2010 main-is: Test.hs other-modules: Markdone build-depends: base >= 4 && <5 , hindent , haskell-src-exts , monad-loops , mtl , bytestring , utf8-string , hspec , directory , deepseq , exceptions , utf8-string , Diff benchmark hindent-bench type: exitcode-stdio-1.0 hs-source-dirs: src/main default-language: Haskell2010 ghc-options: -Wall -O2 -rtsopts main-is: Benchmark.hs other-modules: Markdone build-depends: base >= 4 && < 5 , hindent , bytestring , utf8-string , haskell-src-exts , ghc-prim , directory , criterion , deepseq , exceptions , mtl hindent-5.3.4/README.md0000644000000000000000000001046414261446771012642 0ustar0000000000000000# hindent [![Hackage](https://img.shields.io/hackage/v/hindent.svg?style=flat)](https://hackage.haskell.org/package/hindent) ![CI (Stack)](https://github.com/mihaimaruseac/hindent/workflows/CI%20(Stack)/badge.svg) ![CI (Cabal)](https://github.com/mihaimaruseac/hindent/workflows/CI%20(Cabal)/badge.svg) Haskell pretty printer [Examples](https://github.com/mihaimaruseac/hindent/blob/master/TESTS.md) ## Install $ stack install hindent ## Usage $ hindent --help hindent --version --help --style STYLE --line-length <...> --indent-size <...> --no-force-newline [-X<...>]* [] Version 5.1.1 Default --indent-size is 2. Specify --indent-size 4 if you prefer that. -X to pass extensions e.g. -XMagicHash etc. The --style option is now ignored, but preserved for backwards-compatibility. Johan Tibell is the default and only style. hindent is used in a pipeline style $ cat path/to/sourcefile.hs | hindent The default indentation size is `2` spaces. Configure indentation size with `--indent-size`: $ echo 'example = case x of Just p -> foo bar' | hindent --indent-size 2; echo example = case x of Just p -> foo bar $ echo 'example = case x of Just p -> foo bar' | hindent --indent-size 4; echo example = case x of Just p -> foo bar ## Customization Create a `.hindent.yaml` file in your project directory or in your `~/` home directory. The following fields are accepted and are the default: ``` yaml indent-size: 2 line-length: 80 force-trailing-newline: true line-breaks: [":>", ":<|>"] extensions: - DataKinds - GADTs - TypeApplications ``` By default, hindent preserves the newline or lack of newline in your input. With `force-trailing-newline`, it will make sure there is always a trailing newline. hindent can be forced to insert a newline before specific operators and tokens with `line-breaks`. This is especially useful when utilizing libraries like [`servant`](https://docs.servant.dev/) which use long type aliases. Using `extensions`, hindent can be made aware of valid syntactic compiler extensions that would normally be considered invalid syntax. It is also possible to specify which extensions HIndent runs with in your `.hindent.yaml`: ```yaml extensions: - MagicHash - RecursiveDo ``` ## Emacs In [elisp/hindent.el](https://github.com/mihaimaruseac/hindent/blob/master/elisp/hindent.el) there is `hindent-mode`, which provides keybindings to reindent parts of the buffer: - `M-q` reformats the current declaration. When inside a comment, it fills the current paragraph instead, like the standard `M-q`. - `C-M-\` reformats the current region. To enable it, add the following to your init file: ```lisp (add-to-list 'load-path "/path/to/hindent/elisp") (require 'hindent) (add-hook 'haskell-mode-hook #'hindent-mode) ``` ## Vim The `'formatprg'` option lets you use an external program (like hindent) to format your text. Put the following line into ~/.vim/ftplugin/haskell.vim to set this option for Haskell files: setlocal formatprg=hindent Then you can format with hindent using `gq`. Read `:help gq` and `help 'formatprg'` for more details. Note that unlike in emacs you have to take care of selecting a sensible buffer region as input to hindent yourself. If that is too much trouble you can try [vim-textobj-haskell](https://github.com/gilligan/vim-textobj-haskell) which provides a text object for top level bindings. In order to format an entire source file execute: :%!hindent Alternatively you could use the [vim-hindent](https://github.com/alx741/vim-hindent) plugin which runs hindent automatically when a Haskell file is saved. ## Atom Fortunately, you can use https://atom.io/packages/ide-haskell with the path to hindent specified instead of that to stylish-haskell. Works like a charm that way! ## IntelliJ / other JetBrains IDEs 1. Install the "HaskForce" Haskell plugin (this is so we get the language type recognized in the file watcher) 2. Install the "File Watchers" plugin under "Browse Repositories" 3. Add a File Watcher with 1. File type: Haskell Language 2. Program: `/path/to/hindent` 3. Arguments: `$FilePath$` 4. Immediate file synchronization: off 5. Show console: Error Now whenever you save a file, `hindent` should autoformat it. hindent-5.3.4/CHANGELOG.md0000644000000000000000000000773314261446771013201 0ustar00000000000000005.3.0: * Handle multiple deriving clauses in a DerivingStrategies scenario * Ignore non-files in findCabalFiles * Allow batch processing of multiple files * Prevent hindent from trying to open non-files when searching for .cabal files * Specify default extensions in configuration file * Fix bad output for [p|Foo|] pattern quasi-quotes * Parse C preprocessor line continuations * Fix pretty printing of '(:) * Add parens around symbols (:|) when required * Support $p pattern splices * Fix associated type families * Non-dependent record constructor formatting 5.2.7: * Fix -X option bug 5.2.6: * Switch to optparse-applicative 5.2.5: * Support get extensions from `.cabal` file * Improve indention with record constructions and updates * Fix `let ... in` bug * Fix top-level lambda expressions in TemplateHaskell slices * Update to haskell-src-exts dependency to version `>= 1.20.0` 5.2.4: * Pretty print imports * Fix pretty print for string literals for `DataKinds` * Support `--validate` option for checking the format without reformatting * Support parse `#include`, `#error`, `#warning` directives * Support read `LANGUAGE` pragma and parse the declared extensions from source * Treat `TypeApplications` extension as 'badExtensions' due to the `@` symbol * Improve pretty print for unboxed tuples * Fix many issues related to infix operators, includes TH name quotes, `INLINE`/`NOINLINE` pragmas, infix type operator and infix constructor * Fix pretty print for operators in `INLINE`/`NOINLINE` pragmas * Support for `EmptyCases` extension * Fix TH name quotes on operator names * Optimize pretty print for many fundeps * Fix extra linebreaks after short identifiers 5.2.3: * Sort explicit import lists * Report the `SrcLoc` when there's a parse error * Improve long type signatures pretty printing * Support custom line-break operators, add `--line-breaks` argument * Fix infix data constructor * Disable `RecursiveDo` and `DoRec` extensions by default * Add RecStmt support * Improve GADT records, data declaration records * Complicated type alias and type signatures pretty printing * Fix quasi-quoter names 5.2.2: * Parallel list comprehensions * Leave do, lambda, lambda-case on previous line of $ * Misc fixes 5.2.1: * Fix hanging on large constraints * Render multi-line comments * Rename --tab-size to --indent-size * Don't add a spurious space for comments at the end of the file * Don't add trailing whitespace on <- * Disable PatternSynonyms * Put a newline before the closing bracket on a list 5.2.0: * Default tab-width is now 2 * Supports .hindent.yaml file to specify alt tab-width and max column * Put last paren of export list on a new line * Implement tab-size support in Emacs Lisp 5.1.1: * Preserve spaces between groups of imports (fixes #200) * Support shebangs (closes #208) * Output filename for parse errors (fixes #179) * Input with newline ends with newline (closes #211) * Document -X (closes #212) * Fix explicit forall in instances (closes #218) * Put last paren of export list on a new line #227 5.1.0: * Rewrote comment association, more reliable * Added --tab-size flag for indentation spaces * Fixed some miscellaneous bugs 5.0.1: * Re-implement using bytestring instead of text * Made compatible with GHC 7.8 through to GHC 8.0 * Added test suite and benchmarks in TESTS.md and BENCHMARKS.md 5.0.0: * Drop support for styles 4.6.4 * Copy/delete file instead of renaming 4.4.6 * Fix whole module printer * Accept a filename to reformat 4.4.5 * Fix bug in infix patterns 4.4.2 * Bunch of Gibiansky style fixes. * Support CPP. * Tibell style fixes. 4.3.8 * Fixed: bug in printing operators in statements. 4.5.4 * Improvements to Tibell style. * 6x speed up on rendering operators. hindent-5.3.4/BENCHMARKS.md0000644000000000000000000001456214261446771013325 0ustar0000000000000000# Large inputs Bunch of declarations ``` haskell listPrinters = [(''[] ,\(typeVariable:_) _automaticPrinter -> (let presentVar = varE (presentVarName typeVariable) in lamE [varP (presentVarName typeVariable)] [|(let typeString = "[" ++ fst $(presentVar) ++ "]" in (typeString ,\xs -> case fst $(presentVar) of "GHC.Types.Char" -> ChoicePresentation "String" [("String",undefined) ,("List of characters",undefined)] _ -> ListPresentation typeString (map (snd $(presentVar)) xs)))|]))] printComments loc' ast = do let correctLocation comment = comInfoLocation comment == Just loc' commentsWithLocation = filter correctLocation (nodeInfoComments info) comments <- return $ map comInfoComment commentsWithLocation forM_ comments $ \comment -> do -- Preceeding comments must have a newline before them. hasNewline <- gets psNewline when (not hasNewline && loc' == Before) newline printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment where info = ann ast exp' (App _ op a) = do (fits,st) <- fitsOnOneLine (spaced (map pretty (f : args))) if fits then put st else do pretty f newline spaces <- getIndentSpaces indented spaces (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) infixApp :: Exp NodeInfo -> Exp NodeInfo -> QOp NodeInfo -> Exp NodeInfo -> Maybe Int64 -> Printer () ``` Bunch of declarations - sans comments ``` haskell listPrinters = [(''[] ,\(typeVariable:_) _automaticPrinter -> (let presentVar = varE (presentVarName typeVariable) in lamE [varP (presentVarName typeVariable)] [|(let typeString = "[" ++ fst $(presentVar) ++ "]" in (typeString ,\xs -> case fst $(presentVar) of "GHC.Types.Char" -> ChoicePresentation "String" [("String",undefined) ,("List of characters",undefined)] _ -> ListPresentation typeString (map (snd $(presentVar)) xs)))|]))] printComments loc' ast = do let correctLocation comment = comInfoLocation comment == Just loc' commentsWithLocation = filter correctLocation (nodeInfoComments info) comments <- return $ map comInfoComment commentsWithLocation forM_ comments $ \comment -> do hasNewline <- gets psNewline when (not hasNewline && loc' == Before) newline printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment where info = ann ast exp' (App _ op a) = do (fits,st) <- fitsOnOneLine (spaced (map pretty (f : args))) if fits then put st else do pretty f newline spaces <- getIndentSpaces indented spaces (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) infixApp :: Exp NodeInfo -> Exp NodeInfo -> QOp NodeInfo -> Exp NodeInfo -> Maybe Int64 -> Printer () ``` # Complex inputs Quasi-quotes with nested lets and operators ``` haskell quasiQuotes = [(''[] ,\(typeVariable:_) _automaticPrinter -> (let presentVar = varE (presentVarName typeVariable) in lamE [varP (presentVarName typeVariable)] [|(let typeString = "[" ++ fst $(presentVar) ++ "]" in (typeString ,\xs -> case fst $(presentVar) of "GHC.Types.Char" -> ChoicePresentation "String" [("String" ,StringPresentation "String" (concatMap getCh (map (snd $(presentVar)) xs))) ,("List of characters" ,ListPresentation typeString (map (snd $(presentVar)) xs))] where getCh (CharPresentation "GHC.Types.Char" ch) = ch getCh (ChoicePresentation _ ((_,CharPresentation _ ch):_)) = ch getCh _ = "" _ -> ListPresentation typeString (map (snd $(presentVar)) xs)))|]))] ``` Lots of comments and operators ``` haskell bob -- after bob = foo -- next to foo -- line after foo (bar foo -- next to bar foo bar -- next to bar ) -- next to the end paren of (bar) -- line after (bar) mu -- next to mu -- line after mu -- another line after mu zot -- next to zot -- line after zot (case casey -- after casey of Just -- after Just -> do justice -- after justice * foo (blah * blah + z + 2 / 4 + a - -- before a line break 2 * -- inside this mess z / 2 / 2 / aooooo / aaaaa -- bob comment ) + (sdfsdfsd fsdfsdf) -- blah comment putStrLn "") [1, 2, 3] [ 1 -- foo , ( 2 -- bar , 2.5 -- mu ) , 3] foo = 1 -- after foo ``` hindent-5.3.4/TESTS.md0000644000000000000000000007716214261446771012617 0ustar0000000000000000# Introduction This file is a test suite. Each section maps to an HSpec test, and each line that is followed by a Haskell code fence is tested to make sure re-formatting that code snippet produces the same result. You can browse through this document to see what HIndent's style is like, or contribute additional sections to it, or regression tests. # Modules Empty module ``` haskell ``` Double shebangs ``` haskell #!/usr/bin/env stack #!/usr/bin/env stack main = pure () ``` Extension pragmas ```haskell {-# LANGUAGE TypeApplications #-} fun @Int 12 ``` Module header ``` haskell module X where x = 1 ``` Exports ``` haskell module X ( x , y , Z , P(x, z) ) where ``` Exports, indentation 4 ``` haskell 4 module X ( x , y , Z , P(x, z) ) where ``` # Imports Import lists ``` haskell import Data.Text import Data.Text import qualified Data.Text as T import qualified Data.Text (a, b, c) import Data.Text (a, b, c) import Data.Text hiding (a, b, c) ``` Sorted ```haskell given import B import A ``` ```haskell expect import A import B ``` Explicit imports - capitals first (typeclasses/types), then operators, then identifiers ```haskell given import qualified MegaModule as M ((>>>), MonadBaseControl, void, MaybeT(..), join, Maybe(Nothing, Just), liftIO, Either, (<<<), Monad(return, (>>=), (>>))) ``` ```haskell expect import qualified MegaModule as M ( Either , Maybe(Just, Nothing) , MaybeT(..) , Monad((>>), (>>=), return) , MonadBaseControl , (<<<) , (>>>) , join , liftIO , void ) ``` Pretty import specification ```haskell import A hiding ( foobarbazqux , foobarbazqux , foobarbazqux , foobarbazqux , foobarbazqux , foobarbazqux , foobarbazqux ) import Name hiding () import {-# SOURCE #-} safe qualified Module as M hiding (a, b, c, d, e, f) ``` # Declarations Type declaration ``` haskell type EventSource a = (AddHandler a, a -> IO ()) ``` Type declaration with infix promoted type constructor ```haskell fun1 :: Def ('[ Ref s (Stored Uint32), IBool] 'T.:-> IBool) fun1 = undefined fun2 :: Def ('[ Ref s (Stored Uint32), IBool] ':-> IBool) fun2 = undefined ``` Instance declaration without decls ``` haskell instance C a ``` Instance declaration with decls ``` haskell instance C a where foobar = do x y k p ``` Symbol class constructor in instance declaration ```haskell instance Bool :?: Bool instance (:?:) Int Bool ``` GADT declarations ```haskell data Ty :: (* -> *) where TCon :: { field1 :: Int , field2 :: Bool} -> Ty Bool TCon' :: (a :: *) -> a -> Ty a ``` # Expressions Lazy patterns in a lambda ``` haskell f = \ ~a -> undefined -- \~a yields parse error on input ‘\~’ ``` Bang patterns in a lambda ``` haskell f = \ !a -> undefined -- \!a yields parse error on input ‘\!’ ``` List comprehensions, short ``` haskell map f xs = [f x | x <- xs] ``` List comprehensions, long ``` haskell defaultExtensions = [ e | EnableExtension {extensionField1 = extensionField1} <- knownExtensions knownExtensions , let a = b -- comment , let c = d -- comment ] ``` List comprehensions with operators ```haskell defaultExtensions = [e | e@EnableExtension {} <- knownExtensions] \\ map EnableExtension badExtensions ``` Parallel list comprehension, short ```haskell zip xs ys = [(x, y) | x <- xs | y <- ys] ``` Parallel list comprehension, long ```haskell fun xs ys = [ (alphaBetaGamma, deltaEpsilonZeta) | x <- xs , z <- zs | y <- ys , cond , let t = t ] ``` Record, short ``` haskell getGitProvider :: EventProvider GitRecord () getGitProvider = EventProvider {getModuleName = "Git", getEvents = getRepoCommits} ``` Record, medium ``` haskell commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event commitToEvent gitFolderPath timezone commit = Event.Event {pluginName = getModuleName getGitProvider, eventIcon = "glyphicon-cog"} ``` Record, long ``` haskell commitToEvent :: FolderPath -> TimeZone -> Commit -> Event.Event commitToEvent gitFolderPath timezone commit = Event.Event { pluginName = getModuleName getGitProvider , eventIcon = "glyphicon-cog" , eventDate = localTimeToUTC timezone (commitDate commit) } ``` Record with symbol constructor ```haskell f = (:..?) {} ``` Record with symbol field ```haskell f x = x {(..?) = wat} g x = Rec {(..?)} ``` Cases ``` haskell strToMonth :: String -> Int strToMonth month = case month of "Jan" -> 1 "Feb" -> 2 _ -> error $ "Unknown month " ++ month ``` Operators, bad ``` haskell x = Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*> Just stilllonger <*> evenlonger ``` Operators, good ```haskell pending x = Value <$> thing <*> secondThing <*> thirdThing <*> fourthThing <*> Just thisissolong <*> Just stilllonger <*> evenlonger ``` Operator with `do` ```haskell for xs $ do left x right x ``` Operator with lambda ```haskell for xs $ \x -> do left x right x ``` Operator with lambda-case ```haskell for xs $ \case Left x -> x ``` Operator in parentheses ```haskell cat = (++) ``` Symbol data constructor in parentheses ```haskell cons = (:) cons' = (:|) ``` n+k patterns ``` haskell f (n+5) = 0 ``` Binary symbol data constructor in pattern ```haskell f (x :| _) = x f' ((:|) x _) = x f'' ((Data.List.NonEmpty.:|) x _) = x g (x:xs) = x g' ((:) x _) = x ``` Type application ```haskell {-# LANGUAGE TypeApplications #-} fun @Int 12 ``` Transform list comprehensions ```haskell list = [ (x, y, map the v) | x <- [1 .. 10] , y <- [1 .. 10] , let v = x + y , then group by v using groupWith , then take 10 , then group using permutations , t <- concat v , then takeWhile by t < 3 ] ``` Type families ```haskell type family Id a ``` Type family annotations ``` haskell type family Id a :: * ``` Type family instances ```haskell type instance Id Int = Int ``` Type family dependencies ```haskell type family Id a = r | r -> a ``` Binding implicit parameters ```haskell f = let ?x = 42 in f ``` Closed type families ```haskell type family Closed (a :: k) :: Bool where Closed x = 'True ``` # Template Haskell Expression brackets ```haskell add1 x = [|x + 1|] ``` Pattern brackets ```haskell mkPat = [p|(x, y)|] ``` Type brackets ```haskell foo :: $([t|Bool|]) -> a ``` Quoted data constructors ```haskell cons = '(:) ``` Pattern splices ```haskell f $pat = () g = case x of $(mkPat y z) -> True _ -> False ``` # Type signatures Long argument list should line break ```haskell longLongFunction :: ReaderT r (WriterT w (StateT s m)) a -> StateT s (WriterT w (ReaderT r m)) a ``` Class constraints should leave `::` on same line ``` haskell -- see https://github.com/chrisdone/hindent/pull/266#issuecomment-244182805 fun :: (Class a, Class b) => fooooooooooo bar mu zot -> fooooooooooo bar mu zot -> c ``` Class constraints ``` haskell fun :: (Class a, Class b) => a -> b -> c ``` Symbol class constructor in class constraint ```haskell f :: (a :?: b) => (a, b) f' :: ((:?:) a b) => (a, b) ``` Tuples ``` haskell fun :: (a, b, c) -> (a, b) ``` Quasiquotes in types ```haskell fun :: [a|bc|] ``` Default signatures ```haskell -- https://github.com/chrisdone/hindent/issues/283 class Foo a where bar :: a -> a -> a default bar :: Monoid a => a -> a -> a bar = mappend ``` Implicit parameters ```haskell f :: (?x :: Int) => Int ``` Symbol type constructor ```haskell f :: a :?: b f' :: (:?:) a b ``` Promoted list (issue #348) ```haskell a :: A '[ 'True] a = undefined -- nested promoted list with multiple elements. b :: A '[ '[ 'True, 'False], '[ 'False, 'True]] b = undefined ``` Promoted list with a tuple (issue #348) ```haskell a :: A '[ '( a, b, c, d)] a = undefined -- nested promoted tuples. b :: A '[ '( 'True, 'False, '[], '( 'False, 'True))] b = undefined ``` Prefix promoted symbol type constructor ```haskell a :: '(T.:->) 'True 'False b :: (T.:->) 'True 'False c :: '(:->) 'True 'False d :: (:->) 'True 'False ``` # Function declarations Prefix notation for operators ``` haskell (+) :: Num a => a -> a -> a (+) a b = a ``` Where clause ``` haskell sayHello = do name <- getLine putStrLn $ greeting name where greeting name = "Hello, " ++ name ++ "!" ``` Guards and pattern guards ``` haskell f x | x <- Just x , x <- Just x = case x of Just x -> e | otherwise = do e where x = y ``` Multi-way if ``` haskell x = if | x <- Just x, x <- Just x -> case x of Just x -> e Nothing -> p | otherwise -> e ``` Case inside a `where` and `do` ``` haskell g x = case x of a -> x where foo = case x of _ -> do launchMissiles where y = 2 ``` Let inside a `where` ``` haskell g x = let x = 1 in x where foo = let y = 2 z = 3 in y ``` Lists ``` haskell exceptions = [InvalidStatusCode, MissingContentHeader, InternalServerError] exceptions = [ InvalidStatusCode , MissingContentHeader , InternalServerError , InvalidStatusCode , MissingContentHeader , InternalServerError ] ``` Long line, function application ```haskell test = do alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRh79 alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRho80 alphaBetaGamma deltaEpsilonZeta etaThetaIota kappaLambdaMu nuXiOmicron piRhoS81 ``` Long line, tuple ```haskell test (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicro79) (alphaBetaGamma, deltaEpsilonZeta, etaThetaIota, kappaLambdaMu, nuXiOmicron80) ( alphaBetaGamma , deltaEpsilonZeta , etaThetaIota , kappaLambdaMu , nuXiOmicronP81) ``` Long line, tuple section ```haskell test (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, nu79, ) (, alphaBetaGamma, , deltaEpsilonZeta, , etaThetaIota, kappaLambdaMu, , n80, ) ( , alphaBetaGamma , , deltaEpsilonZeta , , etaThetaIota , kappaLambdaMu , , nu81 ,) ``` # Record syntax Pattern matching, short ```haskell fun Rec {alpha = beta, gamma = delta, epsilon = zeta, eta = theta, iota = kappa} = do beta + delta + zeta + theta + kappa ``` Pattern matching, long ```haskell fun Rec { alpha = beta , gamma = delta , epsilon = zeta , eta = theta , iota = kappa , lambda = mu } = beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa ``` Symbol constructor, short ```haskell fun ((:..?) {}) = undefined ``` Symbol constructor, long ``` fun (:..?) { alpha = beta , gamma = delta , epsilon = zeta , eta = theta , iota = kappa , lambda = mu } = beta + delta + zeta + theta + kappa + mu + beta + delta + zeta + theta + kappa ``` Symbol field ```haskell f (X {(..?) = x}) = x ``` Punned symbol field ```haskell f' (X {(..?)}) = (..?) ``` # Johan Tibell compatibility checks Basic example from Tibbe's style ``` haskell sayHello :: IO () sayHello = do name <- getLine putStrLn $ greeting name where greeting name = "Hello, " ++ name ++ "!" filter :: (a -> Bool) -> [a] -> [a] filter _ [] = [] filter p (x:xs) | p x = x : filter p xs | otherwise = filter p xs ``` Data declarations ``` haskell data Tree a = Branch !a !(Tree a) !(Tree a) | Leaf data Tree a = Branch !a !(Tree a) !(Tree a) !(Tree a) !(Tree a) !(Tree a) !(Tree a) !(Tree a) | Leaf data HttpException = InvalidStatusCode Int | MissingContentHeader data Person = Person { firstName :: !String -- ^ First name , lastName :: !String -- ^ Last name , age :: !Int -- ^ Age } data Expression a = VariableExpression { id :: Id Expression , label :: a } | FunctionExpression { var :: Id Expression , body :: Expression a , label :: a } | ApplyExpression { func :: Expression a , arg :: Expression a , label :: a } | ConstructorExpression { id :: Id Constructor , label :: a } ``` Spaces between deriving classes ``` haskell -- From https://github.com/chrisdone/hindent/issues/167 data Person = Person { firstName :: !String -- ^ First name , lastName :: !String -- ^ Last name , age :: !Int -- ^ Age } deriving (Eq, Show) ``` Hanging lambdas ``` haskell bar :: IO () bar = forM_ [1, 2, 3] $ \n -> do putStrLn "Here comes a number!" print n foo :: IO () foo = alloca 10 $ \a -> alloca 20 $ \b -> cFunction fooo barrr muuu (fooo barrr muuu) (fooo barrr muuu) ``` # Comments Comments within a declaration ``` haskell bob -- after bob = foo -- next to foo -- line after foo (bar foo -- next to bar foo bar -- next to bar ) -- next to the end paren of (bar) -- line after (bar) mu -- next to mu -- line after mu -- another line after mu zot -- next to zot -- line after zot (case casey -- after casey of Just -- after Just -> do justice -- after justice * foo (blah * blah + z + 2 / 4 + a - -- before a line break 2 * -- inside this mess z / 2 / 2 / aooooo / aaaaa -- bob comment ) + (sdfsdfsd fsdfsdf) -- blah comment putStrLn "") [1, 2, 3] [ 1 -- foo , ( 2 -- bar , 2.5 -- mu ) , 3 ] -- in the end of the function where alpha = alpha -- between alpha and beta beta = beta -- after beta foo = 1 -- after foo gamma = do delta epsilon -- in the end of a do-block 1 gamma = do delta epsilon -- the very last block is detected differently ``` Doesn't work yet (wrong comment position detection) ```haskell pending gamma = do -- in the beginning of a do-block delta where -- before alpha alpha = alpha ``` Haddock comments ``` haskell -- | Module comment. module X where -- | Main doc. main :: IO () main = return () data X = X -- ^ X is for xylophone. | Y -- ^ Y is for why did I eat that pizza. data X = X { field1 :: Int -- ^ Field1 is the first field. , field11 :: Char -- ^ This field comment is on its own line. , field2 :: Int -- ^ Field2 is the second field. , field3 :: Char -- ^ This is a long comment which starts next to -- the field but continues onto the next line, it aligns exactly -- with the field name. , field4 :: Char -- ^ This is a long comment which starts on the following line -- from from the field, lines continue at the sme column. } ``` Comments around regular declarations ``` haskell -- This is some random comment. -- | Main entry point. main = putStrLn "Hello, World!" -- This is another random comment. ``` Multi-line comments ``` haskell bob {- after bob -} = foo {- next to foo -} {- line after foo -} (bar foo {- next to bar foo -} bar {- next to bar -} ) {- next to the end paren of (bar) -} {- line after (bar) -} mu {- next to mu -} {- line after mu -} {- another line after mu -} zot {- next to zot -} {- line after zot -} (case casey {- after casey -} of Just {- after Just -} -> do justice {- after justice -} * foo (blah * blah + z + 2 / 4 + a - {- before a line break -} 2 * {- inside this mess -} z / 2 / 2 / aooooo / aaaaa {- bob comment -} ) + (sdfsdfsd fsdfsdf) {- blah comment -} putStrLn "") [1, 2, 3] [ 1 {- foo -} , ( 2 {- bar -} , 2.5 {- mu -} ) , 3 ] foo = 1 {- after foo -} ``` Multi-line comments with multi-line contents ``` haskell {- | This is some random comment. Here is more docs and such. Etc. -} main = putStrLn "Hello, World!" {- This is another random comment. -} ``` # MINIMAL pragma Monad example ```haskell class A where {-# MINIMAL return, ((>>=) | (join, fmap)) #-} ``` Very long names #310 ```haskell class A where {-# MINIMAL averylongnamewithnoparticularmeaning | ananotherverylongnamewithnomoremeaning #-} ``` # Behaviour checks Unicode ``` haskell α = γ * "ω" -- υ ``` Empty module ``` haskell ``` Trailing newline is preserved ``` haskell module X where foo = 123 ``` # Complex input A complex, slow-to-print decl ``` haskell quasiQuotes = [ ( ''[] , \(typeVariable:_) _automaticPrinter -> (let presentVar = varE (presentVarName typeVariable) in lamE [varP (presentVarName typeVariable)] [|(let typeString = "[" ++ fst $(presentVar) ++ "]" in ( typeString , \xs -> case fst $(presentVar) of "GHC.Types.Char" -> ChoicePresentation "String" [ ( "String" , StringPresentation "String" (concatMap getCh (map (snd $(presentVar)) xs))) , ( "List of characters" , ListPresentation typeString (map (snd $(presentVar)) xs)) ] where getCh (CharPresentation "GHC.Types.Char" ch) = ch getCh (ChoicePresentation _ ((_, CharPresentation _ ch):_)) = ch getCh _ = "" _ -> ListPresentation typeString (map (snd $(presentVar)) xs)))|])) ] ``` Random snippet from hindent itself ``` haskell exp' (App _ op a) = do (fits, st) <- fitsOnOneLine (spaced (map pretty (f : args))) if fits then put st else do pretty f newline spaces <- getIndentSpaces indented spaces (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) ``` Quasi quotes ```haskell exp = [name|exp|] f [qq|pattern|] = () ``` # C preprocessor Conditionals (`#if`) ```haskell isDebug :: Bool #if DEBUG isDebug = True #else isDebug = False #endif ``` Macro definitions (`#define`) ```haskell #define STRINGIFY(x) #x f = STRINGIFY (y) ``` Escaped newlines ```haskell #define LONG_MACRO_DEFINITION \ data Pair a b = Pair \ { first :: a \ , second :: b \ } #define SHORT_MACRO_DEFINITION \ x ``` # Regression tests jml Adds trailing whitespace when wrapping #221 ``` haskell x = do config <- execParser options comments <- case config of Diff False args -> commentsFromDiff args Diff True args -> commentsFromDiff ("--cached" : args) Files args -> commentsFromFiles args mapM_ (putStrLn . Fixme.formatTodo) (concatMap Fixme.getTodos comments) ``` meditans hindent freezes when trying to format this code #222 ``` haskell c :: forall new. ( Settable "pitch" Pitch (Map.AsMap (new Map.:\ "pitch")) new , Default (Book' (Map.AsMap (new Map.:\ "pitch"))) ) => Book' new c = set #pitch C (def :: Book' (Map.AsMap (new Map.:\ "pitch"))) foo :: ( Foooooooooooooooooooooooooooooooooooooooooo , Foooooooooooooooooooooooooooooooooooooooooo ) => A ``` bitemyapp wonky multiline comment handling #231 ``` haskell module Woo where hi = "hello" {- test comment -} -- blah blah -- blah blah -- blah blah ``` cocreature removed from declaration issue #186 ``` haskell -- https://github.com/chrisdone/hindent/issues/186 trans One e n = M.singleton (Query Unmarked (Mark NonExistent)) -- The goal of this is to fail always (emptyImage {notPresent = S.singleton (TransitionResult Two (Just A) n)}) ``` sheyll explicit forall in instances #218 ``` haskell -- https://github.com/chrisdone/hindent/issues/218 instance forall x. C instance forall x. Show x => C x ``` tfausak support shebangs #208 ``` haskell given #!/usr/bin/env stack -- stack runghc main = pure () -- https://github.com/chrisdone/hindent/issues/208 ``` ``` haskell expect #!/usr/bin/env stack -- stack runghc main = pure () -- https://github.com/chrisdone/hindent/issues/208 ``` joe9 preserve newlines between import groups ``` haskell -- https://github.com/chrisdone/hindent/issues/200 import Data.List import Data.Maybe import FooBar import MyProject import GHC.Monad -- blah import Hello import CommentAfter -- Comment here shouldn't affect newlines import HelloWorld import CommentAfter -- Comment here shouldn't affect newlines import HelloWorld -- Comment here shouldn't affect newlines import CommentAfter import HelloWorld ``` Wrapped import list shouldn't add newline ```haskell given import ATooLongList (alpha, beta, gamma, delta, epsilon, zeta, eta, theta) import B ``` ```haskell expect import ATooLongList (alpha, beta, delta, epsilon, eta, gamma, theta, zeta) import B ``` radupopescu `deriving` keyword not aligned with pipe symbol for type declarations ``` haskell data Stuffs = Things | This | That deriving (Show) data Simple = Simple deriving (Show) ``` sgraf812 top-level pragmas should not add an additional newline #255 ``` haskell -- https://github.com/chrisdone/hindent/issues/255 {-# INLINE f #-} f :: Int -> Int f n = n ``` ivan-timokhin breaks code with type operators #277 ```haskell -- https://github.com/chrisdone/hindent/issues/277 {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiParamTypeClasses #-} type m ~> n = () class (a :< b) c ``` ivan-timokhin variables swapped around in constraints #278 ```haskell -- https://github.com/chrisdone/hindent/issues/278 data Link c1 c2 a c = forall b. (c1 a b, c2 b c) => Link (Proxy b) ``` ttuegel qualified infix sections get mangled #273 ```haskell -- https://github.com/chrisdone/hindent/issues/273 import qualified Data.Vector as V main :: IO () main = do let _ = foldr1 (V.++) [V.empty, V.empty] pure () -- more corner cases. xs = V.empty V.++ V.empty ys = (++) [] [] cons :: V.Vector a -> V.Vector a -> V.Vector a cons = (V.++) ``` ivan-timokhin breaks operators type signatures #301 ```haskell -- https://github.com/chrisdone/hindent/issues/301 (+) :: () ``` cdepillabout Long deriving clauses are not reformatted #289 ```haskell newtype Foo = Foo Proxy deriving ( Functor , Applicative , Monad , Semigroup , Monoid , Alternative , MonadPlus , Foldable , Traversable ) ``` ivan-timokhin Breaks instances with type operators #342 ```haskell -- https://github.com/chrisdone/hindent/issues/342 instance Foo (->) instance Foo (^>) instance Foo (T.<^) ``` Indents record constructions and updates #358 ```haskell foo = assert sanityCheck BomSnapshotAggr { snapshot = Just bs , previousId = M.bomSnapshotHistoryPreviousId . entityVal <$> bsp , nextId = M.bomSnapshotHistoryNextId . entityVal <$> bsn , bomEx = bx'' , orderSubstitutes = S.fromList . map OrderSubstituteAggrByCreatedAtAsc $ subs , snapshotSubstitute = msub } ``` paraseba Deriving strategies with multiple deriving clauses ```haskell -- https://github.com/commercialhaskell/hindent/issues/503 {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Foo where import Data.Typeable import GHC.Generics newtype Number a = Number a deriving (Generic) deriving newtype (Show, Eq) deriving anyclass (Typeable) ``` neongreen "{" is lost when formatting "Foo{}" #366 ```haskell -- https://github.com/chrisdone/hindent/issues/366 foo = Nothing {} ``` jparoz Trailing space in list comprehension #357 ```haskell -- https://github.com/chrisdone/hindent/issues/357 foo = [ (x, y) | x <- [1 .. 10] , y <- [11 .. 20] , even x , even x , even x , even x , even x , odd y ] ``` ttuegel Record formatting applied to expressions with RecordWildCards #274 ```haskell -- https://github.com/chrisdone/hindent/issues/274 foo (Bar {..}) = Bar {..} ``` RecursiveDo `rec` and `mdo` keyword #328 ```haskell rec = undefined mdo = undefined ``` sophie-h Record syntax change in 5.2.2 #393 ```haskell -- https://github.com/commercialhaskell/hindent/issues/393 data X = X { x :: Int } | X' data X = X { x :: Int , x' :: Int } data X = X { x :: Int , x' :: Int } | X' ``` k-bx Infix data constructor gets reformatted into a parse error #328 ```haskell -- https://github.com/commercialhaskell/hindent/issues/328 data Expect = String :--> String deriving (Show) ``` tfausak Class constraints cause too many newlines #244 ```haskell -- https://github.com/commercialhaskell/hindent/issues/244 x :: Num a => a x = undefined -- instance instance Num a => C a -- long instance instance Nuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuum a => C a where f = undefined ``` expipiplus1 Always break before `::` on overlong signatures #390 ```haskell -- https://github.com/commercialhaskell/hindent/issues/390 fun :: Is => Short fun = undefined someFunctionSignature :: Wiiiiiiiiiiiiiiiiith -> Enough -> (Arguments -> To ()) -> Overflow (The Line Limit) ``` duog Long Type Constraint Synonyms are not reformatted #290 ```haskell -- https://github.com/commercialhaskell/hindent/issues/290 type MyContext m = ( MonadState Int m , MonadReader Int m , MonadError Text m , MonadMask m , Monoid m , Functor m) ``` ocharles Type application differs from function application (leading to long lines) #359 ```haskell -- https://github.com/commercialhaskell/hindent/issues/359 thing :: ( ResB.BomEx , Maybe [( Entity BomSnapshot , ( [ResBS.OrderSubstituteAggr] , ( Maybe (Entity BomSnapshotHistory) , Maybe (Entity BomSnapshotHistory))))]) -> [(ResB.BomEx, Maybe ResBS.BomSnapshotAggr)] ``` NorfairKing Do as left-hand side of an infix operation #296 ```haskell -- https://github.com/commercialhaskell/hindent/issues/296 block = do ds <- inBraces $ inWhiteSpace declarations return $ Block ds "block" ``` NorfairKing Hindent linebreaks after very short names if the total line length goes over 80 #405 ```haskell -- https://github.com/commercialhaskell/hindent/issues/405 t = f "this is a very loooooooooooooooooooooooooooong string that goes over the line length" argx argy argz t = function "this is a very loooooooooooooooooooooooooooong string that goes over the line length" argx argy argz ``` ivan-timokhin No linebreaks for long functional dependency declarations #323 ```haskell -- https://github.com/commercialhaskell/hindent/issues/323 class Foo a b | a -> b where f :: a -> b class Foo a b c d e f | a b c d e -> f , a b c d f -> e , a b c e f -> d , a b d e f -> c , a c d e f -> b , b c d e f -> a where foo :: a -> b -> c -> d -> e -> f ``` utdemir Hindent breaks TH name captures of operators #412 ```haskell -- https://github.com/commercialhaskell/hindent/issues/412 data T = (-) q = '(-) data (-) q = ''(-) ``` utdemir Hindent can not parse empty case statements #414 ```haskell -- https://github.com/commercialhaskell/hindent/issues/414 {-# LANGUAGE EmptyCase #-} {-# LANGUAGE LambdaCase #-} f1 = case () of {} f2 = \case {} ``` TimoFreiberg INLINE (and other) pragmas for operators are reformatted without parens #415 ```haskell -- https://github.com/commercialhaskell/hindent/issues/415 {-# NOINLINE (<>) #-} ``` NorfairKing Hindent breaks servant API's #417 ```haskell -- https://github.com/commercialhaskell/hindent/issues/417 type API = api1 :<|> api2 ``` andersk Cannot parse @: operator #421 ```haskell -- https://github.com/commercialhaskell/hindent/issues/421 a @: b = a + b main = print (2 @: 2) ``` andersk Corrupts parenthesized type operators #422 ```haskell -- https://github.com/commercialhaskell/hindent/issues/422 data T a = a :@ a test = (:@) ``` NorfairKing Infix constructor pattern is broken #424 ```haskell -- https://github.com/commercialhaskell/hindent/issues/424 from $ \(author `InnerJoin` post) -> pure () ``` NorfairKing Hindent can no longer parse type applications code #426 ```haskell -- https://github.com/commercialhaskell/hindent/issues/426 {-# LANGUAGE TypeApplications #-} f :: Num a => a f = id x = f @Int 12 ``` michalrus Multiline `GHC.TypeLits.Symbol`s are being broken #451 ```haskell -- https://github.com/commercialhaskell/hindent/issues/451 import GHC.TypeLits (Symbol) data X (sym :: Symbol) deriving (Typeable) type Y = X "abc\n\n\ndef" ``` DavidEichmann Existential Quantification reordered #443 ```haskell -- https://github.com/commercialhaskell/hindent/issues/443 {-# LANGUAGE ExistentialQuantification #-} data D = forall a b c. D a b c ``` sophie-h Regression: Breaks basic type class code by inserting "|" #459 ```haskell -- https://github.com/commercialhaskell/hindent/issues/459 class Class1 a => Class2 a where f :: a -> Int class (Eq a, Show a) => Num a where (+), (-), (*) :: a -> a -> a negate :: a -> a abs, signum :: a -> a fromInteger :: Integer -> a ``` michalrus `let … in …` inside of `do` breaks compilation #467 ```haskell -- https://github.com/commercialhaskell/hindent/issues/467 main :: IO () main = do let x = 5 in when (x > 0) (return ()) ``` sophie-h Breaking valid top-level template haskell #473 ```haskell -- https://github.com/commercialhaskell/hindent/issues/473 template $ haskell [ ''SomeVeryLongName , ''AnotherLongNameEvenLongToBreakTheLine , ''LastLongNameInList ] ``` schroffl Hindent produces invalid Syntax from FFI exports #479 ```haskell -- https://github.com/commercialhaskell/hindent/issues/479 foreign export ccall "test" test :: IO () foreign import ccall "test" test :: IO () foreign import ccall safe "test" test :: IO () foreign import ccall unsafe "test" test :: IO () ``` ptek Reformatting of the {-# OVERLAPPING #-} pragma #386 ```haskell -- https://github.com/commercialhaskell/hindent/issues/386 instance {-# OVERLAPPING #-} Arbitrary (Set Int) where arbitrary = undefined ``` cdsmith Quotes are dropped from package imports #480 ```haskell -- https://github.com/commercialhaskell/hindent/issues/480 {-# LANGUAGE PackageImports #-} import qualified "base" Prelude as P ``` alexwl Hindent breaks associated type families annotated with injectivity information #528 ```haskell -- https://github.com/commercialhaskell/hindent/issues/528 class C a where type F a = b | b -> a ``` sophie-h Fails to create required indentation for infix #238 ```haskell -- https://github.com/commercialhaskell/hindent/issues/238 {-# LANGUAGE ScopedTypeVariables #-} import Control.Exception x :: IO Int x = do putStrLn "ok" error "ok" `catch` (\(_ :: IOException) -> pure 1) `catch` (\(_ :: ErrorCall) -> pure 2) ``` lippirk Comments on functions in where clause not quite right #540 ```haskell -- https://github.com/chrisdone/hindent/issues/540 topLevelFunc1 = f where -- comment on func in where clause -- stays in the where clause f = undefined topLevelFunc2 = f . g where {- multi line comment -} f = undefined -- single line comment g = undefined ```