hindent (empty) → 0.0
raw patch · 13 files changed
+1841/−0 lines, 13 filesdep +basedep +data-defaultdep +haskell-src-extssetup-changed
Dependencies added: base, data-default, haskell-src-exts, hindent, mtl, text
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- elisp/hindent.el +149/−0
- hindent.cabal +41/−0
- src/HIndent.hs +71/−0
- src/HIndent/Combinators.hs +242/−0
- src/HIndent/Instances.hs +850/−0
- src/HIndent/Styles/ChrisDone.hs +262/−0
- src/HIndent/Styles/Fundamental.hs +27/−0
- src/HIndent/Styles/JohanTibell.hs +29/−0
- src/HIndent/Styles/MichaelSnoyman.hs +29/−0
- src/HIndent/Types.hs +85/−0
- src/main/Main.hs +30/−0
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2014, hindent+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of hindent nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ elisp/hindent.el view
@@ -0,0 +1,149 @@+;;; hindent.el --- Haskell indenter.++;; Copyright (c) 2014 Chris Done. All rights reserved.++;; This file is free software; you can redistribute it and/or modify+;; it under the terms of the GNU General Public License as published by+;; the Free Software Foundation; either version 3, or (at your option)+;; any later version.++;; This file is distributed in the hope that it will be useful,+;; but WITHOUT ANY WARRANTY; without even the implied warranty of+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+;; GNU General Public License for more details.++;; You should have received a copy of the GNU General Public License+;; along with this program. If not, see <http://www.gnu.org/licenses/>.++;;; Code:++(defcustom hindent-style+ "fundamental"+ "The style to use for formatting."+ :group 'haskell+ :type 'string)++(defun hindent/reformat-decl ()+ "Re-format the current declaration by parsing and pretty+ printing it.+COMMENTS ARE CURRENTLY LOST."+ (interactive)+ (let ((start-end (hindent-decl-points)))+ (when start-end+ (let ((original (current-buffer))+ (orig-str (buffer-substring-no-properties (car start-end)+ (cdr start-end))))+ (with-temp-buffer+ (let ((temp (current-buffer)))+ (with-current-buffer original+ (let ((ret (call-process-region (car start-end)+ (cdr start-end)+ "hindent"+ nil ; delete+ temp ; output+ nil+ "--style"+ hindent-style)))+ (cond+ ((= ret 1)+ (error (with-current-buffer temp+ (let ((string (progn (goto-char (point-min))+ (buffer-substring (line-beginning-position)+ (line-end-position)))))+ string))))+ ((= ret 0)+ (let ((new-str (with-current-buffer temp+ (buffer-string))))+ (if (not (string= new-str orig-str))+ (let ((line (line-number-at-pos))+ (col (current-column)))+ (delete-region (car start-end)+ (cdr start-end))+ (insert new-str)+ (goto-char (point-min))+ (forward-line line)+ (goto-char (+ (line-beginning-position) col))+ (message "Formatted."))+ (message "Already formatted.")))))))))))))++(defun hindent-decl-points (&optional use-line-comments)+ "Get the start and end position of the current+declaration. This assumes that declarations start at column zero+and that the rest is always indented by one space afterwards, so+Template Haskell uses with it all being at column zero are not+expected to work."+ (cond+ ;; If we're in a block comment spanning multiple lines then let's+ ;; see if it starts at the beginning of the line (or if any comment+ ;; is at the beginning of the line, we don't care to treat it as a+ ;; proper declaration.+ ((and (not use-line-comments)+ (hindent-in-comment)+ (save-excursion (goto-char (line-beginning-position))+ (hindent-in-comment)))+ nil)+ ((save-excursion+ (goto-char (line-beginning-position))+ (or (looking-at "^-}$")+ (looking-at "^{-$")))+ nil)+ ((bound-and-true-p structured-haskell-repl-mode)+ (case major-mode+ (haskell-interactive-mode+ ;; If the prompt start is available.+ (when (boundp 'haskell-interactive-mode-prompt-start)+ ;; Unless we're running code.+ (unless (> (point)+ (save-excursion (goto-char haskell-interactive-mode-prompt-start)+ (line-end-position)))+ ;; When we're within the prompt and not on some output lines or whatever.+ (when (and (>= (point) haskell-interactive-mode-prompt-start)+ (not (= haskell-interactive-mode-prompt-start+ (line-end-position))))+ (let ((whole-line (buffer-substring-no-properties+ haskell-interactive-mode-prompt-start+ (line-end-position))))+ ;; Don't activate if we're doing a GHCi command.+ (unless (string-match "^:" whole-line)+ (cons haskell-interactive-mode-prompt-start+ (line-end-position)))))))+ )))+ ;; Otherwise we just do our line-based hack.+ (t+ (save-excursion+ (let ((start (or (progn (goto-char (line-end-position))+ (search-backward-regexp "^[^ \n]" nil t 1)+ (unless (or (looking-at "^-}$")+ (looking-at "^{-$"))+ (point)))+ 0))+ (end (progn (goto-char (1+ (point)))+ (or (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)+ (forward-char -1)+ (search-backward-regexp "[^\n ]" nil t)+ (forward-char)+ (point))+ (point-max)))))+ (cons start end))))))++(defun hindent-in-comment ()+ "Are we currently in a comment?"+ (save-excursion+ (when (and (= (line-end-position)+ (point))+ (/= (line-beginning-position) (point)))+ (forward-char -1))+ (and (or (eq 'font-lock-comment-delimiter-face+ (get-text-property (point) 'face))+ (eq 'font-lock-doc-face+ (get-text-property (point) 'face))+ (eq 'font-lock-comment-face+ (get-text-property (point) 'face))+ (save-excursion (goto-char (line-beginning-position))+ (looking-at "^\-\- ")))+ ;; Pragmas {-# SPECIALIZE .. #-} etc are not to be treated as+ ;; comments, even though they are highlighted as such+ (not (save-excursion (goto-char (line-beginning-position))+ (looking-at "{-# "))))))++(provide 'hindent)
+ hindent.cabal view
@@ -0,0 +1,41 @@+name: hindent+version: 0.0+synopsis: Extensible Haskell pretty printer+description: Extensible Haskell pretty printer. Both a library and an executable.+ .+ See the Github page for usage\/explanation: <https://github.com/chrisdone/hindent>+license: BSD3+stability: Unstable+license-file: LICENSE+author: Chris Done+maintainer: chrisdone@gmail.com+copyright: 2014 Chris Done+category: Development+build-type: Simple+cabal-version: >=1.8+data-files: elisp/hindent.el++library+ hs-source-dirs: src/+ ghc-options: -Wall -O2+ exposed-modules: HIndent+ HIndent.Combinators+ HIndent.Types+ 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+ , mtl+ , text++executable hindent+ hs-source-dirs: src/main+ ghc-options: -Wall -O2+ main-is: Main.hs+ build-depends: base >= 4 && < 5+ , hindent+ , text
+ src/HIndent.hs view
@@ -0,0 +1,71 @@+-- | Haskell indenter.++module HIndent+ (-- * Formatting functions.+ reformat+ ,prettyPrint+ ,parseMode+ -- * Style+ ,styles+ ,chrisDone+ ,michaelSnoyman+ ,johanTibell+ ,fundamental+ -- * Testing+ ,test)+ where++import HIndent.Styles.ChrisDone+import HIndent.Styles.MichaelSnoyman+import HIndent.Styles.JohanTibell+import HIndent.Styles.Fundamental+import HIndent.Instances ()+import HIndent.Types++import Control.Monad.State+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++-- | 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)+ 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))+ (case style of+ Style _name _author _desc st extenders _defconfig ->+ PrintState 0 mempty False 0 1 st extenders config))++-- | Parse mode, includes all extensions, doesn't assume any fixities.+parseMode :: ParseMode+parseMode =+ defaultParseMode {extensions = allExtensions+ ,fixities = Nothing}+ where allExtensions =+ filter isDisabledExtention knownExtensions+ isDisabledExtention (DisableExtension _) = False+ isDisabledExtention _ = True++-- | Test with the given style, prints to stdout.+test :: Config -> Style -> Text -> IO ()+test config style =+ either error (T.putStrLn . T.toLazyText) .+ reformat config style++-- | Styles list, useful for programmatically choosing.+styles :: [Style]+styles =+ [fundamental,chrisDone,michaelSnoyman,johanTibell]
+ src/HIndent/Combinators.hs view
@@ -0,0 +1,242 @@+{-# 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
+ src/HIndent/Instances.hs view
@@ -0,0 +1,850 @@+{-# 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'
+ src/HIndent/Styles/ChrisDone.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Chris Done's style.+--+-- Documented here: <https://github.com/chrisdone/haskell-style-guide>++module HIndent.Styles.ChrisDone+ (chrisDone)+ where++import Control.Monad.State.Class+import Data.Int+import HIndent.Combinators+import HIndent.Instances ()+import HIndent.Types+import Language.Haskell.Exts.Syntax+import Prelude hiding (exp)++-- | A short function name.+shortName :: Int64+shortName = 10++-- | Column limit: 50+smallColumnLimit :: Int64+smallColumnLimit = 50++-- | Empty state.+data State = State++-- | The printer style.+chrisDone :: Style+chrisDone =+ Style {styleName = "chris-done"+ ,styleAuthor = "Chris Done"+ ,styleDescription = "Chris Done's personal style. Documented here: <https://github.com/chrisdone/haskell-style-guide>"+ ,styleInitialState = State+ ,styleExtenders =+ [Extender exp+ ,Extender fieldupdate+ ,Extender rhs+ ,Extender guardedrhs+ ,Extender guardedalt+ ,Extender unguardedalt]+ ,styleDefConfig =+ Config {configMaxColumns = 80+ ,configIndentSpaces = 2}}++-- | I want field updates to be dependent or newline.+fieldupdate :: t -> FieldUpdate -> Printer ()+fieldupdate _ e =+ case e of+ FieldUpdate n e' ->+ dependOrNewline+ (do pretty n+ write " = ")+ e'+ pretty+ _ -> prettyInternal e+++rhs :: State -> Rhs -> Printer ()+rhs _ (UnGuardedRhs e) =+ do indentSpaces <- getIndentSpaces+ indented indentSpaces+ (dependOrNewline (write " = ")+ e+ pretty)+rhs _ e = prettyInternal e++-- | I want guarded RHS be dependent or newline.+guardedrhs :: State -> GuardedRhs -> Printer ()+guardedrhs _ (GuardedRhs _ stmts e) =+ indented 1+ (do prefixedLined+ ','+ (map (\p ->+ do space+ pretty p)+ stmts)+ dependOrNewline+ (write " = ")+ e+ (indented 1 .+ pretty))++-- | I want guarded alts be dependent or newline.+guardedalt :: State -> GuardedAlt -> Printer ()+guardedalt _ (GuardedAlt _ stmts e) =+ indented 1+ (do (prefixedLined+ ','+ (map (\p ->+ do space+ pretty p)+ stmts))+ dependOrNewline+ (write " -> ")+ e+ (indented 1 .+ pretty))++-- | I want unguarded alts be dependent or newline.+unguardedalt :: State -> GuardedAlts -> Printer ()+unguardedalt _ (UnGuardedAlt e) =+ dependOrNewline+ (write " -> ")+ e+ (indented 2 .+ pretty)+unguardedalt _ e = prettyInternal e++-- | Expressions+exp :: State -> Exp -> 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) =+ do is <- isFlat e+ if is+ then do depend (do pretty a+ space+ pretty op+ space)+ (do pretty b)+ else do pretty a+ space+ pretty op+ newline+ pretty b+-- | 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) =+ 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))+ if singleLiner &&+ ((headIsShort && flatish) ||+ all id flats)+ then spaced (map pretty args)+ else do allSingleLiners <- fmap (all id)+ (mapM (isSingleLiner . pretty) args)+ if headIsShort || allSingleLiners+ then lined (map pretty args)+ else do newline+ indentSpaces <- getIndentSpaces+ column (orig + indentSpaces)+ (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)+-- | Lambdas are dependent if they can be.+exp _ (Lambda _ ps b) =+ depend (write "\\")+ (do spaced (map pretty ps)+ dependOrNewline+ (write " -> ")+ b+ (indented 1 .+ pretty))+exp _ (Tuple boxed exps) =+ depend (write (case boxed of+ Unboxed -> "(#"+ Boxed -> "("))+ (do single <- isSingleLiner p+ underflow <- fmap not (isOverflow p)+ if single && underflow+ then p+ else parens (prefixedLined ',' (map pretty exps))+ write (case boxed of+ Unboxed -> "#)"+ Boxed -> ")"))+ where p = commas (map pretty exps)+exp _ (List es) =+ do single <- isSingleLiner p+ underflow <- fmap not (isOverflow p)+ if single && underflow+ then p+ else brackets (prefixedLined ','+ (map pretty es))+ where p = brackets (commas (map pretty es))+exp _ e = prettyInternal e++-- | Is the expression "short"? Used for app heads.+isShort :: (Pretty a,Show a) => a -> Printer Bool+isShort p =+ do line <- gets psLine+ orig <- fmap psColumn (sandbox (write ""))+ st <- sandbox (pretty p)+ return (psLine st ==+ line &&+ (psColumn st <+ orig ++ shortName))++-- | Is the given expression "small"? I.e. does it fit on one line and+-- under 'smallColumnLimit' columns.+isSmall :: MonadState PrintState m => m a -> m Bool+isSmall p =+ do line <- gets psLine+ st <- sandbox p+ return (psLine st ==+ line &&+ psColumn st <+ smallColumnLimit)++-- | Make the right hand side dependent if it's flat, otherwise+-- newline it.+dependOrNewline :: Printer () -> Exp -> (Exp -> Printer ()) -> Printer ()+dependOrNewline left right f =+ do flat <- isFlat right+ small <- isSmall (depend left (f right))+ if flat || small+ then depend left (f right)+ else do left+ newline+ (f right)++-- | Is an expression flat?+isFlat :: Exp -> Printer Bool+isFlat (Lambda _ _ e) = isFlat e+isFlat (App a b) = 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+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 _ = return False++-- | Does printing the given thing overflow column limit? (e.g. 80)+isOverflow :: Printer a -> Printer Bool+isOverflow p =+ do st <- sandbox p+ columnLimit <- getColumnLimit+ return (psColumn st >+ columnLimit)++-- | Is the given expression a single-liner when printed?+isSingleLiner :: MonadState PrintState m => m a -> m Bool+isSingleLiner p =+ do line <- gets psLine+ st <- sandbox p+ return (psLine st ==+ line)
+ src/HIndent/Styles/Fundamental.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Fundamental built-in style. Defines no additional extensions or+-- configurations beyond the default printer.++module HIndent.Styles.Fundamental+ (fundamental)+ where++import HIndent.Instances ()+import HIndent.Types++import Data.Default+import Prelude hiding (exp)++-- | Empty state.+data State = State++-- | The printer style.+fundamental :: Style+fundamental =+ Style {styleName = "fundamental"+ ,styleAuthor = "Chris Done"+ ,styleDescription = "This style adds no extensions to the built-in printer."+ ,styleInitialState = State+ ,styleExtenders = []+ ,styleDefConfig = def}
+ src/HIndent/Styles/JohanTibell.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Stub module for Johan Tibell's style.+--+-- Documented here: <https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>++module HIndent.Styles.JohanTibell+ (johanTibell)+ where++import HIndent.Instances ()+import HIndent.Types++import Prelude hiding (exp)++-- | Empty state.+data State = State++-- | The printer style.+johanTibell :: Style+johanTibell =+ Style {styleName = "johan-tibell"+ ,styleAuthor = "Chris Done"+ ,styleDescription = "Style modeled from Johan's style guide here: <https://github.com/tibbe/haskell-style-guide/blob/master/haskell-style.md>"+ ,styleInitialState = State+ ,styleExtenders = []+ ,styleDefConfig =+ Config {configMaxColumns = 80+ ,configIndentSpaces = 4}}
+ src/HIndent/Styles/MichaelSnoyman.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Stub module for Michael Snoyman's style.+--+-- Modelled from existing codebases.++module HIndent.Styles.MichaelSnoyman+ (michaelSnoyman)+ where++import HIndent.Instances ()+import HIndent.Types++import Prelude hiding (exp)++-- | Empty state.+data State = State++-- | The printer style.+michaelSnoyman :: Style+michaelSnoyman =+ Style {styleName = "michael-snoyman"+ ,styleAuthor = "Chris Done"+ ,styleDescription = "Style modelled from existing (Yesod, Conduit, etc.) codebases."+ ,styleInitialState = State+ ,styleExtenders = []+ ,styleDefConfig =+ Config {configMaxColumns = 120+ ,configIndentSpaces = 4}}
+ src/HIndent/Types.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | All types.++module HIndent.Types+ (Printer(..)+ ,PrintState(..)+ ,Extender(..)+ ,Style(..)+ ,Config(..)+ ,Pretty(..))+ where++import Control.Monad.State (MonadState(..),State)+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 ()++-- | 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.+ }++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')++-- | A printer extender. Takes as argument the user state that the+-- printer was run with, and the current node to print. Use+-- 'prettyInternal' to fallback to the built-in printer.+data Extender s =+ forall a. (Typeable a) => Extender (s -> a -> Printer ())++-- | A printer style.+data Style =+ forall s. Style {styleName :: !Text+ ,styleAuthor :: !Text+ ,styleDescription :: !Text+ ,styleInitialState :: !s+ ,styleExtenders :: ![Extender s]+ ,styleDefConfig :: !Config}++-- | Configurations shared among the different styles. Styles may pay+-- attention to or completely disregard this configuration.+data Config =+ Config {configMaxColumns :: !Int64+ ,configIndentSpaces :: !Int64}++instance Default Config where+ def =+ Config {configMaxColumns = 80+ ,configIndentSpaces = 2}
+ src/main/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ViewPatterns #-}+-- | Main entry point to hindent.+--+-- hindent++module Main where++import Data.List+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as T+import qualified Data.Text.Lazy.IO as T+import HIndent+import HIndent.Types+import System.Environment++-- | Main entry point.+main :: IO ()+main =+ do args <- getArgs+ case args of+ ["--style",findStyle -> Just style] ->+ T.interact+ (either error T.toLazyText .+ reformat (styleDefConfig style) style)+ _ ->+ error ("arguments: --style [" +++ intercalate "|" (map (T.unpack . styleName) styles) +++ "]")+ where findStyle name =+ find ((== T.pack name) . styleName) styles