diff --git a/hindent.cabal b/hindent.cabal --- a/hindent.cabal +++ b/hindent.cabal @@ -1,5 +1,5 @@ name: hindent -version: 3.7 +version: 3.8 synopsis: Extensible Haskell pretty printer description: Extensible Haskell pretty printer. Both a library and an executable. . @@ -24,6 +24,7 @@ HIndent.Styles.Fundamental HIndent.Styles.ChrisDone HIndent.Styles.JohanTibell + HIndent.Styles.Gibiansky build-depends: base >= 4 && <5 , data-default , haskell-src-exts == 1.15.* @@ -38,3 +39,17 @@ build-depends: base >= 4 && < 5 , hindent , text + +test-suite hspec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base >= 4 && <5 + , hindent + , data-default + , haskell-src-exts == 1.15.* + , monad-loops + , mtl + , text + , hspec + , directory diff --git a/src/HIndent.hs b/src/HIndent.hs --- a/src/HIndent.hs +++ b/src/HIndent.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-} -- | Haskell indenter. @@ -9,24 +8,29 @@ ,prettyPrint ,parseMode -- * Style + ,Style(..) ,styles ,chrisDone ,johanTibell ,fundamental + ,gibiansky -- * Testing ,test - ,testAll) + ,testAll + ,testAst + ) where -import Data.Function import HIndent.Pretty import HIndent.Styles.ChrisDone import HIndent.Styles.Fundamental +import HIndent.Styles.Gibiansky import HIndent.Styles.JohanTibell import HIndent.Types import Control.Monad.State.Strict import Data.Data +import Data.Function import Data.Monoid import qualified Data.Text.IO as ST import Data.Text.Lazy (Text) @@ -40,15 +44,18 @@ -- | Format the given source. reformat :: Style -> Text -> Either String Builder reformat style x = - case parseDeclWithComments parseMode - (T.unpack x) of - ParseOk (v,comments) -> - case annotateComments v comments of - (cs,ast) -> - Right (prettyPrint - style - (do mapM_ printComment cs - pretty ast)) + case parseModuleWithComments parseMode + (T.unpack x) of + ParseOk (mod,comments) -> + let (cs,ast) = + annotateComments mod comments + in Right (prettyPrint + style + -- For the time being, assume that all "free-floating" comments come at the beginning. + -- If they were not at the beginning, they would be after some ast node. + -- Thus, print them before going for the ast. + (do mapM_ (printComment Nothing) cs + pretty ast)) ParseFailed _ e -> Left e -- | Pretty print the given printable thing. @@ -75,7 +82,7 @@ either error (T.putStrLn . T.toLazyText) . reformat style --- | Test with the given style, prints to stdout. +-- | Test with all styles, prints to stdout. testAll :: Text -> IO () testAll i = forM_ styles @@ -84,39 +91,65 @@ test style i ST.putStrLn "") +-- | Parse the source and annotate it with comments, yielding the resulting AST. +testAst :: Text -> Either String ([ComInfo], Module NodeInfo) +testAst x = + case parseModuleWithComments parseMode + (T.unpack x) of + ParseOk (mod,comments) -> + Right (annotateComments mod comments) + ParseFailed _ e -> Left e + -- | Styles list, useful for programmatically choosing. styles :: [Style] styles = - [fundamental,chrisDone,johanTibell] + [fundamental,chrisDone,johanTibell,gibiansky] -- | Annotate the AST with comments. -annotateComments :: (Data (ast NodeInfo),Traversable ast,Annotated ast) +annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast) => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo) annotateComments = - foldr (\c@(Comment _ cspan _) (cs,ast) -> - case execState (traverse (collect c) ast) Nothing of - Nothing -> - (ComInfo c True : - cs - ,ast) - Just l -> - let ownLine = - srcSpanStartLine cspan /= - srcSpanEndLine (srcInfoSpan l) - in (cs - ,evalState (traverse (insert l (ComInfo c ownLine)) ast) False)) . + -- Add all comments to the ast. + foldr processComment . + -- Turn result into a tuple, with ast as second element. ([],) . + -- Replace source spans with node infos in the AST. + -- The node infos have empty comment lists. fmap (\n -> NodeInfo n []) - where collect c ni@(NodeInfo newL _) = + where processComment :: Comment + -> ([ComInfo],ast NodeInfo) + -> ([ComInfo],ast NodeInfo) + -- Add in a single comment to the ast. + processComment c@(Comment _ cspan _) (cs,ast) = + -- Try to find the node after which this comment lies. + case execState (traverse (collect c) ast) Nothing of + -- When no node is found, the comment is on its own line. + Nothing -> + (ComInfo c True : + cs + ,ast) + -- We found the node that this comment follows. + -- Insert this comment into the ast. + Just l -> + let ownLine = + srcSpanStartLine cspan /= + srcSpanEndLine (srcInfoSpan l) + in (cs + ,evalState (traverse (insert l (ComInfo c ownLine)) ast) False) + -- For a comment, check whether the comment is after the node. + -- If it is, store it in the state; otherwise do nothing. + collect :: Comment -> NodeInfo -> State (Maybe SrcSpanInfo) NodeInfo + collect c ni@(NodeInfo newL _) = do when (commentAfter ni c) - (modify (\ml -> - maybe (Just newL) - (\oldL -> - Just (if on spanBefore srcInfoSpan oldL newL - then newL - else oldL)) - ml)) + (modify (maybe (Just newL) + (\oldL -> + Just (if (spanBefore `on` srcInfoSpan) oldL newL + then newL + else oldL)))) return ni + -- Insert the comment into the ast. Find the right node and add it to the + -- comments of that node. Do nothing afterwards. + insert :: SrcSpanInfo -> ComInfo -> NodeInfo -> State Bool NodeInfo insert al c ni@(NodeInfo bl cs) = do done <- get if not done && al == bl diff --git a/src/HIndent/Pretty.hs b/src/HIndent/Pretty.hs --- a/src/HIndent/Pretty.hs +++ b/src/HIndent/Pretty.hs @@ -36,6 +36,7 @@ -- * Indentation , indented , column + , getColumn , depend , dependBind , swing @@ -92,27 +93,37 @@ case cast a of Just v -> Just (f s v) Nothing -> Nothing - makePrinter s (CatchAll f) = (f s a) + makePrinter s (CatchAll f) = f s a -- | Run the basic printer for the given node without calling an -- extension hook for this node, but do allow extender hooks in child -- nodes. Also auto-inserts comments. prettyNoExt :: (Pretty ast) => ast NodeInfo -> Printer () -prettyNoExt a = prettyInternal a +prettyNoExt = prettyInternal -- | Print comments of a node. printComments :: (Pretty ast) => ast NodeInfo -> Printer () -printComments = mapM_ printComment . nodeInfoComments . ann +printComments ast = + mapM_ (printComment (Just (srcInfoSpan (nodeInfoSpan info)))) comments + where info = ann ast + comments = nodeInfoComments info -- | Pretty print a comment. -printComment :: ComInfo -> Printer () -printComment (ComInfo (Comment inline _ str) own) = - do (_,st) <- sandbox (write "") - if own - then newline - else unless (psColumn st == 0) space +printComment :: Maybe SrcSpan -> ComInfo -> Printer () +printComment mayNodespan (ComInfo (Comment inline cspan str) own) = + do col <- getColumn + when own newline + -- Insert proper amount of space before comment. + -- This maintains alignment. This cannot force comments + -- to go before the left-most possible indent (specified by depends). + case mayNodespan of + Just nodespan -> + do let neededSpaces = srcSpanStartColumn cspan - + srcSpanEndColumn nodespan + replicateM_ neededSpaces space + Nothing -> return () if inline then do write "{-" string str @@ -124,7 +135,7 @@ -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's. -pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),Functor ast) +pretty' :: (Pretty ast, P.Pretty (ast SrcSpanInfo), Functor ast) => ast NodeInfo -> Printer () pretty' = write . T.fromText . T.pack . P.prettyPrint . fmap nodeInfoSpan @@ -160,7 +171,7 @@ (return ()) (zip [1 ..] ps) --- | Print all the printers separated by spaces. +-- | Print all the printers separated by newlines. lined :: [Printer ()] -> Printer () lined ps = sequence_ (intersperse newline ps) @@ -190,6 +201,10 @@ modify (\s -> s {psIndentLevel = level}) return m +-- | Get the current indent level. +getColumn :: Printer Int64 +getColumn = gets psColumn + -- | Output a newline. newline :: Printer () newline = @@ -518,7 +533,7 @@ exp (Case _ e alts) = do depend (write "case ") (do pretty e - write " of ") + write " of") newline indentSpaces <- getIndentSpaces indented indentSpaces (lined (map pretty alts)) @@ -988,7 +1003,8 @@ do depend (do pretty pat1 space case name of - Ident _ i -> string ("`" ++ i ++ "`") + Ident _ i -> + string ("`" ++ i ++ "`") Symbol _ s -> string s) (do space spaced (map pretty pats)) @@ -1083,13 +1099,18 @@ UnboxedSingleCon _ -> write "(##)" -------------------------------------------------------------------------------- --- * Unimplemented printers +-- * Unimplemented or incomplete printers instance Pretty Module where prettyInternal x = case x of - Module _ _ _ _ _ -> - error "FIXME: No implementation for Module." + Module _ mayModHead pragmas imps decls -> + do case mayModHead of + Nothing -> return () + Just modHead -> pretty' modHead + forM_ pragmas pretty + forM_ imps pretty + forM_ decls pretty XmlPage{} -> error "FIXME: No implementation for XmlPage." XmlHybrid{} -> @@ -1140,4 +1161,23 @@ prettyInternal = pretty' instance Pretty TyVarBind where + prettyInternal = pretty' + +instance Pretty ModuleHead where + prettyInternal = pretty' + +instance Pretty ModulePragma where + prettyInternal = pretty' + +instance Pretty ImportDecl where + prettyInternal = pretty' + +instance Pretty ModuleName where + prettyInternal (ModuleName _ name) = + write (T.fromString name) + +instance Pretty ImportSpecList where + prettyInternal = pretty' + +instance Pretty ImportSpec where prettyInternal = pretty' diff --git a/src/HIndent/Styles/Gibiansky.hs b/src/HIndent/Styles/Gibiansky.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/Gibiansky.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, RankNTypes #-} + +module HIndent.Styles.Gibiansky (gibiansky) where + +import Data.Foldable +import Control.Monad (unless, when) +import Control.Monad.State (gets, get, put) + +import HIndent.Pretty +import HIndent.Types + +import Language.Haskell.Exts.Annotated.Syntax +import Language.Haskell.Exts.SrcLoc +import Prelude hiding (exp, all, mapM_) + +-- | Empty state. +data State = State + +-- | The printer style. +gibiansky :: Style +gibiansky = + Style { styleName = "gibiansky" + , styleAuthor = "Andrew Gibiansky" + , styleDescription = "Andrew Gibiansky's style" + , styleInitialState = State + , styleExtenders = [ Extender imp + , Extender context + , Extender derivings + , Extender typ + , Extender exprs + , Extender rhss + , Extender decls + , Extender condecls + , Extender guardedAlts + ] + , styleDefConfig = + Config { configMaxColumns = 100 + , configIndentSpaces = 2 + } + } + +-------------------------------------------------------------------------------- +-- Extenders + +type Extend f = forall t. t -> f NodeInfo -> Printer () + + +-- | Format import statements. +imp :: Extend ImportDecl +imp _ ImportDecl{..} = do + write "import " + write $ if importQualified + then "qualified " + else " " + pretty importModule + + forM_ importAs $ \name -> do + write " as " + pretty name + + forM_ importSpecs $ \speclist -> do + write " " + pretty speclist + +-- | Format contexts with spaces and commas between class constraints. +context :: Extend Context +context _ (CxTuple _ asserts) = + parens $ inter (comma >> space) $ map pretty asserts +context _ ctx = prettyNoExt ctx + +-- | Format deriving clauses with spaces and commas between class constraints. +derivings :: Extend Deriving +derivings _ (Deriving _ instHeads) = do + write "deriving " + go instHeads + + where + go insts | length insts == 1 + = pretty $ head insts + | otherwise + = parens $ inter (comma >> space) $ map pretty insts + +-- | Format function type declarations. +typ :: Extend Type + +-- For contexts, check whether the context and all following function types +-- are on the same line. If they are, print them on the same line; otherwise +-- print the context and each argument to the function on separate lines. +typ _ (TyForall _ _ (Just ctx) rest) = + if all (sameLine ctx) $ collectTypes rest + then do + pretty ctx + write " => " + pretty rest + else do + col <- getColumn + pretty ctx + column (col - 3) $ do + newline + write "=> " + indented 3 $ pretty rest + +typ _ ty@(TyFun _ from to) = + -- If the function argument types are on the same line, + -- put the entire function type on the same line. + if all (sameLine from) $ collectTypes ty + then do + pretty from + write " -> " + pretty to + -- If the function argument types are on different lines, + -- write one argument type per line. + else do + col <- getColumn + pretty from + column (col - 3) $ do + newline + write "-> " + indented 3 $ pretty to +typ _ t = prettyNoExt t + +sameLine :: (Annotated ast, Annotated ast') => ast NodeInfo -> ast' NodeInfo -> Bool +sameLine x y = line x == line y + where + line :: Annotated ast => ast NodeInfo -> Int + line = startLine . nodeInfoSpan . ann + +collectTypes :: Type l -> [Type l] +collectTypes (TyFun _ from to) = from : collectTypes to +collectTypes ty = [ty] + +exprs :: Extend Exp +exprs _ exp@Let{} = letExpr exp +exprs _ exp@App{} = appExpr exp +exprs _ exp@Do{} = doExpr exp +exprs _ exp@List{} = listExpr exp +exprs _ exp = prettyNoExt exp + +letExpr :: Exp NodeInfo -> Printer () +letExpr (Let _ binds result) = do + cols <- depend (write "let ") $ do + col <- getColumn + pretty binds + return $ col - 4 + column cols $ do + newline + write "in " + pretty result +letExpr _ = error "Not a let" + +appExpr :: Exp NodeInfo -> Printer () +appExpr (App _ f x) = spaced [pretty f, pretty x] +appExpr _ = error "Not an app" + +doExpr :: Exp NodeInfo -> Printer () +doExpr (Do _ stmts) = do + write "do" + newline + indented 2 $ lined (map pretty stmts) +doExpr _ = error "Not a do" + +listExpr :: Exp NodeInfo -> Printer () +listExpr (List _ els) = do + -- Try printing list on one line. + prevState <- get + singleLineList els + + -- If it doesn't fit, reprint on multiple lines. + col <- getColumn + when (col > configMaxColumns (psConfig prevState)) $ do + put prevState + multiLineList els +listExpr _ = error "Not a list" + +singleLineList :: [Exp NodeInfo] -> Printer () +singleLineList exprs = do + write "[" + inter (write ", ") $ map pretty exprs + write "]" + +multiLineList :: [Exp NodeInfo] -> Printer () +multiLineList [] = write "[]" +multiLineList (first:exprs) = do + col <- getColumn + column col $ do + write "[ " + pretty first + forM_ exprs $ \el -> do + newline + write ", " + pretty el + newline + write "]" + +rhss :: Extend Rhs +rhss _ (UnGuardedRhs _ exp) = do + write " = " + pretty exp +rhss _ rhs = prettyNoExt rhs + +decls :: Extend Decl +decls _ (DataDecl _ dataOrNew Nothing declHead constructors mayDeriving) = do + pretty dataOrNew + write " " + pretty declHead + case constructors of + [] -> return () + [x] -> do + write " = " + pretty x + (x:xs) -> + depend (write " ") $ do + write "= " + pretty x + forM_ xs $ \constructor -> do + newline + write "| " + pretty constructor + + forM_ mayDeriving $ \deriv -> do + newline + indented 2 $ pretty deriv +decls _ (PatBind _ pat Nothing rhs mbinds) = do + pretty pat + pretty rhs + indentSpaces <- getIndentSpaces + forM_ mbinds $ \binds -> do + newline + when (isDoBlock rhs) newline + indented indentSpaces $ do + write "where" + newline + indented indentSpaces $ pretty binds +decls _ decl = prettyNoExt decl + +isDoBlock :: Rhs l -> Bool +isDoBlock (UnGuardedRhs _ Do{}) = True +isDoBlock _ = False + +condecls :: Extend ConDecl +condecls _ (ConDecl _ name bangty) = + depend (pretty name) $ + forM_ bangty $ \ty -> space >> pretty ty +condecls _ (RecDecl _ name fields) = + depend (pretty name >> space) $ do + write "{ " + case fields of + [] -> return () + [x] -> do + pretty x + eol <- gets psEolComment + unless eol space + + first:rest -> do + pretty first + newline + forM_ rest $ \field -> do + comma + space + pretty field + newline + write "}" +condecls _ other = prettyNoExt other + +guardedAlts :: Extend GuardedAlts +guardedAlts _ (UnGuardedAlt _ exp) = do + write " -> " + pretty exp +guardedAlts _ alt = prettyNoExt alt diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,67 @@ +module Main(main) where + +import Control.Monad +import Control.Applicative +import Data.List (find, unfoldr, break, isPrefixOf, intercalate) + +import Test.Hspec +import System.Directory +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as L + +import qualified HIndent + +styles :: [FilePath] +styles = ["gibiansky"] + +testDir, expectedDir :: String +testDir = "tests" +expectedDir = "expected" + +main :: IO () +main = forM_ styles testStyle + +testStyle :: FilePath -> IO () +testStyle style = do + let Just theStyle = find ((== T.pack style). HIndent.styleName) HIndent.styles + testFilenames <- filter (not . isPrefixOf ".") <$> getDirectoryContents tests + let expFiles = map ((expected ++) . expectedFilename) testFilenames + testFiles = map (tests++) testFilenames + specs <- forM (zip testFiles expFiles) (uncurry $ useTestFiles theStyle) + hspec $ foldl1 (>>) specs + + where + tests = "test/" ++ style ++ "/" ++ testDir ++ "/" + expected = "test/" ++ style ++ "/" ++ expectedDir ++ "/" + + expectedFilename filename = take (length filename - 4) filename ++ "exp" + +useTestFiles :: HIndent.Style -> FilePath -> FilePath -> IO Spec +useTestFiles style test exp = do + testContents <- readFile test + expContents <- readFile exp + let testDecls = parsePieces testContents + expDecls = parsePieces expContents + return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style) testDecls expDecls + +mkSpec :: HIndent.Style -> String -> String -> Spec +mkSpec style input desired = it "works" $ + case HIndent.reformat style (L.pack input) of + Left err -> expectationFailure ("Error: " ++ err) + Right builder -> L.unpack (L.toLazyText builder) `shouldBe` desired + +parsePieces :: String -> [String] +parsePieces str = map (intercalate "\n") pieces + where + pieces = unfoldr unfolder (lines str) + + unfolder :: [String] -> Maybe ([String], [String]) + unfolder [] = Nothing + unfolder remaining = Just $ + case break pieceBreak (zip remaining (tail remaining ++ [""])) of + (nonNull, []) -> (map fst nonNull, []) + (nonNull, _:rest) -> (map fst nonNull, map fst rest) + + pieceBreak :: (String, String) -> Bool + pieceBreak (line, next) = null line && head next /= ' '