hindent 4.5.3 → 4.5.4

raw patch · 14 files changed

+194/−113 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hindent.cabal +1/−1
• src/HIndent.hs +6/−1
• src/HIndent/Styles/ChrisDone.hs +64/−44
• src/HIndent/Styles/Gibiansky.hs +5/−1
• src/HIndent/Styles/JohanTibell.hs +97/−37
• test/chris-done/expected/10.exp +1/−2
• test/gibiansky/expected/45.exp +2/−0
• test/gibiansky/tests/45.test +2/−0
• test/johan-tibell/expected/2.exp +3/−6
• test/johan-tibell/expected/3.exp +1/−2
• test/johan-tibell/expected/4.exp +1/−3
• test/johan-tibell/expected/5.exp +4/−2
• test/johan-tibell/expected/6.exp +4/−8
• test/johan-tibell/expected/7.exp +3/−6

@@ -1,5 +1,5 @@ name:                hindent-version:             4.5.3+version:             4.5.4 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .

@@ -17,6 +17,7 @@   ,gibiansky   -- * Testing   ,test+  ,testFile   ,testAll   ,testAst   )@@ -99,7 +100,7 @@     findSmallestPrefix :: [Text] -> Text     findSmallestPrefix [] = ""     findSmallestPrefix ("":_) = ""-    findSmallestPrefix (p:ps) = +    findSmallestPrefix (p:ps) =       let first = T.head p           startsWithChar c x  = T.length x > 0 && T.head x == c       in if all (startsWithChar first) ps@@ -195,6 +196,10 @@           filter isDisabledExtention knownExtensions         isDisabledExtention (DisableExtension _) = False         isDisabledExtention _ = True++-- | Test the given file.+testFile :: FilePath -> Style -> IO ()+testFile fp style = T.readFile fp >>= test style  -- | Test with the given style, prints to stdout. test :: Style -> Text -> IO ()

@@ -21,6 +21,7 @@ import Language.Haskell.Exts.Annotated.Syntax import Language.Haskell.Exts.Parser (ParseResult(..)) import Prelude hiding (exp)+import Data.Monoid  -------------------------------------------------------------------------------- -- Style configuration@@ -69,11 +70,22 @@ -- decl :: Decl NodeInfo -> Printer s () decl (TypeSig _ names ty') =-  depend (do inter (write ", ")-                   (map pretty names)-             write " :: ")-         (declTy ty')-  where declTy dty =+  do (fitting,st) <- isSmallFitting dependent+     if fitting+        then put st+        else do inter (write ", ")+                      (map pretty names)+                newline+                indentSpaces <- getIndentSpaces+                indented indentSpaces+                         (depend (write ":: ")+                                 (declTy ty'))+  where dependent =+          depend (do inter (write ", ")+                           (map pretty names)+                     write " :: ")+                 (declTy ty')+        declTy dty =           case dty of             TyForall _ mbinds mctx ty ->               do case mbinds of@@ -95,18 +107,14 @@         collapseFaps (TyFun _ arg result) = arg : collapseFaps result         collapseFaps e = [e]         prettyTy ty =-          do small <- isSmall' ty-             if small-                then pretty ty+          do (fits,st) <- fitsOnOneLine (pretty ty)+             if fits+                then put st                 else case collapseFaps ty of                        [] -> pretty ty                        tys ->                          prefixedLined "-> "                                        (map pretty tys)-        isSmall' p =-          do overflows <- isOverflow (pretty p)-             oneLine <- isSingleLiner (pretty p)-             return (not overflows && oneLine) decl e = prettyNoExt e  -- | I want field updates to be dependent or newline.@@ -268,9 +276,8 @@   depend (write (case boxed of                    Unboxed -> "(#"                    Boxed -> "("))-         (do single <- isSingleLiner p-             underflow <- fmap not (isOverflow p)-             if single && underflow+         (do (fits,_) <- fitsOnOneLine p+             if fits                 then p                 else prefixedLined ","                                    (map pretty exps)@@ -363,6 +370,14 @@      (_,st) <- sandbox p      return (psLine st == line && psColumn st < smallColumnLimit,st) +-- | Is the given expression "small"? I.e. does it fit under+-- 'smallColumnLimit' columns.+isSmallFitting :: MonadState (PrintState t) m+               => m a -> m (Bool,PrintState t)+isSmallFitting p =+  do (_,st) <- sandbox p+     return (psColumn st < smallColumnLimit,st)+ -- | Is an expression flat? isFlat :: Exp NodeInfo -> Bool isFlat (Lambda _ _ e) = isFlat e@@ -382,26 +397,19 @@ isFlat _ = False  -- | Does printing the given thing overflow column limit? (e.g. 80)-isOverflow :: Printer t a -> Printer t Bool-isOverflow p =-  do (_,st) <- sandbox p+fitsOnOneLine :: MonadState (PrintState s) m => m a -> m (Bool,PrintState s)+fitsOnOneLine p =+  do line <- gets psLine+     (_,st) <- sandbox p      columnLimit <- getColumnLimit-     return (psColumn st > columnLimit)+     return (psLine st == line && psColumn st < columnLimit,st)  -- | Does printing the given thing overflow column limit? (e.g. 80)-isOverflowMax :: Printer t a -> Printer t Bool-isOverflowMax p =+fitsInColumnLimit :: Printer t a -> Printer t (Bool,PrintState t)+fitsInColumnLimit p =   do (_,st) <- sandbox p      columnLimit <- getColumnLimit-     return (psColumn st > columnLimit + 20)---- | Is the given expression a single-liner when printed?-isSingleLiner :: MonadState (PrintState t) m-              => m a -> m Bool-isSingleLiner p =-  do line <- gets psLine-     (_,st) <- sandbox p-     return (psLine st == line)+     return (psColumn st < columnLimit,st)  -------------------------------------------------------------------------------- -- Helpers@@ -413,19 +421,15 @@          -> Maybe Int64          -> Printer s () infixApp e a op b indent =-  do let is = isFlat e-     overflow <- isOverflow-                   (depend (do prettyWithIndent a-                               space-                               pretty op-                               space)-                           (do prettyWithIndent b))-     if is && not overflow-        then do depend (do prettyWithIndent a-                           space-                           pretty op-                           space)-                       (do prettyWithIndent b)+  do (fits,st) <-+       fitsOnOneLine+         (spaced (map (\link ->+                         case link of+                           OpChainExp e' -> pretty e'+                           OpChainLink qop -> pretty qop)+                      (flattenOpChain e)))+     if fits+        then put st         else do prettyWithIndent a                 space                 pretty op@@ -438,8 +442,24 @@                               (prettyWithIndent b)   where prettyWithIndent e' =           case e' of-            (InfixApp _ a' op' b') -> infixApp e' a' op' b' indent+            (InfixApp _ a' op' b') ->+              infixApp e' a' op' b' indent             _ -> pretty e'++-- | A link in a chain of operator applications.+data OpChainLink l+  = OpChainExp (Exp l)+  | OpChainLink (QOp l)+  deriving (Show)++-- | Flatten a tree of InfixApp expressions into a chain of operator+-- links.+flattenOpChain :: Exp l -> [OpChainLink l]+flattenOpChain (InfixApp _ left op right) =+  flattenOpChain left <>+  [OpChainLink op] <>+  flattenOpChain right+flattenOpChain e = [OpChainExp e]  -- | Make the right hand side dependent if it's flat, otherwise -- newline it.

@@ -336,7 +336,11 @@ -- 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) =+typ (TyForall _ mforall (Just ctx) rest) = do+  forM_ mforall $ \forallVars -> do+    write "forall "+    spaced $ map pretty forallVars+    write ". "   if all (sameLine ctx) $ collectTypes rest     then do       pretty ctx

@@ -19,9 +19,8 @@ import Data.Int import Data.Maybe import HIndent.Pretty+import HIndent.Styles.ChrisDone (infixApp) import HIndent.Types-import HIndent.Styles.ChrisDone (infixApp,dependOrNewline)- import Language.Haskell.Exts.Annotated.Syntax import Prelude hiding (exp) @@ -82,6 +81,21 @@                  pretty) stmt e = prettyNoExt e +-- | Make the right hand side dependent if it fits on one line,+-- otherwise send it to the next line.+dependOrNewline :: Printer t ()+                -> Exp NodeInfo+                -> (Exp NodeInfo -> Printer t ())+                -> Printer t ()+dependOrNewline left right f =+  do (fits,st) <- fitsOnOneLine renderDependent+     if fits+        then put st+        else do left+                newline+                (f right)+  where renderDependent = depend left (f right)+ -- | Handle do and case specially and also space out guards more. rhs :: Rhs NodeInfo -> Printer s () rhs (UnGuardedRhs _ (Do _ dos)) =@@ -93,25 +107,68 @@      swingBy indentation              (write "do")              (lined (map pretty dos))-rhs x = prettyNoExt x+rhs (UnGuardedRhs _ e) =+  do (fits,st) <-+       fitsOnOneLine+         (do write " "+             rhsSeparator+             write " "+             pretty e)+     if fits+        then put st+        else swing (write " " >> rhsSeparator >> write " ")+                   (pretty e)+rhs (GuardedRhss _ gas) =+  do newline+     indented 2+              (lined (map (\p ->+                             do write "|"+                                pretty p)+                          gas))  -- | Implement dangling right-hand-sides. guardedRhs :: GuardedRhs NodeInfo -> Printer s () -- | Handle do specially.+ guardedRhs (GuardedRhs _ stmts (Do _ dos)) =   do indented 1               (do prefixedLined                     ","                     (map (\p ->-                            do space +                            do space                                pretty p)                          stmts))      inCase <- gets psInsideCase      write (if inCase then " -> " else " = ")      swing (write "do")            (lined (map pretty dos))-guardedRhs e = prettyNoExt e+guardedRhs (GuardedRhs _ stmts e) =+  do (fits,st) <-+       fitsOnOneLine+         (indented 1+                   (do prefixedLined+                         ","+                         (map (\p ->+                                 do space+                                    pretty p)+                              stmts)))+     put st+     if fits+        then do (fits',st') <-+                  fitsOnOneLine+                    (do write " "+                        rhsSeparator+                        write " "+                        pretty e)+                if fits'+                   then put st'+                   else swingIt+        else swingIt+  where swingIt =+          swing (write " " >> rhsSeparator >> write " ")+                (pretty e) + -- | Expression customizations. exp :: Exp NodeInfo -> Printer s () -- | Space out tuples.@@ -166,31 +223,21 @@ -- | App algorithm similar to ChrisDone algorithm, but with no -- parent-child alignment. exp (App _ op a) =-  do orig <- gets psIndentLevel-     headIsShort <- isShort f-     depend (do pretty f-                space)-            (do flats <- mapM isFlat args-                flatish <- fmap ((< 2) . length . filter not)-                                (return flats)-                singleLiner <- isSingleLiner (spaced (map pretty args))-                overflow <- isOverflow (spaced (map pretty args))-                if singleLiner &&-                   ((headIsShort && flatish) ||-                    all id flats) &&-                   not overflow-                   then spaced (map pretty args)-                   else do newline-                           indentSpaces <- getIndentSpaces-                           column (orig + indentSpaces)-                                  (lined (map pretty args)))+  do (fits,st) <-+       fitsOnOneLine (spaced (map pretty (f : args)))+     if fits+        then put st+        else do pretty f+                newline+                spaces <- getIndentSpaces+                indented spaces (lined (map pretty args))   where (f,args) = flatten op [a]         flatten :: Exp NodeInfo                 -> [Exp NodeInfo]                 -> (Exp NodeInfo,[Exp NodeInfo])         flatten (App _ f' a') b =           flatten f' (a' : b)-        flatten f' as = (((f',as)))+        flatten f' as = (f',as) -- | Space out commas in list. exp (List _ es) =   do single <- isSingleLiner p@@ -202,7 +249,7 @@   where p =           brackets (inter (write ", ")                           (map pretty es))-exp (RecUpdate _ exp updates) = recUpdateExpr (pretty exp) updates+exp (RecUpdate _ exp' updates) = recUpdateExpr (pretty exp') updates exp (RecConstr _ qname updates) = recUpdateExpr (pretty qname) updates exp (Let _ binds e) =   depend (write "let ")@@ -213,13 +260,13 @@ exp e = prettyNoExt e  match :: Match NodeInfo -> Printer s ()-match (Match _ name pats rhs mbinds) =+match (Match _ name pats rhs' mbinds) =   do depend (do pretty name                 space)             (spaced (map pretty pats))-     withCaseContext False (pretty rhs)+     withCaseContext False (pretty rhs')      forM_ mbinds bindingGroup-match (InfixMatch _ pat1 name pats rhs mbinds) =+match (InfixMatch _ pat1 name pats rhs' mbinds) =   do depend (do pretty pat1                 space                 case name of@@ -228,7 +275,7 @@                   Symbol _ s -> string s)             (do space                 spaced (map pretty pats))-     withCaseContext False (pretty rhs)+     withCaseContext False (pretty rhs')      forM_ mbinds bindingGroup  -- | Format contexts with spaces and commas between class constraints.@@ -260,10 +307,19 @@ --     -> IO () -- decl (TypeSig _ names ty') =-  depend (do inter (write ", ")-                   (map pretty names)-             write " :: ")-         (declTy ty')+  do small <- isSmall (declTy ty')+     if small+        then depend (do inter (write ", ")+                              (map pretty names)+                        write " :: ")+                    (declTy ty')+        else do inter (write ", ")+                      (map pretty names)+                newline+                indentSpaces <- getIndentSpaces+                indented indentSpaces+                         (depend (write ":: ")+                                 (declTy ty'))   where declTy dty =           case dty of             TyForall _ mbinds mctx ty ->@@ -386,6 +442,14 @@      columnLimit <- getColumnLimit      return (psColumn st > columnLimit) +-- | Does printing the given thing overflow column limit? (e.g. 80)+fitsOnOneLine :: MonadState (PrintState s) m => m a -> m (Bool,PrintState s)+fitsOnOneLine p =+  do line <- gets psLine+     (_,st) <- sandbox p+     columnLimit <- getColumnLimit+     return (psLine st == line && psColumn st < columnLimit,st)+ -- | Is the given expression a single-liner when printed? isSingleLiner :: MonadState (PrintState s) m               => m a -> m Bool@@ -411,10 +475,6 @@   return (isName a && isName b)   where isName (Var{}) = True         isName _ = False-isFlat (InfixApp _ a _ b) =-  do a' <- isFlat a-     b' <- isFlat b-     return (a' && b') isFlat (NegApp _ a) = isFlat a isFlat VarQuote{} = return True isFlat TypQuote{} = return True

@@ -17,8 +17,7 @@ map (\x -> x)     [1,2,3] -forM_ lst $-\x -> do putStrLn x+forM_ lst $ \x -> do putStrLn x  forM_ lst $ \x -> putStrLn x 

@@ -0,0 +1,2 @@+a :: forall b. Typeable b => b+a = 3

@@ -0,0 +1,2 @@+a :: forall b. Typeable b => b+a = 3

@@ -1,9 +1,6 @@ strToMonth :: String -> Int strToMonth month =      case month of-        "Jan" -> -            1-        "Feb" -> -            2-        _ -> -            error $ "Unknown month " ++ month+        "Jan" -> 1+        "Feb" -> 2+        _ -> error $ "Unknown month " ++ month

@@ -3,5 +3,4 @@     name <- getLine     putStrLn $ greeting name   where-    greeting name = -        "Hello, " ++ name ++ "!"+    greeting name = "Hello, " ++ name ++ "!"

@@ -3,7 +3,5 @@     Event.Event     { pluginName = getModuleName getGitProvider     , eventIcon = "glyphicon-cog"-    , eventDate = localTimeToUTC -          timezone-          (commitDate commit)+    , eventDate = localTimeToUTC timezone (commitDate commit)     }

@@ -1,7 +1,9 @@-fun :: (Class a, Class b)+fun+    :: (Class a, Class b)     => a -> b -> c  fun :: (a, b, c) -> (a, b) -fun :: (Class a, Class b)+fun+    :: (Class a, Class b)     => a -> (# d, e #) -> c

@@ -3,23 +3,19 @@   | x <- Just x   , x <- Just x =        case x of-          Just x -> -              e+          Just x -> e   | otherwise = do       e   where-    x = -        y+    x = y  g x =      case x of-        a -> -            x+        a -> x   where     foo =          case x of             _ -> do                 launchMissiles       where-        y = -            2+        y = 2

@@ -1,11 +1,8 @@ g x = -    let x = -            1+    let x = 1     in x   where     foo = -        let y = -                2-            z = -                3+        let y = 2+            z = 3         in y