diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/elisp/hindent.el b/elisp/hindent.el new file mode 100644 --- /dev/null +++ b/elisp/hindent.el @@ -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 . + +;;; 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) diff --git a/hindent.cabal b/hindent.cabal new file mode 100644 --- /dev/null +++ b/hindent.cabal @@ -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: +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 diff --git a/src/HIndent.hs b/src/HIndent.hs new file mode 100644 --- /dev/null +++ b/src/HIndent.hs @@ -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] diff --git a/src/HIndent/Combinators.hs b/src/HIndent/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Combinators.hs @@ -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 diff --git a/src/HIndent/Instances.hs b/src/HIndent/Instances.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Instances.hs @@ -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' diff --git a/src/HIndent/Styles/ChrisDone.hs b/src/HIndent/Styles/ChrisDone.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/ChrisDone.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Chris Done's style. +-- +-- Documented here: + +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: " + ,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) diff --git a/src/HIndent/Styles/Fundamental.hs b/src/HIndent/Styles/Fundamental.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/Fundamental.hs @@ -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} diff --git a/src/HIndent/Styles/JohanTibell.hs b/src/HIndent/Styles/JohanTibell.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/JohanTibell.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Stub module for Johan Tibell's style. +-- +-- Documented here: + +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: " + ,styleInitialState = State + ,styleExtenders = [] + ,styleDefConfig = + Config {configMaxColumns = 80 + ,configIndentSpaces = 4}} diff --git a/src/HIndent/Styles/MichaelSnoyman.hs b/src/HIndent/Styles/MichaelSnoyman.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Styles/MichaelSnoyman.hs @@ -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}} diff --git a/src/HIndent/Types.hs b/src/HIndent/Types.hs new file mode 100644 --- /dev/null +++ b/src/HIndent/Types.hs @@ -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} diff --git a/src/main/Main.hs b/src/main/Main.hs new file mode 100644 --- /dev/null +++ b/src/main/Main.hs @@ -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