hindent 3.7 → 3.8

raw patch · 5 files changed

+477/−53 lines, 5 filesdep +directorydep +hspecPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, hspec

API changes (from Hackage documentation)

Files

• hindent.cabal +16/−1
• src/HIndent.hs +69/−36
• src/HIndent/Pretty.hs +56/−16
• src/HIndent/Styles/Gibiansky.hs +269/−0
• test/Spec.hs +67/−0

@@ -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

@@ -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

@@ -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'

@@ -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

@@ -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 /= ' '