hindent 0.0 → 1.0

raw patch · 11 files changed

+1295/−1187 lines, 11 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• elisp/hindent.el +5/−3
• hindent.cabal +2/−3
• src/HIndent.hs +57/−12
• src/HIndent/Combinators.hs +0/−242
• src/HIndent/Instances.hs +0/−850
• src/HIndent/Pretty.hs +1147/−0
• src/HIndent/Styles/ChrisDone.hs +49/−34
• src/HIndent/Styles/Fundamental.hs +0/−1
• src/HIndent/Styles/JohanTibell.hs +0/−1
• src/HIndent/Styles/MichaelSnoyman.hs +0/−1
• src/HIndent/Types.hs +35/−40

@@ -25,8 +25,8 @@  (defun hindent/reformat-decl ()   "Re-format the current declaration by parsing and pretty-  printing it.-COMMENTS ARE CURRENTLY LOST."+  printing it. Comments are preserved, although placement may be+  funky."   (interactive)   (let ((start-end (hindent-decl-points)))     (when start-end@@ -61,8 +61,10 @@                                          (cdr start-end))                           (insert new-str)                           (goto-char (point-min))-                          (forward-line line)+                          (forward-line (1- line))                           (goto-char (+ (line-beginning-position) col))+                          (when (looking-back "^[ ]+")+                            (back-to-indentation))                           (message "Formatted."))                       (message "Already formatted."))))))))))))) 

@@ -1,5 +1,5 @@ name:                hindent-version:             0.0+version:             1.0 synopsis:            Extensible Haskell pretty printer description:         Extensible Haskell pretty printer. Both a library and an executable.                      .@@ -19,13 +19,12 @@   hs-source-dirs:    src/   ghc-options:       -Wall -O2   exposed-modules:   HIndent-                     HIndent.Combinators                      HIndent.Types+                     HIndent.Pretty                      HIndent.Styles.Fundamental                      HIndent.Styles.ChrisDone                      HIndent.Styles.MichaelSnoyman                      HIndent.Styles.JohanTibell-  other-modules:     HIndent.Instances   build-depends:     base >= 4 && <5                    , data-default                    , haskell-src-exts

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} -- | Haskell indenter.  module HIndent@@ -15,39 +16,44 @@   ,test)   where +import           Data.Function+import           HIndent.Pretty import           HIndent.Styles.ChrisDone-import           HIndent.Styles.MichaelSnoyman-import           HIndent.Styles.JohanTibell import           HIndent.Styles.Fundamental-import           HIndent.Instances ()+import           HIndent.Styles.JohanTibell+import           HIndent.Styles.MichaelSnoyman import           HIndent.Types  import           Control.Monad.State+import           Data.Data import           Data.Monoid import           Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.IO as T import           Data.Text.Lazy.Builder (Builder) import qualified Data.Text.Lazy.Builder as T-import           Language.Haskell.Exts.Extension-import           Language.Haskell.Exts.Parser+import qualified Data.Text.Lazy.IO as T+import           Data.Traversable+import           Language.Haskell.Exts.Annotated hiding (Style,prettyPrint,Pretty,style,parse)  -- | Format the given source. reformat :: Config -> Style -> Text -> Either String Builder reformat config style x =   case parseDeclWithComments parseMode                              (T.unpack x) of-    ParseOk (v,_comments) ->-      Right (prettyPrint config style v)+    ParseOk (v,comments) ->+      case annotateComments v comments of+        (cs,ast) ->+          Right (prettyPrint config style (do mapM_ printComment cs+                                              pretty ast))     ParseFailed _ e -> Left e  -- | Pretty print the given printable thing.-prettyPrint :: Pretty a => Config -> Style -> a -> Builder-prettyPrint config style a =-  psOutput (execState (runPrinter (pretty a))+prettyPrint :: Config -> Style -> Printer () -> Builder+prettyPrint config style m =+  psOutput (execState (runPrinter m)                       (case style of                          Style _name _author _desc st extenders _defconfig ->-                           PrintState 0 mempty False 0 1 st extenders config))+                           PrintState 0 mempty False 0 1 st extenders config False))  -- | Parse mode, includes all extensions, doesn't assume any fixities. parseMode :: ParseMode@@ -69,3 +75,42 @@ styles :: [Style] styles =   [fundamental,chrisDone,michaelSnoyman,johanTibell]++-- | Annotate the AST with comments.+annotateComments :: (Data (ast NodeInfo),Traversable ast,Annotated ast) => ast SrcSpanInfo -> [Comment] -> ([Comment],ast NodeInfo)+annotateComments =+  foldr (\c (cs,ast) ->+           case execState (traverse (collect c) ast) Nothing of+             Nothing -> (c : cs,ast)+             Just l ->+               (cs,evalState (traverse (insert l c) ast) False)) .+  ([],) .+  fmap (\n -> NodeInfo n [])+  where collect c ni@(NodeInfo l _) =+          do when (commentAfter c ni)+                  (modify (\ml ->+                             maybe (Just l)+                                   (\l' ->+                                      Just (if on spanBefore srcInfoSpan l l'+                                               then l'+                                               else l))+                                   ml))+             return ni+        insert al c ni@(NodeInfo bl cs) =+          do done <- get+             if not done && al == bl+                then do put True+                        return (ni {nodeInfoComments = c : cs})+                else return ni++-- | Is the comment after the node?+commentAfter :: Comment -> NodeInfo -> Bool+commentAfter (Comment _ cspan _) (NodeInfo (SrcSpanInfo nspan _) _) =+  spanBefore nspan cspan++-- | Span: a < b+spanBefore :: SrcSpan -> SrcSpan -> Bool+spanBefore a b =+  (srcSpanEndLine a < srcSpanEndLine b) ||+  ((srcSpanEndLine a == srcSpanEndLine b) &&+   (srcSpanEndColumn a < srcSpanEndColumn b))

@@ -1,242 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}---- | Combinators used for printing.--module HIndent.Combinators-  (-  -- * Insertion-    write-  , newline-  , space-  , comma-  , int-  , string-  -- * Common node types-  , maybeCtx-  -- * Interspersing-  , inter-  , spaced-  , lined-  , prefixedLined-  , commas-  -- * Wrapping-  , parens-  , brackets-  , braces-  -- * Indentation-  , indented-  , column-  , depend-  , swing-  , getIndentSpaces-  , getColumnLimit-  -- * Predicates-  , nullBinds-  -- * Sandboxing-  , sandbox-  -- * Fallback-  , pretty'-  )-  where--import           HIndent.Types--import           Control.Monad.State hiding (state)-import           Data.Int-import           Data.List-import           Data.Monoid-import qualified Data.Text as T-import qualified Data.Text.Lazy as LT-import           Data.Text.Lazy.Builder (Builder)-import qualified Data.Text.Lazy.Builder as T-import           Data.Text.Lazy.Builder.Int-import qualified Language.Haskell.Exts.Pretty as P-import           Language.Haskell.Exts.Syntax-import           Prelude hiding (exp)---- | Increase indentation level by n spaces for the given printer.-indented :: Int64 -> Printer a -> Printer a-indented i p =-  do level <- gets psIndentLevel-     modify (\s -> s {psIndentLevel = level + i})-     m <- p-     modify (\s -> s {psIndentLevel = level})-     return m---- | Print all the printers separated by spaces.-spaced :: [Printer ()] -> Printer ()-spaced = inter space---- | Print all the printers separated by commas.-commas :: [Printer ()] -> Printer ()-commas = inter comma---- | Print all the printers separated by sep.-inter :: Printer () -> [Printer ()] -> Printer ()-inter sep ps =-  foldr (\(i,p) next ->-           depend (do p-                      if i <-                         length ps-                         then sep-                         else return ())-                  next)-        (return ())-        (zip [1 ..] ps)---- | Print all the printers separated by spaces.-lined :: [Printer ()] -> Printer ()-lined ps = sequence_ (intersperse newline ps)---- | Print all the printers separated newlines and optionally a line--- prefix.-prefixedLined :: Char -> [Printer ()] -> Printer ()-prefixedLined pref ps' =-  case ps' of-    [] -> return ()-    (p:ps) ->-      do p-         indented (-1)-                  (mapM_ (\p' ->-                            do newline-                               depend (string [pref]) p')-                         ps)---- | Set the (newline-) indent level to the given column for the given--- printer.-column :: Int64 -> Printer a -> Printer a-column i p =-  do level <- gets psIndentLevel-     modify (\s -> s {psIndentLevel = i})-     m <- p-     modify (\s -> s {psIndentLevel = level})-     return m---- | Output a newline.-newline :: Printer ()-newline =-  do write "\n"-     modify (\s -> s {psNewline = True})---- | Make the latter's indentation depend upon the end column of the--- former.-depend :: Printer () -> Printer b -> Printer b-depend maker dependent =-  do state <- get-     maker-     st <- get-     col <- gets psColumn-     if state /= st-        then column col dependent-        else dependent---- | Wrap in parens.-parens :: Printer a -> Printer a-parens p =-  depend (write "(")-         (do v <- p-             write ")"-             return v)---- | Wrap in braces.-braces :: Printer a -> Printer a-braces p =-  depend (write "{")-         (do v <- p-             write "}"-             return v)---- | Wrap in brackets.-brackets :: Printer a -> Printer a-brackets p =-  depend (write "[")-         (do v <- p-             write "]"-             return v)---- | Write a space.-space :: Printer ()-space = write " "---- | Write a comma.-comma :: Printer ()-comma = write ","---- | Write an integral.-int :: Integral n => n -> Printer ()-int = write . decimal---- | Write out a string, updating the current position information.-write :: Builder -> Printer ()-write x =-  do state <- get-     let out =-           if psNewline state-              then T.fromText (T.replicate (fromIntegral (psIndentLevel state)) " ") <>-                   x-              else x-         out' = T.toLazyText out-     modify (\s ->-               s {psOutput = psOutput state <> out-                 ,psNewline = False-                 ,psLine = psLine state + additionalLines-                 ,psColumn =-                    if additionalLines > 0-                       then LT.length (LT.concat (take 1 (reverse srclines)))-                       else psColumn state + LT.length out'})-  where x' = T.toLazyText x-        srclines = LT.lines x'-        additionalLines =-          LT.length (LT.filter (== '\n') x')---- | Pretty print using HSE's own printer. The 'P.Pretty' class here is--- HSE's.-pretty' :: P.Pretty a => a -> Printer ()-pretty' = write . T.fromText . T.pack . P.prettyPrint---- | Write a string.-string :: String -> Printer ()-string = write . T.fromText . T.pack---- | Indent spaces, e.g. 2.-getIndentSpaces :: Printer Int64-getIndentSpaces = gets (configIndentSpaces . psConfig)---- | Column limit, e.g. 80-getColumnLimit :: Printer Int64-getColumnLimit = gets (configMaxColumns . psConfig)---- | Play with a printer and then restore the state to what it was--- before.-sandbox :: MonadState s m => m a -> m s-sandbox p =-  do orig <- get-     _ <- p-     new <- get-     put orig-     return new---- | No binds?-nullBinds :: Binds -> Bool-nullBinds (BDecls x) = null x-nullBinds (IPBinds x) = null x---- | Maybe render a class context.-maybeCtx :: Pretty a => [a] -> Printer ()-maybeCtx ctx =-  unless (null ctx)-         (do write "("-             commas (map pretty ctx)-             write ") => ")---- | Swing the second printer below and indented with respect to the first.-swing :: Printer () -> Printer b -> Printer b-swing a b =-  do orig <- gets psIndentLevel-     a-     newline-     indentSpaces <- getIndentSpaces-     column (orig + indentSpaces) b

@@ -1,850 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-}---- | Instances for pretty printing.--module HIndent.Instances () where--import           HIndent.Combinators-import           HIndent.Types--import           Control.Monad.State-import qualified Data.Text as T-import qualified Data.Text.Lazy.Builder as T-import           Language.Haskell.Exts.Syntax-import           Prelude hiding (exp)--instance Pretty Pat where-  prettyInternal x =-    case x of-      PLit l -> pretty l-      PNeg l ->-        depend (write "-")-               (pretty l)-      PNPlusK n k ->-        depend (do pretty n-                   write "+")-               (int k)-      PInfixApp a op b ->-        case op of-          Special{} ->-            depend (pretty a)-                   (depend (prettyInfixOp op)-                           (pretty b))-          _ ->-            depend (do pretty a-                       space)-                   (depend (do prettyInfixOp op-                               space)-                           (pretty b))-      PApp f args ->-        depend (do pretty f-                   unless (null args) space)-               (spaced (map pretty args))-      PTuple boxed pats ->-        depend (write (case boxed of-                         Unboxed -> "(#"-                         Boxed -> "("))-               (do commas (map pretty pats)-                   write (case boxed of-                            Unboxed -> "#)"-                            Boxed -> ")"))-      PList ps ->-        brackets (commas (map pretty ps))-      PParen e -> parens (pretty e)-      PRec qname fields ->-        depend (pretty qname)-               (braces (commas (map pretty fields)))-      PAsPat n p ->-        depend (do pretty n-                   write "@")-               (pretty p)-      PWildCard -> write "_"-      PIrrPat p ->-        depend (write "~")-               (pretty p)-      PatTypeSig _ p ty ->-        depend (do pretty p-                   write " :: ")-               (pretty ty)-      PViewPat e p ->-        depend (do pretty e-                   write " -> ")-               (pretty p)-      PQuasiQuote name str ->-        brackets (depend (do write "$"-                             string name-                             write "|")-                         (string str))-      PBangPat p ->-        depend (write "!")-               (pretty p)-      PRPat{} -> pretty' x-      PXTag{} -> pretty' x-      PXETag{} -> pretty' x-      PXPcdata{} -> pretty' x-      PXPatTag{} -> pretty' x-      PXRPats{} -> pretty' x-      PVar{} -> pretty' x---- | Pretty print a name for being an infix operator.-prettyInfixOp :: QName -> Printer ()-prettyInfixOp x =-  case x of-    Qual{} -> pretty' x-    UnQual n ->-      case n of-        Ident i -> string ("`" ++ i ++ "`")-        Symbol s -> string s-    Special s ->-      case s of-        UnitCon -> write "()"-        ListCon -> write "[]"-        FunCon -> write "->"-        TupleCon Boxed i ->-          string ("(" ++-                  replicate (i - 1) ',' ++-                  ")")-        TupleCon Unboxed i ->-          string ("(#" ++-                  replicate (i - 1) ',' ++-                  "#)")-        Cons -> write ":"-        UnboxedSingleCon -> write "(##)"--instance Pretty Type where-  prettyInternal x =-    case x of-      TyForall mbinds ctx ty ->-        depend (case mbinds of-                  Nothing -> return ()-                  Just ts ->-                    do write "forall "-                       spaced (map pretty ts)-                       write ". ")-               (depend (maybeCtx ctx)-                       (pretty ty))-      TyFun a b ->-        depend (do pretty a-                   write " -> ")-               (pretty b)-      TyTuple boxed tys ->-        depend (write (case boxed of-                         Unboxed -> "(#"-                         Boxed -> "("))-               (do commas (map pretty tys)-                   write (case boxed of-                            Unboxed -> "#)"-                            Boxed -> ")"))-      TyList t -> brackets (pretty t)-      TyApp f a -> spaced [pretty f,pretty a]-      TyVar n -> pretty n-      TyCon p -> pretty p-      TyParen e -> parens (pretty e)-      TyInfix a op b ->-        depend (do pretty a-                   space)-               (depend (do pretty op-                           space)-                       (pretty b))-      TyKind ty k ->-        parens (do pretty ty-                   write " :: "-                   pretty k)-      TyPromoted{} ->-        error "FIXME: No implementation for TyPromoted."--instance Pretty Exp where-  prettyInternal = exp---- | Render an expression.-exp :: Exp -> Printer ()-exp (InfixApp a op b) =-  depend (do pretty a-             space-             pretty op-             space)-         (do pretty b)-exp (App op a) =-  swing (do pretty f)-        (lined (map pretty args))-  where (f,args) = flatten op [a]-        flatten :: Exp -> [Exp] -> (Exp,[Exp])-        flatten (App f' a') b =-          flatten f' (a' : b)-        flatten f' as = (f',as)-exp (NegApp e) =-  depend (write "-")-         (pretty e)-exp (Lambda _ ps e) =-  depend (write "\\")-         (do spaced (map pretty ps)-             swing (write " -> ")-                   (pretty e))-exp (Let binds e) =-  do depend (write "let ")-            (pretty binds)-     newline-     depend (write "in ")-            (pretty e)-exp (If p t e) =-  do depend (write "if ")-            (do pretty p-                newline-                depend (write "then ")-                       (pretty t)-                newline-                depend (write "else ")-                       (pretty e))-exp (Paren e) = parens (pretty e)-exp (Case e alts) =-  do depend (write "case ")-            (do pretty e-                write " of ")-     newline-     indentSpaces <- getIndentSpaces-     indented indentSpaces (lined (map pretty alts))-exp (Do stmts) =-  depend (write "do ")-         (lined (map pretty stmts))-exp (MDo stmts) =-  depend (write "mdo ")-         (lined (map pretty stmts))-exp (Tuple boxed exps) =-  depend (write (case boxed of-                   Unboxed -> "(#"-                   Boxed -> "("))-         (do parens (prefixedLined ','-                                   (map pretty exps))-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))-exp (TupleSection boxed mexps) =-  depend (write (case boxed of-                   Unboxed -> "(#"-                   Boxed -> "("))-         (do commas (map (maybe (return ()) pretty) mexps)-             write (case boxed of-                      Unboxed -> "#)"-                      Boxed -> ")"))-exp (List es) =-  brackets (prefixedLined ',' (map pretty es))-exp (LeftSection e op) =-  parens (depend (do pretty e-                     space)-                 (pretty op))-exp (RightSection e op) =-  parens (depend (do pretty e-                     space)-                 (pretty op))-exp (RecConstr n fs) =-  do indentSpaces <- getIndentSpaces-     depend (do pretty n-                space)-            (braces (prefixedLined-                       ','-                       (map (indented indentSpaces .-                             pretty)-                            fs)))-exp (RecUpdate n fs) =-  do indentSpaces <- getIndentSpaces-     depend (do pretty n-                space)-            (braces (prefixedLined-                       ','-                       (map (indented indentSpaces .-                             pretty)-                            fs)))-exp (EnumFrom e) =-  brackets (do pretty e-               write " ..")-exp (EnumFromTo e f) =-  brackets (depend (do pretty e-                       write " .. ")-                   (pretty f))-exp (EnumFromThen e t) =-  brackets (depend (do pretty e-                       write ",")-                   (do pretty t-                       write " .."))-exp (EnumFromThenTo e t f) =-  brackets (depend (do pretty e-                       write ",")-                   (depend (do pretty t-                               write " .. ")-                           (pretty f)))-exp (ListComp e qstmt) =-  brackets (depend (do pretty e-                       unless (null qstmt)-                              (write " |"))-                   (do space-                       prefixedLined-                         ','-                         (map (\(i,x) ->-                                 depend (if i == 0-                                            then return ()-                                            else space)-                                        (pretty x))-                              (zip [0 :: Integer ..] qstmt))))-exp (ExpTypeSig _ e t) =-  depend (do pretty e-             write " :: ")-         (pretty t)-exp (VarQuote x) =-  depend (write "'")-         (pretty x)-exp (TypQuote x) =-  depend (write "''")-         (pretty x)-exp (BracketExp b) = pretty b-exp (SpliceExp s) = pretty s-exp (QuasiQuote n s) =-  brackets (depend (do string n-                       write "|")-                   (do string s-                       write "|"))-exp x@XTag{} = pretty' x-exp x@XETag{} = pretty' x-exp x@XPcdata{} = pretty' x-exp x@XExpTag{} = pretty' x-exp x@XChildTag{} = pretty' x-exp x@Var{} = pretty' x-exp x@IPVar{} = pretty' x-exp x@Con{} = pretty' x-exp x@Lit{} = pretty' x-exp x@CorePragma{} = pretty' x-exp x@SCCPragma{} = pretty' x-exp x@GenPragma{} = pretty' x-exp x@Proc{} = pretty' x-exp x@LeftArrApp{} = pretty' x-exp x@RightArrApp{} = pretty' x-exp x@LeftArrHighApp{} = pretty' x-exp x@RightArrHighApp{} = pretty' x-exp (LCase _) =-  error "FIXME: No implementation for LCase."-exp (MultiIf _) =-  error "FIXME: No implementation for MultiIf."-exp ParComp{} =-  error "FIXME: No implementation for ParComp."--instance Pretty Stmt where-  prettyInternal x =-    case x of-      Generator _ p e ->-        depend (do pretty p-                   write " <- ")-               (pretty e)-      Qualifier e -> pretty e-      LetStmt binds ->-        depend (write "let ")-               (pretty binds)-      RecStmt{} ->-        error "FIXME: No implementation for RecStmt."--instance Pretty QualStmt where-  prettyInternal x =-    case x of-      QualStmt s -> pretty s-      ThenTrans{} ->-        error "FIXME: No implementation for ThenTrans."-      ThenBy{} ->-        error "FIXME: No implementation for ThenBy."-      GroupBy{} ->-        error "FIXME: No implementation for GroupBy."-      GroupUsing{} ->-        error "FIXME: No implementation for GroupUsing."-      GroupByUsing{} ->-        error "FIXME: No implementation for GroupByUsing."--instance Pretty Decl where-  prettyInternal = decl---- | Render a declaration.-decl :: Decl -> Printer ()-decl (PatBind _ pat mty rhs binds) =-  case mty of-    Just{} ->-      error "Unimlpemented (Maybe Type) in PatBind."-    Nothing ->-      do pretty pat-         pretty rhs-         indentSpaces <- getIndentSpaces-         unless (nullBinds binds)-                (do newline-                    indented indentSpaces-                             (depend (write "where ")-                                     (pretty binds)))-decl (InstDecl _ ctx name tys decls) =-  do indentSpaces <- getIndentSpaces-     depend (write "instance ")-            (depend (maybeCtx ctx)-                    (depend (do pretty name-                                space)-                            (do spaced (map pretty tys)-                                unless (null decls)-                                       (write " where"))))-     unless (null decls)-            (do newline-                indented indentSpaces (lined (map pretty decls)))-decl (SpliceDecl _ e) = pretty e-decl (TypeSig _ names ty) =-  depend (do inter (write ", ")-                   (map pretty names)-             write " :: ")-         (pretty ty)-decl (FunBind matches) =-  lined (map pretty matches)-decl (ClassDecl _ ctx name tys fundeps decls) =-  do depend (write "class ")-            (depend (maybeCtx ctx)-                    (depend (do pretty name-                                space)-                            (depend (depend (spaced (map pretty tys))-                                            (unless (null fundeps)-                                                    (do write " | "-                                                        commas (map pretty fundeps))))-                                    (unless (null decls)-                                            (write " where")))))-     unless (null decls)-            (do newline-                indentSpaces <- getIndentSpaces-                indented indentSpaces (lined (map pretty decls)))-decl (TypeDecl _ _ _ _) =-  error "FIXME: No implementation for TypeDecl."-decl (TypeFamDecl _ _ _ _) =-  error "FIXME: No implementation for TypeFamDecl."-decl (DataDecl _ dataornew ctx name tyvars condecls _derivs) =-  depend (do pretty dataornew-             space)-         (depend (maybeCtx ctx)-                 (do spaced (pretty name :-                             map pretty tyvars)-                     case condecls of-                       [] -> return ()-                       [x] -> singleCons x-                       xs -> multiCons xs))-  where singleCons x =-          do write " ="-             indentSpaces <- getIndentSpaces-             column indentSpaces-                    (do newline-                        pretty x)-        multiCons xs =-          do newline-             indentSpaces <- getIndentSpaces-             column indentSpaces-                    (depend (write "=")-                            (prefixedLined '|'-                                           (map (depend space . pretty) xs)))-decl (GDataDecl _ _ _ _ _ _ _ _) =-  error "FIXME: No implementation for GDataDecl."-decl (DataFamDecl _ _ _ _ _) =-  error "FIXME: No implementation for DataFamDecl."-decl (TypeInsDecl _ _ _) =-  error "FIXME: No implementation for TypeInsDecl."-decl (DataInsDecl _ _ _ _ _) =-  error "FIXME: No implementation for DataInsDecl."-decl (GDataInsDecl _ _ _ _ _ _) =-  error "FIXME: No implementation for GDataInsDecl."-decl (DerivDecl _ _ _ _) =-  error "FIXME: No implementation for DerivDecl."-decl (ForImp _ _ _ _ _ _) =-  error "FIXME: No implementation for ForImp."-decl (ForExp _ _ _ _ _) =-  error "FIXME: No implementation for ForExp."-decl (RulePragmaDecl _ _) =-  error "FIXME: No implementation for RulePragmaDecl."-decl (DeprPragmaDecl _ _) =-  error "FIXME: No implementation for DeprPragmaDecl."-decl (InlineSig _ _ _ _) =-  error "FIXME: No implementation for InlineSig."-decl (InlineConlikeSig _ _ _) =-  error "FIXME: No implementation for InlineConlikeSig."-decl (SpecSig _ _ _ _) =-  error "FIXME: No implementation for SpecSig."-decl (SpecInlineSig _ _ _ _ _) =-  error "FIXME: No implementation for SpecInlineSig."-decl (InstSig _ _ _ _) =-  error "FIXME: No implementation for InstSig."-decl x@WarnPragmaDecl{} = pretty' x-decl x@AnnPragma{} = pretty' x-decl x@InfixDecl{} = pretty' x-decl x@DefaultDecl{} = pretty' x--instance Pretty Alt where-  prettyInternal x =-    case x of-      Alt _ p galts binds ->-        do pretty p-           pretty galts-           unless (nullBinds binds)-                  (do newline-                      indentSpaces <- getIndentSpaces-                      indented indentSpaces-                               (depend (write "where ")-                                       (pretty binds)))--instance Pretty Asst where-  prettyInternal x =-    case x of-      ClassA name types ->-        spaced (pretty name : map pretty types)-      InfixA _ _ _ ->-        error "FIXME: No implementation for InfixA."-      IParam _ _ ->-        error "FIXME: No implementation for IParam."-      EqualP _ _ ->-        error "FIXME: No implementation for EqualP."--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)--instance Pretty Binds where-  prettyInternal x =-    case x of-      BDecls ds -> lined (map pretty ds)-      IPBinds i -> lined (map pretty i)--instance Pretty Bracket where-  prettyInternal x =-    case x of-      ExpBracket _ ->-        error "FIXME: No implementation for ExpBracket."-      PatBracket _ ->-        error "FIXME: No implementation for PatBracket."-      TypeBracket _ ->-        error "FIXME: No implementation for TypeBracket."-      DeclBracket _ ->-        error "FIXME: No implementation for DeclBracket."--instance Pretty ClassDecl where-  prettyInternal x =-    case x of-      ClsDecl d -> pretty d-      ClsDataFam _ ctx n tyvars mkind ->-        depend (write "data ")-               (depend (maybeCtx ctx)-                       (do spaced (pretty n :-                                   map pretty tyvars)-                           case mkind of-                             Nothing -> return ()-                             Just kind ->-                               do write " :: "-                                  pretty kind))-      ClsTyFam _ n tyvars mkind ->-        depend (write "type ")-               (do spaced (pretty n :-                           map pretty tyvars)-                   case mkind of-                     Nothing -> return ()-                     Just kind ->-                       do write " :: "-                          pretty kind)-      ClsTyDef _ this that ->-        do write "type "-           pretty this-           write " = "-           pretty that--instance Pretty ConDecl where-  prettyInternal x =-    case x of-      ConDecl name bangty ->-        depend (do pretty name-                   space)-               (lined (map pretty bangty))-      InfixConDecl a f b ->-        pretty (ConDecl f [a,b])-      RecDecl name fields ->-        depend (pretty name)-               (do space-                   indentSpaces <- getIndentSpaces-                   braces (prefixedLined-                             ','-                             (map (indented indentSpaces . pretty)-                                  (concatMap (\(names,ty) ->-                                                map (,ty) names)-                                             fields))))--instance Pretty (Name,BangType) where-  prettyInternal (name,ty) =-    depend (do pretty name-               write " :: ")-           (pretty ty)--instance Pretty FieldUpdate where-  prettyInternal x =-    case x of-      FieldUpdate n e ->-        swing (do pretty n-                  write " = ")-              (pretty e)-      FieldPun n -> pretty n-      FieldWildcard -> write ".."--instance Pretty GadtDecl where-  prettyInternal x =-    case x of-      GadtDecl _ _ _ ->-        error "FIXME: No implementation for GadtDecl."--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-      GuardedRhs _ stmts e ->-        do indented 1-                    (do prefixedLined-                          ','-                          (map (\p ->-                                  do space-                                     pretty p)-                               stmts))-           swing (write " = ")-                 (pretty e)--instance Pretty IPBind where-  prettyInternal x =-    case x of-      IPBind _ _ _ ->-        error "FIXME: No implementation for IPBind."--instance Pretty IfAlt where-  prettyInternal x =-    case x of-      IfAlt _ _ ->-        error "FIXME: No implementation for IfAlt."--instance Pretty InstDecl where-  prettyInternal i =-    case i of-      InsDecl d -> pretty d-      InsType _ name ty ->-        depend (do write "type "-                   pretty name-                   write " = ")-               (pretty ty)-      _ -> pretty' i--instance Pretty Match where-  prettyInternal x =-    case x of-      Match _ name pats mty rhs binds ->-        case mty of-          Just{} ->-            error "Unimlpemented (Maybe Type) in Match."-          Nothing ->-            do depend (do pretty name-                          space)-                      (spaced (map pretty pats))-               pretty rhs-               unless (nullBinds binds)-                      (do newline-                          indentSpaces <- getIndentSpaces-                          indented indentSpaces-                                   (depend (write "where ")-                                           (pretty binds)))--instance Pretty Module where-  prettyInternal x =-    case x of-      Module _ _ _ _ _ _ _ ->-        error "FIXME: No implementation for Module."--instance Pretty PatField where-  prettyInternal x =-    case x of-      PFieldPat n p ->-        depend (do pretty n-                   write " = ")-               (pretty p)-      PFieldPun n -> pretty n-      PFieldWildcard -> write ".."--instance Pretty QualConDecl where-  prettyInternal x =-    case x of-      QualConDecl _ tyvars ctx d ->-        depend (unless (null tyvars)-                       (do write "forall "-                           spaced (map pretty tyvars)-                           write ". "))-               (depend (maybeCtx ctx)-                       (pretty d))--instance Pretty Rhs where-  prettyInternal x =-    case x of-      UnGuardedRhs e ->-        (swing (write " = ")-               (pretty e))-      GuardedRhss gas ->-        do newline-           indented 2-                    (lined (map (\p ->-                                   do write "|"-                                      pretty p)-                                gas))--instance Pretty Rule where-  prettyInternal x =-    case x of-      Rule _ _ _ _ _ ->-        error "FIXME: No implementation for Rule."--instance Pretty RuleVar where-  prettyInternal x =-    case x of-      RuleVar _ ->-        error "FIXME: No implementation for RuleVar."-      TypedRuleVar _ _ ->-        error "FIXME: No implementation for TypedRuleVar."--instance Pretty Splice where-  prettyInternal x =-    case x of-      IdSplice _ ->-        error "FIXME: No implementation for IdSplice."-      ParenSplice e ->-        depend (write "$")-               (parens (pretty e))--instance Pretty WarningText where-  prettyInternal x =-    case x of-      DeprText _ ->-        error "FIXME: No implementation for DeprText."-      WarnText _ ->-        error "FIXME: No implementation for WarnText."--instance Pretty Tool where-  prettyInternal x =-    case x of-      GHC -> write "GHC"-      HUGS -> write "HUGS"-      NHC98 -> write "NHC98"-      YHC -> write "YHC"-      HADDOCK -> write "HADDOCK"-      UnknownTool t ->-        write (T.fromText (T.pack t))--instance Pretty Activation where-  prettyInternal = pretty'--instance Pretty Annotation where-  prettyInternal = pretty'--instance Pretty Assoc where-  prettyInternal = pretty'--instance Pretty CName where-  prettyInternal = pretty'--instance Pretty CallConv where-  prettyInternal = pretty'--instance Pretty DataOrNew where-  prettyInternal = pretty'--instance Pretty ExportSpec where-  prettyInternal = pretty'--instance Pretty FunDep where-  prettyInternal = pretty'--instance Pretty IPName where-  prettyInternal = pretty'--instance Pretty ImportSpec where-  prettyInternal = pretty'--instance Pretty ImportDecl where-  prettyInternal = pretty'--instance Pretty Kind where-  prettyInternal = pretty'--instance Pretty Literal where-  prettyInternal = pretty'--instance Pretty ModulePragma where-  prettyInternal = pretty'--instance Pretty Name where-  prettyInternal = pretty'--instance Pretty Op where-  prettyInternal = pretty'--instance Pretty PXAttr where-  prettyInternal = pretty'--instance Pretty Promoted where-  prettyInternal = pretty'--instance Pretty QName where-  prettyInternal = pretty'--instance Pretty QOp where-  prettyInternal = pretty'--instance Pretty RPat where-  prettyInternal = pretty'--instance Pretty RPatOp where-  prettyInternal = pretty'--instance Pretty Safety where-  prettyInternal = pretty'--instance Pretty SpecialCon where-  prettyInternal = pretty'--instance Pretty TyVarBind where-  prettyInternal = pretty'--instance Pretty XAttr where-  prettyInternal = pretty'--instance Pretty XName where-  prettyInternal = pretty'

@@ -0,0 +1,1147 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Pretty printing.++module HIndent.Pretty+  (+  -- * Printing+    Pretty+  , pretty+  , prettyNoExt+  -- * Insertion+  , write+  , newline+  , space+  , comma+  , int+  , string+  -- * Common node types+  , maybeCtx+  , printComment+  -- * Interspersing+  , inter+  , spaced+  , lined+  , prefixedLined+  , commas+  -- * Wrapping+  , parens+  , brackets+  , braces+  -- * Indentation+  , indented+  , column+  , depend+  , swing+  , getIndentSpaces+  , getColumnLimit+  -- * Predicates+  , nullBinds+  -- * Sandboxing+  , sandbox+  -- * Fallback+  , pretty'+  )+  where++import           Data.Char++import           HIndent.Types+import           Language.Haskell.Exts.Comments++import           Control.Monad.State hiding (state)+import           Data.Int+import           Data.List+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import           Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as T+import           Data.Text.Lazy.Builder.Int+import           Data.Typeable+import qualified Language.Haskell.Exts.Annotated as P+import           Language.Haskell.Exts.Annotated.Syntax+import           Language.Haskell.Exts.SrcLoc+import           Prelude hiding (exp)++--------------------------------------------------------------------------------+-- * Pretty printing class++-- | Pretty printing class.+class (Annotated ast,Typeable1 ast) => Pretty ast where+  prettyInternal :: ast NodeInfo -> Printer ()++-- | Pretty print using extenders.+pretty :: (Pretty ast) => ast NodeInfo -> Printer ()+pretty a =+  do st <- get+     case st of+       PrintState{psExtenders = es,psUserState = s} ->+         case listToMaybe (mapMaybe (makePrinter s) es) of+           Just m -> m+           Nothing -> prettyNoExt a+  where makePrinter s (Extender f) =+          case cast a of+            Just v -> Just (f s v)+            Nothing -> Nothing++-- | 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 =+  do prettyInternal a+     mapM_ printComment (nodeInfoComments (ann a))++-- | Pretty print a comment.+printComment :: Comment -> Printer ()+printComment (Comment inline _ str) =+  do st <- sandbox (write "")+     unless (psColumn st == 0) space+     if inline+        then do write "{-"+                string str+                write "-}"+        else do write "--"+                string str+                modify (\s ->+                          s {psEolComment = True})++-- | Pretty print using HSE's own printer. The 'P.Pretty' class here+-- is HSE's.+pretty' :: (P.Pretty (ast SrcSpanInfo),Functor ast) => ast NodeInfo -> Printer ()+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 i p =+  do level <- gets psIndentLevel+     modify (\s -> s {psIndentLevel = level + i})+     m <- p+     modify (\s -> s {psIndentLevel = level})+     return m++-- | Print all the printers separated by spaces.+spaced :: [Printer ()] -> Printer ()+spaced = inter space++-- | Print all the printers separated by commas.+commas :: [Printer ()] -> Printer ()+commas = inter comma++-- | Print all the printers separated by sep.+inter :: Printer () -> [Printer ()] -> Printer ()+inter sep ps =+  foldr (\(i,p) next ->+           depend (do p+                      if i <+                         length ps+                         then sep+                         else return ())+                  next)+        (return ())+        (zip [1 ..] ps)++-- | Print all the printers separated by spaces.+lined :: [Printer ()] -> Printer ()+lined ps = sequence_ (intersperse newline ps)++-- | Print all the printers separated newlines and optionally a line+-- prefix.+prefixedLined :: Char -> [Printer ()] -> Printer ()+prefixedLined pref ps' =+  case ps' of+    [] -> return ()+    (p:ps) ->+      do p+         indented (-1)+                  (mapM_ (\p' ->+                            do newline+                               depend (string [pref]) p')+                         ps)++-- | Set the (newline-) indent level to the given column for the given+-- printer.+column :: Int64 -> Printer a -> Printer a+column i p =+  do level <- gets psIndentLevel+     modify (\s -> s {psIndentLevel = i})+     m <- p+     modify (\s -> s {psIndentLevel = level})+     return m++-- | Output a newline.+newline :: Printer ()+newline =+  do write "\n"+     modify (\s -> s {psNewline = True})++-- | Make the latter's indentation depend upon the end column of the+-- former.+depend :: Printer () -> Printer b -> Printer b+depend maker dependent =+  do state' <- get+     maker+     st <- get+     col <- gets psColumn+     if state' /= st+        then column col dependent+        else dependent++-- | Wrap in parens.+parens :: Printer a -> Printer a+parens p =+  depend (write "(")+         (do v <- p+             write ")"+             return v)++-- | Wrap in braces.+braces :: Printer a -> Printer a+braces p =+  depend (write "{")+         (do v <- p+             write "}"+             return v)++-- | Wrap in brackets.+brackets :: Printer a -> Printer a+brackets p =+  depend (write "[")+         (do v <- p+             write "]"+             return v)++-- | Write a space.+space :: Printer ()+space = write " "++-- | Write a comma.+comma :: Printer ()+comma = write ","++-- | Write an integral.+int :: Integral n => n -> Printer ()+int = write . decimal++-- | Write out a string, updating the current position information.+write :: Builder -> Printer ()+write x =+  do eol <- gets psEolComment+     when (eol && x /= "\n") newline+     state <- get+     let out =+           if psNewline state+              then T.fromText+                     (T.replicate (fromIntegral (psIndentLevel state))+                                  " ") <>+                   x+              else x+         out' = T.toLazyText out+     modify (\s ->+               s {psOutput = psOutput state <> out+                 ,psNewline = False+                 ,psEolComment = False+                 ,psLine = psLine state + additionalLines+                 ,psColumn =+                    if additionalLines > 0+                       then LT.length (LT.concat (take 1 (reverse srclines)))+                       else psColumn state + LT.length out'})+  where x' = T.toLazyText x+        srclines = LT.lines x'+        additionalLines =+          LT.length (LT.filter (== '\n') x')++-- | Write a string.+string :: String -> Printer ()+string = write . T.fromText . T.pack++-- | Indent spaces, e.g. 2.+getIndentSpaces :: Printer Int64+getIndentSpaces = gets (configIndentSpaces . psConfig)++-- | Column limit, e.g. 80+getColumnLimit :: Printer Int64+getColumnLimit = gets (configMaxColumns . psConfig)++-- | Play with a printer and then restore the state to what it was+-- before.+sandbox :: MonadState s m => m a -> m s+sandbox p =+  do orig <- get+     _ <- p+     new <- get+     put orig+     return new++-- | No binds?+nullBinds :: Binds NodeInfo -> Bool+nullBinds (BDecls _ x) = null x+nullBinds (IPBinds _ x) = null x++-- | Maybe render a class context.+maybeCtx :: Maybe (Context NodeInfo) -> Printer ()+maybeCtx =+  maybe (return ())+        (\p ->+           pretty p >>+           write " => ")++-- | Swing the second printer below and indented with respect to the first.+swing :: Printer () -> Printer b -> Printer b+swing a b =+  do orig <- gets psIndentLevel+     a+     newline+     indentSpaces <- getIndentSpaces+     column (orig + indentSpaces) b++--------------------------------------------------------------------------------+-- * Instances++instance Pretty Context where+  prettyInternal ctx =+    case ctx of+      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)+      PNPlusK _ n k ->+        depend (do pretty n+                   write "+")+               (int k)+      PInfixApp _ a op b ->+        case op of+          Special{} ->+            depend (pretty a)+                   (depend (prettyInfixOp op)+                           (pretty b))+          _ ->+            depend (do pretty a+                       space)+                   (depend (do prettyInfixOp op+                               space)+                           (pretty b))+      PApp _ f args ->+        depend (do pretty f+                   unless (null args) space)+               (spaced (map pretty args))+      PTuple _ boxed pats ->+        depend (write (case boxed of+                         Unboxed -> "(#"+                         Boxed -> "("))+               (do commas (map pretty pats)+                   write (case boxed of+                            Unboxed -> "#)"+                            Boxed -> ")"))+      PList _ ps ->+        brackets (commas (map pretty ps))+      PParen _ e -> parens (pretty e)+      PRec _ qname fields ->+        depend (pretty qname)+               (braces (commas (map pretty fields)))+      PAsPat _ n p ->+        depend (do pretty n+                   write "@")+               (pretty p)+      PWildCard _ -> write "_"+      PIrrPat _ p ->+        depend (write "~")+               (pretty p)+      PatTypeSig _ p ty ->+        depend (do pretty p+                   write " :: ")+               (pretty ty)+      PViewPat _ e p ->+        depend (do pretty e+                   write " -> ")+               (pretty p)+      PQuasiQuote _ name str ->+        brackets (depend (do write "$"+                             string name+                             write "|")+                         (string str))+      PBangPat _ p ->+        depend (write "!")+               (pretty p)+      PRPat{} -> pretty' x+      PXTag{} -> pretty' x+      PXETag{} -> pretty' x+      PXPcdata{} -> pretty' x+      PXPatTag{} -> pretty' x+      PXRPats{} -> pretty' x+      PVar{} -> pretty' x++-- | Pretty print a name for being an infix operator.+prettyInfixOp :: QName NodeInfo -> Printer ()+prettyInfixOp x =+  case x of+    Qual{} -> pretty' x+    UnQual _ n ->+      case n of+        Ident _ i -> string ("`" ++ i ++ "`")+        Symbol _ s -> string s+    Special _ s -> pretty s++instance Pretty Type where+  prettyInternal x =+    case x of+      TyForall _ mbinds ctx ty ->+        depend (case mbinds of+                  Nothing -> return ()+                  Just ts ->+                    do write "forall "+                       spaced (map pretty ts)+                       write ". ")+               (depend (maybeCtx ctx)+                       (pretty ty))+      TyFun _ a b ->+        depend (do pretty a+                   write " -> ")+               (pretty b)+      TyTuple _ boxed tys ->+        depend (write (case boxed of+                         Unboxed -> "(#"+                         Boxed -> "("))+               (do commas (map pretty tys)+                   write (case boxed of+                            Unboxed -> "#)"+                            Boxed -> ")"))+      TyList _ t -> brackets (pretty t)+      TyApp _ f a -> spaced [pretty f,pretty a]+      TyVar _ n -> pretty n+      TyCon _ p -> pretty p+      TyParen _ e -> parens (pretty e)+      TyInfix _ a op b ->+        depend (do pretty a+                   space)+               (depend (do pretty op+                           space)+                       (pretty b))+      TyKind _ ty k ->+        parens (do pretty ty+                   write " :: "+                   pretty k)+      TyPromoted{} ->+        error "FIXME: No implementation for TyPromoted."++instance Pretty Exp where+  prettyInternal = exp++-- | Render an expression.+exp :: Exp NodeInfo -> Printer ()+exp (InfixApp _ a op b) =+  depend (do pretty a+             space+             pretty op+             space)+         (do pretty b)+exp (App _ op a) =+  swing (do pretty f)+        (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)+exp (NegApp _ e) =+  depend (write "-")+         (pretty e)+exp (Lambda _ ps e) =+  depend (write "\\")+         (do spaced (map pretty ps)+             swing (write " -> ")+                   (pretty e))+exp (Let _ binds e) =+  do depend (write "let ")+            (pretty binds)+     newline+     depend (write "in ")+            (pretty e)+exp (If _ p t e) =+  do depend (write "if ")+            (do pretty p+                newline+                depend (write "then ")+                       (pretty t)+                newline+                depend (write "else ")+                       (pretty e))+exp (Paren _ e) = parens (pretty e)+exp (Case _ e alts) =+  do depend (write "case ")+            (do pretty e+                write " of ")+     newline+     indentSpaces <- getIndentSpaces+     indented indentSpaces (lined (map pretty alts))+exp (Do _ stmts) =+  depend (write "do ")+         (lined (map pretty stmts))+exp (MDo _ stmts) =+  depend (write "mdo ")+         (lined (map pretty stmts))+exp (Tuple _ boxed exps) =+  depend (write (case boxed of+                   Unboxed -> "(#"+                   Boxed -> "("))+         (do parens (prefixedLined ','+                                   (map pretty exps))+             write (case boxed of+                      Unboxed -> "#)"+                      Boxed -> ")"))+exp (TupleSection _ boxed mexps) =+  depend (write (case boxed of+                   Unboxed -> "(#"+                   Boxed -> "("))+         (do commas (map (maybe (return ()) pretty) mexps)+             write (case boxed of+                      Unboxed -> "#)"+                      Boxed -> ")"))+exp (List _ es) =+  brackets (prefixedLined ',' (map pretty es))+exp (LeftSection _ e op) =+  parens (depend (do pretty e+                     space)+                 (pretty op))+exp (RightSection _ e op) =+  parens (depend (do pretty e+                     space)+                 (pretty op))+exp (RecConstr _ n fs) =+  do indentSpaces <- getIndentSpaces+     depend (do pretty n+                space)+            (braces (prefixedLined ','+                                   (map (indented indentSpaces . pretty) fs)))+exp (RecUpdate _ n fs) =+  do indentSpaces <- getIndentSpaces+     depend (do pretty n+                space)+            (braces (prefixedLined ','+                                   (map (indented indentSpaces . pretty) fs)))+exp (EnumFrom _ e) =+  brackets (do pretty e+               write " ..")+exp (EnumFromTo _ e f) =+  brackets (depend (do pretty e+                       write " .. ")+                   (pretty f))+exp (EnumFromThen _ e t) =+  brackets (depend (do pretty e+                       write ",")+                   (do pretty t+                       write " .."))+exp (EnumFromThenTo _ e t f) =+  brackets (depend (do pretty e+                       write ",")+                   (depend (do pretty t+                               write " .. ")+                           (pretty f)))+exp (ListComp _ e qstmt) =+  brackets (depend (do pretty e+                       unless (null qstmt)+                              (write " |"))+                   (do space+                       prefixedLined+                         ','+                         (map (\(i,x) ->+                                 depend (if i == 0+                                            then return ()+                                            else space)+                                        (pretty x))+                              (zip [0 :: Integer ..] qstmt))))+exp (ExpTypeSig _ e t) =+  depend (do pretty e+             write " :: ")+         (pretty t)+exp (VarQuote _ x) =+  depend (write "'")+         (pretty x)+exp (TypQuote _ x) =+  depend (write "''")+         (pretty x)+exp (BracketExp _ b) = pretty b+exp (SpliceExp _ s) = pretty s+exp (QuasiQuote _ n s) =+  brackets (depend (do string n+                       write "|")+                   (do string s+                       write "|"))+exp x@XTag{} = pretty' x+exp x@XETag{} = pretty' x+exp x@XPcdata{} = pretty' x+exp x@XExpTag{} = pretty' x+exp x@XChildTag{} = pretty' x+exp x@Var{} = pretty' x+exp x@IPVar{} = pretty' x+exp x@Con{} = pretty' x+exp x@Lit{} = pretty' x+exp x@CorePragma{} = pretty' x+exp x@SCCPragma{} = pretty' x+exp x@GenPragma{} = pretty' x+exp x@Proc{} = pretty' x+exp x@LeftArrApp{} = pretty' x+exp x@RightArrApp{} = pretty' x+exp x@LeftArrHighApp{} = pretty' x+exp x@RightArrHighApp{} = pretty' x+exp (LCase _ _) =+  error "FIXME: No implementation for LCase."+exp (MultiIf _ _) =+  error "FIXME: No implementation for MultiIf."+exp ParComp{} =+  error "FIXME: No implementation for ParComp."++instance Pretty Stmt where+  prettyInternal x =+    case x of+      Generator _ p e ->+        depend (do pretty p+                   write " <- ")+               (pretty e)+      Qualifier _ e -> pretty e+      LetStmt _ binds ->+        depend (write "let ")+               (pretty binds)+      RecStmt{} ->+        error "FIXME: No implementation for RecStmt."++instance Pretty QualStmt where+  prettyInternal x =+    case x of+      QualStmt _ s -> pretty s+      ThenTrans{} ->+        error "FIXME: No implementation for ThenTrans."+      ThenBy{} ->+        error "FIXME: No implementation for ThenBy."+      GroupBy{} ->+        error "FIXME: No implementation for GroupBy."+      GroupUsing{} ->+        error "FIXME: No implementation for GroupUsing."+      GroupByUsing{} ->+        error "FIXME: No implementation for GroupByUsing."++instance Pretty Decl where+  prettyInternal = decl++-- | Render a declaration.+decl :: Decl NodeInfo -> Printer ()+decl (PatBind _ pat mty rhs mbinds) =+  case mty of+    Just{} ->+      error "Unimplemented (Maybe Type) in PatBind."+    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) =+  do indentSpaces <- getIndentSpaces+     depend (write "instance ")+            (depend (maybeCtx ctx)+                    (depend (pretty dhead)+                            (unless (null (fromMaybe [] decls))+                                    (write " where"))))+     unless (null (fromMaybe [] decls))+            (do newline+                indented indentSpaces (lined (map pretty (fromMaybe [] decls))))+decl (SpliceDecl _ e) = pretty e+decl (TypeSig _ names ty) =+  depend (do inter (write ", ")+                   (map pretty names)+             write " :: ")+         (pretty ty)+decl (FunBind _ matches) =+  lined (map pretty matches)+decl (ClassDecl _ ctx dhead fundeps decls) =+  do depend (write "class ")+            (depend (maybeCtx ctx)+                    (depend (do pretty dhead+                                space)+                            (depend (unless (null fundeps)+                                            (do write " | "+                                                commas (map pretty fundeps)))+                                    (unless (null (fromMaybe [] decls))+                                            (write " where")))))+     unless (null (fromMaybe [] decls))+            (do newline+                indentSpaces <- getIndentSpaces+                indented indentSpaces (lined (map pretty (fromMaybe [] decls))))+decl TypeDecl{} =+  error "FIXME: No implementation for TypeDecl."+decl TypeFamDecl{} =+  error "FIXME: No implementation for TypeFamDecl."+decl (DataDecl _ dataornew ctx dhead condecls _derivs) =+  depend (do pretty dataornew+             space)+         (depend (maybeCtx ctx)+                 (do pretty dhead+                     case condecls of+                       [] -> return ()+                       [x] -> singleCons x+                       xs -> multiCons xs))+  where singleCons x =+          do write " ="+             indentSpaces <- getIndentSpaces+             column indentSpaces+                    (do newline+                        pretty x)+        multiCons xs =+          do newline+             indentSpaces <- getIndentSpaces+             column indentSpaces+                    (depend (write "=")+                            (prefixedLined '|'+                                           (map (depend space . pretty) xs)))+decl GDataDecl{} =+  error "FIXME: No implementation for GDataDecl."+decl DataFamDecl{} =+  error "FIXME: No implementation for DataFamDecl."+decl TypeInsDecl{} =+  error "FIXME: No implementation for TypeInsDecl."+decl DataInsDecl{} =+  error "FIXME: No implementation for DataInsDecl."+decl GDataInsDecl{} =+  error "FIXME: No implementation for GDataInsDecl."+decl DerivDecl{} =+  error "FIXME: No implementation for DerivDecl."+decl ForImp{} =+  error "FIXME: No implementation for ForImp."+decl ForExp{} =+  error "FIXME: No implementation for ForExp."+decl RulePragmaDecl{} =+  error "FIXME: No implementation for RulePragmaDecl."+decl DeprPragmaDecl{} =+  error "FIXME: No implementation for DeprPragmaDecl."+decl InlineSig{} =+  error "FIXME: No implementation for InlineSig."+decl InlineConlikeSig{} =+  error "FIXME: No implementation for InlineConlikeSig."+decl SpecSig{} =+  error "FIXME: No implementation for SpecSig."+decl SpecInlineSig{} =+  error "FIXME: No implementation for SpecInlineSig."+decl InstSig{} =+  error "FIXME: No implementation for InstSig."+decl x@WarnPragmaDecl{} = pretty' x+decl x@AnnPragma{} = pretty' x+decl x@InfixDecl{} = pretty' x+decl x@DefaultDecl{} = pretty' x++instance Pretty Alt where+  prettyInternal x =+    case x of+      Alt _ p galts mbinds ->+        do pretty p+           pretty galts+           case mbinds of+             Nothing -> return ()+             Just binds ->+               do newline+                  indentSpaces <- getIndentSpaces+                  indented indentSpaces+                           (depend (write "where ")+                                   (pretty binds))++instance Pretty Asst where+  prettyInternal x =+    case x of+      ClassA _ name types ->+        spaced (pretty name : map pretty types)+      InfixA{} ->+        error "FIXME: No implementation for InfixA."+      IParam{} ->+        error "FIXME: No implementation for IParam."+      EqualP{} ->+        error "FIXME: No implementation for EqualP."++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)++instance Pretty Binds where+  prettyInternal x =+    case x of+      BDecls _ ds -> lined (map pretty ds)+      IPBinds _  i -> lined (map pretty i)++instance Pretty Bracket where+  prettyInternal x =+    case x of+      ExpBracket _ _ ->+        error "FIXME: No implementation for ExpBracket."+      PatBracket _ _ ->+        error "FIXME: No implementation for PatBracket."+      TypeBracket _ _ ->+        error "FIXME: No implementation for TypeBracket."+      DeclBracket _ _ ->+        error "FIXME: No implementation for DeclBracket."++instance Pretty ClassDecl where+  prettyInternal x =+    case x of+      ClsDecl _ d -> pretty d+      ClsDataFam _ ctx h mkind ->+        depend (write "data ")+               (depend (maybeCtx ctx)+                       (do pretty h+                           (case mkind of+                              Nothing -> return ()+                              Just kind ->+                                do write " :: "+                                   pretty kind)))+      ClsTyFam _ h mkind ->+        depend (write "type ")+               (depend (pretty h)+                       (case mkind of+                          Nothing -> return ()+                          Just kind ->+                            do write " :: "+                               pretty kind))+      ClsTyDef _ this that ->+        do write "type "+           pretty this+           write " = "+           pretty that++instance Pretty ConDecl where+  prettyInternal x =+    case x of+      ConDecl _ name bangty ->+        depend (do pretty name+                   space)+               (lined (map pretty bangty))+      InfixConDecl l a f b ->+        pretty (ConDecl l f [a,b])+      RecDecl _ name fields ->+        depend (pretty name)+               (do space+                   indentSpaces <- getIndentSpaces+                   braces (prefixedLined+                             ','+                             (map (indented indentSpaces . prettyPair)+                                  (concatMap (\(FieldDecl _ names ty) ->+                                                map (,ty) names)+                                             fields))))+    where prettyPair (name,ty) =+            depend (do pretty name+                       write " :: ")+                   (pretty ty)++instance Pretty FieldUpdate where+  prettyInternal x =+    case x of+      FieldUpdate _ n e ->+        swing (do pretty n+                  write " = ")+              (pretty e)+      FieldPun _ n -> pretty n+      FieldWildcard _ -> write ".."++instance Pretty GadtDecl where+  prettyInternal x =+    case x of+      GadtDecl _ _ _ ->+        error "FIXME: No implementation for GadtDecl."++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+      GuardedRhs _ stmts e ->+        do indented 1+                    (do prefixedLined+                          ','+                          (map (\p ->+                                  do space+                                     pretty p)+                               stmts))+           swing (write " = ")+                 (pretty e)++instance Pretty IPBind where+  prettyInternal x =+    case x of+      IPBind _ _ _ ->+        error "FIXME: No implementation for IPBind."++instance Pretty IfAlt where+  prettyInternal x =+    case x of+      IfAlt _ _ _ ->+        error "FIXME: No implementation for IfAlt."++instance Pretty InstDecl where+  prettyInternal i =+    case i of+      InsDecl _ d -> pretty d+      InsType _ name ty ->+       depend (do write "type "+                  pretty name+                  write " = ")+              (pretty ty)+      _ -> pretty' i++instance Pretty Match where+  prettyInternal x =+    case x of+      Match _ name pats rhs mbinds ->+        do depend (do pretty name+                      space)+                  (spaced (map pretty pats))+           pretty rhs+           case mbinds of+             Nothing -> return ()+             Just binds ->+               do newline+                  indentSpaces <- getIndentSpaces+                  indented indentSpaces+                           (depend (write "where ")+                                   (pretty binds))+      InfixMatch{} ->+        error "FIXME: No implementation for InfixMatch."++instance Pretty Module where+  prettyInternal x =+    case x of+      Module _ _ _ _ _ ->+        error "FIXME: No implementation for Module."+      XmlPage{} ->+        error "FIXME: No implementation for XmlPage."+      XmlHybrid{} ->+        error "FIXME: No implementation for XmlHybrid."++instance Pretty PatField where+  prettyInternal x =+    case x of+      PFieldPat _ n p ->+        depend (do pretty n+                   write " = ")+               (pretty p)+      PFieldPun _ n -> pretty n+      PFieldWildcard _ -> write ".."++instance Pretty QualConDecl where+  prettyInternal x =+    case x of+      QualConDecl _ tyvars ctx d ->+        depend (unless (null (fromMaybe [] tyvars))+                       (do write "forall "+                           spaced (map pretty (fromMaybe [] tyvars))+                           write ". "))+               (depend (maybeCtx ctx)+                       (pretty d))++instance Pretty Rhs where+  prettyInternal x =+    case x of+      UnGuardedRhs _ e ->+        (swing (write " = ")+               (pretty e))+      GuardedRhss _ gas ->+        do newline+           indented 2+                    (lined (map (\p ->+                                   do write "|"+                                      pretty p)+                                gas))++instance Pretty Rule where+  prettyInternal x =+    case x of+      Rule _ _ _ _ _ _ ->+        error "FIXME: No implementation for Rule."++instance Pretty RuleVar where+  prettyInternal x =+    case x of+      RuleVar _ _ ->+        error "FIXME: No implementation for RuleVar."+      TypedRuleVar _ _ _ ->+        error "FIXME: No implementation for TypedRuleVar."++instance Pretty Splice where+  prettyInternal x =+    case x of+      IdSplice _ _ ->+        error "FIXME: No implementation for IdSplice."+      ParenSplice _ e ->+        depend (write "$")+               (parens (pretty e))++instance Pretty WarningText where+  prettyInternal x =+    case x of+      DeprText _ _ ->+        error "FIXME: No implementation for DeprText."+      WarnText _ _ ->+        error "FIXME: No implementation for WarnText."++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])+      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])+      DHParen _ h -> parens (pretty h)++instance Pretty SpecialCon where+  prettyInternal s =+    case s of+      UnitCon _ -> write "()"+      ListCon _ -> write "[]"+      FunCon _ -> write "->"+      TupleCon _ Boxed i ->+        string ("(" +++                replicate (i - 1) ',' +++                ")")+      TupleCon _ Unboxed i ->+        string ("(#" +++                replicate (i - 1) ',' +++                "#)")+      Cons _ -> write ":"+      UnboxedSingleCon _ -> write "(##)"++instance Pretty Activation where+  prettyInternal = pretty'++instance Pretty Annotation where+  prettyInternal = pretty'++instance Pretty Assoc where+  prettyInternal = pretty'++instance Pretty CName where+  prettyInternal = pretty'++instance Pretty CallConv where+  prettyInternal = pretty'++instance Pretty DataOrNew where+  prettyInternal = pretty'++instance Pretty ExportSpec where+  prettyInternal = pretty'++instance Pretty FunDep where+  prettyInternal = pretty'++instance Pretty IPName where+  prettyInternal = pretty'++instance Pretty ImportSpec where+  prettyInternal = pretty'++instance Pretty ImportDecl where+  prettyInternal = pretty'++instance Pretty Kind where+  prettyInternal = pretty'++instance Pretty Literal where+  prettyInternal = pretty'++instance Pretty ModulePragma where+  prettyInternal = pretty'++instance Pretty Name where+  prettyInternal = pretty'++instance Pretty Op where+  prettyInternal = pretty'++instance Pretty PXAttr where+  prettyInternal = pretty'++instance Pretty QName where+  prettyInternal = pretty'++instance Pretty QOp where+  prettyInternal = pretty'++instance Pretty RPat where+  prettyInternal = pretty'++instance Pretty RPatOp where+  prettyInternal = pretty'++instance Pretty Safety where+  prettyInternal = pretty'++instance Pretty TyVarBind where+  prettyInternal = pretty'++instance Pretty XAttr where+  prettyInternal = pretty'++instance Pretty XName where+  prettyInternal = pretty'

@@ -9,12 +9,12 @@   (chrisDone)   where +import HIndent.Pretty+import HIndent.Types+ import Control.Monad.State.Class import Data.Int-import HIndent.Combinators-import HIndent.Instances ()-import HIndent.Types-import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Annotated.Syntax import Prelude hiding (exp)  -- | A short function name.@@ -47,29 +47,29 @@                   ,configIndentSpaces = 2}}  -- | I want field updates to be dependent or newline.-fieldupdate :: t -> FieldUpdate -> Printer ()+fieldupdate :: t -> FieldUpdate NodeInfo -> Printer () fieldupdate _ e =   case e of-    FieldUpdate n e' ->+    FieldUpdate _ n e' ->       dependOrNewline         (do pretty n             write " = ")         e'         pretty-    _ -> prettyInternal e+    _ -> prettyNoExt e  -rhs :: State -> Rhs -> Printer ()-rhs _ (UnGuardedRhs e) =+rhs :: State -> Rhs NodeInfo -> Printer ()+rhs _ (UnGuardedRhs _ e) =   do indentSpaces <- getIndentSpaces      indented indentSpaces               (dependOrNewline (write " = ")                                e                                pretty)-rhs _ e = prettyInternal e+rhs _ e = prettyNoExt e  -- | I want guarded RHS be dependent or newline.-guardedrhs :: State -> GuardedRhs -> Printer ()+guardedrhs :: State -> GuardedRhs NodeInfo -> Printer () guardedrhs _ (GuardedRhs _ stmts e) =   indented 1            (do prefixedLined@@ -85,7 +85,7 @@                   pretty))  -- | I want guarded alts be dependent or newline.-guardedalt :: State -> GuardedAlt -> Printer ()+guardedalt :: State -> GuardedAlt NodeInfo -> Printer () guardedalt _ (GuardedAlt _ stmts e) =   indented 1            (do (prefixedLined@@ -101,23 +101,29 @@                   pretty))  -- | I want unguarded alts be dependent or newline.-unguardedalt :: State -> GuardedAlts -> Printer ()-unguardedalt _ (UnGuardedAlt e) =+unguardedalt :: State -> GuardedAlts NodeInfo -> Printer ()+unguardedalt _ (UnGuardedAlt _ e) =   dependOrNewline     (write " -> ")     e     (indented 2 .      pretty)-unguardedalt _ e = prettyInternal e+unguardedalt _ e = prettyNoExt e  -- | Expressions-exp :: State -> Exp -> Printer ()+exp :: State -> 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.-exp _ e@(InfixApp a op b) =+exp _ e@(InfixApp _ a op b) =   do is <- isFlat e-     if is+     overflow <- isOverflow+                   (depend (do pretty a+                               space+                               pretty op+                               space)+                           (do pretty b))+     if is && not overflow         then do depend (do pretty a                            space                            pretty op@@ -131,7 +137,7 @@ -- | We try to render everything on a flat line. More than one of the -- arguments are not flat and it wouldn't be a single liner. -- If the head is short we depend, otherwise we swing.-exp _ (App op a) =+exp _ (App _ op a) =   do orig <- gets psIndentLevel      headIsShort <- isShort f      depend (do pretty f@@ -140,9 +146,10 @@                 flatish <- fmap ((< 2) . length . filter not)                                 (return flats)                 singleLiner <- isSingleLiner (spaced (map pretty args))+                overflow <- isOverflowMax (spaced (map pretty args))                 if singleLiner &&                    ((headIsShort && flatish) ||-                    all id flats)+                    all id flats) && not overflow                    then spaced (map pretty args)                    else do allSingleLiners <- fmap (all id)                                                    (mapM (isSingleLiner . pretty) args)@@ -153,8 +160,8 @@                                       column (orig + indentSpaces)                                              (lined (map pretty args)))   where (f,args) = flatten op [a]-        flatten :: Exp -> [Exp] -> (Exp,[Exp])-        flatten (App f' a') b =+        flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo,[Exp NodeInfo])+        flatten (App _ f' a') b =           flatten f' (a' : b)         flatten f' as = (f',as) -- | Lambdas are dependent if they can be.@@ -166,7 +173,7 @@                b                (indented 1 .                 pretty))-exp _ (Tuple boxed exps) =+exp _ (Tuple _ boxed exps) =   depend (write (case boxed of                    Unboxed -> "(#"                    Boxed -> "("))@@ -179,7 +186,7 @@                       Unboxed -> "#)"                       Boxed -> ")"))   where p = commas (map pretty exps)-exp _ (List es) =+exp _ (List _ es) =   do single <- isSingleLiner p      underflow <- fmap not (isOverflow p)      if single && underflow@@ -187,10 +194,10 @@         else brackets (prefixedLined ','                                      (map pretty es))   where p = brackets (commas (map pretty es))-exp _ e = prettyInternal e+exp _ e = prettyNoExt e  -- | Is the expression "short"? Used for app heads.-isShort :: (Pretty a,Show a) => a -> Printer Bool+isShort :: (Pretty ast) => ast NodeInfo -> Printer Bool isShort p =   do line <- gets psLine      orig <- fmap psColumn (sandbox (write ""))@@ -214,7 +221,7 @@  -- | Make the right hand side dependent if it's flat, otherwise -- newline it.-dependOrNewline :: Printer () -> Exp -> (Exp -> Printer ()) -> Printer ()+dependOrNewline :: Printer () -> Exp NodeInfo -> (Exp NodeInfo -> Printer ()) -> Printer () dependOrNewline left right f =   do flat <- isFlat right      small <- isSmall (depend left (f right))@@ -225,24 +232,24 @@                 (f right)  -- | Is an expression flat?-isFlat :: Exp -> Printer Bool+isFlat :: Exp NodeInfo -> Printer Bool isFlat (Lambda _ _ e) = isFlat e-isFlat (App a b) = return (isName a && isName b)+isFlat (App _ a b) = return (isName a && isName b)   where isName (Var{}) = True         isName _ = False-isFlat (InfixApp a _ b) =+isFlat (InfixApp _ a _ b) =   do a' <- isFlat a      b' <- isFlat b      return (a' && b')-isFlat (NegApp a) = isFlat a+isFlat (NegApp _ a) = isFlat a isFlat VarQuote{} = return True isFlat TypQuote{} = return True-isFlat (List []) = return True+isFlat (List _ []) = return True isFlat Var{} = return True isFlat Lit{} = return True isFlat Con{} = return True-isFlat (LeftSection e _) = isFlat e-isFlat (RightSection _ e) = isFlat e+isFlat (LeftSection _ e _) = isFlat e+isFlat (RightSection _ _ e) = isFlat e isFlat _ = return False  -- | Does printing the given thing overflow column limit? (e.g. 80)@@ -252,6 +259,14 @@      columnLimit <- getColumnLimit      return (psColumn st >              columnLimit)++-- | Does printing the given thing overflow column limit? (e.g. 80)+isOverflowMax :: Printer a -> Printer Bool+isOverflowMax p =+  do st <- sandbox p+     columnLimit <- getColumnLimit+     return (psColumn st >+             columnLimit + 20)  -- | Is the given expression a single-liner when printed? isSingleLiner :: MonadState PrintState m => m a -> m Bool

@@ -7,7 +7,6 @@   (fundamental)   where -import HIndent.Instances () import HIndent.Types  import Data.Default

@@ -8,7 +8,6 @@   (johanTibell)   where -import HIndent.Instances () import HIndent.Types  import Prelude hiding (exp)

@@ -8,7 +8,6 @@   (michaelSnoyman)   where -import HIndent.Instances () import HIndent.Types  import Prelude hiding (exp)

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -10,53 +11,38 @@   ,Extender(..)   ,Style(..)   ,Config(..)-  ,Pretty(..))+  ,NodeInfo(..))   where  import Control.Monad.State (MonadState(..),State)+import Data.Data import Data.Default import Data.Int (Int64)-import Data.Maybe (listToMaybe,mapMaybe) import Data.Text (Text) import Data.Text.Lazy.Builder (Builder)-import Data.Typeable (Typeable,cast)---- | Pretty printing class.-class (Typeable a) => Pretty a where-  pretty :: a -> Printer ()-  pretty a =-    do st <- get-       case st of-         PrintState{psExtenders = es,psUserState = s} ->-           case listToMaybe (mapMaybe (makePrinter s) es) of-             Just m -> m-             Nothing -> prettyInternal a-    where makePrinter s (Extender f) =-            case cast a of-              Just v -> Just (f s v)-              Nothing -> Nothing-  prettyInternal :: a -> Printer ()+import Language.Haskell.Exts.Comments+import Language.Haskell.Exts.SrcLoc  -- | A pretty printing monad. newtype Printer a = Printer { runPrinter :: State PrintState a }   deriving (Monad,Functor,MonadState PrintState)  -- | The state of the pretty printer.-data PrintState = forall s. PrintState-  { psIndentLevel :: !Int64        -- ^ Current indentation level.-  , psOutput      :: !Builder      -- ^ The current output.-  , psNewline     :: !Bool         -- ^ Just outputted a newline?-  , psColumn      :: !Int64        -- ^ Current column.-  , psLine        :: !Int64        -- ^ Current line number.)-  , psUserState   :: !s            -- ^ User state.-  , psExtenders   :: ![Extender s] -- ^ Extenders.-  , psConfig      :: !Config       -- ^ Config which styles may or may-                                   -- not pay attention to.-  }+data PrintState =+  forall s. PrintState {psIndentLevel :: !Int64 -- ^ Current indentation level.+                       ,psOutput :: !Builder -- ^ The current output.+                       ,psNewline :: !Bool -- ^ Just outputted a newline?+                       ,psColumn :: !Int64 -- ^ Current column.+                       ,psLine :: !Int64 -- ^ Current line number.+                       ,psUserState :: !s -- ^ User state.+                       ,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.+                        }  instance Eq PrintState where-  PrintState ilevel out newline col line _ _ _ == PrintState ilevel' out' newline' col' line' _ _ _ =-    (ilevel,out,newline,col,line) == (ilevel',out',newline',col',line')+  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')  -- | A printer extender. Takes as argument the user state that the -- printer was run with, and the current node to print. Use@@ -66,20 +52,29 @@  -- | A printer style. data Style =-  forall s. Style {styleName :: !Text-                  ,styleAuthor :: !Text-                  ,styleDescription :: !Text-                  ,styleInitialState :: !s-                  ,styleExtenders :: ![Extender s]-                  ,styleDefConfig :: !Config}+  forall s. Style {styleName :: !Text -- ^ Name of the style, used in the commandline interface.+                  ,styleAuthor :: !Text -- ^ Author of the printer (as opposed to the author of the style).+                  ,styleDescription :: !Text -- ^ Description of the style.+                  ,styleInitialState :: !s -- ^ User state, if needed.+                  ,styleExtenders :: ![Extender s] -- ^ Extenders to the printer.+                  ,styleDefConfig :: !Config -- ^ Default config to use for this style.+                   }  -- | Configurations shared among the different styles. Styles may pay -- attention to or completely disregard this configuration. data Config =-  Config {configMaxColumns :: !Int64-         ,configIndentSpaces :: !Int64}+  Config {configMaxColumns :: !Int64 -- ^ Maximum columns to fit code into ideally.+         ,configIndentSpaces :: !Int64 -- ^ How many spaces to indent?+          }  instance Default Config where   def =     Config {configMaxColumns = 80            ,configIndentSpaces = 2}++-- | Information for each node in the AST.+data NodeInfo =+  NodeInfo {nodeInfoSpan :: SrcSpanInfo -- ^ Location info from the parser.+           ,nodeInfoComments :: [Comment] -- ^ Comments which follow this node.+            }+  deriving (Typeable,Show,Data)