hindent 3.9.1 → 4.0

raw patch · 11 files changed

+755/−314 lines, 11 filesdep ~haskell-src-extsnew-component:exe:hindent-generate-testsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• hindent.cabal +14/−5
• src/HIndent.hs +72/−39
• src/HIndent/Pretty.hs +200/−128
• src/HIndent/Styles/ChrisDone.hs +49/−33
• src/HIndent/Styles/Fundamental.hs +1/−3
• src/HIndent/Styles/Gibiansky.hs +288/−39
• src/HIndent/Styles/JohanTibell.hs +7/−55
• src/HIndent/Types.hs +13/−7
• src/main/TestGenerate.hs +89/−0
• test/Spec.hs +11/−3
• vim/hindent.vim +11/−2

@@ -1,5 +1,5 @@ name:                hindent-version:             3.9.1+version:             4.0 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .@@ -27,7 +27,7 @@                      HIndent.Styles.Gibiansky   build-depends:     base >= 4 && <5                    , data-default-                   , haskell-src-exts == 1.15.*+                   , haskell-src-exts == 1.16.*                    , monad-loops                    , mtl                    , text@@ -36,18 +36,27 @@   hs-source-dirs:    src/main   ghc-options:       -Wall -O2   main-is:           Main.hs-  build-depends:     base >= 4.7 && < 5+  build-depends:     base >= 4 && < 5                    , hindent                    , text +executable hindent-generate-tests+  hs-source-dirs:    src/main+  ghc-options:       -Wall -O2+  main-is:           TestGenerate.hs+  build-depends:     base >= 4 && < 5+                   , hindent+                   , text+                   , directory+ test-suite hspec   type: exitcode-stdio-1.0   hs-source-dirs: test   main-is: Spec.hs-  build-depends:     base >= 4.7 && <5+  build-depends:     base >= 4 && <5                    , hindent                    , data-default-                   , haskell-src-exts == 1.15.*+                   , haskell-src-exts == 1.16.*                    , monad-loops                    , mtl                    , text

@@ -47,9 +47,9 @@ reformat style x =   case parseModuleWithComments parseMode                                (T.unpack x) of-    ParseOk (mod,comments) ->+    ParseOk (m,comments) ->       let (cs,ast) =-            annotateComments (fromMaybe mod $ applyFixities baseFixities mod) comments+            annotateComments (fromMaybe m $ applyFixities baseFixities m) comments       in Right (prettyPrint                   style                   -- For the time being, assume that all "free-floating" comments come at the beginning.@@ -65,7 +65,7 @@   psOutput (execState (runPrinter m)                       (case style of                          Style _name _author _desc st extenders config ->-                           PrintState 0 mempty False 0 1 st extenders config False))+                           PrintState 0 mempty False 0 1 st extenders config False False))  -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode@@ -97,8 +97,8 @@ testAst x =   case parseModuleWithComments parseMode                                (T.unpack x) of-    ParseOk (mod,comments) ->-      Right (annotateComments mod comments)+    ParseOk (m,comments) ->+      Right (annotateComments m comments)     ParseFailed _ e -> Left e  -- | Styles list, useful for programmatically choosing.@@ -109,45 +109,73 @@ -- | Annotate the AST with comments. annotateComments :: forall ast. (Data (ast NodeInfo),Traversable ast,Annotated ast)                  => ast SrcSpanInfo -> [Comment] -> ([ComInfo],ast NodeInfo)-annotateComments =-  -- 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 [])+annotateComments src comments =+  let+      -- Make sure to process comments top to bottom.+      reversed = reverse comments++      -- Replace source spans with node infos in the AST.+      src' = fmap (\n -> NodeInfo n []) src++      -- Add all comments to the ast.+      (cominfos, src'') = foldr processComment ([], src') reversed++  in -- Reverse order of comments at each node.+    (cominfos, fmap (\(NodeInfo n cs) -> NodeInfo n $ reverse cs) src'')+   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+          case execState (traverse (collect After c) ast) Nothing of             -- When no node is found, the comment is on its own line.-            Nothing ->-              (ComInfo c True :-               cs-              ,ast)+            Nothing -> (ComInfo c Nothing : 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)+            -- Check whether the node is on the same line.+            Just (NodeInfo l coms)+              -- If it's on a different line than the node, but the node has an+              -- EOL comment, and the EOL comment and this comment are aligned,+              -- attach this comment to the preceding node.+              | ownLine && alignedWithPrevious -> insertedBefore++              -- If it's on a different line than the node, look for the following node to attach it to.+              | ownLine ->+                  case execState (traverse (collect Before c) ast) Nothing of+                    -- If we don't find a node after the comment, leave it with the previous node.+                    Nothing   -> insertedBefore+                    Just (NodeInfo node _) ->+                      (cs, evalState (traverse (insert node (ComInfo c $ Just Before)) ast) False)++              -- If it's on the same line, insert this comment into that node.+              | otherwise -> insertedBefore+              where+                ownLine = srcSpanStartLine cspan /= srcSpanEndLine (srcInfoSpan l)+                insertedBefore = (cs, evalState (traverse (insert l (ComInfo c $ Just After)) ast) False)+                alignedWithPrevious+                  | null coms = False+                  | otherwise = case last coms of+                      -- Require single line comment after the node.+                      ComInfo (Comment False prevSpan _) (Just After) ->+                        srcSpanStartLine prevSpan == srcSpanStartLine cspan - 1 &&+                        srcSpanStartColumn prevSpan == srcSpanStartColumn cspan+                      _       -> 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 (maybe (Just newL)-                                 (\oldL ->-                                    Just (if (spanBefore `on` srcInfoSpan) oldL newL-                                             then newL-                                             else oldL))))+        -- The location specifies where the comment should lie relative to the node.+        collect :: ComInfoLocation -> Comment -> NodeInfo -> State (Maybe NodeInfo) NodeInfo+        collect loc' c ni@(NodeInfo newL _) =+          do when (commentLocated loc' ni c)+                  (modify (maybe (Just ni)+                                 (\oldni@(NodeInfo oldL _) ->+                                    Just (if (spanTest loc' `on` srcInfoSpan) oldL newL+                                             then ni+                                             else oldni))))              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@@ -159,13 +187,18 @@                 else return ni  -- | Is the comment after the node?-commentAfter :: NodeInfo -> Comment -> Bool-commentAfter (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) =-  spanBefore n c+commentLocated :: ComInfoLocation -> NodeInfo -> Comment -> Bool+commentLocated loc' (NodeInfo (SrcSpanInfo n _) _) (Comment _ c _) =+  spanTest loc' n c --- | Does the first span end before the second starts?-spanBefore :: SrcSpan -> SrcSpan -> Bool-spanBefore before after =+-- | For @After@, does the first span end before the second starts?+-- For @Before@, does the first span start after the second ends?+spanTest :: ComInfoLocation -> SrcSpan -> SrcSpan -> Bool+spanTest loc' first second =   (srcSpanStartLine after > srcSpanEndLine before) ||   ((srcSpanStartLine after == srcSpanEndLine before) &&    (srcSpanStartColumn after > srcSpanEndColumn before))+  where (before,after) =+          case loc' of+            After -> (first,second)+            Before -> (second,first)

@@ -23,6 +23,9 @@   -- * Common node types   , maybeCtx   , printComment+  , printComments+  , withCaseContext+  , rhsSeparator   -- * Interspersing   , inter   , spaced@@ -37,6 +40,7 @@   , indented   , column   , getColumn+  , getLineNum   , depend   , dependBind   , swing@@ -54,7 +58,7 @@ import           HIndent.Types  import           Language.Haskell.Exts.Comments-import           Control.Monad.State hiding (state)+import           Control.Monad.State.Strict hiding (state) import           Data.Int import           Data.List import           Data.Maybe@@ -75,20 +79,23 @@ -- * Pretty printing class  -- | Pretty printing class.-class (Annotated ast,Typeable1 ast) => Pretty ast where-  prettyInternal :: ast NodeInfo -> Printer ()+class (Annotated ast,Typeable ast) => Pretty ast where+  prettyInternal :: MonadState PrintState m => ast NodeInfo -> m ()  -- | Pretty print using extenders.-pretty :: (Pretty ast)-       => ast NodeInfo -> Printer ()+pretty :: (Pretty ast,MonadState PrintState m)+       => ast NodeInfo -> m () pretty a =   do st <- get      case st of        PrintState{psExtenders = es,psUserState = s} ->-         do case listToMaybe (mapMaybe (makePrinter s) es) of-              Just m -> m-              Nothing -> prettyNoExt a-            printComments a+         do+           printComments Before a+           depend+             (case listToMaybe (mapMaybe (makePrinter s) es) of+                Just (Printer m) -> modify (execState m)+                Nothing -> prettyNoExt a)+             (printComments After a)   where makePrinter s (Extender f) =           case cast a of             Just v -> Just (f s v)@@ -98,23 +105,28 @@ -- | 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 :: (Pretty ast,MonadState PrintState m)+            => ast NodeInfo -> m () prettyNoExt = prettyInternal  -- | Print comments of a node.-printComments :: (Pretty ast)-              => ast NodeInfo -> Printer ()-printComments ast =-  mapM_ (printComment (Just (srcInfoSpan (nodeInfoSpan info)))) comments+printComments :: (Pretty ast,MonadState PrintState m)+              => ComInfoLocation -> ast NodeInfo -> m ()+printComments loc' ast =+  forM_ comments $ \comment ->+    when (comInfoLocation comment == Just loc') $ 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         comments = nodeInfoComments info  -- | Pretty print a comment.-printComment :: Maybe SrcSpan -> ComInfo -> Printer ()-printComment mayNodespan (ComInfo (Comment inline cspan str) own) =-  do when own newline-     -- Insert proper amount of space before comment.+printComment :: MonadState PrintState m => Maybe SrcSpan -> ComInfo -> m ()+printComment mayNodespan (ComInfo (Comment inline cspan str) _) =+  do -- 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@@ -134,15 +146,15 @@  -- | Pretty print using HSE's own printer. The 'P.Pretty' class here -- is HSE's.-pretty' :: (Pretty ast, P.Pretty (ast SrcSpanInfo), Functor ast)-        => ast NodeInfo -> Printer ()+pretty' :: (Pretty ast,P.Pretty (ast SrcSpanInfo),Functor ast,MonadState PrintState m)+        => ast NodeInfo -> m () pretty' = write . T.fromText . T.pack . P.prettyPrint . fmap nodeInfoSpan  -------------------------------------------------------------------------------- -- * Combinators  -- | Increase indentation level by n spaces for the given printer.-indented :: Int64 -> Printer a -> Printer a+indented :: MonadState PrintState m => Int64 -> m a -> m a indented i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = level + i})@@ -151,15 +163,15 @@      return m  -- | Print all the printers separated by spaces.-spaced :: [Printer ()] -> Printer ()+spaced :: MonadState PrintState m => [m ()] -> m () spaced = inter space  -- | Print all the printers separated by commas.-commas :: [Printer ()] -> Printer ()+commas :: MonadState PrintState m => [m ()] -> m () commas = inter comma  -- | Print all the printers separated by sep.-inter :: Printer () -> [Printer ()] -> Printer ()+inter :: MonadState PrintState m => m () -> [m ()] -> m () inter sep ps =   foldr (\(i,p) next ->            depend (do p@@ -171,12 +183,12 @@         (zip [1 ..] ps)  -- | Print all the printers separated by newlines.-lined :: [Printer ()] -> Printer ()+lined :: MonadState PrintState m => [m ()] -> m () lined ps = sequence_ (intersperse newline ps)  -- | Print all the printers separated newlines and optionally a line -- prefix.-prefixedLined :: Text -> [Printer ()] -> Printer ()+prefixedLined :: MonadState PrintState m => Text -> [m ()] -> m () prefixedLined pref ps' =   case ps' of     [] -> return ()@@ -192,7 +204,7 @@  -- | Set the (newline-) indent level to the given column for the given -- printer.-column :: Int64 -> Printer a -> Printer a+column :: MonadState PrintState m => Int64 -> m a -> m a column i p =   do level <- gets psIndentLevel      modify (\s -> s {psIndentLevel = i})@@ -201,18 +213,41 @@      return m  -- | Get the current indent level.-getColumn :: Printer Int64+getColumn :: MonadState PrintState m => m Int64 getColumn = gets psColumn +-- | Get the current line number.+getLineNum :: MonadState PrintState m => m Int64+getLineNum = gets psLine+ -- | Output a newline.-newline :: Printer ()+newline :: MonadState PrintState m => m () newline =   do write "\n"      modify (\s -> s {psNewline = True}) +-- | Set the context to a case context, where RHS is printed with -> .+withCaseContext :: MonadState PrintState m+                => Bool -> m a -> m 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 :: MonadState PrintState m+             => m ()+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 :: MonadState PrintState m => m () -> m b -> m b depend maker dependent =   do state' <- get      maker@@ -224,7 +259,7 @@  -- | Make the latter's indentation depend upon the end column of the -- former.-dependBind :: Printer a -> (a -> Printer b) -> Printer b+dependBind :: MonadState PrintState m => m a -> (a -> m b) -> m b dependBind maker dependent =   do state' <- get      v <- maker@@ -235,7 +270,7 @@         else (dependent v)  -- | Wrap in parens.-parens :: Printer a -> Printer a+parens :: MonadState PrintState m => m a -> m a parens p =   depend (write "(")          (do v <- p@@ -243,7 +278,7 @@              return v)  -- | Wrap in braces.-braces :: Printer a -> Printer a+braces :: MonadState PrintState m => m a -> m a braces p =   depend (write "{")          (do v <- p@@ -251,7 +286,7 @@              return v)  -- | Wrap in brackets.-brackets :: Printer a -> Printer a+brackets :: MonadState PrintState m => m a -> m a brackets p =   depend (write "[")          (do v <- p@@ -259,20 +294,20 @@              return v)  -- | Write a space.-space :: Printer ()+space :: MonadState PrintState m => m () space = write " "  -- | Write a comma.-comma :: Printer ()+comma :: MonadState PrintState m => m () comma = write ","  -- | Write an integral.-int :: Integral n-    => n -> Printer ()+int :: (Integral n, MonadState PrintState m)+    => n -> m () int = write . decimal  -- | Write out a string, updating the current position information.-write :: Builder -> Printer ()+write :: MonadState PrintState m => Builder -> m () write x =   do eol <- gets psEolComment      when (eol && x /= "\n") newline@@ -304,16 +339,16 @@           LT.length (LT.filter (== '\n') x')  -- | Write a string.-string :: String -> Printer ()+string :: MonadState PrintState m =>String -> m () string = write . T.fromText . T.pack  -- | Indent spaces, e.g. 2.-getIndentSpaces :: Printer Int64+getIndentSpaces :: MonadState PrintState m => m Int64 getIndentSpaces =   gets (configIndentSpaces . psConfig)  -- | Column limit, e.g. 80-getColumnLimit :: Printer Int64+getColumnLimit :: MonadState PrintState m => m Int64 getColumnLimit =   gets (configMaxColumns . psConfig) @@ -334,15 +369,23 @@ nullBinds (IPBinds _ x) = null x  -- | Maybe render a class context.-maybeCtx :: Maybe (Context NodeInfo) -> Printer ()+maybeCtx :: MonadState PrintState m => Maybe (Context NodeInfo) -> m () maybeCtx =   maybe (return ())         (\p ->            pretty p >>            write " => ") +-- | Maybe render an overlap definition.+maybeOverlap :: MonadState PrintState m => Maybe (Overlap NodeInfo) -> m ()+maybeOverlap =+  maybe (return ())+        (\p ->+           pretty p >>+           space)+ -- | Swing the second printer below and indented with respect to the first.-swing :: Printer () -> Printer b -> Printer b+swing :: MonadState PrintState m => m () -> m b -> m b swing a b =   do orig <- gets psIndentLevel      a@@ -359,16 +402,12 @@       CxSingle _ a -> pretty a       CxTuple _ as ->         parens (commas (map pretty as))-      CxParen _ c -> parens (pretty c)       CxEmpty _ -> parens (return ())  instance Pretty Pat where   prettyInternal x =     case x of-      PLit _ l -> pretty l-      PNeg _ l ->-        depend (write "-")-               (pretty l)+      PLit _ sign l -> pretty sign >> pretty l       PNPlusK _ n k ->         depend (do pretty n                    write "+")@@ -436,7 +475,7 @@       PVar{} -> pretty' x  -- | Pretty print a name for being an infix operator.-prettyInfixOp :: QName NodeInfo -> Printer ()+prettyInfixOp :: MonadState PrintState m => QName NodeInfo -> m () prettyInfixOp x =   case x of     Qual{} -> pretty' x@@ -471,6 +510,10 @@                             Unboxed -> "#)"                             Boxed -> ")"))       TyList _ t -> brackets (pretty t)+      TyParArray _ t ->+        brackets (do write ":"+                     pretty t+                     write ":")       TyApp _ f a -> spaced [pretty f,pretty a]       TyVar _ n -> pretty n       TyCon _ p -> pretty p@@ -485,14 +528,23 @@         parens (do pretty ty                    write " :: "                    pretty k)+      TyBang _ bangty right ->+        do pretty bangty+           pretty right+      TyEquals _ left right ->+        do pretty left+           write " == "+           pretty right       TyPromoted{} ->         error "FIXME: No implementation for TyPromoted."+      TySplice{} ->+        error "FIXME: No implementation for TySplice."  instance Pretty Exp where   prettyInternal = exp  -- | Render an expression.-exp :: Exp NodeInfo -> Printer ()+exp :: MonadState PrintState m => Exp NodeInfo -> m () exp (InfixApp _ a op b) =   depend (do pretty a              space@@ -539,7 +591,7 @@                 write " of")      newline      indentSpaces <- getIndentSpaces-     indented indentSpaces (lined (map pretty alts))+     indented indentSpaces (lined (map (withCaseContext True . pretty) alts)) exp (Do _ stmts) =   depend (write "do ")          (lined (map pretty stmts))@@ -662,15 +714,13 @@ 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 ParComp{} =   error "FIXME: No implementation for ParComp." -instance Pretty IfAlt where-  prettyInternal (IfAlt _ cond body) =-    do pretty cond-       swing (write " -> ")-             (pretty body)- instance Pretty Stmt where   prettyInternal x =     case x of@@ -704,26 +754,22 @@   prettyInternal = decl  -- | Render a declaration.-decl :: Decl NodeInfo -> Printer ()-decl (PatBind _ pat mty rhs mbinds) =-  case mty of-    Just e ->-      error ("Unimplemented (Maybe Type) in PatBind." ++ show e)-    Nothing ->-      do pretty pat-         pretty rhs-         indentSpaces <- getIndentSpaces-         case mbinds of-           Nothing -> return ()-           Just binds ->-             do newline-                indented indentSpaces-                         (depend (write "where ")-                                 (pretty binds))-decl (InstDecl _ ctx dhead decls) =+decl :: MonadState PrintState m => Decl NodeInfo -> m ()+decl (PatBind _ pat rhs mbinds) =+  do pretty pat+     withCaseContext False (pretty rhs)+     indentSpaces <- getIndentSpaces+     case mbinds of+       Nothing -> return ()+       Just binds ->+         do newline+            indented indentSpaces+                     (depend (write "where ")+                             (pretty binds))+decl (InstDecl _ moverlap dhead decls) =   do indentSpaces <- getIndentSpaces      depend (write "instance ")-            (depend (maybeCtx ctx)+            (depend (maybeOverlap moverlap)                     (depend (pretty dhead)                             (unless (null (fromMaybe [] decls))                                     (write " where"))))@@ -752,8 +798,12 @@             (do newline                 indentSpaces <- getIndentSpaces                 indented indentSpaces (lined (map pretty (fromMaybe [] decls))))-decl TypeDecl{} =-  error "FIXME: No implementation for TypeDecl."+decl (TypeDecl _ typehead typ) =+  depend (write "type ")+         (depend (pretty typehead)+                 (depend (write " = ")+                         (pretty typ)))+ decl TypeFamDecl{} =   error "FIXME: No implementation for TypeFamDecl." decl (DataDecl _ dataornew ctx dhead condecls mderivs) =@@ -814,7 +864,10 @@   error "FIXME: No implementation for SpecInlineSig." decl InstSig{} =   error "FIXME: No implementation for InstSig."+decl ClosedTypeFamDecl{} =+  error "FIXME: No implementation for ClosedTypeFamDecl." decl x@WarnPragmaDecl{} = pretty' x+decl x@MinimalPragma{} = pretty' x decl x@AnnPragma{} = pretty' x decl x@InfixDecl{} = pretty' x decl x@DefaultDecl{} = pretty' x@@ -854,17 +907,14 @@         do pretty a            write " ~ "            pretty b+      ParenA _ asst -> parens $ pretty asst+      VarA _ var -> pretty var  instance Pretty BangType where   prettyInternal x =     case x of-      BangedTy _ ty ->-        depend (write "!")-               (pretty ty)-      UnBangedTy _ ty -> pretty ty-      UnpackedTy _ ty ->-        depend (write "{-# UNPACK #-} !")-               (pretty ty)+      BangedTy _ -> write "!"+      UnpackedTy _ -> write "{-# UNPACK #-} !"  instance Pretty Binds where   prettyInternal x =@@ -899,6 +949,11 @@            pretty this            write " = "            pretty that+      ClsDefSig _ name ty ->+        do write "default "+           pretty name+           write " :: "+           pretty ty  instance Pretty ConDecl where   prettyInternal x =@@ -933,34 +988,6 @@       FieldPun _ n -> pretty n       FieldWildcard _ -> write ".." -instance Pretty GuardedAlts where-  prettyInternal x =-    case x of-      UnGuardedAlt _ e ->-        swing (write " -> ")-              (pretty e)-      GuardedAlts _ gas ->-        do newline-           indented 2-                    (lined (map (\p ->-                                   do write "|"-                                      pretty p)-                                gas))--instance Pretty GuardedAlt where-  prettyInternal x =-    case x of-      GuardedAlt _ stmts e ->-        do indented 1-                    (do (prefixedLined-                           ","-                           (map (\p ->-                                   do space-                                      pretty p)-                                stmts)))-           swing (write " -> ")-                 (pretty e)- instance Pretty GuardedRhs where   prettyInternal x =     case x of@@ -972,7 +999,7 @@                                   do space                                      pretty p)                                stmts))-           swing (write " = ")+           swing (write " " >> rhsSeparator >> write " ")                  (pretty e)  instance Pretty InstDecl where@@ -993,7 +1020,7 @@         do depend (do pretty name                       space)                   (spaced (map pretty pats))-           pretty rhs+           withCaseContext False (pretty rhs)            case mbinds of              Nothing -> return ()              Just binds ->@@ -1011,7 +1038,7 @@                         Symbol _ s -> string s)                   (do space                       spaced (map pretty pats))-           pretty rhs+           withCaseContext False (pretty rhs)            case mbinds of              Nothing -> return ()              Just binds ->@@ -1045,8 +1072,8 @@ instance Pretty Rhs where   prettyInternal x =     case x of-      UnGuardedRhs _ e ->-        (swing (write " = ")+      UnGuardedRhs _ e -> do+        (swing (write " " >> rhsSeparator >> write " ")                (pretty e))       GuardedRhss _ gas ->         do newline@@ -1066,23 +1093,48 @@         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 -> spaced (map pretty xs)+       depend (maybeCtx mctx)+              (pretty ihead)++ instance Pretty InstHead where   prettyInternal x =     case x of-      IHead _ name tys ->-        spaced (pretty name :-                map pretty tys)-      IHInfix l a o b -> pretty (IHead l o [a,b])+      -- 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 tys ->-        spaced (pretty name :-                map pretty tys)-      DHInfix l a o b -> pretty (DHead l o [a,b])+      DHead _ name -> pretty name       DHParen _ h -> parens (pretty h)+      DHInfix _ var name ->+        do pretty var+           space+           write "`"+           pretty name+           write "`"+      DHApp _ dhead var ->+        depend (pretty dhead)+               (do space+                   pretty var)  instance Pretty SpecialCon where   prettyInternal s =@@ -1101,6 +1153,15 @@       Cons _ -> write ":"       UnboxedSingleCon _ -> write "(##)" +instance Pretty Overlap where+  prettyInternal (Overlap _) = write "{-# OVERLAP #-}"+  prettyInternal (NoOverlap _) = write "{-# NO_OVERLAP #-}"+  prettyInternal (Incoherent _) = write "{-# INCOHERENT #-}"++instance Pretty Sign where+  prettyInternal (Signless _) = return ()+  prettyInternal (Negative _) = write "-"+ -------------------------------------------------------------------------------- -- * Unimplemented or incomplete printers @@ -1110,7 +1171,9 @@       Module _ mayModHead pragmas imps decls ->         do case mayModHead of              Nothing -> return ()-             Just modHead -> pretty' modHead+             Just modHead -> do+               pretty modHead+               unless (null pragmas && null imps && null decls) $ newline            inter newline (map pretty pragmas)            inter newline (map pretty imps)            inter newline (map pretty decls)@@ -1183,4 +1246,13 @@   prettyInternal = pretty'  instance Pretty ImportSpec where+  prettyInternal = pretty'++instance Pretty WarningText where+  prettyInternal = pretty'++instance Pretty ExportSpecList where+  prettyInternal = pretty'++instance Pretty ExportSpec where   prettyInternal = pretty'

@@ -5,9 +5,7 @@ -- -- Documented here: <https://github.com/chrisdone/haskell-style-guide> -module HIndent.Styles.ChrisDone-  (chrisDone)-  where+module HIndent.Styles.ChrisDone where  import HIndent.Pretty import HIndent.Types@@ -31,7 +29,8 @@ smallColumnLimit = 50  -- | Empty state.-data State = State+data State =+  State  -- | The printer style. chrisDone :: Style@@ -44,9 +43,7 @@            [Extender exp            ,Extender fieldupdate            ,Extender rhs-           ,Extender guardedrhs-           ,Extender guardedalt-           ,Extender unguardedalt+           ,Extender contextualGuardedRhs            ,Extender stmt            ,Extender decl]         ,styleDefConfig =@@ -119,17 +116,43 @@     _ -> prettyNoExt e  -- | Right-hand sides are dependent.-rhs :: State -> Rhs NodeInfo -> Printer ()-rhs _ (UnGuardedRhs _ e) =+rhs :: s -> Rhs NodeInfo -> Printer ()+rhs s grhs =+  do inCase <- gets psInsideCase+     if inCase+        then unguardedalt s grhs+        else unguardedrhs s grhs++-- | Right-hand sides are dependent.+unguardedrhs :: s -> Rhs NodeInfo -> Printer ()+unguardedrhs _ (UnGuardedRhs _ e) =   do indentSpaces <- getIndentSpaces      indented indentSpaces               (dependOrNewline (write " = ")                                e                                pretty)-rhs _ e = prettyNoExt e+unguardedrhs _ e = prettyNoExt e +-- | Unguarded case alts.+unguardedalt :: t -> Rhs NodeInfo -> Printer ()+unguardedalt _ (UnGuardedRhs _ e) =+  dependOrNewline+    (write " -> ")+    e+    (indented 2 .+     pretty)+unguardedalt _ e = prettyNoExt e++-- | Decide whether to do alts or rhs based on the context.+contextualGuardedRhs :: s -> GuardedRhs NodeInfo -> Printer ()+contextualGuardedRhs s grhs =+  do inCase <- gets psInsideCase+     if inCase+        then guardedalt s grhs+        else guardedrhs s grhs+ -- | I want guarded RHS be dependent or newline.-guardedrhs :: State -> GuardedRhs NodeInfo -> Printer ()+guardedrhs :: s -> GuardedRhs NodeInfo -> Printer () guardedrhs _ (GuardedRhs _ stmts e) =   indented 1            (do prefixedLined@@ -145,8 +168,8 @@                   pretty))  -- | I want guarded alts be dependent or newline.-guardedalt :: State -> GuardedAlt NodeInfo -> Printer ()-guardedalt _ (GuardedAlt _ stmts e) =+guardedalt :: s -> GuardedRhs NodeInfo -> Printer ()+guardedalt _ (GuardedRhs _ stmts e) =   indented 1            (do (prefixedLined                   ","@@ -160,28 +183,19 @@                  (indented 1 .                   pretty)) --- | I want unguarded alts be dependent or newline.-unguardedalt :: State -> GuardedAlts NodeInfo -> Printer ()-unguardedalt _ (UnGuardedAlt _ e) =-  dependOrNewline-    (write " -> ")-    e-    (indented 2 .-     pretty)-unguardedalt _ e = prettyNoExt e- -- Do statements need to handle infix expression indentation specially because -- do x * --    y -- is two invalid statements, not one valid infix op.-stmt :: State -> Stmt NodeInfo -> Printer ()+stmt :: s -> Stmt NodeInfo -> Printer () stmt _ (Qualifier _ e@(InfixApp _ a op b)) =-  do col <- fmap (psColumn . snd) (sandbox (write ""))+  do col <- fmap (psColumn . snd)+                 (sandbox (write ""))      infixApp e a op b (Just col) stmt _ e = prettyNoExt e  -- | Expressions-exp :: State -> Exp NodeInfo -> Printer ()+exp :: s -> Exp NodeInfo -> Printer () -- Infix applications will render on one line if possible, otherwise -- if any of the arguments are not "flat" then that expression is -- line-separated.@@ -264,7 +278,9 @@                => [ast NodeInfo] -> Printer (Bool,PrintState) sandboxSingles args =   sandbox (allM (\(i,arg) ->-                   do when (i /= (0::Int)) newline+                   do when (i /=+                            (0 :: Int))+                           newline                       line <- gets psLine                       pretty arg                       st <- get@@ -306,10 +322,12 @@         => ast NodeInfo -> Printer (Bool,PrintState) isShort p =   do line <- gets psLine-     orig <- fmap (psColumn . snd) (sandbox (write ""))+     orig <- fmap (psColumn . snd)+                  (sandbox (write ""))      (_,st) <- sandbox (pretty p)      return (psLine st == line &&-             (psColumn st < orig + shortName),st)+             (psColumn st < orig + shortName)+            ,st)  -- | Is the given expression "small"? I.e. does it fit on one line and -- under 'smallColumnLimit' columns.@@ -323,12 +341,10 @@ -- | Is an expression flat? isFlat :: Exp NodeInfo -> Bool isFlat (Lambda _ _ e) = isFlat e-isFlat (App _ a b) =-  isName a && isName b+isFlat (App _ a b) = isName a && isName b   where isName (Var{}) = True         isName _ = False-isFlat (InfixApp _ a _ b) =-  isFlat a && isFlat b+isFlat (InfixApp _ a _ b) = isFlat a && isFlat b isFlat (NegApp _ a) = isFlat a isFlat VarQuote{} = True isFlat TypQuote{} = True

@@ -3,9 +3,7 @@ -- | Fundamental built-in style. Defines no additional extensions or -- configurations beyond the default printer. -module HIndent.Styles.Fundamental-  (fundamental)-  where+module HIndent.Styles.Fundamental where  import HIndent.Types 

@@ -1,18 +1,19 @@ {-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards, RankNTypes #-} -module HIndent.Styles.Gibiansky (gibiansky) where+module HIndent.Styles.Gibiansky where  import Data.Foldable-import Control.Monad (unless, when, replicateM_, void)+import Control.Applicative((<$>))+import Control.Monad (unless, when, replicateM_) import Control.Monad.State (gets, get, put)-import Debug.Trace  import HIndent.Pretty import HIndent.Types  import Language.Haskell.Exts.Annotated.Syntax import Language.Haskell.Exts.SrcLoc-import Prelude hiding (exp, all, mapM_)+import Language.Haskell.Exts.Comments+import Prelude hiding (exp, all, mapM_, minimum, and, maximum)  -- | Empty state. data State = State@@ -30,12 +31,16 @@                            , Extender typ                            , Extender exprs                            , Extender rhss+                           , Extender guardedRhs                            , Extender decls                            , Extender condecls-                           , Extender guardedAlts+                           , Extender alt+                           , Extender moduleHead+                           , Extender exportList+                           , Extender fieldUpdate                            ]         , styleDefConfig =-           defaultConfig { configMaxColumns = maxColumns+           defaultConfig { configMaxColumns = 100                          , configIndentSpaces = indentSpaces                          , configClearEmptyLines =  True                          }@@ -49,21 +54,26 @@ indentOnce :: Printer () indentOnce = replicateM_ indentSpaces $ write " " --- | Max number of columns per line.-maxColumns :: Integral a => a-maxColumns = 100+-- | How many exports to format in a single line.+-- If an export list has more than this, it will be formatted as multiple lines.+maxSingleLineExports :: Integral a => a+maxSingleLineExports = 4 -attemptSingleLine :: Printer a -> Printer a -> Printer ()+attemptSingleLine :: Printer a -> Printer a -> Printer a attemptSingleLine single multiple = do   -- Try printing on one line.   prevState <- get-  void single+  result <- single    --  If it doesn't fit, reprint on multiple lines.   col <- getColumn-  when (col > maxColumns) $ do-    put prevState-    void multiple+  maxColumns <- configMaxColumns <$> gets psConfig+  if col > maxColumns+    then do+      put prevState+      multiple+    else+      return result  -------------------------------------------------------------------------------- -- Extenders@@ -126,6 +136,16 @@       write  "=> "       indented 3 $ pretty rest +typ _ (TyTuple _ boxed types) = parens $ do+  boxed'+  inter (write ", ") $ map pretty types+  boxed'++  where+    boxed' = case boxed of+      Boxed   -> return ()+      Unboxed -> write "#"+ typ _ ty@(TyFun _ from to) =   -- If the function argument types are on the same line,   -- put the entire function type on the same line.@@ -148,7 +168,7 @@ 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 :: Annotated ast => ast NodeInfo -> Int     line = startLine . nodeInfoSpan . ann  collectTypes :: Type l -> [Type l]@@ -163,6 +183,10 @@ exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "$"))) _) = dollarExpr exp exprs _ exp@(InfixApp _ _ (QVarOp _ (UnQual _ (Symbol _ "<*>"))) _) = applicativeExpr exp exprs _ exp@Lambda{} = lambdaExpr exp+exprs _ exp@Case{} = caseExpr exp+exprs _ (RecUpdate _ exp updates) = recUpdateExpr (pretty exp) updates+exprs _ (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates+exprs _ (Tuple _ _ exps) = parens $ inter (write ", ") $ map pretty exps exprs _ exp = prettyNoExt exp  letExpr :: Exp NodeInfo -> Printer ()@@ -178,7 +202,65 @@ letExpr _ = error "Not a let"  appExpr :: Exp NodeInfo -> Printer ()-appExpr (App _ f x) = spaced [pretty f, pretty x]+appExpr app@(App _ f x) = do+  prevState <- get+  prevLine <- getLineNum+  attemptSingleLine singleLine multiLine+  curLine <- getLineNum++  -- If the multiline version takes more than two lines,+  -- print everything with one argument per line.+  when (curLine - prevLine > 1) $ do+    -- Restore to before printing.+    put prevState++    allArgsSeparate <- not <$> canSingleLine (pretty f)+    if allArgsSeparate+      then separateArgs app+      else do+        col <- getColumn+        column col $ do+          pretty f+          newline+          indented indentSpaces $ pretty x++  where+    singleLine = spaced [pretty f, pretty x]+    multiLine = do+      col <- getColumn+      column col $ do+        pretty f+        newline+        indentOnce+        pretty x++    canSingleLine :: Printer a -> Printer Bool+    canSingleLine printer = do+      st <- get+      prevLine <- getLineNum+      _ <- printer+      curLine <- getLineNum+      put st+      return $ prevLine == curLine++    -- Separate a function application into the function+    -- and all of its arguments. Arguments are returned in reverse order.+    collectArgs :: Exp NodeInfo -> (Exp NodeInfo, [Exp NodeInfo])+    collectArgs (App _ g y) =+      let (fun, args) = collectArgs g in+        (fun, y : args)+    collectArgs nonApp = (nonApp, [])++    separateArgs :: Exp NodeInfo -> Printer ()+    separateArgs expr =+      let (fun, args) = collectArgs expr+      in do+        col <- getColumn+        column col $ do+          pretty fun+          newline+          indented indentSpaces $ lined $ map pretty $ reverse args+ appExpr _ = error "Not an app"  doExpr :: Exp NodeInfo -> Printer ()@@ -193,19 +275,20 @@ listExpr _ = error "Not a list"  singleLineList :: [Exp NodeInfo] -> Printer ()-singleLineList exprs = do+singleLineList exps = do   write "["-  inter (write ", ") $ map pretty exprs+  inter (write ", ") $ map pretty exps   write "]"  multiLineList :: [Exp NodeInfo] -> Printer () multiLineList [] = write "[]"-multiLineList (first:exprs) = do+multiLineList (first:exps) = do   col <- getColumn-  column col $ do+  ind <- gets psIndentLevel+  column (max col ind) $ do     write "[ "     pretty first-    forM_ exprs $ \el -> do+    forM_ exps $ \el -> do       newline       write ", "       pretty el@@ -288,11 +371,113 @@     pretty exp lambdaExpr _ = error "Not a lambda" +caseExpr :: Exp NodeInfo -> Printer ()+caseExpr (Case _ exp alts) = do+  allSingle <- and <$> mapM isSingle alts++  depend (write "case ") $ do+    pretty exp+    write " of"+  newline++  withCaseContext True $ indented indentSpaces $+    if allSingle+    then do+      maxPatLen <- maximum <$> mapM (patternLen . altPattern) alts+      lined $ map (prettyCase $ Just maxPatLen) alts+    else lined $ map (prettyCase Nothing) alts+  where+    isSingle :: Alt NodeInfo -> Printer Bool+    isSingle alt' = fst <$> sandbox (do+      line <- gets psLine+      pretty alt'+      line' <- gets psLine+      return $ line == line')++    altPattern :: Alt l -> Pat l+    altPattern (Alt _ p _ _) = p++    patternLen :: Pat NodeInfo -> Printer Int+    patternLen pat = fromIntegral <$> fst <$> sandbox (do+      col <- getColumn+      pretty pat+      col' <- getColumn+      return $ col' - col)++    prettyCase :: Maybe Int -> Alt NodeInfo -> Printer ()+    prettyCase mpatlen (Alt _ p galts mbinds) = do+      -- Padded pattern+      case mpatlen of+        Just patlen -> do+          col <- getColumn+          pretty p+          col' <- getColumn+          replicateM_ (patlen - fromIntegral (col' - col)) space+        Nothing -> pretty p++      case galts of+        UnGuardedRhs{} -> pretty galts+        GuardedRhss{} -> indented indentSpaces $ pretty galts++      --  Optional where clause!+      forM_ mbinds $ \binds -> do+        newline+        indented indentSpaces $ depend (write "where ") (pretty binds)+++caseExpr _ = error "Not a case"++recUpdateExpr :: Printer () -> [FieldUpdate NodeInfo] -> Printer ()+recUpdateExpr expWriter updates = do+  expWriter+  write " "+  attemptSingleLine single mult++  where+    single = do+      write "{ "+      inter (write ", ") $ map pretty updates+      write " }"+    mult = do+      col <- getColumn+      column col $ do+        write "{ "+        inter (newline >> write ", ") $ map pretty updates+        newline+        write "}"+ rhss :: Extend Rhs rhss _ (UnGuardedRhs _ exp) = do-  write " = "+  write " " +  rhsSeparator+  if onNextLine exp+    then indented indentSpaces $ do+      newline+      pretty exp+    else do+      space+      pretty exp+  +  where+    onNextLine Let{} = True+    onNextLine _ = False+rhss _ (GuardedRhss _ rs) =+  lined $ flip map rs $ \a@(GuardedRhs _ stmts exp) -> do+    printComments Before a+    write "| "+    inter (write ", ") $ map pretty stmts+    write " "+    rhsSeparator+    write " "+    pretty exp++guardedRhs :: Extend GuardedRhs+guardedRhs _ (GuardedRhs _ stmts exp) = do+  indented 1 $ prefixedLined "," (map (\p -> space >> pretty p) stmts)+  write " " +  rhsSeparator+  write " "   pretty exp-rhss _ rhs = prettyNoExt rhs  decls :: Extend Decl decls _ (DataDecl _ dataOrNew Nothing declHead constructors mayDeriving) = do@@ -317,11 +502,10 @@     newline     indented indentSpaces $ pretty deriv -decls _ (PatBind _ pat Nothing rhs mbinds) = funBody [pat] rhs mbinds-decls _ (FunBind _ matches) = -  forM_ matches $ \match -> do--    (name, pat, rhs, mbinds) <- +decls _ (PatBind _ pat rhs mbinds) = funBody [pat] rhs mbinds+decls _ (FunBind _ matches) =+  lined $  flip map matches $ \match -> do+    (name, pat, rhs, mbinds) <-       case match of         Match _ name pat rhs mbinds -> return (name, pat, rhs, mbinds)         InfixMatch _ left name pat rhs mbinds -> do@@ -337,8 +521,13 @@ funBody :: [Pat NodeInfo] -> Rhs NodeInfo -> Maybe (Binds NodeInfo) -> Printer () funBody pat rhs mbinds = do   spaced $ map pretty pat-  pretty rhs +  withCaseContext False $ case rhs of+    UnGuardedRhs{} -> pretty rhs+    GuardedRhss{}  -> do+      newline +      indented indentSpaces $ pretty rhs+   -- Process the binding group, if it exists.   forM_ mbinds $ \binds -> do     newline@@ -350,16 +539,24 @@       indented indentSpaces $ writeWhereBinds binds  writeWhereBinds :: Binds NodeInfo -> Printer ()-writeWhereBinds (BDecls _ binds@(first:rest)) = do+writeWhereBinds ds@(BDecls _ binds@(first:rest)) = do+  printComments Before ds   pretty first   forM_ (zip binds rest) $ \(prev, cur) -> do-    let prevLine = srcSpanEndLine . srcInfoSpan . nodeInfoSpan . ann $ prev-        curLine = startLine . nodeInfoSpan . ann $ cur-        emptyLines = curLine - prevLine-    replicateM_ (traceShowId emptyLines) newline+    replicateM_ (max 1 $ lineDelta cur prev) newline     pretty cur writeWhereBinds binds = prettyNoExt binds +astStartLine :: Annotated ast => ast NodeInfo -> Int+astStartLine decl =+  let info = ann decl+      comments = nodeInfoComments info+      befores = filter ((== Just Before) . comInfoLocation) comments+      commentStartLine (Comment _ sp _) = srcSpanStartLine sp+  in if null befores+     then startLine $ nodeInfoSpan info+     else minimum $ map (commentStartLine . comInfoComment) befores+ isDoBlock :: Rhs l -> Bool isDoBlock (UnGuardedRhs _ Do{}) = True isDoBlock _ = False@@ -389,8 +586,60 @@     write "}" condecls _ other = prettyNoExt other -guardedAlts :: Extend GuardedAlts-guardedAlts _ (UnGuardedAlt _ exp) = do-  write " -> "-  pretty exp-guardedAlts _ alt = prettyNoExt alt+alt :: Extend Alt+alt _ (Alt _ p rhs mbinds) = do+  pretty p+  case rhs of+    UnGuardedRhs{} -> pretty rhs+    GuardedRhss{}  -> indented indentSpaces $ pretty rhs+  forM_ mbinds $ \binds -> do+    newline+    indented indentSpaces $+      depend (write "where ") (pretty binds)++moduleHead :: Extend ModuleHead+moduleHead _ (ModuleHead _ name mwarn mexports) = do+  forM_ mwarn pretty+  write "module "+  pretty name+  forM_ mexports $ \exports -> do+    space+    pretty exports+  write " where"++exportList :: Extend ExportSpecList+exportList _ (ExportSpecList _ exports) = do+  write "("+  if length exports <= maxSingleLineExports+    then do+      inter (write ", ") $ map pretty exports+      write ")"+    else indented indentSpaces' $ do+      -- First export+      let first:rest = exports+      newline+      pretty first+      write ","++      forM_ (zip rest exports) $ \(cur, prev) -> do+        replicateM_ (max 1 $ lineDelta cur prev) newline+        pretty cur+        write ","+      newline+      write ")"+  where+    indentSpaces' = 2 * indentSpaces++lineDelta :: (Annotated ast1, Annotated ast2) => ast1 NodeInfo -> ast2 NodeInfo -> Int+lineDelta cur prev = emptyLines+  where+    prevLine = srcSpanEndLine . srcInfoSpan . nodeInfoSpan . ann $ prev+    curLine = astStartLine cur+    emptyLines = curLine - prevLine++fieldUpdate :: Extend FieldUpdate+fieldUpdate _ (FieldUpdate _ name val) = do+  pretty name+  write " = "+  pretty val+fieldUpdate _ upd = prettyNoExt upd

@@ -11,9 +11,7 @@ -- How to indent let? -- How to indent large ADT constructors types? -module HIndent.Styles.JohanTibell-  (johanTibell)-  where+module HIndent.Styles.JohanTibell where  import Control.Monad import Control.Monad.State.Class@@ -49,9 +47,7 @@            ,Extender exp            ,Extender guardedRhs            ,Extender rhs-           ,Extender ifAlt-           ,Extender alts-           ,Extender guardedAlt]+           ]         ,styleDefConfig =            defaultConfig {configMaxColumns = 80                          ,configIndentSpaces = 4}}@@ -76,46 +72,6 @@                               gas))     _ -> prettyNoExt x --- | Case alts.-alts :: t -> GuardedAlts NodeInfo -> Printer ()--- | Handle do specially.-alts _ x =-  case x of-    UnGuardedAlt _ (Do _ dos) ->-      swing (write " -> do")-            (lined (map pretty dos))-    GuardedAlts _ gas ->-      do newline-         indentSpaces <- getIndentSpaces-         indented indentSpaces-                  (lined (map (\p ->-                                 do write "|"-                                    pretty p)-                              gas))-    _ -> prettyNoExt x---- | Handle do specially.-guardedAlt _ x =-  case x of-    GuardedAlt _ stmts (Do _ dos) ->-      do indented 1-                  (do (prefixedLined-                         ","-                         (map (\p ->-                                 do space-                                    pretty p)-                              stmts)))-         swing (write " -> do ")-               (lined (map pretty dos))-    _ -> prettyNoExt x---- | Handle do specially.-ifAlt _ (IfAlt _ cond (Do _ dos)) =-  do pretty cond-     swing (write " -> do")-           (lined (map pretty dos))-ifAlt _ e = prettyNoExt e- -- | Implement dangling right-hand-sides. guardedRhs :: t -> GuardedRhs NodeInfo -> Printer () -- | Handle do specially.@@ -171,16 +127,16 @@                   newline                   branch "else " else')      -- Special handling for do.-  where branch string e =+  where branch str e =           case e of             Do _ stmts ->-              do write string+              do write str                  write "do"                  newline                  indentSpaces <- getIndentSpaces                  indented indentSpaces (lined (map pretty stmts))             _ ->-              depend (write string)+              depend (write str)                      (pretty e) -- | App algorithm similar to ChrisDone algorithm, but with no -- parent-child alignment.@@ -225,13 +181,9 @@  -- | Specially format records. Indent where clauses only 2 spaces. decl :: t -> Decl NodeInfo -> Printer ()-decl _ (PatBind _ pat mty rhs mbinds) =-  case mty of-    Just e ->-      error ("Unimplemented (Maybe Type) in PatBind." ++ show e)-    Nothing ->+decl _ (PatBind _ pat rhs' mbinds) =       do pretty pat-         pretty rhs+         pretty rhs'          case mbinds of            Nothing -> return ()            Just binds ->

@@ -14,8 +14,9 @@   ,Config(..)   ,defaultConfig   ,NodeInfo(..)-  ,ComInfo(..))-  where+  ,ComInfo(..)+  ,ComInfoLocation(..)+  ) where  import Control.Applicative import Control.Monad.State.Strict (MonadState(..),State)@@ -43,11 +44,12 @@                        ,psExtenders :: ![Extender s] -- ^ Extenders.                        ,psConfig :: !Config -- ^ Config which styles may or may not pay attention to.                        ,psEolComment :: !Bool -- ^ An end of line comment has just been outputted.+                       ,psInsideCase :: !Bool -- ^ Whether we're in a case statement, used for Rhs printing.                        }  instance Eq PrintState where-  PrintState ilevel out newline col line _ _ _ eolc == PrintState ilevel' out' newline' col' line' _ _ _ eolc' =-    (ilevel,out,newline,col,line,eolc) == (ilevel',out',newline',col',line',eolc')+  PrintState ilevel out newline col line _ _ _ eolc inc == PrintState ilevel' out' newline' col' line' _ _ _ eolc' inc' =+    (ilevel,out,newline,col,line,eolc, inc) == (ilevel',out',newline',col',line',eolc', inc')  -- | A printer extender. Takes as argument the user state that the -- printer was run with, and the current node to print. Use@@ -87,13 +89,17 @@ -- | Information for each node in the AST. data NodeInfo =   NodeInfo {nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.-           ,nodeInfoComments :: ![ComInfo] -- ^ Comments which follow this node.+           ,nodeInfoComments :: ![ComInfo] -- ^ Comments which are attached to this node.            }   deriving (Typeable,Show,Data) +-- | Comment relative locations.+data ComInfoLocation = Before | After+  deriving (Show,Typeable,Data,Eq)+ -- | Comment with some more info. data ComInfo =-  ComInfo {comInfoComment :: !Comment --  ^ The normal comment type.-          ,comInfoOwnLine :: !Bool -- ^ Does the comment rest on its own line?+  ComInfo {comInfoComment :: !Comment                -- ^ The normal comment type.+          ,comInfoLocation :: !(Maybe ComInfoLocation) -- ^ Where the comment lies relative to the node.           }   deriving (Show,Typeable,Data)

@@ -0,0 +1,89 @@+module Main(main) where++import Control.Monad+import Control.Applicative+import Data.List (find, unfoldr, isPrefixOf, intercalate)++import System.Directory+import System.Environment+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.Builder as L++import qualified HIndent++testDir, expectedDir :: String+testDir = "tests"+expectedDir = "expected"++-- This executable generates a test suite for a style using a test suite+-- from a previous style. Given arguments `from` and `to` which are style names,+-- it will take all the input files for `from`, create identical input files for `to`,+-- run each block in the input files through the `to` style, and generate expectation files matching the output.+main :: IO ()+main = do+  args <- getArgs+  case args of+    [from, to] -> generateTests from to+    _          -> putStrLn "Two arguments required: source tests and destination tests."++generateTests :: String -> String -> IO ()+generateTests from to = do+  --  Find the source and destination styles.+  let Just toStyle = findStyle (T.pack to)++  --  Get all the test and expectation files for the original test suite.+  testFilenamesFrom <- filter (not . isPrefixOf ".") <$> getDirectoryContents (tests from)++  -- Verify the target directories exist.+  createDirectoryIfMissing True $ tests to+  createDirectoryIfMissing True $ expected to++  -- Copy test files to the new style test directory.+  forM_ testFilenamesFrom $ \filename ->+    copyFile (tests from ++ filename) (tests to ++ filename)++  -- Generate expectation files for the new style test directory.+  forM_ testFilenamesFrom $ \filename -> do+    let dstFilename = expected to ++ expectedFilename filename+    contents <- expectationFileContents toStyle <$> readFile (tests to ++ filename)+    writeFile dstFilename contents++  where+    findStyle style = find ((== style). HIndent.styleName) HIndent.styles+    tests style = "test/" ++ style ++ "/" ++ testDir ++ "/"+    expected style = "test/" ++ style ++ "/" ++ expectedDir ++ "/"+    expectedFilename filename = take (length filename - 4) filename ++ "exp"++expectationFileContents :: HIndent.Style -> String -> String+expectationFileContents style contents =+  let testDecls = parsePieces contents+      fmt input = L.unpack $ L.toLazyText $ case HIndent.reformat style $ L.pack input of+                                              Left err      -> error err+                                              Right builder -> builder+      outputs = map (replaceEmptyNewlines . fmt) testDecls+  in intercalate "\n" outputs+  where+    replaceEmptyNewlines = unlines . map replaceNewline . lines+    replaceNewline "" = ">"+    replaceNewline x = x++parsePieces :: String -> [String]+parsePieces str = map (intercalate "\n" . map mkNewlines) 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 ("", "") = error "Two consecutive line breaks!"+    pieceBreak (line, next) = null line && head next /= ' '++    mkNewlines :: String -> String+    mkNewlines ">" = ""+    mkNewlines x = x

@@ -13,7 +13,7 @@ import qualified HIndent  styles :: [FilePath]-styles = ["gibiansky"]+styles = ["fundamental", "gibiansky", "chris-done"]  testDir, expectedDir :: String testDir = "tests"@@ -44,7 +44,11 @@   let testDecls = parsePieces testContents       expDecls = parsePieces expContents   when (length testDecls /= length expDecls) $-    error $ "Mismatched number of pieces in files " ++ test ++ " and " ++ exp+    error $ concat [ "Mismatched number of pieces in files "+                   , test, " (", show $ length testDecls, ")"+                   , " and "+                   , exp, " (", show $ length expDecls, ")"+                   ]   return $ describe ("hindent applied to chunks in " ++ test) $ foldl1 (>>) $ zipWith (mkSpec style) testDecls expDecls  mkSpec :: HIndent.Style -> String -> String -> Spec@@ -54,7 +58,7 @@     Right builder -> L.unpack (L.toLazyText builder) `shouldBe` desired  parsePieces :: String -> [String]-parsePieces str = map (intercalate "\n") pieces+parsePieces str = map (intercalate "\n" . map mkNewlines) pieces   where     pieces = unfoldr unfolder (lines str) @@ -68,3 +72,7 @@     pieceBreak :: (String, String) -> Bool     pieceBreak ("", "") = error "Two consecutive line breaks!"     pieceBreak (line, next) = null line && head next /= ' '++    mkNewlines :: String -> String+    mkNewlines ">" = ""+    mkNewlines x = x

@@ -7,7 +7,16 @@     let g:hindent_style = "fundamental" endif +function! FormatHaskell()+    if !empty(v:char)+        return 1+    else+        let l:filter = "hindent --style " . g:hindent_style+        let l:command = v:lnum.','.(v:lnum+v:count-1).'!'.l:filter+        execute l:command+    endif+endfunction+ if has("autocmd")-  let hindent = "hindent --style " . g:hindent_style-  autocmd FileType haskell setlocal formatexpr=FormatprgLocal(hindent)+  autocmd FileType haskell setlocal formatexpr=FormatHaskell() endif