floskell (empty) → 0.9.0
raw patch · 21 files changed
+6128/−0 lines, 21 filesdep +aesondep +aeson-prettydep +basesetup-changed
Dependencies added: aeson, aeson-pretty, base, bytestring, containers, criterion, data-default, deepseq, directory, exceptions, filepath, floskell, ghc-prim, haskell-src-exts, hspec, monad-dijkstra, monad-loops, mtl, optparse-applicative, text, transformers, unordered-containers, utf8-string
Files
- BENCHMARK.md +90/−0
- CHANGELOG.md +3/−0
- LICENSE.md +29/−0
- README.md +273/−0
- Setup.hs +3/−0
- TEST.md +750/−0
- contrib/floskell.coffee +83/−0
- contrib/floskell.el +263/−0
- floskell.cabal +106/−0
- src/Floskell.hs +222/−0
- src/Floskell/Buffer.hs +67/−0
- src/Floskell/Comments.hs +121/−0
- src/Floskell/Config.hs +458/−0
- src/Floskell/Pretty.hs +2143/−0
- src/Floskell/Printers.hs +446/−0
- src/Floskell/Styles.hs +391/−0
- src/Floskell/Types.hs +115/−0
- src/main/Benchmark.hs +50/−0
- src/main/Main.hs +251/−0
- src/main/Markdone.hs +118/−0
- src/main/Test.hs +146/−0
+ BENCHMARK.md view
@@ -0,0 +1,90 @@+# Large inputs++Bunch of declarations++``` haskell+listPrinters =+ [(''[]+ ,\(typeVariable:_) _automaticPrinter ->+ (let presentVar = varE (presentVarName typeVariable)+ in lamE [varP (presentVarName typeVariable)]+ [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+ in (typeString+ ,\xs ->+ case fst $(presentVar) of+ "GHC.Types.Char" ->+ ChoicePresentation+ "String"+ [("String",undefined)+ ,("List of characters",undefined)]+ _ ->+ ListPresentation typeString+ (map (snd $(presentVar)) xs)))|]))]+printComments loc' ast = do+ let correctLocation comment = comInfoLocation comment == Just loc'+ commentsWithLocation = filter correctLocation (nodeInfoComments info)+ comments <- return $ map comInfoComment commentsWithLocation++ forM_ comments $ \comment -> do+ -- Preceeding comments must have a newline before them.+ hasNewline <- gets psNewline+ when (not hasNewline && loc' == Before) newline++ printComment (Just $ srcInfoSpan $ nodeInfoSpan info) comment+ where info = ann ast+exp' (App _ op a) =+ do (fits,st) <-+ fitsOnOneLine (spaced (map pretty (f : args)))+ if fits+ then put st+ else do pretty f+ newline+ spaces <- getIndentSpaces+ indented spaces (lined (map pretty args))+ where (f,args) = flatten op [a]+ flatten :: Exp NodeInfo+ -> [Exp NodeInfo]+ -> (Exp NodeInfo,[Exp NodeInfo])+ flatten (App _ f' a') b =+ flatten f' (a' : b)+ flatten f' as = (f',as)+infixApp :: Exp NodeInfo+ -> Exp NodeInfo+ -> QOp NodeInfo+ -> Exp NodeInfo+ -> Maybe Int64+ -> Printer ()+```++# Complex inputs++Quasi-quotes with nested lets and operators++``` haskell+quasiQuotes =+ [(''[]+ ,\(typeVariable:_) _automaticPrinter ->+ (let presentVar = varE (presentVarName typeVariable)+ in lamE [varP (presentVarName typeVariable)]+ [|(let typeString = "[" ++ fst $(presentVar) ++ "]"+ in (typeString+ ,\xs ->+ case fst $(presentVar) of+ "GHC.Types.Char" ->+ ChoicePresentation+ "String"+ [("String"+ ,StringPresentation "String"+ (concatMap getCh (map (snd $(presentVar)) xs)))+ ,("List of characters"+ ,ListPresentation typeString+ (map (snd $(presentVar)) xs))]+ where getCh (CharPresentation "GHC.Types.Char" ch) =+ ch+ getCh (ChoicePresentation _ ((_,CharPresentation _ ch):_)) =+ ch+ getCh _ = ""+ _ ->+ ListPresentation typeString+ (map (snd $(presentVar)) xs)))|]))]+```
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# Floskell 1.0.0++* Initial release
+ LICENSE.md view
@@ -0,0 +1,29 @@+Copyright (c) 2014, Chris Done+Copyright (c) 2016-2019, Enno Cramer++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 the copyright holder 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 THE COPYRIGHT+HOLDER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,273 @@+# Floskell [](https://travis-ci.org/ennocramer/floskell)++Floskell is a flexible Haskell source code pretty printer.++[Documentation](https://github.com/ennocramer/floskell/blob/master/README.md)++[Examples](https://github.com/ennocramer/floskell/blob/master/styles)++Floskell started as a fork of version 4 of [Chris Done's+hindent](https://github.com/commercialhaskell/hindent). The+formatting styles present in hindent 4 have been preserved in spirit,+but generally will not produce exactly the same output.+++## Installation++ $ git clone https://github.com/ennocramer/floskell+ $ cd floskell+ $ stack install+++## Usage++Floskell can be used to reformat Haskell source files in place++ $ floskell path/to/sourcefile.hs++or as a pipeline processor++ $ cat path/to/sourcefile.hs | floskell > outfile.hs++One of the predefined formatting styles can be selected with the+`--style` option++ $ floskell --style cramer path/to/sourcefile.hs++Or the style can be read from a configuration file++ $ floskell --config path/to/config.json path/to/sourcefile.hs++If neither style nor configuration file is given on the command line,+Floskell will try to find a configuration file in the current working+directory or any of its parent directories, or fall back to the users+global configuration file.+++## Formatting Process++A style in Floskell is a set of formatting possibilities for different+language constructs. Floskell formats Haskell code according to a+given style by finding the combination of allowed formatting choices+that result in the best overall layout.++### Penalty++The overall layout of the generated output is judged by a penalty+function. This function takes into account the number of lines+generated, whether lines are longer than a defined limit, and the+indentation of each line.++In general, Floskell will try to generate++* the smallest number of lines,++* the least amount of indentation, and++* the least amount of overflow.++### Layout++A number of language constructs can be formatted in different ways.+Floskell generally defines two layout choices for these constructs,+`flex` and `vertical`, and three modes to apply these choices, `flex`,+`vertical`, and `try-oneline`.++The layout choice `flex` generally tries to fit as much on each line+as possible, but allows linebreaks in a number of places, while the+`vertical` layout choice forces linebreaks in various places.++The `flex` and `vertical` layout modes simply select the respective+layout choice, while `try-oneline` will first try `flex`, but replace+the choice with `vertical` if the `flex` layout would more than one+line or an overfull line.++An example:++```haskell+-- flex layout for con-decls+data Enum = One | Two | Three++-- vertical layout for con-decls+data Enum = One+ | Two+ | Three+```++### Indentation++A number of language constructs can apply indentation to sub-elements.+Floskell provides two different indentation choices, `aligned` and+`indented`, and three modes to apply these choices, `align`,+`indent-by n`, and `align-or-indent-by n`.++`align` will start the sub-element on the same line and raise the+indentation to align following lines, while `indent-by n` will start+the sub-element on the following line with the indentation raised by+`n`.++`align-or-indent-by n` will allow either choice and select the+formatting with the least penalty.++An example:++```haskell+-- align for do+foo = do x <- xs+ y <- ys+ return (x, y)++-- indent-by 4 for do+foo = do+ x <- xs+ y <- ys+ return (x, y)+```++### Tabstop Alignment++Some language constructs allow for tabstop alignment. Alignment is+optional and subject to configurable limits, regarding the amount of+added whitespace.++An example:++```haskell+-- let without alignment+let foo = bar+ quux = quuz+in foo quux++-- let with alignment+let foo = bar+ quuuux = quuz+in foo quuuux+```++### Whitespace++Floskell allows the customization of whitespace around infix+operators, as well as inside parentheses and other enclosing+punctuation characters.++The presence of whitespace or linebreaks is as `before`, meaning+before the operator/enclosed item, `after`, meaning after the+operator/enclosed item, or `both`, meaning both before and after the+operator/enclosed item.++Whitespace configuration can depend on the context where an operator+or enclosing punctuation is used. The context can be one of+`declaration`, `type`, `pattern`, `expression`, or `other`.++An example:++```haskell+-- tuple with space after/before parentheses and after comma+tuple = ( 1, 2 )+-- tuple without any spaces+tuple = (1,2)+```+++## Customization++Floskell's behaviour and the style of its output can be modified with+a configuration file.++See the documentation on the [Configuration Format](CONFIGURATION.md)+for a detailed description of the contents of the configuration file.++### Initial Configuration++The `--print-config` command line option can be used to create an+initial configuration file.++ $ floskell --style cramer --print-config > ~/.floskell++This command will create a configuration file with all fields and the+entire definition of the selected style in the `formatting` block.++### Configuration File Location++* If a style is given on the command line, but no explicit+ configuration file, the style will be used as-is and not+ configuration file will be loaded.++* If both a style and an explicit configuration file are given on the+ command line, the explicit configuration file will be loaded and the+ style parameter will replace any style setting in the configuration+ file.++* If neither style nor explicit configuration file are given on the+ command line, Floskell will try to find an applicable configuration+ file. Floskell will look for++ * a file called `floskell.json` in the current working directory and+ all its parent directories,++ * a file called `config.json` in `~/.floskell`, `~/config/floskell`,+ or `%APPDATA%/floskell`, and lastly++ * a file called `.floskell.json` in `~` or `~/.config`.++ Only the first file found will be loaded.+++## Editor Integration++### Emacs++In+[contrib/floskell.el](https://github.com/ennocramer/floskell/blob/master/contrib/floskell.el)+there is `floskell-mode`, which provides keybindings to reindent parts+of the buffer:++- `M-q` reformats the current declaration. When inside a comment, it+ fills the current paragraph instead, like the standard `M-q`.+- `C-M-\` reformats the current region.++To enable it, add the following to your init file:++```lisp+(add-to-list 'load-path "/path/to/floskell/contrib")+(require 'floskell)+(add-hook 'haskell-mode-hook #'floskell-mode)+```++By default, Floskell uses the style called `base`. If you want to use+another, run `M-x customize-variable floskell-style` or create a+Floskell configuration file in your home directory. If you want to+configure per-project, add a configuration file in the project root or+make a file called `.dir-locals.el` in the project root directory like+this:++``` lisp+((nil . ((floskell-style . "johan-tibell"))))+```++### Vim++The `'formatprg'` option lets you use an external program (like+floskell) to format your text. Put the following line into+~/.vim/ftplugin/haskell.vim to set this option for Haskell files:++ setlocal formatprg=floskell\ --style\ chris-done++Then you can format with floskell using `gq`. Read `:help gq` and `help+'formatprg'` for more details.++Note that unlike in emacs you have to take care of selecting a+sensible buffer region as input to floskell yourself. If that is too+much trouble you can try+[vim-textobj-haskell](https://github.com/gilligan/vim-textobj-haskell)+which provides a text object for top level bindings.++### Atom++Basic support is provided through+[contrib/floskell.coffee](https://github.com/ennocramer/floskell/blob/master/contrib/floskell.coffee),+which adds floskell to atom menu with each available style, and+`Default` which will use the appropriate configuration file. Mode+should be installed as package into `.atom\packages\${PACKAGE_NAME}`,+here is simple example of atom+[package](https://github.com/Heather/atom-hindent).
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ TEST.md view
@@ -0,0 +1,750 @@+# Introduction++This file acts both as a presentation of the Floskell formatting+styles, as well as a set of regression tests.++You can see how a particular style will format Haskell source by+reading the matching Markdown file in the styles/ directory.++For regression testing, the canonical source, TEST.md in the root+directory, is parsed and each Haskell code block formatted according+to all predefined styles. The formatted output is then compared with+the corresponding, already formatted code block in the <style\>.md file+in the styles/ subdirectory.++The regression test will also verify that repeated invocations of the+pretty printer will not modify an already formatted piece of code.++The following code block acts as a quick presentation for the+different formatting styles, by presenting a mixture of common Haskell+constructs.++``` haskell+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module: Style.Haskell.Example++Haskell Code Style Example.+-}+module Style.Haskell.Example (+ -- * Types+ Enum(..)+ ,Either(..)+ ,Point(..)+ -- * Functions+ ,hello+ ) where++-- Module imports+import qualified Control.Monad.Trans.State (State,evalState,execState,get,modify,put,runState)+import qualified Data.Map as Map+import qualified Data.Text as Text+import Prelude hiding (map)++-- Data declarations+data Enum=CaseA|CaseB|CaseC deriving(Eq,Enum,Show)++data Either a b=Left a|Right b deriving(Eq,Show)++data Point=Point{pointX::Float,pointY::Float,pointLabel::String}deriving(Eq,Show)++-- Type classes+class Functor f=>Applicative a where+ pure::b->a b+ ap::a (b->c)->a b->a c++class Fundep a b|a->b where+ convert::a->b++instance Functor f=>Functor(Wrap f)where+ fmap f (Wrap x)=Wrap $ fmap f x++-- Values+origin::Point+origin=Point{pointX=0,pointY=0,pointLabel="Origin"}++lorem::[String]+lorem=["Lorem ipsum dolor sit amet, consectetur adipiscing elit.",+ "Curabitur nec ante nec mauris ornare suscipit.",+ "In ac vulputate libero.",+ "Duis eget magna non purus imperdiet molestie nec quis mauris.",+ "Praesent blandit quam vel arcu pellentesque, id aliquet turpis faucibus."]++-- Functions+facs::[Int]+facs=[1,1]++zipWith(+)(tailfacs)++hello::MonadIO m=>m ()+hello=do name<-liftIO getLine+ liftIO . putStrLn $ greetings name+ where+ greetings n="Hello "++n++"!"++letExpr::Point->String+letExp x=let y=1+ z=2+ in if x>0 then y else z++ifExpr::Bool->Bool+ifExpr b=if b == True then False else True++caseExpr::[a]->Maybe a+caseExpr xs=case xs of+ [] -> Nothing+ (x:_) -> Just x++guarded::Int->Int+guarded x|x == 0=1+ |x == 1=1+ |otherwise=guarded (x - 2) + guarded (x - 1)++someLongFunctionNameWithALotOfParameters::+ (MonadIO m,MonadRandom m)=>String->(String->String)->m ()+someLongFunctionNameWithALotOfParameters=undefined+```++# Unit Tests++## ModuleHead and ExportSpecList++Without exports++``` haskell+module Main where+```++With exports++``` haskell+module Main (foo,bar,baz,main) where+```++With exports and comments++``` haskell+module Main (+ -- * Main Program+ main+ -- * Functions+ , foo -- foo function+ , bar -- bar function+ , baz -- baz function+ ) where+```++With deprecation++``` haskell+module Main {-# DEPRECATED "no longer supported" #-} where+```++With warnings++``` haskell+module Main {-# WARNING "do not use" #-} where+```++## ImportDecl++``` haskell+import Prelude+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.ByteString (ByteString,pack,unpack)+import qualified Data.ByteString as BS (pack, unpack)+import Control.Monad hiding (forM)+```++## Decl++### TypeDecl++``` haskell+type Name = String+type Pair a = (a, a)+type Fun a b = a -> b+```++### DataDecl and GDataDecl++``` haskell+data Void+data Unit = Unit+data Maybe a = Nothing | Just a+data Num a => SomeNum = SomeNum a++newtype RWS r w s = RWS (ReaderT r (WriterT w (StateT s Identity)))+ deriving (Functor, Applicative, Monad)++data Enum =+ One -- Foo+ | Two -- Bar+ | Three -- Baz++data Foo deriving ()+data Foo deriving Show+data Foo deriving (Show)+data Foo deriving (Eq, Ord)++data Expr :: * -> * where+ Const :: Int -> Expr Int+ Plus :: Expr Int -> Expr Int -> Expr Int+ Eq :: Expr Int -> Expr Int -> Expr Bool+ deriving (Show)++data Term a where+ Lit :: { val :: Int } -> Term Int+ Succ :: { num :: Term Int } -> Term Int+ Pred :: { num :: Term Int } -> Term Int+ IsZero :: { arg :: Term Int } -> Term Bool+ Pair :: { arg1 :: Term a, arg2 :: Term b } -> Term (a,b)+ If :: { cnd :: Term Bool, tru :: Term a, fls :: Term a } -> Term a+```++### TypeFamDecl, TypeInsDecl, and ClosedTypeFamDecl++``` haskell+type family Mutable v+type family Mutable v = (r :: *)+type family Mutable v = r | r -> v++type instance Mutable Int = MIntVector++type family Store a where+ Store Bool = [Int]+ Store a = [a]++type family Store a = (r :: *) where+ Store a = [a]++type family Store a = r | r -> a where+ Store a = [a]+```++### DataFamDecl, DataInsDecl, and GDataInsDecl++``` haskell+data family List a++data instance List () = NilList Int+data instance List Char = CharNil | CharCons Char (List Char)+ deriving (Eq, Ord, Show)++data instance List Int :: * where+ IntNil :: List Int+ IntCons :: Int -> List Int+ deriving (Eq, Ord, Show)++data instance List Int :: * where+ IntNil :: List Int+ IntCons :: { val :: Int } -> List Int+ deriving (Eq, Ord, Show)+```++### ClassDecl and InstDecl++``` haskell+class Monoid a where+ mempty :: a+ mappend :: a -> a -> a++class Applicative m => Monad m where+ fail :: m a+ return :: a -> m a+ (>>=) :: a -> (a -> m b) -> m b++class Monad m => MonadState s m | m -> s where+ get :: m s+ put :: s -> m ()+ state :: (s -> (a, s)) -> m a++class ToJSON a where+ toJSON :: a -> Value+ default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value+ toJSON = genericToJSON defaultOptions++instance ToJSON ()++instance Bounded Bool where+ minBound = False+ maxBound = True++instance Semigroup a => Monoid (Maybe a) where+ mempty = Nothing+ Nothing `mappend` m = m+ m `mappend` Nothing = m+ Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)++instance Data () where+ type Base = ()+ newtype Wrapped = Wrapped { unWrap :: () }+ data Expr :: * -> * where+ Const :: Int -> Expr Int+ Plus :: Expr Int -> Expr Int -> Expr Int+ Eq :: Expr Int -> Expr Int -> Expr Bool+```++### DerivDecl++``` haskell+deriving instance Eq a => Eq (Sum a)+deriving instance {-# OVERLAP #-} Eq a => Eq (Sum a)+deriving stock instance {-# OVERLAPS #-} Eq a => Eq (Sum a)+deriving anyclass instance {-# OVERLAPPING #-} Eq a => Eq (Sum a)+deriving newtype instance {-# OVERLAPPABLE #-} Eq a => Eq (Sum a)+```++### InfixDecl++``` haskell+infix 4 ==, /=, <, <=, >, >=+infixr 0 $+infixl !!+```++### DefaultDecl++``` haskell+default ()+default (Integer, Double)+```++### SpliceDecl++``` haskell+$foo+$(bar baz)+```++### TypeSig++``` haskell+id :: a -> a+sort :: Ord a => [a] -> [a]+long :: (IsString a, Monad m) => ByteString -> ByteString -> ByteString -> ByteString -> ByteString -> a -> m ()+mktime :: Int -- hours+ -> Int -- minutes+ -> Int -- seconds+ -> Time+transform :: forall a. St -> State St a -> EitherT ServantErr IO a+```++### PatSyn and PatSynSig++``` haskell+{-# LANGUAGE PatternSynonyms #-}++pattern MyJust :: a -> Maybe a+pattern MyJust a = Just a++pattern MyPoint :: Int -> Int -> (Int, Int)+pattern MyPoint{x, y} = (x,y)++pattern ErrorCall :: String -> ErrorCall+pattern ErrorCall s <- ErrorCallWithLocation s _+ where+ ErrorCall s = ErrorCallWithLocation s ""++pattern IsTrue :: Show a => a+pattern IsTrue <- ((== "True") . show -> True)++pattern ExNumPat :: () => Show b => b -> T+pattern ExNumPat x = MkT x++pattern Foo, Bar :: Show a => a+```++### FunBind and PatBind++``` haskell+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE RecordWildCards #-}++pi = 3.14++id x = x++not False = True+not _ = False++head (x : _) = x++maybe x _ Nothing = x+maybe _ f (Some x) = f x++fst (x, _) = x+fst' (# x, _ #) = x++fstPrism (# x | | #) = Just x+fstPrism (# | _ | #) = Nothing+fstPrism (# | | _ #) = Nothing++empty [] = True+empty _ = False++unSum (Sum { getSum = s }) = s++mag2 Point{x, y} = sqr x + sqr y+mag2 Point{..} = sqr x + sqr y++strict !x = x+irrefutable ~x = x++(//) a b = undefined+a // b = undefined++main = do+ greet "World"+ where+ greet who = putStrLn $ "Hello, " ++ who ++ "!"+```++### ForImp and ForExp++``` haskell+{-# LANGUAGE ForeignFunctionInterface #-}+foreign import ccall sin :: Double -> Double+foreign import ccall "sin" sin :: Double -> Double+foreign import ccall "sin" sin :: Double -> Double+foreign import ccall unsafe exit :: Double -> Double++foreign export ccall callback :: Int -> Int+```++### Pragmas++``` haskell+{-# RULES #-}+{-# RULES "map/map" forall f g xs. map f (map g xs) = map (f.g) xs #-}+{-# RULES "map/append" [2] forall f xs ys. map f (xs ++ ys) = map f xs ++ map f ys #-}++{-# DEPRECATED #-}+{-# DEPRECATED foo "use bar instead" #-}+{-# DEPRECATED foo, bar, baz "no longer supported" #-}++{-# WARNING #-}+{-# WARNING foo "use bar instead" #-}+{-# WARNING foo, bar, baz "no longer supported" #-}++{-# INLINE foo #-}+{-# INLINE [3] foo #-}+{-# INLINE [~3] foo #-}+{-# NOINLINE foo #-}++{-# INLINE CONLIKE foo #-}+{-# INLINE CONLIKE [3] foo #-}++{-# SPECIALISE foo :: Int -> Int #-}+{-# SPECIALISE [3] foo :: Int -> Int, Float -> Float #-}++{-# SPECIALISE INLINE foo :: Int -> Int #-}+{-# SPECIALISE NOINLINE foo :: Int -> Int #-}++{-# SPECIALISE instance Foo Int #-}+{-# SPECIALISE instance forall a. (Ord a) => Foo a #-}++{-# ANN foo (Just "Foo") #-}+{-# ANN type Foo (Just "Foo") #-}+{-# ANN module (Just "Foo") #-}++{-# MINIMAL foo | bar, (baz | quux) #-}+```++## Exp++### Var, Con, Lit, Tuple, UnboxedSum, List, and ExpTypeSig++``` haskell+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnboxedSums #-}++foo = foo++foo = Nothing++foo = 123++foo = 'x'++foo = ""+foo = "Lorem Ipsum Dolor Amet Sit"++foo = ()+foo = (1, 2)+foo = (1 -- the one+ , 2)++foo = (# #)+foo = (# 1, 2 #)+foo = (# 1 -- the one+ , 2 #)+++foo = (# 1 #)+foo = (# | 1 | | #)+foo = (# | 1 -- the one+ | | #)++foo = []+foo = [1]+foo = [1,2]+foo = [1 -- the one+ , 2]++foo = 1 :: Int+```++### App, InfixApp, NegApp, LeftSection, RightSection++``` haskell+foo = foldl fn init list+foo = foldl fn -- reducer+ init -- initial value+ list++foo = 1 + 2+foo = fn `map` list++foo = -3++foo = (+ arg)+foo = (`op` arg)++foo = (arg +)+foo = (arg `op`)+```++### EnumFrom, EnumFromTo, EnumFromThen, EnumFromThenTo, ParArrayFromTo, ParArrayFromThenTo++``` haskell+foo = [1..]+foo = [1..10]+foo = [1, 2..]+foo = [1, 2..10]+foo = [:1..10:]+foo = [:1, 2..10:]+```++### ListComp, ParComp, and ParArrayComp++``` haskell+{-# LANGUAGE TransformListComp #-}++foo = [ (x, y) | x <- xs, y <- ys ]+foo = [ (x, y) -- cartesian product+ | x <- xs -- first list+ , y <- ys -- second list+ ]+foo = [ (x,y) | x <- xs | y <- ys ]+foo = [ (x,y) -- zip+ | x <- xs -- first list+ | y <- ys -- second list+ ]+foo = [: (x,y) | x <- xs | y <- ys :]+foo = [: (x,y) -- zip+ | x <- xs -- first list+ | y <- ys -- second list+ :]++foo = [ (x, y)+ | x <- xs+ , y <- ys+ , then reverse+ , then sortWith by (x+y)+ , then group using permutations+ , then group by (x+y) using groupWith+ ]+```++### RecConstr and RecUpdate++``` haskell+{-# LANGUAGE RecordWildCards #-}++foo = Point { x = 1, y = 2 }+foo = Point { x = 1 -- the one+ , y+ , ..+ }++foo = bar { x = 1 }+foo = bar { x = 1 -- the one+ , y+ , ..+ }+```++### Let, If, MultiIf, and Case++``` haskell+{-# LANGUAGE MultiWayIf #-}++foo = let x = x in x++foo = let x = x -- bottom+ in+ -- bottom+ x++foo = if null xs then None else Some $ head xs++foo = if null xs -- condition+ then None -- it's empty+ else Some $ head xs -- it's not++foo = if | null xs -> None+ | otherwise -> Some $ head xs++foo = if | null xs ->+ -- it's empty+ None+ | otherwise ->+ -- it's not+ Some $ head x++foo = case x of+ True -> False+ False -> True++foo = case xs of+ [] ->+ -- it's empty+ None+ x : _ ->+ -- it's not+ Some x++foo = case xs of+ _ | null xs -> None+ _ -> Some $ head x+```++### Do and MDo++``` haskell+{-# LANGUAGE RecursiveDo #-}++foo = do { return () }++foo = do+ return ()++foo = do+ this <- that+ let this' = tail this+ if this -- condition+ then that+ else those++foo = mdo+ return ()+```++### Lambda, LCase++``` haskell+{-# LANGUAGE LambdaCase #-}++foo = \x -> x+foo = \ ~x -> x+foo = \ !x -> x+foo d = \case+ Nothing -> d+ Some x -> x+```++### BracketExp, SpliceExp, QuasiQuote, VarQuote, and TypQuote++``` haskell+{-# LANGUAGE TemplateHaskell #-}++mkDecl :: Q Decl+mkDecl = [d|id x = x|]++mkType :: Q Type+mkType = [t|(a, b) -> a|]++mkPat :: Q Pat+mkPat = [p|(a, b)|]++mkExp :: Q Exp+mkExp = [e|a|]++fst :: $(mkType)+fst $(mkPat) = $(mkExp)++html = [html|<p>Lorem Ipsum Dolor Amet Sit</p>|]++foo = mkSomething 'id 'Nothing ''Maybe+```++# Regression Tests++## Do++Before comments and onside indent do not mix well.++``` haskell+foo = do+ -- comment+ some expression+```++## Onside++Indent within onside started on non-empty line should still not stack.++``` haskell+foo = if cond+ then do+ this+ else do+ that+```++Before comments at the start of onside do not trigger onside.++``` haskell+foo = do+ -- comment+ some expression+```++Matche arms have individual onside.++``` haskell+foo True = some -- comment+ expression+foo False = some -- comment+ other expression+```++Where binds are considered outside of onside.++``` haskell+foo = some -- comment+ expression+ where+ expression = other+```++Align overrides onside.++``` haskell+foo = some expr [ 1 -- comment+ , 2+ ]+```++If-then-else must always indent in do blocks.++``` haskell+foo = do+ if condition -- comment+ then this+ else that+```
+ contrib/floskell.coffee view
@@ -0,0 +1,83 @@+{CompositeDisposable} = require 'atom'+{BufferedProcess} = require 'atom'+{dirname} = require 'path'+{statSync} = require 'fs'++prettify = (args, text, workingDirectory, {onComplete, onFailure}) ->+ lines = []+ proc = new BufferedProcess+ command: 'floskell'+ args: args+ options:+ cwd: workingDirectory+ stdout: (line) -> lines.push(line)+ exit: -> onComplete?(lines.join(''))+ proc.onWillThrowError ({error, handle}) ->+ atom.notifications.addError "Floskell could not spawn",+ detail: "#{error}"+ onFailure?()+ handle()+ proc.process.stdin.write(text)+ proc.process.stdin.end()++prettifyFile = (args, editor, format = 'haskell') ->+ [firstCursor, cursors...] = editor.getCursors().map (cursor) ->+ cursor.getBufferPosition()+ try+ workDir = dirname(editor.getPath())+ if not statSync(workDir).isDirectory()+ workDir = '.'+ catch+ workDir = '.'+ prettify args, editor.getText(), workDir,+ onComplete: (text) ->+ editor.setText(text)+ if editor.getLastCursor()?+ editor.getLastCursor().setBufferPosition firstCursor,+ autoscroll: false+ cursors.forEach (cursor) ->+ editor.addCursorAtBufferPosition cursor,+ autoscroll: false++module.exports = Floskell =+ disposables: null+ menu: null++ activate: (state) ->+ @disposables = new CompositeDisposable+ @menu = new CompositeDisposable++ @disposables.add \+ atom.commands.add 'atom-text-editor[data-grammar~="haskell"]',+ 'floskell:prettify-none': ({target}) =>+ prettifyFile [], target.getModel()+ 'floskell:prettify-chris-done': ({target}) =>+ prettifyFile ['--style', 'chris-done'], target.getModel()+ 'floskell:prettify-cramer': ({target}) =>+ prettifyFile ['--style', 'cramer'], target.getModel()+ 'floskell:prettify-gibiansky': ({target}) =>+ prettifyFile ['--style', 'gibiansky'], target.getModel()+ 'floskell:prettify-johan-tibell': ({target}) =>+ prettifyFile ['--style', 'johan-tibell'], target.getModel()++ @menu.add atom.menu.add [+ label: 'floskell'+ submenu : [+ {label: 'Default', command: 'floskell:prettify-none'}+ {label: 'Cramer', command: 'floskell:prettify-cramer'}+ {label: 'Chris Done', command: 'floskell:prettify-chris-done'}+ {label: 'Gibiansky', command: 'floskell:prettify-gibiansky'}+ {label: 'Johan Tibell', command: 'floskell:prettify-johan-tibell'}+ ]+ ]++ deactivate: ->+ @disposables.dispose()+ @disposables = null++ @clearMenu()++ clearMenu: ->+ @menu.dispose()+ @menu = null+ atom.menu.update()
+ contrib/floskell.el view
@@ -0,0 +1,263 @@+;;; floskell.el --- Indent haskell code using the "floskell" program++;; Copyright (c) 2014 Chris Done. All rights reserved.++;; Author: Chris Done <chrisdone@gmail.com>+;; URL: https://github.com/ennocramer/floskell+;; Package-Requires: ((cl-lib "0.5"))++;; 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:++(require 'cl-lib)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Minor mode++(defvar floskell-mode-map+ (let ((map (make-sparse-keymap)))+ (define-key map [remap indent-region] #'floskell-reformat-region)+ (define-key map [remap fill-paragraph] #'floskell-reformat-decl-or-fill)+ map)+ "Keymap for `floskell-mode'.")++;;;###autoload+(define-minor-mode floskell-mode+ "Indent code with the floskell program.++Provide the following keybindings:++\\{floskell-mode-map}"+ :init-value nil+ :keymap floskell-mode-map+ :lighter " HI"+ :group 'haskell+ :require 'floskell)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Customization properties++(defcustom floskell-style+ nil+ "The style to use for formatting."+ :group 'haskell+ :type 'string+ :safe #'stringp)++(defcustom floskell-process-path+ "floskell"+ "Location where the floskell executable is located."+ :group 'haskell+ :type 'string+ :safe #'stringp)++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Interactive functions++;;;###autoload+(defun floskell-reformat-decl ()+ "Re-format the current declaration by parsing and pretty+ printing it. Comments are preserved, although placement may be+ funky."+ (interactive)+ (let ((start-end (floskell-decl-points)))+ (when start-end+ (let ((beg (car start-end))+ (end (cdr start-end)))+ (floskell-reformat-region beg end)))))++;;;###autoload+(defun floskell-reformat-buffer ()+ "Reformat the whole buffer."+ (interactive)+ (floskell-reformat-region (point-min)+ (point-max)))++;;;###autoload+(defun floskell-reformat-decl-or-fill (justify)+ "Re-format current declaration, or fill paragraph.++Fill paragraph if in a comment, otherwise reformat the current+declaration."+ (interactive (progn+ ;; Copied from `fill-paragraph'+ (barf-if-buffer-read-only)+ (list (if current-prefix-arg 'full))))+ (if (floskell-in-comment)+ (fill-paragraph justify t)+ (floskell/reformat-decl)))++;;;###autoload+(defun floskell-reformat-region (beg end)+ "Reformat the given region, accounting for indentation."+ (interactive "r")+ (if (= (save-excursion (goto-char beg)+ (line-beginning-position))+ beg)+ (floskell-reformat-region-as-is beg end)+ (let* ((column (- beg (line-beginning-position)))+ (string (buffer-substring-no-properties beg end))+ (new-string (with-temp-buffer+ (insert (make-string column ? ) string)+ (floskell-reformat-region-as-is (point-min)+ (point-max))+ (delete-region (point-min) (1+ column))+ (buffer-substring (point-min)+ (point-max)))))+ (save-excursion+ (goto-char beg)+ (delete-region beg end)+ (insert new-string)))))++;;;###autoload+(defun floskell/reformat-decl ()+ "See `floskell-reformat-decl'."+ (floskell-reformat-decl))++;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;; Internal library++(defun floskell-reformat-region-as-is (beg end)+ "Reformat the given region as-is.++This is the place where floskell is actually called."+ (let* ((original (current-buffer))+ (orig-str (buffer-substring-no-properties beg end)))+ (with-temp-buffer+ (let ((temp (current-buffer)))+ (with-current-buffer original+ (let ((ret (apply #'call-process-region+ (append (list beg+ end+ floskell-process-path+ nil ; delete+ temp ; output+ nil)+ (when floskell-style+ (list "--style" floskell-style))+ (floskell-extra-arguments)))))+ (cond+ ((= ret 1)+ (let ((error-string+ (with-current-buffer temp+ (let ((string (progn (goto-char (point-min))+ (buffer-substring (line-beginning-position)+ (line-end-position)))))+ string))))+ (if (string= error-string "floskell: Parse error: EOF")+ (message "language pragma")+ (error error-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 beg+ end)+ (let ((new-start (point)))+ (insert new-str)+ (let ((new-end (point)))+ (goto-char (point-min))+ (forward-line (1- line))+ (goto-char (+ (line-beginning-position) col))+ (when (looking-back "^[ ]+")+ (back-to-indentation))+ (delete-trailing-whitespace new-start new-end)))+ (message "Formatted."))+ (message "Already formatted.")))))))))))++(defun floskell-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)+ (floskell-in-comment)+ (save-excursion (goto-char (line-beginning-position))+ (floskell-in-comment)))+ nil)+ ((save-excursion+ (goto-char (line-beginning-position))+ (or (looking-at "^-}$")+ (looking-at "^{-$")))+ nil)+ ;; Otherwise we just do our line-based hack.+ (t+ (save-excursion+ (let ((start+ (or (cl-letf+ (((symbol-function 'jump)+ #'(lambda ()+ (search-backward-regexp "^[^ \n]" nil t 1)+ (cond+ ((save-excursion (goto-char (line-beginning-position))+ (looking-at "|]"))+ (jump))+ (t (unless (or (looking-at "^-}$")+ (looking-at "^{-$"))+ (point)))))))+ (goto-char (line-end-position))+ (jump))+ 0))+ (end+ (progn+ (goto-char (1+ (point)))+ (or (cl-letf+ (((symbol-function 'jump)+ #'(lambda ()+ (when (search-forward-regexp "[\n]+[^ \n]" nil t 1)+ (cond+ ((save-excursion (goto-char (line-beginning-position))+ (looking-at "|]"))+ (jump))+ (t (forward-char -1)+ (search-backward-regexp "[^\n ]" nil t)+ (forward-char)+ (point)))))))+ (jump))+ (point-max)))))+ (cons start end))))))++(defun floskell-in-comment ()+ "Are we currently in a comment?"+ (save-excursion+ (when (and (= (line-end-position)+ (point))+ (/= (line-beginning-position) (point)))+ (forward-char -1))+ (and+ (elt (syntax-ppss) 4)+ ;; 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 "{-# "))))))++(defun floskell-extra-arguments ()+ "Pass in extra arguments, such as extensions and optionally+other things later."+ (if (boundp 'haskell-language-extensions)+ haskell-language-extensions+ '()))++(provide 'floskell)++;;; floskell.el ends here
+ floskell.cabal view
@@ -0,0 +1,106 @@+name: floskell+version: 0.9.0+synopsis: A flexible Haskell source code pretty printer+description: A flexible Haskell source code pretty printer.+ .+ See the Github page for usage\/explanation: <https://github.com/ennocramer/floskell>+license: BSD3+stability: Unstable+license-file: LICENSE.md+author: Chris Done, Andrew Gibiansky, Tobias Pflug, Pierre Radermecker, Enno Cramer+maintainer: ecramer@memfrob.de+copyright: 2014 Chris Done, 2015 Andrew Gibiansky, 2016-2019 Enno Cramer+category: Development+build-type: Simple+cabal-version: >=1.8+homepage: https://www.github.com/ennocramer/floskell+bug-reports: https://github.com/ennocramer/floskell/issues+data-files: contrib/floskell.el+ contrib/floskell.coffee+extra-source-files: README.md+ CHANGELOG.md+ BENCHMARK.md+ TEST.md++source-repository head+ type: git+ location: https://github.com/ennocramer/floskell++library+ hs-source-dirs: src/+ ghc-options: -Wall+ exposed-modules: Floskell+ Floskell.Buffer+ Floskell.Comments+ Floskell.Config+ Floskell.Pretty+ Floskell.Printers+ Floskell.Styles+ Floskell.Types+ build-depends: base >= 4.7 && <5+ , aeson+ , containers+ , unordered-containers+ , data-default+ , haskell-src-exts >= 1.20+ , monad-loops+ , monad-dijkstra+ , mtl+ , bytestring+ , utf8-string+ , transformers+ , text++executable floskell+ hs-source-dirs: src/main+ ghc-options: -Wall -Wno-missing-home-modules -optP-Wno-nonportable-include-path+ main-is: Main.hs+ build-depends: base >= 4 && < 5+ , floskell+ , aeson+ , aeson-pretty+ , bytestring+ , optparse-applicative+ , haskell-src-exts+ , ghc-prim+ , directory+ , filepath+ , unordered-containers+ , text++test-suite floskell-test+ type: exitcode-stdio-1.0+ hs-source-dirs: src/main+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ main-is: Test.hs+ other-modules: Markdone+ build-depends: base >= 4 && <5+ , floskell+ , haskell-src-exts+ , monad-loops+ , mtl+ , bytestring+ , utf8-string+ , hspec+ , directory+ , text+ , deepseq+ , exceptions++benchmark floskell-bench+ type: exitcode-stdio-1.0+ hs-source-dirs: src/main+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ main-is: Benchmark.hs+ other-modules: Markdone+ build-depends: base >= 4 && < 5+ , floskell+ , bytestring+ , utf8-string+ , haskell-src-exts+ , ghc-prim+ , directory+ , criterion+ , deepseq+ , exceptions+ , text
+ src/Floskell.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- | Haskell indenter.+module Floskell+ ( -- * Formatting functions.+ reformat+ , prettyPrint+ -- * Style+ , Style(..)+ , styles+ -- * Testing+ , defaultExtensions+ ) where++import Data.ByteString ( ByteString )+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Internal as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Unsafe as S+import Data.Function ( on )+import Data.List+import qualified Data.Map.Strict as Map+import Data.Maybe+import Data.Monoid++import qualified Floskell.Buffer as Buffer+import Floskell.Comments+import Floskell.Pretty ( pretty, printComment )+import Floskell.Styles ( styles )+import Floskell.Types++import Language.Haskell.Exts+ hiding ( Pretty, Style, parse, prettyPrint, style )+import qualified Language.Haskell.Exts as Exts++data CodeBlock = HaskellSource Int ByteString | CPPDirectives ByteString+ deriving ( Show, Eq )++-- | Format the given source.+reformat :: Style+ -> Language+ -> [Extension]+ -> Maybe FilePath+ -> ByteString+ -> Either String L.ByteString+reformat style language langextensions mfilepath x = preserveTrailingNewline x+ . mconcat . intersperse "\n" <$> mapM processBlock (cppSplitBlocks x)+ where+ processBlock :: CodeBlock -> Either String L.ByteString+ processBlock (CPPDirectives text) = Right $ L.fromStrict text+ processBlock (HaskellSource offset text) =+ let ls = S8.lines text+ prefix = findPrefix ls+ code = unlines' (map (stripPrefix prefix) ls)+ exts = readExtensions (UTF8.toString code)+ mode'' = case exts of+ Nothing -> mode'+ Just (Nothing, exts') ->+ mode' { extensions = exts' ++ extensions mode' }+ Just (Just lang, exts') ->+ mode' { baseLanguage = lang+ , extensions = exts' ++ extensions mode'+ }+ in+ case parseModuleWithComments mode'' (UTF8.toString code) of+ ParseOk (m, comments) ->+ fmap (addPrefix prefix) (prettyPrint style m comments)+ ParseFailed loc e -> Left $+ Exts.prettyPrint (loc { srcLine = srcLine loc + offset })+ ++ ": " ++ e++ unlines' = S.concat . intersperse "\n"++ unlines'' = L.concat . intersperse "\n"++ addPrefix :: ByteString -> L8.ByteString -> L8.ByteString+ addPrefix prefix = unlines'' . map (L8.fromStrict prefix <>) . L8.lines++ stripPrefix :: ByteString -> ByteString -> ByteString+ stripPrefix prefix line = if S.null (S8.dropWhile (== '\n') line)+ then line+ else fromMaybe (error "Missing expected prefix")+ . s8_stripPrefix prefix $ line++ findPrefix :: [ByteString] -> ByteString+ findPrefix = takePrefix False . findSmallestPrefix . dropNewlines++ dropNewlines :: [ByteString] -> [ByteString]+ dropNewlines = filter (not . S.null . S8.dropWhile (== '\n'))++ takePrefix :: Bool -> ByteString -> ByteString+ takePrefix bracketUsed txt = case S8.uncons txt of+ Nothing -> ""+ Just ('>', txt') ->+ if not bracketUsed then S8.cons '>' (takePrefix True txt') else ""+ Just (c, txt') -> if c == ' ' || c == '\t'+ then S8.cons c (takePrefix bracketUsed txt')+ else ""++ findSmallestPrefix :: [ByteString] -> ByteString+ findSmallestPrefix [] = ""+ findSmallestPrefix ("" : _) = ""+ findSmallestPrefix (p : ps) =+ let first = S8.head p+ startsWithChar c x = S8.length x > 0 && S8.head x == c+ in+ if all (startsWithChar first) ps+ then S8.cons first (findSmallestPrefix (S.tail p : map S.tail ps))+ else ""++ mode' = defaultParseMode { parseFilename = fromMaybe "<stdin>" mfilepath+ , baseLanguage = language+ , extensions = langextensions+ }++ preserveTrailingNewline x x' = if not (S8.null x) && S8.last x == '\n'+ && not (L8.null x') && L8.last x' /= '\n'+ then x' <> "\n"+ else x'++-- | Break a Haskell code string into chunks, using CPP as a delimiter.+-- Lines that start with '#if', '#end', or '#else' are their own chunks, and+-- also act as chunk separators. For example, the code+--+-- > #ifdef X+-- > x = X+-- > y = Y+-- > #else+-- > x = Y+-- > y = X+-- > #endif+--+-- will become five blocks, one for each CPP line and one for each pair of declarations.+cppSplitBlocks :: ByteString -> [CodeBlock]+cppSplitBlocks = map (classify . unlines') . groupBy ((==) `on` (cppLine . snd))+ . zip [ 0 .. ] . S8.lines+ where+ cppLine :: ByteString -> Bool+ cppLine src =+ any (`S8.isPrefixOf` src)+ [ "#if"+ , "#end"+ , "#else"+ , "#define"+ , "#undef"+ , "#elif"+ , "#include"+ , "#error"+ , "#warning"+ ]++ unlines' :: [(Int, ByteString)] -> (Int, ByteString)+ unlines' [] = (0, "")+ unlines' xs@((line, _) : _) = (line, S8.unlines $ map snd xs)++ classify :: (Int, ByteString) -> CodeBlock+ classify (ofs, text) =+ if cppLine text then CPPDirectives text else HaskellSource ofs text++-- | Print the module.+prettyPrint :: Style+ -> Module SrcSpanInfo+ -> [Comment]+ -> Either a L.ByteString+prettyPrint style m comments =+ let (cs, ast) =+ annotateComments (fromMaybe m $ applyFixities baseFixities m)+ comments+ csComments = map comInfoComment cs+ in+ Right (runPrinterStyle style+ -- For the time being, assume that all "free-floating" comments come at the beginning.+ -- If they were not at the beginning, they would be after some ast node.+ -- Thus, print them before going for the ast.+ (do+ mapM_ (printComment Nothing)+ (reverse csComments)+ pretty ast))++-- | Pretty print the given printable thing.+runPrinterStyle :: Style -> Printer () -> L.ByteString+runPrinterStyle (Style _name _author _desc st) m =+ maybe (error "Printer failed with mzero call.")+ (Buffer.toLazyByteString . psBuffer)+ (snd <$> execPrinter m+ (PrintState Buffer.empty+ 0+ 0+ Map.empty+ st+ False+ Anything))++-- | Default extensions.+defaultExtensions :: [Extension]+defaultExtensions = [ e | e@EnableExtension{} <- knownExtensions ]+ \\ map EnableExtension badExtensions++-- | Extensions which steal too much syntax.+badExtensions :: [KnownExtension]+badExtensions =+ [ Arrows -- steals proc+ , TransformListComp -- steals the group keyword+ , XmlSyntax+ , RegularPatterns -- steals a-b+ , UnboxedTuples -- breaks (#) lens operator+ , PatternSynonyms -- steals the pattern keyword+ , RecursiveDo -- steals the rec keyword+ , DoRec -- same+ , TypeApplications -- since GHC 8 and haskell-src-exts-1.19+ ]++-- ,QuasiQuotes -- breaks [x| ...], making whitespace free list comps break+s8_stripPrefix :: ByteString -> ByteString -> Maybe ByteString+s8_stripPrefix bs1@(S.PS _ _ l1) bs2+ | bs1 `S.isPrefixOf` bs2 = Just (S.unsafeDrop l1 bs2)+ | otherwise = Nothing
+ src/Floskell/Buffer.hs view
@@ -0,0 +1,67 @@+-- | An outout buffer for ByteStrings that keeps track of line and+-- column numbers.+module Floskell.Buffer+ ( Buffer+ , empty+ , newline+ , write+ , line+ , column+ , toLazyByteString+ ) where++import qualified Data.ByteString as BS+import Data.ByteString.Builder ( Builder )+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL++import Data.Int ( Int64 )++data Buffer =+ Buffer { bufferData :: !Builder -- ^ The current output.+ , bufferDataNoSpace :: !Builder -- ^ The current output without trailing spaces.+ , bufferLine :: !Int64 -- ^ Current line number.+ , bufferColumn :: !Int64 -- ^ Current column number.+ }++-- | An empty output buffer.+empty :: Buffer+empty = Buffer { bufferData = mempty+ , bufferDataNoSpace = mempty+ , bufferLine = 0+ , bufferColumn = 0+ }++-- | Append a ByteString to the output buffer. It is an error for the+-- string to contain newlines.+write :: BS.ByteString -> Buffer -> Buffer+write str buf =+ buf { bufferData = newBufferData+ , bufferDataNoSpace =+ if BS.all (== 32) str then bufferData buf else newBufferData+ , bufferColumn = bufferColumn buf + fromIntegral (BS.length str)+ }+ where+ newBufferData = bufferData buf `mappend` BB.byteString str++-- | Append a newline to the output buffer.+newline :: Buffer -> Buffer+newline buf = buf { bufferData = newBufferData+ , bufferDataNoSpace = newBufferData+ , bufferLine = bufferLine buf + 1+ , bufferColumn = 0+ }+ where+ newBufferData = bufferDataNoSpace buf `mappend` BB.char7 '\n'++-- | Return the current line number, counting from 0.+line :: Buffer -> Int64+line = bufferLine++-- | Return the column number, counting from 0.+column :: Buffer -> Int64+column = bufferColumn++-- | Return the contents of the output buffer as a lazy ByteString.+toLazyByteString :: Buffer -> BL.ByteString+toLazyByteString = BB.toLazyByteString . bufferData
+ src/Floskell/Comments.hs view
@@ -0,0 +1,121 @@+-- | Comment handling.+module Floskell.Comments where++import Control.Arrow ( first, second )+import Control.Monad.State.Strict++import Data.Foldable ( traverse_ )+import qualified Data.Map.Strict as M++import Floskell.Types++import Language.Haskell.Exts+ hiding ( Pretty, Style, parse, prettyPrint, style )++-- Order by start of span, larger spans before smaller spans.+newtype OrderByStart = OrderByStart SrcSpan+ deriving ( Eq )++instance Ord OrderByStart where+ compare (OrderByStart l) (OrderByStart r) =+ compare (srcSpanStartLine l) (srcSpanStartLine r)+ `mappend` compare (srcSpanStartColumn l) (srcSpanStartColumn r)+ `mappend` compare (srcSpanEndLine r) (srcSpanEndLine l)+ `mappend` compare (srcSpanEndColumn r) (srcSpanEndColumn l)++-- Order by end of span, smaller spans before larger spans.+newtype OrderByEnd = OrderByEnd SrcSpan+ deriving ( Eq )++instance Ord OrderByEnd where+ compare (OrderByEnd l) (OrderByEnd r) =+ compare (srcSpanEndLine l) (srcSpanEndLine r)+ `mappend` compare (srcSpanEndColumn l) (srcSpanEndColumn r)+ `mappend` compare (srcSpanStartLine r) (srcSpanStartLine l)+ `mappend` compare (srcSpanStartColumn r) (srcSpanStartColumn l)++-- | Annotate the AST with comments.+annotateComments :: Traversable ast+ => ast SrcSpanInfo+ -> [Comment]+ -> ([ComInfo], ast NodeInfo)+annotateComments src comments =+ evalState (do+ traverse_ assignComment comments+ cis <- gets fst+ ast <- traverse transferComments src+ return (cis, ast))+ ([], nodeinfos)+ where+ nodeinfos :: M.Map SrcSpanInfo NodeInfo+ nodeinfos = foldr (\ssi -> M.insert ssi (NodeInfo ssi [])) M.empty src++ -- Assign a single comment to the right AST node+ assignComment :: Comment+ -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) ()+ assignComment comment@(Comment _ cspan _) =+ -- Find the biggest AST node directly in front of this comment.+ case nodeBefore comment of+ -- Comments before any AST node are handled separately.+ Nothing -> modify $ first $ (:) (ComInfo comment Nothing)++ Just ssi ->+ -- Comments on the same line as the AST node belong to this node.+ if sameline (srcInfoSpan ssi) cspan+ then insertComment After ssi+ else do+ nodeinfo <- gets ((M.! ssi) . snd)+ case nodeinfo of+ -- We've already collected comments for this+ -- node and this comment is a continuation.+ NodeInfo _ (ComInfo c' _ : _)+ | aligned c' comment -> insertComment After ssi++ -- The comment does not belong to this node.+ -- If there is a node following this comment,+ -- assign it to that node, else keep it here,+ -- anyway.+ _ -> case nodeAfter comment of+ Nothing -> insertComment After ssi+ Just ssi' -> insertComment Before ssi'+ where+ sameline :: SrcSpan -> SrcSpan -> Bool+ sameline before after = srcSpanEndLine before == srcSpanStartLine after++ aligned :: Comment -> Comment -> Bool+ aligned (Comment _ before _) (Comment _ after _) =+ srcSpanEndLine before == srcSpanStartLine after - 1+ && srcSpanStartColumn before == srcSpanStartColumn after++ insertComment :: Location+ -> SrcSpanInfo+ -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) ()+ insertComment l ssi = modify $ second $+ M.adjust (addComment (ComInfo comment (Just l))) ssi++ addComment :: ComInfo -> NodeInfo -> NodeInfo+ addComment x (NodeInfo s xs) = NodeInfo s (x : xs)++ -- Transfer collected comments into the AST.+ transferComments :: SrcSpanInfo+ -> State ([ComInfo], M.Map SrcSpanInfo NodeInfo) NodeInfo+ transferComments ssi = do+ ni <- gets ((M.! ssi) . snd)+ -- Sometimes, there are multiple AST nodes with the same+ -- SrcSpan. Make sure we assign comments to only one of+ -- them.+ modify $ second $ M.adjust (\(NodeInfo s _) -> NodeInfo s []) ssi+ return ni { nodeInfoComments = reverse $ nodeInfoComments ni }++ nodeBefore (Comment _ ss _) =+ fmap snd $ OrderByEnd ss `M.lookupLT` spansByEnd++ nodeAfter (Comment _ ss _) =+ fmap snd $ OrderByStart ss `M.lookupGT` spansByStart++ spansByStart = foldr (\ssi -> M.insert (OrderByStart $ srcInfoSpan ssi) ssi)+ M.empty+ src++ spansByEnd =+ foldr (\ssi -> M.insert (OrderByEnd $ srcInfoSpan ssi) ssi) M.empty src
+ src/Floskell/Config.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Floskell.Config+ ( Indent(..)+ , LayoutContext(..)+ , Location(..)+ , WsLoc(..)+ , Whitespace(..)+ , Layout(..)+ , ConfigMapKey(..)+ , ConfigMap(..)+ , PenaltyConfig(..)+ , AlignConfig(..)+ , IndentConfig(..)+ , LayoutConfig(..)+ , OpConfig(..)+ , GroupConfig(..)+ , OptionConfig(..)+ , FlexConfig(..)+ , defaultFlexConfig+ , safeFlexConfig+ , cfgMapFind+ , cfgOpWs+ , cfgGroupWs+ , inWs+ , wsSpace+ , wsLinebreak+ ) where++import Data.Aeson+ ( FromJSON(..), ToJSON(..), genericParseJSON, genericToJSON )+import qualified Data.Aeson as JSON+import Data.Aeson.Types as JSON+ ( Options(..), camelTo2, typeMismatch )+import Data.ByteString ( ByteString )+import Data.Default ( Default(..) )+import qualified Data.HashMap.Lazy as HashMap+import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map+import qualified Data.Text as T+import qualified Data.Text.Encoding as T ( decodeUtf8, encodeUtf8 )++import GHC.Generics++data Indent = Align | IndentBy !Int | AlignOrIndentBy !Int+ deriving ( Eq, Ord, Show, Generic )++data LayoutContext = Declaration | Type | Pattern | Expression | Other+ deriving ( Eq, Ord, Bounded, Enum, Show, Generic )++data Location = Before | After+ deriving ( Eq, Ord, Bounded, Enum, Show, Generic )++data WsLoc = WsNone | WsBefore | WsAfter | WsBoth+ deriving ( Eq, Ord, Bounded, Enum, Show, Generic )++data Whitespace = Whitespace { wsSpaces :: !WsLoc+ , wsLinebreaks :: !WsLoc+ , wsForceLinebreak :: !Bool+ }+ deriving ( Show, Generic )++data Layout = Flex | Vertical | TryOneline+ deriving ( Eq, Ord, Bounded, Enum, Show, Generic )++data ConfigMapKey = ConfigMapKey !(Maybe ByteString) !(Maybe LayoutContext)+ deriving ( Eq, Ord, Show )++data ConfigMap a =+ ConfigMap { cfgMapDefault :: !a, cfgMapOverrides :: !(Map ConfigMapKey a) }+ deriving ( Generic )++data PenaltyConfig = PenaltyConfig { penaltyMaxLineLength :: !Int+ , penaltyLinebreak :: !Int+ , penaltyIndent :: !Int+ , penaltyOverfull :: !Int+ , penaltyOverfullOnce :: !Int+ }+ deriving ( Generic )++instance Default PenaltyConfig where+ def = PenaltyConfig { penaltyMaxLineLength = 80+ , penaltyLinebreak = 100+ , penaltyIndent = 1+ , penaltyOverfull = 10+ , penaltyOverfullOnce = 200+ }++data AlignConfig =+ AlignConfig { cfgAlignLimits :: !(Int, Int)+ , cfgAlignCase :: !Bool+ , cfgAlignClass :: !Bool+ , cfgAlignImportModule :: !Bool+ , cfgAlignImportSpec :: !Bool+ , cfgAlignLetBinds :: !Bool+ , cfgAlignRecordFields :: !Bool+ , cfgAlignWhere :: !Bool+ }+ deriving ( Generic )++instance Default AlignConfig where+ def = AlignConfig { cfgAlignLimits = (10, 25)+ , cfgAlignCase = False+ , cfgAlignClass = False+ , cfgAlignImportModule = False+ , cfgAlignImportSpec = False+ , cfgAlignLetBinds = False+ , cfgAlignRecordFields = False+ , cfgAlignWhere = False+ }++data IndentConfig =+ IndentConfig { cfgIndentOnside :: !Int+ , cfgIndentDeriving :: !Int+ , cfgIndentWhere :: !Int+ , cfgIndentApp :: !Indent+ , cfgIndentCase :: !Indent+ , cfgIndentClass :: !Indent+ , cfgIndentDo :: !Indent+ , cfgIndentExportSpecList :: !Indent+ , cfgIndentIf :: !Indent+ , cfgIndentImportSpecList :: !Indent+ , cfgIndentLet :: !Indent+ , cfgIndentLetBinds :: !Indent+ , cfgIndentLetIn :: !Indent+ , cfgIndentMultiIf :: !Indent+ , cfgIndentWhereBinds :: !Indent+ }+ deriving ( Generic )++instance Default IndentConfig where+ def = IndentConfig { cfgIndentOnside = 4+ , cfgIndentDeriving = 4+ , cfgIndentWhere = 2+ , cfgIndentApp = IndentBy 4+ , cfgIndentCase = IndentBy 4+ , cfgIndentClass = IndentBy 4+ , cfgIndentDo = IndentBy 4+ , cfgIndentExportSpecList = IndentBy 4+ , cfgIndentIf = IndentBy 4+ , cfgIndentImportSpecList = IndentBy 4+ , cfgIndentLet = IndentBy 4+ , cfgIndentLetBinds = IndentBy 4+ , cfgIndentLetIn = IndentBy 4+ , cfgIndentMultiIf = IndentBy 4+ , cfgIndentWhereBinds = IndentBy 2+ }++data LayoutConfig =+ LayoutConfig { cfgLayoutApp :: !Layout+ , cfgLayoutConDecls :: !Layout+ , cfgLayoutDeclaration :: !Layout+ , cfgLayoutExportSpecList :: !Layout+ , cfgLayoutIf :: !Layout+ , cfgLayoutImportSpecList :: !Layout+ , cfgLayoutInfixApp :: !Layout+ , cfgLayoutLet :: !Layout+ , cfgLayoutListComp :: !Layout+ , cfgLayoutRecord :: !Layout+ , cfgLayoutTypesig :: !Layout+ }+ deriving ( Generic )++instance Default LayoutConfig where+ def = LayoutConfig { cfgLayoutApp = Flex+ , cfgLayoutConDecls = Flex+ , cfgLayoutDeclaration = Flex+ , cfgLayoutExportSpecList = Flex+ , cfgLayoutIf = Flex+ , cfgLayoutImportSpecList = Flex+ , cfgLayoutInfixApp = Flex+ , cfgLayoutLet = Flex+ , cfgLayoutListComp = Flex+ , cfgLayoutRecord = Flex+ , cfgLayoutTypesig = Flex+ }++newtype OpConfig = OpConfig { unOpConfig :: ConfigMap Whitespace }+ deriving ( Generic )++instance Default OpConfig where+ def =+ OpConfig ConfigMap { cfgMapDefault = Whitespace WsBoth WsBefore False+ , cfgMapOverrides = Map.empty+ }++newtype GroupConfig = GroupConfig { unGroupConfig :: ConfigMap Whitespace }+ deriving ( Generic )++instance Default GroupConfig where+ def = GroupConfig ConfigMap { cfgMapDefault =+ Whitespace WsBoth WsAfter False+ , cfgMapOverrides = Map.empty+ }++data OptionConfig = OptionConfig { cfgOptionSortPragmas :: !Bool+ , cfgOptionSplitLanguagePragmas :: !Bool+ , cfgOptionSortImports :: !Bool+ , cfgOptionSortImportLists :: !Bool+ , cfgOptionPreserveVerticalSpace :: !Bool+ }+ deriving ( Generic )++instance Default OptionConfig where+ def = OptionConfig { cfgOptionSortPragmas = False+ , cfgOptionSplitLanguagePragmas = False+ , cfgOptionSortImports = False+ , cfgOptionSortImportLists = False+ , cfgOptionPreserveVerticalSpace = False+ }++data FlexConfig = FlexConfig { cfgPenalty :: !PenaltyConfig+ , cfgAlign :: !AlignConfig+ , cfgIndent :: !IndentConfig+ , cfgLayout :: !LayoutConfig+ , cfgOp :: !OpConfig+ , cfgGroup :: !GroupConfig+ , cfgOptions :: !OptionConfig+ }+ deriving ( Generic )++instance Default FlexConfig where+ def = FlexConfig { cfgPenalty = def+ , cfgAlign = def+ , cfgIndent = def+ , cfgLayout = def+ , cfgOp = def+ , cfgGroup = def+ , cfgOptions = def+ }++defaultFlexConfig :: FlexConfig+defaultFlexConfig =+ def { cfgOp = OpConfig ((unOpConfig def) { cfgMapOverrides =+ Map.fromList opWsOverrides+ })+ }+ where+ opWsOverrides =+ [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)+ , ( ConfigMapKey (Just "record") Nothing+ , Whitespace WsAfter WsAfter False+ )+ , ( ConfigMapKey (Just ".") (Just Type)+ , Whitespace WsAfter WsAfter False+ )+ ]++safeFlexConfig :: FlexConfig -> FlexConfig+safeFlexConfig cfg = cfg { cfgGroup = group, cfgOp = op }+ where+ group = GroupConfig $+ updateOverrides (unGroupConfig $ cfgGroup cfg)+ [ ("(#", Expression), ("(#", Pattern) ]++ op = OpConfig $+ updateOverrides (unOpConfig $ cfgOp cfg) [ (".", Expression) ]++ updateOverrides config overrides =+ config { cfgMapOverrides =+ foldl (updateWs config) (cfgMapOverrides config) overrides+ }++ updateWs config m (key, ctx) =+ Map.insert (ConfigMapKey (Just key) (Just ctx))+ (cfgMapFind ctx key config) { wsSpaces = WsBoth }+ m++cfgMapFind :: LayoutContext -> ByteString -> ConfigMap a -> a+cfgMapFind ctx key ConfigMap{..} =+ let value = cfgMapDefault+ value' = Map.findWithDefault value+ (ConfigMapKey Nothing (Just ctx))+ cfgMapOverrides+ value'' = Map.findWithDefault value'+ (ConfigMapKey (Just key) Nothing)+ cfgMapOverrides+ value''' = Map.findWithDefault value''+ (ConfigMapKey (Just key) (Just ctx))+ cfgMapOverrides+ in+ value'''++cfgOpWs :: LayoutContext -> ByteString -> OpConfig -> Whitespace+cfgOpWs ctx op = cfgMapFind ctx op . unOpConfig++cfgGroupWs :: LayoutContext -> ByteString -> GroupConfig -> Whitespace+cfgGroupWs ctx op = cfgMapFind ctx op . unGroupConfig++inWs :: Location -> WsLoc -> Bool+inWs _ WsBoth = True+inWs Before WsBefore = True+inWs After WsAfter = True+inWs _ _ = False++wsSpace :: Location -> Whitespace -> Bool+wsSpace loc ws = loc `inWs` wsSpaces ws++wsLinebreak :: Location -> Whitespace -> Bool+wsLinebreak loc ws = loc `inWs` wsLinebreaks ws++------------------------------------------------------------------------+readMaybe :: Read a => String -> Maybe a+readMaybe str = case reads str of+ [ (x, "") ] -> Just x+ _ -> Nothing++enumOptions :: Int -> Options+enumOptions n =+ JSON.defaultOptions { constructorTagModifier = JSON.camelTo2 '-' . drop n }++recordOptions :: Int -> Options+recordOptions n =+ JSON.defaultOptions { fieldLabelModifier = JSON.camelTo2 '-' . drop n+ , unwrapUnaryRecords = True+ }++instance ToJSON Indent where+ toJSON i = JSON.String $ case i of+ Align -> "align"+ IndentBy x -> "indent-by " `T.append` T.pack (show x)+ AlignOrIndentBy x -> "align-or-indent-by " `T.append` T.pack (show x)++instance FromJSON Indent where+ parseJSON v@(JSON.String t) = maybe (JSON.typeMismatch "Indent" v) return $+ if t == "align"+ then Just Align+ else if "indent-by " `T.isPrefixOf` t+ then IndentBy <$> readMaybe (T.unpack $ T.drop 10 t)+ else if "align-or-indent-by " `T.isPrefixOf` t+ then AlignOrIndentBy <$> readMaybe (T.unpack $ T.drop 19 t)+ else Nothing++ parseJSON v = JSON.typeMismatch "Indent" v++instance ToJSON LayoutContext where+ toJSON = genericToJSON (enumOptions 0)++instance FromJSON LayoutContext where+ parseJSON = genericParseJSON (enumOptions 0)++instance ToJSON WsLoc where+ toJSON = genericToJSON (enumOptions 2)++instance FromJSON WsLoc where+ parseJSON = genericParseJSON (enumOptions 2)++instance ToJSON Whitespace where+ toJSON = genericToJSON (recordOptions 2)++instance FromJSON Whitespace where+ parseJSON = genericParseJSON (recordOptions 2)++instance ToJSON Layout where+ toJSON = genericToJSON (enumOptions 0)++instance FromJSON Layout where+ parseJSON = genericParseJSON (enumOptions 0)++layoutToText :: LayoutContext -> T.Text+layoutToText Declaration = "declaration"+layoutToText Type = "type"+layoutToText Pattern = "pattern"+layoutToText Expression = "expression"+layoutToText Other = "other"++textToLayout :: T.Text -> Maybe LayoutContext+textToLayout "declaration" = Just Declaration+textToLayout "type" = Just Type+textToLayout "pattern" = Just Pattern+textToLayout "expression" = Just Expression+textToLayout "other" = Just Other+textToLayout _ = Nothing++keyToText :: ConfigMapKey -> T.Text+keyToText (ConfigMapKey Nothing Nothing) = "default"+keyToText (ConfigMapKey (Just n) Nothing) = T.decodeUtf8 n+keyToText (ConfigMapKey Nothing (Just l)) = "* in " `T.append` layoutToText l+keyToText (ConfigMapKey (Just n) (Just l)) =+ T.decodeUtf8 n `T.append` " in " `T.append` layoutToText l++textToKey :: T.Text -> Maybe ConfigMapKey+textToKey t = case T.splitOn " in " t of+ [ "default" ] -> Just (ConfigMapKey Nothing Nothing)+ [ "*", "*" ] -> Just (ConfigMapKey Nothing Nothing)+ [ name ] -> Just (ConfigMapKey (Just (T.encodeUtf8 name)) Nothing)+ [ name, "*" ] -> Just (ConfigMapKey (Just (T.encodeUtf8 name)) Nothing)+ [ "*", layout ] -> ConfigMapKey Nothing . Just <$> textToLayout layout+ [ name, layout ] -> ConfigMapKey (Just (T.encodeUtf8 name)) . Just+ <$> textToLayout layout+ _ -> Nothing++instance ToJSON a => ToJSON (ConfigMap a) where+ toJSON ConfigMap{..} = toJSON $ Map.insert "default" cfgMapDefault $+ Map.mapKeys keyToText cfgMapOverrides++instance FromJSON a => FromJSON (ConfigMap a) where+ parseJSON value = do+ o <- parseJSON value+ cfgMapDefault <- maybe (fail "Missing key: default") return $+ HashMap.lookup "default" o+ cfgMapOverrides <- either fail (return . Map.fromList) $ mapM toKey $+ HashMap.toList $ HashMap.delete "default" o+ return ConfigMap { .. }+ where+ toKey (k, v) = case textToKey k of+ Just k' -> Right (k', v)+ Nothing -> Left ("Invalid key: " ++ T.unpack k)++instance ToJSON PenaltyConfig where+ toJSON = genericToJSON (recordOptions 7)++instance FromJSON PenaltyConfig where+ parseJSON = genericParseJSON (recordOptions 7)++instance ToJSON AlignConfig where+ toJSON = genericToJSON (recordOptions 8)++instance FromJSON AlignConfig where+ parseJSON = genericParseJSON (recordOptions 8)++instance ToJSON IndentConfig where+ toJSON = genericToJSON (recordOptions 9)++instance FromJSON IndentConfig where+ parseJSON = genericParseJSON (recordOptions 9)++instance ToJSON LayoutConfig where+ toJSON = genericToJSON (recordOptions 9)++instance FromJSON LayoutConfig where+ parseJSON = genericParseJSON (recordOptions 9)++instance ToJSON OpConfig where+ toJSON = genericToJSON (recordOptions 0)++instance FromJSON OpConfig where+ parseJSON = genericParseJSON (recordOptions 0)++instance ToJSON GroupConfig where+ toJSON = genericToJSON (recordOptions 0)++instance FromJSON GroupConfig where+ parseJSON = genericParseJSON (recordOptions 0)++instance ToJSON OptionConfig where+ toJSON = genericToJSON (recordOptions 9)++instance FromJSON OptionConfig where+ parseJSON = genericParseJSON (recordOptions 9)++instance ToJSON FlexConfig where+ toJSON = genericToJSON (recordOptions 3)++instance FromJSON FlexConfig where+ parseJSON = genericParseJSON (recordOptions 3)
+ src/Floskell/Pretty.hs view
@@ -0,0 +1,2143 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Floskell.Pretty where++import Control.Applicative ( (<|>) )+import Control.Monad+ ( forM_, guard, replicateM_, unless, void, when )+import Control.Monad.State.Strict ( get, gets, modify )++import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as BL++import Data.List ( groupBy, sortBy, sortOn )+import Data.Maybe ( catMaybes, fromMaybe )++import qualified Floskell.Buffer as Buffer+import Floskell.Config+import Floskell.Printers++import Floskell.Types++import Language.Haskell.Exts.Comments ( Comment(..) )+import qualified Language.Haskell.Exts.Pretty as HSE++import Language.Haskell.Exts.SrcLoc+ ( SrcSpan(..), noSrcSpan, srcInfoSpan )+import Language.Haskell.Exts.Syntax++-- | Like `span`, but comparing adjacent items.+run :: (a -> a -> Bool) -> [a] -> ([a], [a])+run _ [] = ([], [])+run _ [ x ] = ([ x ], [])+run eq (x : y : xs)+ | eq x y = let (ys, zs) = run eq (y : xs) in (x : ys, zs)+ | otherwise = ([ x ], y : xs)++-- | Like `groupBy`, but comparing adjacent items.+runs :: (a -> a -> Bool) -> [a] -> [[a]]+runs _ [] = []+runs eq xs = let (ys, zs) = run eq xs in ys : runs eq zs++stopImportModule :: TabStop+stopImportModule = TabStop "import-module"++stopImportSpec :: TabStop+stopImportSpec = TabStop "import-spec"++stopRecordField :: TabStop+stopRecordField = TabStop "record"++stopRhs :: TabStop+stopRhs = TabStop "rhs"++flattenApp :: Annotated ast+ => (ast NodeInfo -> Maybe (ast NodeInfo, ast NodeInfo))+ -> ast NodeInfo+ -> [ast NodeInfo]+flattenApp fn = go . amap (\info -> info { nodeInfoComments = [] })+ where+ go x = case fn x of+ Just (lhs, rhs) -> let lhs' = go $ copyComments Before x lhs+ rhs' = go $ copyComments After x rhs+ in+ lhs' ++ rhs'+ Nothing -> [ x ]++flattenInfix+ :: (Annotated ast1, Annotated ast2)+ => (ast1 NodeInfo -> Maybe (ast1 NodeInfo, ast2 NodeInfo, ast1 NodeInfo))+ -> ast1 NodeInfo+ -> (ast1 NodeInfo, [(ast2 NodeInfo, ast1 NodeInfo)])+flattenInfix fn = go . amap (\info -> info { nodeInfoComments = [] })+ where+ go x = case fn x of+ Just (lhs, op, rhs) ->+ let (lhs', ops) = go $ copyComments Before x lhs+ (lhs'', ops') = go $ copyComments After x rhs+ in+ (lhs', ops ++ (op, lhs'') : ops')+ Nothing -> (x, [])++-- | Syntax shortcut for Pretty Printers.+type PrettyPrinter f = f NodeInfo -> Printer ()++-- | Pretty printing prettyHSE using haskell-src-exts pretty printer+prettyHSE :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast+prettyHSE ast = string $ HSE.prettyPrint ast++-- | Type class for pretty-printable types.+class Pretty ast where+ prettyPrint :: PrettyPrinter ast+ default prettyPrint :: HSE.Pretty (ast NodeInfo) => PrettyPrinter ast+ prettyPrint = prettyHSE++-- | Pretty print a syntax tree with annotated comments+pretty :: (Annotated ast, Pretty ast) => PrettyPrinter ast+pretty ast = do+ printComments Before ast+ prettyPrint ast+ printComments After ast++prettyOnside :: (Annotated ast, Pretty ast) => PrettyPrinter ast+prettyOnside ast = do+ eol <- gets psEolComment+ when eol newline+ nl <- gets psNewline+ if nl+ then do+ printComments Before ast+ onside $ prettyPrint ast+ printComments After ast+ else onside $ pretty ast++-- | Empty NodeInfo+noNodeInfo :: NodeInfo+noNodeInfo = NodeInfo noSrcSpan []++-- | Compare two AST nodes ignoring the annotation+compareAST :: (Functor ast, Ord (ast ()))+ => ast NodeInfo+ -> ast NodeInfo+ -> Ordering+compareAST a b = void a `compare` void b++-- | Return comments with matching location.+filterComments :: Annotated a+ => (Maybe Location -> Bool)+ -> a NodeInfo+ -> [ComInfo]+filterComments f = filter (f . comInfoLocation) . nodeInfoComments . ann++-- | Copy comments from one AST node to another.+copyComments :: (Annotated ast1, Annotated ast2)+ => Location+ -> ast1 NodeInfo+ -> ast2 NodeInfo+ -> ast2 NodeInfo+copyComments loc from to = amap updateComments to+ where+ updateComments info =+ info { nodeInfoComments = oldComments ++ newComments }++ oldComments = filterComments (/= Just loc) to++ newComments = filterComments (== Just loc) from++-- | Pretty print a comment.+printComment :: Maybe SrcSpan -> Comment -> Printer ()+printComment mayNodespan (Comment inline cspan str) = do+ -- Insert proper amount of space before comment.+ -- This maintains alignment. This cannot force comments+ -- to go before the left-most possible indent (specified by depends).+ case mayNodespan of+ Just nodespan -> do+ let neededSpaces = srcSpanStartColumn cspan+ - max 1 (srcSpanEndColumn nodespan)+ replicateM_ neededSpaces space+ Nothing -> return ()++ if inline+ then do+ write "{-"+ string str+ write "-}"+ when (1 == srcSpanStartColumn cspan) $+ modify (\s -> s { psEolComment = True })+ else do+ write "--"+ string str+ modify (\s -> s { psEolComment = True })++-- | Print comments of a node.+printComments :: Annotated ast => Location -> ast NodeInfo -> Printer ()+printComments loc' ast = do+ let correctLocation comment = comInfoLocation comment == Just loc'+ commentsWithLocation = filter correctLocation (nodeInfoComments info)+ comments = map comInfoComment commentsWithLocation++ unless (null comments) $ do+ -- Preceeding comments must have a newline before them, but not break onside indent.+ nl <- gets psNewline+ onside' <- gets psOnside+ when nl $ modify $ \s -> s { psOnside = 0 }+ when (loc' == Before && not nl) newline++ forM_ comments $ printComment (Just $ srcInfoSpan $ nodeInfoSpan info)++ -- Write newline before restoring onside indent.+ eol <- gets psEolComment+ when (loc' == Before && eol && onside' > 0) newline+ when nl $ modify $ \s -> s { psOnside = onside' }+ where+ info = ann ast++-- | Return the configuration name of an operator+opName :: QOp a -> ByteString+opName op = case op of+ (QVarOp _ qname) -> opName' qname+ (QConOp _ qname) -> opName' qname++-- | Return the configuration name of an operator+opName' :: QName a -> ByteString+opName' (Qual _ _ (Ident _ _)) = "``"+opName' (Qual _ _ (Symbol _ _)) = ""+opName' (UnQual _ (Ident _ _)) = "``"+opName' (UnQual _ (Symbol _ str)) = BS8.pack str+opName' (Special _ (FunCon _)) = "->"+opName' (Special _ (Cons _)) = ":"+opName' (Special _ _) = ""++lineDelta :: Annotated ast => ast NodeInfo -> ast NodeInfo -> Int+lineDelta prev next = nextLine - prevLine+ where+ prevLine = maximum (prevNodeLine : prevCommentLines)++ nextLine = minimum (nextNodeLine : nextCommentLines)++ prevNodeLine = srcSpanEndLine $ annSrcSpan prev++ nextNodeLine = srcSpanStartLine $ annSrcSpan next++ annSrcSpan = srcInfoSpan . nodeInfoSpan . ann++ prevCommentLines = map (srcSpanEndLine . commentSrcSpan) $+ filterComments (== Just After) prev++ nextCommentLines = map (srcSpanStartLine . commentSrcSpan) $+ filterComments (== Just Before) next++ commentSrcSpan = (\(Comment _ sp _) -> sp) . comInfoComment++linedFn :: Annotated ast+ => (ast NodeInfo -> Printer ())+ -> [ast NodeInfo]+ -> Printer ()+linedFn fn xs = do+ preserveP <- getOption cfgOptionPreserveVerticalSpace+ if preserveP+ then case xs of+ x : xs' -> do+ cut $ fn x+ forM_ (zip xs xs') $ \(prev, cur) -> do+ replicateM_ (min 2 (max 1 $ lineDelta prev cur)) newline+ cut $ fn cur+ [] -> return ()+ else inter newline $ map (cut . fn) xs++lined :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()+lined = linedFn pretty++linedOnside :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()+linedOnside = linedFn prettyOnside++listVinternal :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listVinternal ctx sep xs = aligned $ do+ ws <- getConfig (cfgOpWs ctx sep . cfgOp)+ nl <- gets psNewline+ col <- getNextColumn+ let correction = if wsLinebreak After ws || length xs < 2+ then 0+ else BS.length sep + if wsSpace After ws then 1 else 0+ extraIndent = if nl then correction else 0+ itemCol = col + fromIntegral extraIndent+ sepCol = itemCol - fromIntegral correction+ case xs of+ [] -> newline+ (x : xs') -> column itemCol $ do+ cut $ do+ printCommentsSimple Before x+ cut . onside $ prettyPrint x+ printCommentsSimple After x+ forM_ xs' $ \x' -> do+ printComments Before x'+ column sepCol $ operatorV ctx sep+ cut . onside $ prettyPrint x'+ printComments After x'+ where+ printCommentsSimple loc ast =+ let comments = map comInfoComment $ filterComments (== Just loc) ast+ in+ forM_ comments $+ printComment (Just . srcInfoSpan . nodeInfoSpan $ ann ast)++listH :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> ByteString+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listH _ open close _ [] = do+ write open+ write close++listH ctx open close sep xs =+ groupH ctx open close . inter (operatorH ctx sep) $ map pretty xs++listV :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> ByteString+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listV ctx open close sep xs = groupV ctx open close $ do+ ws <- getConfig (cfgOpWs ctx sep . cfgOp)+ ws' <- getConfig (cfgGroupWs ctx open . cfgGroup)+ unless (wsLinebreak Before ws' || wsSpace After ws' || wsLinebreak After ws+ || not (wsSpace After ws))+ space+ listVinternal ctx sep xs++list :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> ByteString+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+list ctx open close sep xs = oneline hor <|> ver+ where+ hor = listH ctx open close sep xs++ ver = listV ctx open close sep xs++listH' :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listH' ctx sep = inter (operatorH ctx sep) . map pretty++listV' :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listV' = listVinternal++list' :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+list' ctx sep xs = oneline hor <|> ver+ where+ hor = listH' ctx sep xs++ ver = listV' ctx sep xs++listAutoWrap :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> ByteString+ -> ByteString+ -> ByteString+ -> [ast NodeInfo]+ -> Printer ()+listAutoWrap _ open close _ [] = do+ write open+ write close++listAutoWrap ctx open close sep (x : xs) =+ aligned . groupH ctx open close . aligned $ do+ ws <- getConfig (cfgOpWs ctx sep . cfgOp)+ let correction = if wsLinebreak After ws+ then 0+ else BS.length sep + if wsSpace After ws then 1 else 0+ col <- getNextColumn+ pretty x+ forM_ xs $ \x' -> do+ printComments Before x'+ cut $ do+ column (col - fromIntegral correction) $ operator ctx sep+ prettyPrint x'+ printComments After x'++measure :: Printer a -> Printer (Maybe Int)+measure p = do+ s <- get+ let s' = s { psBuffer = Buffer.empty, psEolComment = False }+ return $ case execPrinter (oneline p) s' of+ Nothing -> Nothing+ Just (_, s'') -> Just . fromIntegral . (\x -> x - psIndentLevel s)+ . BL.length . Buffer.toLazyByteString $ psBuffer s''++measureDecl :: Decl NodeInfo -> Printer (Maybe [Int])+measureDecl (PatBind _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)+measureDecl (FunBind _ matches) = sequence <$> traverse measureMatch matches+ where+ measureMatch (Match _ name pats _ Nothing) = measure $ do+ pretty name+ space+ inter space $ map pretty pats+ measureMatch (InfixMatch _ pat name pats _ Nothing) = measure $ do+ pretty pat+ pretty $ VarOp noNodeInfo name+ inter space $ map pretty pats+ measureMatch _ = return Nothing+measureDecl _ = return Nothing++measureClassDecl :: ClassDecl NodeInfo -> Printer (Maybe [Int])+measureClassDecl (ClsDecl _ decl) = measureDecl decl+measureClassDecl _ = return Nothing++measureInstDecl :: InstDecl NodeInfo -> Printer (Maybe [Int])+measureInstDecl (InsDecl _ decl) = measureDecl decl+measureInstDecl _ = return Nothing++measureAlt :: Alt NodeInfo -> Printer (Maybe [Int])+measureAlt (Alt _ pat _ Nothing) = fmap (: []) <$> measure (pretty pat)+measureAlt _ = return Nothing++withComputedTabStop :: TabStop+ -> (AlignConfig -> Bool)+ -> (a -> Printer (Maybe [Int]))+ -> [a]+ -> Printer b+ -> Printer b+withComputedTabStop name predicate fn xs p = do+ enabled <- getConfig (predicate . cfgAlign)+ (limAbs, limRel) <- getConfig (cfgAlignLimits . cfgAlign)+ mtabss <- sequence <$> traverse fn xs+ let tab = do+ tabss <- mtabss+ let tabs = concat tabss+ maxtab = maximum tabs+ mintab = minimum tabs+ delta = maxtab - mintab+ diff = delta * 100 `div` maxtab+ guard enabled+ guard $ delta <= limAbs || diff <= limRel+ return maxtab+ withTabStops [ (name, tab) ] p++------------------------------------------------------------------------+-- Module+-- | Extract the name as a String from a ModuleName+moduleName :: ModuleName a -> String+moduleName (ModuleName _ s) = s++nameLength :: Name a -> Int+nameLength (Ident _ i) = length i+nameLength (Symbol _ s) = 2 + length s++qnameLength :: QName a -> Int+qnameLength (Qual _ mname name) = length (moduleName mname) + nameLength name+ + 1+qnameLength (UnQual _ name) = nameLength name+qnameLength (Special _ con) = case con of+ UnitCon _ -> 2+ ListCon _ -> 2+ FunCon _ -> 2+ TupleCon _ boxed n -> 2 + n + case boxed of+ Boxed -> 2+ Unboxed -> 0+ Cons _ -> 1+ UnboxedSingleCon _ -> 5+ ExprHole _ -> 1++prettyPragmas :: [ModulePragma NodeInfo] -> Printer ()+prettyPragmas ps = do+ splitP <- getOption cfgOptionSplitLanguagePragmas+ sortP <- getOption cfgOptionSortPragmas+ let ps' = if splitP then concatMap splitPragma ps else ps+ let ps'' = if sortP then sortBy compareAST ps' else ps'+ inter blankline . map lined $ groupBy sameType ps''+ where+ splitPragma (LanguagePragma anno langs) =+ map (LanguagePragma anno . (: [])) langs+ splitPragma p = [ p ]++ sameType LanguagePragma{} LanguagePragma{} = True+ sameType OptionsPragma{} OptionsPragma{} = True+ sameType AnnModulePragma{} AnnModulePragma{} = True+ sameType _ _ = False++prettyImports :: [ImportDecl NodeInfo] -> Printer ()+prettyImports is = do+ sortP <- getOption cfgOptionSortImports+ alignModuleP <- getConfig (cfgAlignImportModule . cfgAlign)+ alignSpecP <- getConfig (cfgAlignImportSpec . cfgAlign)+ let maxNameLength = maximum $ map (length . moduleName . importModule) is+ alignModule = if alignModuleP then Just 16 else Nothing+ alignSpec = if alignSpecP+ then Just (fromMaybe 0 alignModule + 1 + maxNameLength)+ else Nothing+ withTabStops [ (stopImportModule, alignModule)+ , (stopImportSpec, alignSpec)+ ] $ if sortP+ then inter blankline . map lined . groupBy samePrefix $+ sortOn (moduleName . importModule) is+ else lined is+ where+ samePrefix left right = prefix left == prefix right++ prefix = takeWhile (/= '.') . moduleName . importModule++skipBlank :: Annotated ast+ => (ast NodeInfo -> ast NodeInfo -> Bool)+ -> ast NodeInfo+ -> ast NodeInfo+ -> Bool+skipBlank skip a b = skip a b && null (comments After a)+ && null (comments Before b)+ where+ comments loc = filterComments (== Just loc)++skipBlankAfterDecl :: Decl a -> Bool+skipBlankAfterDecl a = case a of+ TypeSig{} -> True+ DeprPragmaDecl{} -> True+ WarnPragmaDecl{} -> True+ AnnPragma{} -> True+ MinimalPragma{} -> True+ InlineSig{} -> True+ InlineConlikeSig{} -> True+ SpecSig{} -> True+ SpecInlineSig{} -> True+ InstSig{} -> True+ PatSynSig{} -> True+ _ -> False++skipBlankDecl :: Decl NodeInfo -> Decl NodeInfo -> Bool+skipBlankDecl = skipBlank $ \a _ -> skipBlankAfterDecl a++skipBlankClassDecl :: ClassDecl NodeInfo -> ClassDecl NodeInfo -> Bool+skipBlankClassDecl = skipBlank $ \a _ -> case a of+ (ClsDecl _ decl) -> skipBlankAfterDecl decl+ ClsTyDef{} -> True+ ClsDefSig{} -> True+ _ -> False++skipBlankInstDecl :: InstDecl NodeInfo -> InstDecl NodeInfo -> Bool+skipBlankInstDecl = skipBlank $ \a _ -> case a of+ (InsDecl _ decl) -> skipBlankAfterDecl decl+ _ -> False++prettyDecls :: (Annotated ast, Pretty ast)+ => (ast NodeInfo -> ast NodeInfo -> Bool)+ -> [ast NodeInfo]+ -> Printer ()+prettyDecls fn = inter blankline . map lined . runs fn++prettySimpleDecl :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)+ => ast1 NodeInfo+ -> ByteString+ -> ast2 NodeInfo+ -> Printer ()+prettySimpleDecl lhs op rhs = withLayout cfgLayoutDeclaration flex vertical+ where+ flex = do+ pretty lhs+ operator Declaration op+ pretty rhs++ vertical = do+ pretty lhs+ operatorV Declaration op+ pretty rhs++prettyConDecls :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()+prettyConDecls condecls = withLayout cfgLayoutConDecls flex vertical+ where+ flex = listH' Declaration "|" condecls++ vertical = listV' Declaration "|" condecls++prettyForall :: (Annotated ast, Pretty ast) => [ast NodeInfo] -> Printer ()+prettyForall vars = do+ write "forall "+ inter space $ map pretty vars+ operator Type "."++prettyTypesig :: (Annotated ast, Pretty ast)+ => LayoutContext+ -> [ast NodeInfo]+ -> Type NodeInfo+ -> Printer ()+prettyTypesig ctx names ty = withLayout cfgLayoutTypesig flex vertical+ where+ flex = do+ inter comma $ map pretty names+ atTabStop stopRecordField+ operator ctx "::"+ pretty ty++ vertical = do+ inter comma $ map pretty names+ atTabStop stopRecordField+ alignOnOperator ctx "::" $ pretty' ty++ pretty' (TyForall _ mtyvarbinds mcontext ty') = do+ forM_ mtyvarbinds $ \tyvarbinds -> do+ write "forall "+ inter space $ map pretty tyvarbinds+ withOperatorFormattingV Type "." (write "." >> space) id+ forM_ mcontext $ \context -> do+ case context of+ (CxSingle _ asst) -> pretty asst+ (CxTuple _ assts) -> list Type "(" ")" "," assts+ (CxEmpty _) -> write "()"+ operatorV Type "=>"+ pretty' ty'+ pretty' (TyFun _ ty' ty'') = do+ pretty ty'+ operatorV Type "->"+ pretty' ty''+ pretty' ty' = pretty ty'++prettyApp :: (Annotated ast1, Annotated ast2, Pretty ast1, Pretty ast2)+ => ast1 NodeInfo+ -> [ast2 NodeInfo]+ -> Printer ()+prettyApp fn args = withLayout cfgLayoutApp flex vertical+ where+ flex = do+ pretty fn+ forM_ args $ \arg -> cut $ do+ spaceOrNewline+ pretty arg++ vertical = do+ pretty fn+ withIndent cfgIndentApp $ linedOnside args++prettyInfixApp :: (Annotated ast, Pretty ast, HSE.Pretty (op NodeInfo))+ => (op NodeInfo -> ByteString)+ -> LayoutContext+ -> (ast NodeInfo, [(op NodeInfo, ast NodeInfo)])+ -> Printer ()+prettyInfixApp nameFn ctx (lhs, args) =+ withLayout cfgLayoutInfixApp flex vertical+ where+ flex = do+ pretty lhs+ forM_ args $ \(op, arg) -> cut $ do+ withOperatorFormatting ctx (nameFn op) (prettyHSE op) id+ pretty arg++ vertical = do+ pretty lhs+ forM_ args $ \(op, arg) -> do+ withOperatorFormattingV ctx (nameFn op) (prettyHSE op) id+ pretty arg++prettyRecord :: (Annotated ast1, Pretty ast1, Annotated ast2, Pretty ast2)+ => (ast2 NodeInfo -> Printer (Maybe Int))+ -> LayoutContext+ -> ast1 NodeInfo+ -> [ast2 NodeInfo]+ -> Printer ()+prettyRecord len ctx name fields = withLayout cfgLayoutRecord flex vertical+ where+ flex = do+ withOperatorFormattingH ctx "record" (pretty name) id+ groupH ctx "{" "}" $ inter (operatorH ctx ",") $+ map prettyOnside fields++ vertical = do+ withOperatorFormatting ctx "record" (pretty name) id+ groupV ctx "{" "}" $ withComputedTabStop stopRecordField+ cfgAlignRecordFields+ (fmap (fmap pure) . len)+ fields $+ listVinternal ctx "," fields++prettyRecordFields :: (Annotated ast, Pretty ast)+ => (ast NodeInfo -> Printer (Maybe Int))+ -> LayoutContext+ -> [ast NodeInfo]+ -> Printer ()+prettyRecordFields len ctx fields = withLayout cfgLayoutRecord flex vertical+ where+ flex = groupH ctx "{" "}" $ inter (operatorH ctx ",") $+ map prettyOnside fields++ vertical = groupV ctx "{" "}" $+ withComputedTabStop stopRecordField+ cfgAlignRecordFields+ (fmap (fmap pure) . len)+ fields $ listVinternal ctx "," fields++prettyPragma :: ByteString -> Printer () -> Printer ()+prettyPragma name = prettyPragma' name . Just++prettyPragma' :: ByteString -> Maybe (Printer ()) -> Printer ()+prettyPragma' name mp = do+ write "{-# "+ write name+ mayM_ mp $ withPrefix space aligned+ write " #-}"++instance Pretty Module where+ prettyPrint (Module _ mhead pragmas imports decls) = inter blankline $+ catMaybes [ ifNotEmpty prettyPragmas pragmas+ , pretty <$> mhead+ , ifNotEmpty prettyImports imports+ , ifNotEmpty (prettyDecls skipBlankDecl) decls+ ]+ where+ ifNotEmpty f xs = if null xs then Nothing else Just (f xs)++ prettyPrint ast@XmlPage{} = prettyHSE ast+ prettyPrint ast@XmlHybrid{} = prettyHSE ast++instance Pretty ModuleHead where+ prettyPrint (ModuleHead _ name mwarning mexports) = do+ depend "module" $ do+ pretty name+ mayM_ mwarning $ withPrefix spaceOrNewline pretty+ mayM_ mexports pretty+ write " where"++instance Pretty WarningText where+ prettyPrint (DeprText _ s) = write "{-# DEPRECATED " >> string (show s)+ >> write " #-}"+ prettyPrint (WarnText _ s) = write "{-# WARNING " >> string (show s)+ >> write " #-}"++instance Pretty ExportSpecList where+ prettyPrint (ExportSpecList _ exports) =+ withLayout cfgLayoutExportSpecList flex vertical+ where+ flex = do+ space+ listAutoWrap Other "(" ")" "," exports++ vertical = withIndent cfgIndentExportSpecList $+ listV Other "(" ")" "," exports++instance Pretty ExportSpec++instance Pretty ImportDecl where+ prettyPrint ImportDecl{..} = do+ inter space . map write $+ filter (not . BS.null)+ [ "import"+ , if importSrc then "{-# SOURCE #-}" else ""+ , if importSafe then "safe" else ""+ , if importQualified then "qualified" else ""+ ]+ atTabStop stopImportModule+ space+ string $ moduleName importModule+ mayM_ importAs $ \name -> do+ atTabStop stopImportSpec+ write " as "+ pretty name+ mayM_ importSpecs pretty++instance Pretty ImportSpecList where+ prettyPrint (ImportSpecList _ hiding specs) = do+ sortP <- getOption cfgOptionSortImportLists+ let specs' = if sortP then sortOn HSE.prettyPrint specs else specs+ atTabStop stopImportSpec+ withLayout cfgLayoutImportSpecList (flex specs') (vertical specs')+ where+ flex imports = do+ when hiding $ write " hiding"+ space+ listAutoWrap Other "(" ")" "," imports++ vertical imports = withIndent cfgIndentImportSpecList $ do+ when hiding $ write "hiding "+ listAutoWrap Other "(" ")" "," imports++instance Pretty ImportSpec++instance Pretty Assoc++instance Pretty Decl where+ prettyPrint (TypeDecl _ declhead ty) =+ depend "type" $ prettySimpleDecl declhead "=" ty++ prettyPrint (TypeFamDecl _ declhead mresultsig minjectivityinfo) =+ depend "type family" $ do+ pretty declhead+ mayM_ mresultsig pretty+ mayM_ minjectivityinfo pretty++ prettyPrint (ClosedTypeFamDecl _+ declhead+ mresultsig+ minjectivityinfo+ typeeqns) = depend "type family" $ do+ pretty declhead+ mayM_ mresultsig pretty+ mayM_ minjectivityinfo pretty+ write " where"+ newline+ linedOnside typeeqns++ prettyPrint (DataDecl _ dataornew mcontext declhead qualcondecls derivings) = do+ depend' (pretty dataornew) $ do+ mapM_ pretty mcontext+ pretty declhead+ unless (null qualcondecls) $+ withLayout cfgLayoutDeclaration flex vertical+ mapM_ pretty derivings+ where+ flex = do+ operator Declaration "="+ prettyConDecls qualcondecls++ vertical = do+ operatorV Declaration "="+ prettyConDecls qualcondecls++ prettyPrint (GDataDecl _+ dataornew+ mcontext+ declhead+ mkind+ gadtdecls+ derivings) = do+ depend' (pretty dataornew) $ do+ mapM_ pretty mcontext+ pretty declhead+ mayM_ mkind $ \kind -> do+ operator Declaration "::"+ pretty kind+ write " where"+ newline+ linedOnside gadtdecls+ mapM_ pretty derivings++ prettyPrint (DataFamDecl _ mcontext declhead mresultsig) =+ depend "data family" $ do+ mapM_ pretty mcontext+ pretty declhead+ mapM_ pretty mresultsig++ prettyPrint (TypeInsDecl _ ty ty') =+ depend "type instance" $ prettySimpleDecl ty "=" ty'++ prettyPrint (DataInsDecl _ dataornew ty qualcondecls derivings) = do+ depend' (pretty dataornew >> write " instance") $ do+ pretty ty+ withLayout cfgLayoutDeclaration flex vertical+ mapM_ pretty derivings+ where+ flex = do+ operator Declaration "="+ prettyConDecls qualcondecls++ vertical = do+ operatorV Declaration "="+ prettyConDecls qualcondecls++ prettyPrint (GDataInsDecl _ dataornew ty mkind gadtdecls derivings) = do+ depend' (pretty dataornew >> write " instance") $ do+ pretty ty+ mayM_ mkind $ \kind -> do+ operator Declaration "::"+ pretty kind+ write " where"+ newline+ linedOnside gadtdecls+ mapM_ pretty derivings++ prettyPrint (ClassDecl _ mcontext declhead fundeps mclassdecls) = do+ depend "class" $ do+ mapM_ pretty mcontext+ pretty declhead+ unless (null fundeps) $ do+ operator Declaration "|"+ list' Declaration "," fundeps+ mayM_ mclassdecls $ \decls -> do+ write " where"+ withIndent cfgIndentClass $ withComputedTabStop stopRhs+ cfgAlignClass+ measureClassDecl+ decls $+ prettyDecls skipBlankClassDecl decls++ prettyPrint (InstDecl _ moverlap instrule minstdecls) = do+ depend "instance" $ do+ mapM_ pretty moverlap+ pretty instrule+ mayM_ minstdecls $ \decls -> do+ write " where"+ withIndent cfgIndentClass $+ withComputedTabStop stopRhs cfgAlignClass measureInstDecl decls $+ prettyDecls skipBlankInstDecl decls++ prettyPrint (DerivDecl _ mderivstrategy moverlap instrule) =+ depend "deriving" $ do+ mayM_ mderivstrategy $ withPostfix space pretty+ write "instance "+ mayM_ moverlap $ withPostfix space pretty+ pretty instrule++ prettyPrint (InfixDecl _ assoc mint ops) = onside $ do+ pretty assoc+ mayM_ mint $ withPrefix space (int . fromIntegral)+ space+ inter comma $ map prettyHSE ops++ prettyPrint (DefaultDecl _ types) = do+ write "default "+ listAutoWrap Other "(" ")" "," types++ prettyPrint (SpliceDecl _ expr) = pretty expr++ prettyPrint (TypeSig _ names ty) =+ onside $ prettyTypesig Declaration names ty++ prettyPrint (PatSynSig _ names mtyvarbinds mcontext mcontext' ty) =+ depend "pattern" $ do+ inter comma $ map pretty names+ operator Declaration "::"+ mapM_ prettyForall mtyvarbinds+ mayM_ mcontext pretty+ mayM_ mcontext' pretty+ pretty ty++ prettyPrint (FunBind _ matches) = linedOnside matches++ prettyPrint (PatBind _ pat rhs mbinds) = do+ onside $ do+ pretty pat+ atTabStop stopRhs+ pretty rhs+ mapM_ pretty mbinds++ prettyPrint (PatSyn _ pat pat' patternsyndirection) = do+ depend "pattern" $ prettySimpleDecl pat sep pat'+ case patternsyndirection of+ ExplicitBidirectional _ decls -> pretty (BDecls noNodeInfo decls)+ _ -> return ()+ where+ sep = case patternsyndirection of+ ImplicitBidirectional -> "="+ ExplicitBidirectional _ _ -> "<-"+ Unidirectional -> "<-"++ prettyPrint (ForImp _ callconv msafety mstring name ty) =+ depend "foreign import" $ do+ pretty callconv+ mayM_ msafety $ withPrefix space pretty+ mayM_ mstring $ withPrefix space (string . show)+ space+ prettyTypesig Declaration [ name ] ty++ prettyPrint (ForExp _ callconv mstring name ty) =+ depend "foreign export" $ do+ pretty callconv+ mayM_ mstring $ withPrefix space (string . show)+ space+ prettyTypesig Declaration [ name ] ty++ prettyPrint (RulePragmaDecl _ rules) =+ if null rules+ then prettyPragma' "RULES" Nothing+ else prettyPragma "RULES" $ mapM_ pretty rules++ prettyPrint (DeprPragmaDecl _ deprecations) =+ if null deprecations+ then prettyPragma' "DEPRECATED" Nothing+ else prettyPragma "DEPRECATED" $ forM_ deprecations $+ \(names, str) -> do+ unless (null names) $ do+ inter comma $ map pretty names+ space+ string (show str)++ prettyPrint (WarnPragmaDecl _ warnings) =+ if null warnings+ then prettyPragma' "WARNING" Nothing+ else prettyPragma "WARNING" $ forM_ warnings $ \(names, str) -> do+ unless (null names) $ do+ inter comma $ map pretty names+ space+ string (show str)++ prettyPrint (InlineSig _ inline mactivation qname) = prettyPragma name $ do+ mayM_ mactivation $ withPostfix space pretty+ pretty qname+ where+ name = if inline then "INLINE" else "NOINLINE"++ prettyPrint (InlineConlikeSig _ mactivation qname) =+ prettyPragma "INLINE CONLIKE" $ do+ mayM_ mactivation $ withPostfix space pretty+ pretty qname++ prettyPrint (SpecSig _ mactivation qname types) =+ prettyPragma "SPECIALISE" $ do+ mayM_ mactivation $ withPostfix space pretty+ pretty qname+ operator Declaration "::"+ inter comma $ map pretty types++ prettyPrint (SpecInlineSig _ inline mactivation qname types) =+ prettyPragma name $ do+ mayM_ mactivation $ withPostfix space pretty+ pretty qname+ operator Declaration "::"+ inter comma $ map pretty types+ where+ name = if inline then "SPECIALISE INLINE" else "SPECIALISE NOINLINE"++ prettyPrint (InstSig _ instrule) =+ prettyPragma "SPECIALISE instance" $ pretty instrule++ prettyPrint (AnnPragma _ annotation) =+ prettyPragma "ANN" $ pretty annotation++ prettyPrint (MinimalPragma _ mbooleanformula) =+ prettyPragma "MINIMAL" $ mapM_ pretty mbooleanformula++ -- prettyPrint (RoleAnnotDecl _ qname roles) = undefined+ prettyPrint decl = prettyHSE decl++instance Pretty DeclHead where+ prettyPrint (DHead _ name) = pretty name++ prettyPrint (DHInfix _ tyvarbind name) = do+ pretty tyvarbind+ pretty $ VarOp noNodeInfo name++ prettyPrint (DHParen _ declhead) = parens $ pretty declhead++ prettyPrint (DHApp _ declhead tyvarbind) = depend' (pretty declhead) $+ pretty tyvarbind++instance Pretty InstRule where+ prettyPrint (IRule _ mtyvarbinds mcontext insthead) = do+ mapM_ prettyForall mtyvarbinds+ mapM_ pretty mcontext+ pretty insthead++ prettyPrint (IParen _ instrule) = parens $ pretty instrule++instance Pretty InstHead where+ prettyPrint (IHCon _ qname) = pretty qname++ prettyPrint (IHInfix _ ty qname) = do+ pretty ty+ space+ pretty qname++ prettyPrint (IHParen _ insthead) = parens $ pretty insthead++ prettyPrint (IHApp _ insthead ty) = depend' (pretty insthead) $ pretty ty++instance Pretty Binds where+ prettyPrint (BDecls _ decls) = withIndentBy cfgIndentWhere $ do+ write "where"+ withIndent cfgIndentWhereBinds $+ withComputedTabStop stopRhs cfgAlignWhere measureDecl decls $+ prettyDecls skipBlankDecl decls++ prettyPrint (IPBinds _ ipbinds) = withIndentBy cfgIndentWhere $ do+ write "where"+ withIndent cfgIndentWhereBinds $ linedOnside ipbinds++instance Pretty IPBind where+ prettyPrint (IPBind _ ipname expr) = prettySimpleDecl ipname "=" expr++instance Pretty InjectivityInfo where+ prettyPrint (InjectivityInfo _ name names) = do+ operator Declaration "|"+ pretty name+ operator Declaration "->"+ inter space $ map pretty names++instance Pretty ResultSig where+ prettyPrint (KindSig _ kind) =+ withLayout cfgLayoutDeclaration flex vertical+ where+ flex = do+ operator Declaration "::"+ pretty kind++ vertical = do+ operatorV Declaration "::"+ pretty kind++ prettyPrint (TyVarSig _ tyvarbind) =+ withLayout cfgLayoutDeclaration flex vertical+ where+ flex = do+ operator Declaration "="+ pretty tyvarbind++ vertical = do+ operatorV Declaration "="+ pretty tyvarbind++instance Pretty ClassDecl where+ prettyPrint (ClsDecl _ decl) = pretty decl++ prettyPrint (ClsDataFam _ mcontext declhead mresultsig) = depend "data" $ do+ mapM_ pretty mcontext+ pretty declhead+ mayM_ mresultsig pretty++ prettyPrint (ClsTyFam _ declhead mresultsig minjectivityinfo) =+ depend "type" $ do+ pretty declhead+ mayM_ mresultsig pretty+ mapM_ pretty minjectivityinfo++ prettyPrint (ClsTyDef _ typeeqn) = depend "type" $ pretty typeeqn++ prettyPrint (ClsDefSig _ name ty) =+ depend "default" $ prettyTypesig Declaration [ name ] ty++instance Pretty InstDecl where+ prettyPrint (InsDecl _ decl) = pretty decl++ prettyPrint (InsType _ ty ty') =+ depend "type" $ prettySimpleDecl ty "=" ty'++ prettyPrint (InsData _ dataornew ty qualcondecls derivings) =+ depend' (pretty dataornew) $ do+ pretty ty+ unless (null qualcondecls) $+ withLayout cfgLayoutDeclaration flex vertical+ mapM_ pretty derivings+ where+ flex = do+ operator Declaration "="+ prettyConDecls qualcondecls++ vertical = do+ operatorV Declaration "="+ prettyConDecls qualcondecls++ prettyPrint (InsGData _ dataornew ty mkind gadtdecls derivings) = do+ depend' (pretty dataornew) $ do+ pretty ty+ mayM_ mkind $ \kind -> do+ operator Declaration "::"+ pretty kind+ write " where"+ newline+ lined gadtdecls+ mapM_ pretty derivings++instance Pretty Deriving where+ prettyPrint (Deriving _ mderivstrategy instrules) =+ withIndentBy cfgIndentDeriving $ do+ write "deriving "+ mayM_ mderivstrategy $ withPostfix space pretty+ case instrules of+ [ i@IRule{} ] -> pretty i+ [ IParen _ i ] -> listAutoWrap Other "(" ")" "," [ i ]+ _ -> listAutoWrap Other "(" ")" "," instrules++instance Pretty ConDecl where+ prettyPrint (ConDecl _ name types) = do+ pretty name+ unless (null types) $ do+ space+ oneline hor <|> ver+ where+ hor = inter space $ map pretty types++ ver = aligned $ linedOnside types++ prettyPrint (InfixConDecl _ ty name ty') = do+ pretty ty+ pretty $ ConOp noNodeInfo name+ pretty ty'++ prettyPrint (RecDecl _ name fielddecls) =+ prettyRecord len Declaration name fielddecls+ where+ len (FieldDecl _ names _) = measure $ inter comma $ map pretty names++instance Pretty FieldDecl where+ prettyPrint (FieldDecl _ names ty) = prettyTypesig Declaration names ty++instance Pretty QualConDecl where+ prettyPrint (QualConDecl _ mtyvarbinds mcontext condecl) = do+ mapM_ prettyForall mtyvarbinds+ mapM_ pretty mcontext+ pretty condecl++instance Pretty GadtDecl where+ prettyPrint (GadtDecl _ name mfielddecls ty) = do+ pretty name+ operator Declaration "::"+ mayM_ mfielddecls $ \decls -> do+ prettyRecordFields len Declaration decls+ operator Type "->"+ pretty ty+ where+ len (FieldDecl _ names _) = measure $ inter comma $ map pretty names++instance Pretty Match where+ prettyPrint (Match _ name pats rhs mbinds) = do+ onside $ do+ pretty name+ unless (null pats) $ do+ space+ inter space $ map pretty pats+ atTabStop stopRhs+ pretty rhs+ mapM_ pretty mbinds++ prettyPrint (InfixMatch _ pat name pats rhs mbinds) = do+ onside $ do+ pretty pat+ pretty $ VarOp noNodeInfo name+ inter space $ map pretty pats+ atTabStop stopRhs+ pretty rhs+ mapM_ pretty mbinds++instance Pretty Rhs where+ prettyPrint (UnGuardedRhs _ expr) =+ cut $ withLayout cfgLayoutDeclaration flex vertical+ where+ flex = do+ operator Declaration "="+ pretty expr++ vertical = do+ operatorV Declaration "="+ pretty expr++ prettyPrint (GuardedRhss _ guardedrhss) =+ withIndent cfgIndentMultiIf $ linedOnside guardedrhss++instance Pretty GuardedRhs where+ prettyPrint (GuardedRhs _ stmts expr) =+ withLayout cfgLayoutDeclaration flex vertical+ where+ flex = do+ operatorSectionR Pattern "|" $ write "|"+ inter comma $ map pretty stmts+ operator Declaration "="+ pretty expr++ vertical = do+ operatorSectionR Pattern "|" $ write "|"+ inter comma $ map pretty stmts+ operatorV Declaration "="+ pretty expr++instance Pretty Context where+ prettyPrint (CxSingle _ asst) = do+ pretty asst+ operator Type "=>"++ prettyPrint (CxTuple _ assts) = do+ list Type "(" ")" "," assts+ operator Type "=>"++ prettyPrint (CxEmpty _) = do+ write "()"+ operator Type "=>"++instance Pretty FunDep where+ prettyPrint (FunDep _ names names') = do+ inter space $ map pretty names+ operator Declaration "->"+ inter space $ map pretty names'++instance Pretty Asst where+ prettyPrint (ClassA _ qname types) = do+ pretty qname+ space+ inter space $ map pretty types++ prettyPrint (AppA _ name types) = do+ pretty name+ space+ inter space $ map pretty types++ prettyPrint (InfixA _ ty qname ty') = do+ pretty ty+ pretty $ QVarOp noNodeInfo qname+ pretty ty'++ prettyPrint (IParam _ ipname ty) = prettyTypesig Declaration [ ipname ] ty++ prettyPrint (EqualP _ ty ty') = do+ pretty ty+ operator Type "~"+ pretty ty'++ prettyPrint (ParenA _ asst) = parens $ pretty asst++ prettyPrint (WildCardA _ mname) = do+ write "_"+ mapM_ pretty mname++instance Pretty Type where+ prettyPrint (TyForall _ mtyvarbinds mcontext ty) = do+ mapM_ prettyForall mtyvarbinds+ mapM_ pretty mcontext+ pretty ty++ prettyPrint (TyFun _ ty ty') = do+ pretty ty+ operator Type "->"+ pretty ty'++ prettyPrint (TyTuple _ boxed tys) = case boxed of+ Unboxed -> list Type "(#" "#)" "," tys+ Boxed -> list Type "(" ")" "," tys++ prettyPrint (TyUnboxedSum _ tys) = list Type "(#" "#)" "|" tys++ prettyPrint (TyList _ ty) = group Type "[" "]" $ pretty ty++ prettyPrint (TyParArray _ ty) = group Type "[:" ":]" $ pretty ty++ prettyPrint (TyApp _ ty ty') = do+ pretty ty+ space+ pretty ty'++ prettyPrint (TyVar _ name) = pretty name++ prettyPrint (TyCon _ qname) = pretty qname++ prettyPrint (TyParen _ ty) = parens $ pretty ty++ prettyPrint (TyInfix _ ty op ty') = do+ pretty ty+ withOperatorFormatting Type opname (prettyHSE op) id+ pretty ty'+ where+ opname = opName' $ case op of+ PromotedName _ qname -> qname+ UnpromotedName _ qname -> qname++ prettyPrint (TyKind _ ty kind) = do+ pretty ty+ operator Type "::"+ pretty kind++ prettyPrint t@(TyPromoted _ _promoted) = prettyHSE t++ prettyPrint (TyEquals _ ty ty') = do+ pretty ty+ operator Type "~"+ pretty ty'++ prettyPrint (TySplice _ splice) = pretty splice++ prettyPrint (TyBang _ bangtype unpackedness ty) = do+ pretty unpackedness+ pretty bangtype+ pretty ty++ prettyPrint t@(TyWildCard _ _mname) = prettyHSE t++ prettyPrint (TyQuasiQuote _ str str') = do+ write "["+ string str+ write "|"+ string str'+ write "|]"++instance Pretty Kind where+ prettyPrint (KindStar _) = write "*"++ prettyPrint (KindFn _ kind kind') = do+ pretty kind+ operator Type "->"+ pretty kind'++ prettyPrint (KindParen _ kind) = parens $ pretty kind++ prettyPrint (KindVar _ qname) = pretty qname++ prettyPrint (KindApp _ kind kind') = do+ pretty kind+ space+ pretty kind'++ prettyPrint (KindTuple _ kinds) = list Type "'(" ")" "," kinds++ prettyPrint (KindList _ kind) = group Type "'[" "]" $ pretty kind++instance Pretty TyVarBind where+ prettyPrint (KindedVar _ name kind) = parens $ do+ pretty name+ operator Type "::"+ pretty kind++ prettyPrint (UnkindedVar _ name) = pretty name++instance Pretty TypeEqn where+ prettyPrint (TypeEqn _ ty ty') = do+ pretty ty+ operator Type "="+ pretty ty'++instance Pretty Exp where+ prettyPrint (Var _ qname) = pretty qname++ prettyPrint (OverloadedLabel _ str) = do+ write "#"+ string str++ prettyPrint (IPVar _ ipname) = pretty ipname++ prettyPrint (Con _ qname) = pretty qname++ prettyPrint (Lit _ literal) = pretty literal++ prettyPrint e@(InfixApp _ _ qop _) =+ prettyInfixApp opName Expression $ flattenInfix flattenInfixApp e+ where+ flattenInfixApp (InfixApp _ lhs qop' rhs) =+ if compareAST qop qop' == EQ+ then Just (lhs, qop', rhs)+ else Nothing+ flattenInfixApp _ = Nothing++ prettyPrint e@App{} = case flattenApp flatten e of+ fn : args -> prettyApp fn args+ [] -> error "impossible"+ where+ flatten (App _ fn arg) = Just (fn, arg)+ flatten _ = Nothing++ prettyPrint (NegApp _ expr) = do+ write "-"+ pretty expr++ prettyPrint (Lambda _ pats expr) = do+ write "\\"+ maybeSpace+ inter space $ map pretty pats+ operator Expression "->"+ pretty expr+ where+ maybeSpace = case pats of+ PIrrPat{} : _ -> space+ PBangPat{} : _ -> space+ _ -> return ()++ prettyPrint (Let _ binds expr) = withLayout cfgLayoutLet flex vertical+ where+ flex = do+ write "let "+ prettyOnside (CompactBinds binds)+ spaceOrNewline+ write "in "+ prettyOnside expr++ vertical = withIndentFlat cfgIndentLet "let" $ do+ withIndent cfgIndentLetBinds $ pretty (CompactBinds binds)+ newline+ write "in"+ withIndent cfgIndentLetIn $ pretty expr++ prettyPrint (If _ expr expr' expr'') = withLayout cfgLayoutIf flex vertical+ where+ flex = do+ write "if "+ prettyOnside expr+ spaceOrNewline+ write "then "+ prettyOnside expr'+ spaceOrNewline+ write "else "+ prettyOnside expr''++ vertical = withIndentFlat cfgIndentIf "if " $ do+ prettyOnside expr+ newline+ write "then "+ prettyOnside expr'+ newline+ write "else "+ prettyOnside expr''++ prettyPrint (MultiIf _ guardedrhss) = do+ write "if"+ withIndent cfgIndentMultiIf . linedOnside $ map GuardedAlt guardedrhss++ prettyPrint (Case _ expr alts) = do+ write "case "+ pretty expr+ write " of"+ if null alts+ then write " { }"+ else withIndent cfgIndentCase $+ withComputedTabStop stopRhs cfgAlignCase measureAlt alts $+ lined alts++ prettyPrint (Do _ stmts) = do+ write "do"+ withIndent cfgIndentDo $ linedOnside stmts++ prettyPrint (MDo _ stmts) = do+ write "mdo"+ withIndent cfgIndentDo $ linedOnside stmts++ prettyPrint (Tuple _ boxed exprs) = case boxed of+ Boxed -> list Expression "(" ")" "," exprs+ Unboxed -> list Expression "(#" "#)" "," exprs++ prettyPrint (UnboxedSum _ before after expr) = group Expression "(#" "#)"+ . inter space $ replicate before (write "|") ++ [ pretty expr ]+ ++ replicate after (write "|")++ prettyPrint (TupleSection _ boxed mexprs) = case boxed of+ Boxed -> list Expression "(" ")" "," $ map MayAst mexprs+ Unboxed -> list Expression "(#" "#)" "," $ map MayAst mexprs++ prettyPrint (List _ exprs) = list Expression "[" "]" "," exprs++ prettyPrint (ParArray _ exprs) = list Expression "[:" ":]" "," exprs++ prettyPrint (Paren _ expr) = parens $ pretty expr++ prettyPrint (LeftSection _ expr qop) = parens $ do+ pretty expr+ operatorSectionL Expression (opName qop) $ prettyHSE qop++ prettyPrint (RightSection _ qop expr) = parens $ do+ operatorSectionR Expression (opName qop) $ prettyHSE qop+ pretty expr++ prettyPrint (RecConstr _ qname fieldupdates) =+ prettyRecord len Expression qname fieldupdates+ where+ len (FieldUpdate _ n _) = measure $ pretty n+ len (FieldPun _ n) = measure $ pretty n+ len (FieldWildcard _) = measure $ write ".."++ prettyPrint (RecUpdate _ expr fieldupdates) =+ prettyRecord len Expression expr fieldupdates+ where+ len (FieldUpdate _ n _) = measure $ pretty n+ len (FieldPun _ n) = measure $ pretty n+ len (FieldWildcard _) = measure $ write ".."++ prettyPrint (EnumFrom _ expr) = group Expression "[" "]" $ do+ pretty expr+ operatorSectionL Expression ".." $ write ".."++ prettyPrint (EnumFromTo _ expr expr') = group Expression "[" "]" $ do+ pretty expr+ operator Expression ".."+ pretty expr'++ prettyPrint (EnumFromThen _ expr expr') = group Expression "[" "]" $ do+ pretty expr+ comma+ pretty expr'+ operatorSectionL Expression ".." $ write ".."++ prettyPrint (EnumFromThenTo _ expr expr' expr'') =+ group Expression "[" "]" $ do+ pretty expr+ comma+ pretty expr'+ operator Expression ".."+ pretty expr''++ prettyPrint (ParArrayFromTo _ expr expr') = group Expression "[:" ":]" $ do+ pretty expr+ operator Expression ".."+ pretty expr'++ prettyPrint (ParArrayFromThenTo _ expr expr' expr'') =+ group Expression "[:" ":]" $ do+ pretty expr+ comma+ pretty expr'+ operator Expression ".."+ pretty expr''++ prettyPrint (ListComp _ expr qualstmts) =+ withLayout cfgLayoutListComp flex vertical+ where+ flex = group Expression "[" "]" $ do+ prettyOnside expr+ operator Expression "|"+ list' Expression "," qualstmts++ vertical = groupV Expression "[" "]" $ do+ prettyOnside expr+ operatorV Expression "|"+ listV' Expression "," qualstmts++ prettyPrint (ParComp _ expr qualstmtss) =+ withLayout cfgLayoutListComp flex vertical+ where+ flex = group Expression "[" "]" $ do+ prettyOnside expr+ forM_ qualstmtss $ \qualstmts -> cut $ do+ operator Expression "|"+ list' Expression "," qualstmts++ vertical = groupV Expression "[" "]" $ do+ prettyOnside expr+ forM_ qualstmtss $ \qualstmts -> cut $ do+ operatorV Expression "|"+ listV' Expression "," qualstmts++ prettyPrint (ParArrayComp _ expr qualstmtss) =+ withLayout cfgLayoutListComp flex vertical+ where+ flex = group Expression "[:" ":]" $ do+ prettyOnside expr+ forM_ qualstmtss $ \qualstmts -> cut $ do+ operator Expression "|"+ list' Expression "," qualstmts++ vertical = groupV Expression "[:" ":]" $ do+ prettyOnside expr+ forM_ qualstmtss $ \qualstmts -> cut $ do+ operatorV Expression "|"+ listV' Expression "," qualstmts++ prettyPrint (ExpTypeSig _ expr typ) = prettyTypesig Expression [ expr ] typ++ prettyPrint (VarQuote _ qname) = do+ write "'"+ pretty qname++ prettyPrint (TypQuote _ qname) = do+ write "''"+ pretty qname++ prettyPrint (BracketExp _ bracket) = pretty bracket++ prettyPrint (SpliceExp _ splice) = pretty splice++ prettyPrint (QuasiQuote _ str str') = do+ write "["+ string str+ write "|"+ string str'+ write "|]"++ prettyPrint (TypeApp _ typ) = do+ write "@"+ pretty typ++ prettyPrint (XTag _ xname xattrs mexpr exprs) = do+ write "<"+ pretty xname+ forM_ xattrs $ withPrefix space pretty+ mayM_ mexpr $ withPrefix space pretty+ write ">"+ mapM_ pretty exprs+ write "</"+ pretty xname+ write ">"++ prettyPrint (XETag _ xname xattrs mexpr) = do+ write "<"+ pretty xname+ forM_ xattrs $ withPrefix space pretty+ mayM_ mexpr $ withPrefix space pretty+ write "/>"++ prettyPrint (XPcdata _ str) = string str++ prettyPrint (XExpTag _ expr) = do+ write "<% "+ pretty expr+ write " %>"++ prettyPrint (XChildTag _ exprs) = do+ write "<%>"+ inter space $ map pretty exprs+ write "</%>"++ prettyPrint (CorePragma _ str expr) = do+ prettyPragma "CORE" . string $ show str+ space+ pretty expr++ prettyPrint (SCCPragma _ str expr) = do+ prettyPragma "SCC" . string $ show str+ space+ pretty expr++ prettyPrint (GenPragma _ str (a, b) (c, d) expr) = do+ prettyPragma "GENERATED" $+ inter space+ [ string $ show str+ , int $ fromIntegral a+ , write ":"+ , int $ fromIntegral b+ , write "-"+ , int $ fromIntegral c+ , write ":"+ , int $ fromIntegral d+ ]+ space+ pretty expr++ prettyPrint (Proc _ pat expr) = do+ write "proc "+ pretty pat+ operator Expression "->"+ pretty expr++ prettyPrint (LeftArrApp _ expr expr') = do+ pretty expr+ operator Expression "-<"+ pretty expr'++ prettyPrint (RightArrApp _ expr expr') = do+ pretty expr+ operator Expression ">-"+ pretty expr'++ prettyPrint (LeftArrHighApp _ expr expr') = do+ pretty expr+ operator Expression "-<<"+ pretty expr'++ prettyPrint (RightArrHighApp _ expr expr') = do+ pretty expr+ operator Expression ">>-"+ pretty expr'++ prettyPrint (LCase _ alts) = do+ write "\\case"+ if null alts+ then write " { }"+ else withIndent cfgIndentCase $+ withComputedTabStop stopRhs cfgAlignCase measureAlt alts $+ lined alts++instance Pretty Alt where+ prettyPrint (Alt _ pat rhs mbinds) = do+ onside $ do+ pretty pat+ atTabStop stopRhs+ pretty $ GuardedAlts rhs+ mapM_ pretty mbinds++instance Pretty XAttr where+ prettyPrint (XAttr _ xname expr) = do+ pretty xname+ operator Expression "="+ pretty expr++instance Pretty Pat where+ prettyPrint (PVar _ name) = pretty name++ prettyPrint (PLit _ sign literal) = do+ case sign of+ Signless _ -> return ()+ Negative _ -> write "-"+ pretty literal++ prettyPrint (PNPlusK _ name integer) = do+ pretty name+ operator Pattern "+"+ int integer++ prettyPrint p@(PInfixApp _ _ qname _) =+ prettyInfixApp opName Pattern $ flattenInfix flattenPInfixApp p+ where+ flattenPInfixApp (PInfixApp _ lhs qname' rhs) =+ if compareAST qname qname' == EQ+ then Just (lhs, QConOp noNodeInfo qname', rhs)+ else Nothing+ flattenPInfixApp _ = Nothing++ prettyPrint (PApp _ qname pats) = prettyApp qname pats++ prettyPrint (PTuple _ boxed pats) = case boxed of+ Boxed -> list Pattern "(" ")" "," pats+ Unboxed -> list Pattern "(#" "#)" "," pats++ prettyPrint (PUnboxedSum _ before after pat) = group Pattern "(#" "#)"+ . inter space $ replicate before (write "|") ++ [ pretty pat ]+ ++ replicate after (write "|")++ prettyPrint (PList _ pats) = list Pattern "[" "]" "," pats++ prettyPrint (PParen _ pat) = parens $ pretty pat++ prettyPrint (PRec _ qname patfields) = do+ withOperatorFormatting Pattern "record" (pretty qname) id+ list Pattern "{" "}" "," patfields++ prettyPrint (PAsPat _ name pat) = do+ pretty name+ operator Pattern "@"+ pretty pat++ prettyPrint (PWildCard _) = write "_"++ prettyPrint (PIrrPat _ pat) = do+ write "~"+ pretty pat++ prettyPrint (PatTypeSig _ pat ty) = prettyTypesig Pattern [ pat ] ty++ prettyPrint (PViewPat _ expr pat) = do+ pretty expr+ operator Pattern "->"+ pretty pat++ prettyPrint (PRPat _ rpats) = list Pattern "[" "]" "," rpats++ prettyPrint (PXTag _ xname pxattrs mpat pats) = do+ write "<"+ pretty xname+ forM_ pxattrs $ withPrefix space pretty+ mayM_ mpat $ withPrefix space pretty+ write ">"+ mapM_ pretty pats+ write "<"+ pretty xname+ write ">"++ prettyPrint (PXETag _ xname pxattrs mpat) = do+ write "<"+ pretty xname+ forM_ pxattrs $ withPrefix space pretty+ mayM_ mpat $ withPrefix space pretty+ write "/>"++ prettyPrint (PXPcdata _ str) = string str++ prettyPrint (PXPatTag _ pat) = do+ write "<%"+ pretty pat+ write "%>"++ prettyPrint (PXRPats _ rpats) = do+ write "<["+ inter space $ map pretty rpats+ write "%>"++ prettyPrint (PSplice _ splice) = pretty splice++ prettyPrint (PQuasiQuote _ str str') = do+ write "[$"+ string str+ write "|"+ string str'+ write "|]"++ prettyPrint (PBangPat _ pat) = do+ write "!"+ pretty pat++instance Pretty PatField where+ prettyPrint (PFieldPat _ qname pat) = do+ pretty qname+ operator Pattern "="+ pretty pat++ prettyPrint (PFieldPun _ qname) = pretty qname++ prettyPrint (PFieldWildcard _) = write ".."++instance Pretty PXAttr where+ prettyPrint (PXAttr _ xname pat) = do+ pretty xname+ operator Pattern "="+ pretty pat++instance Pretty Literal where+ prettyPrint (Char _ _ str) = do+ write "'"+ string str+ write "'"++ prettyPrint (String _ _ str) = do+ write "\""+ string str+ write "\""++ prettyPrint (Int _ _ str) = string str++ prettyPrint (Frac _ _ str) = string str++ prettyPrint (PrimInt _ _ str) = do+ string str+ write "#"++ prettyPrint (PrimWord _ _ str) = do+ string str+ write "##"++ prettyPrint (PrimFloat _ _ str) = do+ string str+ write "#"++ prettyPrint (PrimDouble _ _ str) = do+ string str+ write "##"++ prettyPrint (PrimChar _ _ str) = do+ write "'"+ string str+ write "'#"++ prettyPrint (PrimString _ _ str) = do+ write "\""+ string str+ write "\"#"++instance Pretty QualStmt where+ prettyPrint (QualStmt _ stmt) = pretty stmt++ prettyPrint (ThenTrans _ expr) = do+ write "then "+ pretty expr++ prettyPrint (ThenBy _ expr expr') = do+ write "then "+ pretty expr+ write " by "+ pretty expr'++ prettyPrint (GroupBy _ expr) = do+ write "then group by "+ pretty expr++ prettyPrint (GroupUsing _ expr) = do+ write "then group using "+ pretty expr++ prettyPrint (GroupByUsing _ expr expr') = do+ write "then group by "+ pretty expr+ write " using "+ pretty expr'++instance Pretty Stmt where+ prettyPrint (Generator _ pat expr) = do+ pretty pat+ operator Expression "<-"+ pretty expr++ -- Special case for If in Do,+ prettyPrint (Qualifier _ expr@If{}) = do+ cfg <- getConfig (cfgIndentIf . cfgIndent)+ case cfg of+ Align -> do+ write ""+ indented $ pretty expr+ _ -> pretty expr++ prettyPrint (Qualifier _ expr) = pretty expr++ prettyPrint (LetStmt _ binds) = do+ write "let "+ pretty $ CompactBinds binds++ prettyPrint (RecStmt _ stmts) = do+ write "rec "+ aligned $ linedOnside stmts++instance Pretty FieldUpdate where+ prettyPrint (FieldUpdate _ qname expr) = do+ pretty qname+ atTabStop stopRecordField+ operator Expression "="+ pretty expr++ prettyPrint (FieldPun _ qname) = pretty qname++ prettyPrint (FieldWildcard _) = write ".."++instance Pretty QOp where+ prettyPrint qop =+ withOperatorFormatting Expression (opName qop) (prettyHSE qop) id++instance Pretty Op where+ prettyPrint (VarOp l name) = prettyPrint (QVarOp l (UnQual noNodeInfo name))+ prettyPrint (ConOp l name) = prettyPrint (QConOp l (UnQual noNodeInfo name))++instance Pretty Bracket where+ prettyPrint (ExpBracket _ expr) = group Expression "[|" "|]" $ pretty expr++ prettyPrint (PatBracket _ pat) = group Expression "[p|" "|]" $ pretty pat++ prettyPrint (TypeBracket _ ty) = group Expression "[t|" "|]" $ pretty ty++ prettyPrint (DeclBracket _ decls) =+ group Expression "[d|" "|]" . aligned $ lined decls++instance Pretty Splice where+ prettyPrint (IdSplice _ str) = do+ write "$"+ string str++ prettyPrint (ParenSplice _ expr) = group Expression "$(" ")" $ pretty expr++instance Pretty ModulePragma where+ prettyPrint (LanguagePragma _ names) =+ prettyPragma "LANGUAGE" . inter comma $ map pretty names++ prettyPrint (OptionsPragma _ mtool str) = prettyPragma name $+ string (trim str)+ where+ name = case mtool of+ Just tool -> "OPTIONS_" `mappend` BS8.pack (HSE.prettyPrint tool)+ Nothing -> "OPTIONS"++ trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ')++ prettyPrint (AnnModulePragma _ annotation) =+ prettyPragma "ANN" $ pretty annotation++instance Pretty Rule where+ prettyPrint (Rule _ str mactivation mrulevars expr expr') = do+ string (show str)+ space+ mayM_ mactivation $ withPostfix space pretty+ mapM_ prettyForall mrulevars+ pretty expr+ operator Expression "="+ pretty expr'++instance Pretty RuleVar where+ prettyPrint (RuleVar _ name) = pretty name++ prettyPrint (TypedRuleVar _ name ty) =+ parens $ prettyTypesig Declaration [ name ] ty++instance Pretty Activation where+ prettyPrint (ActiveFrom _ pass) = brackets . int $ fromIntegral pass++ prettyPrint (ActiveUntil _ pass) = brackets $ do+ write "~"+ int $ fromIntegral pass++instance Pretty Annotation where+ prettyPrint (Ann _ name expr) = do+ pretty name+ space+ pretty expr++ prettyPrint (TypeAnn _ name expr) = do+ write "type "+ pretty name+ space+ pretty expr++ prettyPrint (ModuleAnn _ expr) = do+ write "module "+ pretty expr++instance Pretty BooleanFormula where+ prettyPrint (VarFormula _ name) = pretty name++ prettyPrint (AndFormula _ booleanformulas) =+ inter comma $ map pretty booleanformulas++ prettyPrint (OrFormula _ booleanformulas) =+ inter (operator Expression "|") $ map pretty booleanformulas++ prettyPrint (ParenFormula _ booleanformula) = parens $ pretty booleanformula++-- Stick with HSE+instance Pretty DerivStrategy++instance Pretty DataOrNew++instance Pretty BangType++instance Pretty Unpackedness++instance Pretty RPat++instance Pretty ModuleName++instance Pretty QName++instance Pretty Name++instance Pretty IPName++instance Pretty XName++instance Pretty Safety++instance Pretty CallConv++instance Pretty Overlap++-- Helpers+newtype GuardedAlt l = GuardedAlt (GuardedRhs l)+ deriving ( Functor, Annotated )++instance Pretty GuardedAlt where+ prettyPrint (GuardedAlt (GuardedRhs _ stmts expr)) = cut $ do+ operatorSectionR Pattern "|" $ write "|"+ inter comma $ map pretty stmts+ operator Expression "->"+ pretty expr++newtype GuardedAlts l = GuardedAlts (Rhs l)+ deriving ( Functor, Annotated )++instance Pretty GuardedAlts where+ prettyPrint (GuardedAlts (UnGuardedRhs _ expr)) = cut $ do+ operator Expression "->"+ pretty expr++ prettyPrint (GuardedAlts (GuardedRhss _ guardedrhss)) =+ withIndent cfgIndentMultiIf $ linedOnside $ map GuardedAlt guardedrhss++newtype CompactBinds l = CompactBinds (Binds l)+ deriving ( Functor, Annotated )++instance Pretty CompactBinds where+ prettyPrint (CompactBinds (BDecls _ decls)) = aligned $+ withComputedTabStop stopRhs cfgAlignLetBinds measureDecl decls $+ lined decls+ prettyPrint (CompactBinds (IPBinds _ ipbinds)) =+ aligned $ linedOnside ipbinds++newtype MayAst a l = MayAst (Maybe (a l))++instance Functor a => Functor (MayAst a) where+ fmap _ (MayAst Nothing) = MayAst Nothing+ fmap f (MayAst (Just x)) = MayAst . Just $ fmap f x++instance Annotated a => Annotated (MayAst a) where+ ann (MayAst Nothing) = undefined+ ann (MayAst (Just x)) = ann x++ amap _ (MayAst Nothing) = MayAst Nothing+ amap f (MayAst (Just x)) = MayAst . Just $ amap f x++instance (Annotated a, Pretty a) => Pretty (MayAst a) where+ prettyPrint (MayAst x) = mapM_ pretty x
+ src/Floskell/Printers.hs view
@@ -0,0 +1,446 @@+{-# LANGUAGE OverloadedStrings #-}++module Floskell.Printers+ ( getConfig+ , getOption+ , cut+ , oneline+ -- * Basic printing+ , write+ , string+ , int+ , space+ , newline+ , linebreak+ , blankline+ , spaceOrNewline+ -- * Tab stops+ , withTabStops+ , atTabStop+ -- * Combinators+ , mayM_+ , withPrefix+ , withPostfix+ , withIndent+ , withIndentFlat+ , withIndentBy+ , withLayout+ , inter+ -- * Indentation+ , getNextColumn+ , column+ , aligned+ , indented+ , onside+ , depend+ , depend'+ , parens+ , brackets+ -- * Wrapping+ , group+ , groupH+ , groupV+ -- * Operators+ , operator+ , operatorH+ , operatorV+ , alignOnOperator+ , alignOnOperatorH+ , alignOnOperatorV+ , withOperatorFormatting+ , withOperatorFormattingH+ , withOperatorFormattingV+ , operatorSectionL+ , operatorSectionR+ , comma+ ) where++import Control.Applicative ( (<|>) )++import Control.Monad ( guard, unless, when )+import Control.Monad.Search ( cost, winner )++import Control.Monad.State.Strict ( get, gets, modify )++import Data.ByteString ( ByteString )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as BL+import Data.Int ( Int64 )+import Data.List ( intersperse )+import qualified Data.Map.Strict as Map+import Data.Monoid ( (<>) )++import qualified Floskell.Buffer as Buffer+import Floskell.Config+import Floskell.Types++-- | Query part of the pretty printer config+getConfig :: (FlexConfig -> b) -> Printer b+getConfig f = f <$> gets psUserState++-- | Query pretty printer options+getOption :: (OptionConfig -> Bool) -> Printer Bool+getOption f = getConfig (f . cfgOptions)++-- | Line penalty calculation+linePenalty :: Bool -> Int64 -> Printer Penalty+linePenalty eol col = do+ indentLevel <- gets psIndentLevel+ config <- getConfig cfgPenalty+ let maxcol = penaltyMaxLineLength config+ let pLinebreak = onlyIf eol $ penaltyLinebreak config+ let pIndent = fromIntegral indentLevel * (penaltyIndent config)+ let pOverfull = onlyIf (col > fromIntegral maxcol) $ penaltyOverfull config+ * fromIntegral (col - fromIntegral maxcol)+ + penaltyOverfullOnce config+ return . fromIntegral $ pLinebreak + pIndent + pOverfull+ where+ onlyIf cond penalty = if cond then penalty else 0++-- | Try only the first (i.e. locally best) solution to the given+-- pretty printer. Use this function to improve performance whenever+-- the formatting of an AST node has no effect on the penalty of any+-- following AST node, such as top-level declarations or case+-- branches.+cut :: Printer a -> Printer a+cut = winner++withOutputRestriction :: OutputRestriction -> Printer a -> Printer a+withOutputRestriction r p = do+ orig <- gets psOutputRestriction+ modify $ \s -> s { psOutputRestriction = max orig r }+ result <- p+ modify $ \s -> s { psOutputRestriction = orig }+ return result++oneline :: Printer a -> Printer a+oneline p = do+ eol <- gets psEolComment+ when eol $ newline+ withOutputRestriction NoOverflowOrLinebreak p++-- | Write out a string, updating the current position information.+write :: ByteString -> Printer ()+write x = do+ eol <- gets psEolComment+ when eol newline+ write' x+ where+ write' x' = do+ state <- get+ let indentLevel = fromIntegral (psIndentLevel state)+ out = if psNewline state+ then BS.replicate indentLevel 32 <> x'+ else x'+ buffer = psBuffer state+ newCol = Buffer.column buffer + fromIntegral (BS.length out)+ guard $ psOutputRestriction state == Anything || newCol+ < fromIntegral (penaltyMaxLineLength (cfgPenalty (psUserState state)))+ penalty <- linePenalty False newCol+ when (penalty /= mempty) $ cost mempty penalty+ modify (\s ->+ s { psBuffer = Buffer.write out buffer, psEolComment = False })++-- | Write a string.+string :: String -> Printer ()+string = write . BL.toStrict . BB.toLazyByteString . BB.stringUtf8++-- | Write an integral.+int :: Integer -> Printer ()+int = string . show++-- | Write a space.+space :: Printer ()+space = do+ comment <- gets psEolComment+ unless comment $ write " "++-- | Output a newline.+newline :: Printer ()+newline = do+ modify (\s ->+ s { psIndentLevel = psIndentLevel s + psOnside s, psOnside = 0 })+ state <- get+ guard $ psOutputRestriction state /= NoOverflowOrLinebreak+ penalty <- linePenalty True (psColumn state)+ when (penalty /= mempty) $ cost penalty mempty+ modify (\s -> s { psBuffer = Buffer.newline (psBuffer state)+ , psEolComment = False+ })++linebreak :: Printer ()+linebreak = return () <|> newline++blankline :: Printer ()+blankline = newline >> newline++spaceOrNewline :: Printer ()+spaceOrNewline = space <|> newline++withTabStops :: [(TabStop, Maybe Int)] -> Printer a -> Printer a+withTabStops stops p = do+ col <- getNextColumn+ oldstops <- gets psTabStops+ modify $ \s ->+ s { psTabStops =+ foldr (\(k, v) ->+ Map.alter (const $ fmap (\x -> col + fromIntegral x) v)+ k)+ (psTabStops s)+ stops+ }+ res <- p+ modify $ \s -> s { psTabStops = oldstops }+ return res++atTabStop :: TabStop -> Printer ()+atTabStop tabstop = do+ mstop <- gets (Map.lookup tabstop . psTabStops)+ mayM_ mstop $ \stop -> do+ col <- getNextColumn+ let padding = max 0 $ fromIntegral (stop - col)+ write (BS.replicate padding 32)++mayM_ :: Maybe a -> (a -> Printer ()) -> Printer ()+mayM_ Nothing _ = return ()+mayM_ (Just x) p = p x++withPrefix :: Applicative f => f a -> (x -> f b) -> x -> f b+withPrefix pre f x = pre *> f x++withPostfix :: Applicative f => f a -> (x -> f b) -> x -> f b+withPostfix post f x = f x <* post++withIndent :: (IndentConfig -> Indent) -> Printer a -> Printer a+withIndent fn p = do+ cfg <- getConfig (fn . cfgIndent)+ case cfg of+ Align -> align+ IndentBy i -> indentby i+ AlignOrIndentBy i -> align <|> indentby i+ where+ align = do+ space+ aligned p++ indentby i = indent i $ do+ newline+ p++withIndentFlat :: (IndentConfig -> Indent)+ -> ByteString+ -> Printer a+ -> Printer a+withIndentFlat fn kw p = do+ cfg <- getConfig (fn . cfgIndent)+ case cfg of+ Align -> align+ IndentBy i -> indentby i+ AlignOrIndentBy i -> align <|> indentby i+ where+ align = aligned $ do+ write kw+ p++ indentby i = do+ write kw+ indent i p++withIndentBy :: (IndentConfig -> Int) -> Printer a -> Printer a+withIndentBy fn = withIndent (IndentBy . fn)++withLayout :: (LayoutConfig -> Layout) -> Printer a -> Printer a -> Printer a+withLayout fn flex vertical = do+ cfg <- getConfig (fn . cfgLayout)+ case cfg of+ Flex -> flex+ Vertical -> vertical+ TryOneline -> oneline flex <|> vertical++inter :: Printer () -> [Printer ()] -> Printer ()+inter x = sequence_ . intersperse x++-- | Get the column for the next printed character.+getNextColumn :: Printer Int64+getNextColumn = do+ st <- get+ return $ if psEolComment st+ then psIndentLevel st + psOnside st+ else max (psColumn st) (psIndentLevel st)++-- | 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+ onside' <- gets psOnside+ modify (\s -> s { psIndentLevel = i+ , psOnside = if i > level then 0 else onside'+ })+ m <- p+ modify (\s -> s { psIndentLevel = level, psOnside = onside' })+ return m++-- | Increase indentation level by n spaces for the given printer.+indent :: Int -> Printer a -> Printer a+indent i p = do+ level <- gets psIndentLevel+ column (level + fromIntegral i) p++aligned :: Printer a -> Printer a+aligned p = do+ col <- getNextColumn+ column col $ do+ modify $ \s -> s { psOnside = 0 }+ p++indented :: Printer a -> Printer a+indented p = do+ i <- getConfig (cfgIndentOnside . cfgIndent)+ indent i p++-- | Increase indentation level b n spaces for the given printer, but+-- ignore increase when computing further indentations.+onside :: Printer a -> Printer a+onside p = do+ eol <- gets psEolComment+ when eol newline+ onsideIndent <- getConfig (cfgIndentOnside . cfgIndent)+ level <- gets psIndentLevel+ onside' <- gets psOnside+ modify (\s -> s { psOnside = fromIntegral onsideIndent })+ m <- p+ modify (\s -> s { psIndentLevel = level, psOnside = onside' })+ return m++depend :: ByteString -> Printer a -> Printer a+depend kw = depend' (write kw)++depend' :: Printer () -> Printer a -> Printer a+depend' kw p = do+ kw+ space+ indented p++-- | Wrap in parens.+parens :: Printer () -> Printer ()+parens p = do+ write "("+ aligned $ do+ p+ write ")"++-- | Wrap in brackets.+brackets :: Printer () -> Printer ()+brackets p = do+ write "["+ aligned $ do+ p+ write "]"++group :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer ()+group ctx open close p = do+ force <- getConfig (wsForceLinebreak . cfgGroupWs ctx open . cfgGroup)+ if force then vert else oneline hor <|> vert+ where+ hor = groupH ctx open close p++ vert = groupV ctx open close p++groupH :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer ()+groupH ctx open close p = do+ ws <- getConfig (cfgGroupWs ctx open . cfgGroup)+ write open+ when (wsSpace Before ws) space+ p+ when (wsSpace After ws) space+ write close++groupV :: LayoutContext -> ByteString -> ByteString -> Printer () -> Printer ()+groupV ctx open close p = aligned $ do+ ws <- getConfig (cfgGroupWs ctx open . cfgGroup)+ write open+ if wsLinebreak Before ws then newline else when (wsSpace Before ws) space+ p+ if wsLinebreak After ws then newline else when (wsSpace After ws) space+ write close++operator :: LayoutContext -> ByteString -> Printer ()+operator ctx op = withOperatorFormatting ctx op (write op) id++operatorH :: LayoutContext -> ByteString -> Printer ()+operatorH ctx op = withOperatorFormattingH ctx op (write op) id++operatorV :: LayoutContext -> ByteString -> Printer ()+operatorV ctx op = withOperatorFormattingV ctx op (write op) id++alignOnOperator :: LayoutContext -> ByteString -> Printer a -> Printer a+alignOnOperator ctx op p =+ withOperatorFormatting ctx op (write op) (aligned . (*> p))++alignOnOperatorH :: LayoutContext -> ByteString -> Printer a -> Printer a+alignOnOperatorH ctx op p =+ withOperatorFormattingH ctx op (write op) (aligned . (*> p))++alignOnOperatorV :: LayoutContext -> ByteString -> Printer a -> Printer a+alignOnOperatorV ctx op p =+ withOperatorFormattingV ctx op (write op) (aligned . (*> p))++withOperatorFormatting :: LayoutContext+ -> ByteString+ -> Printer ()+ -> (Printer () -> Printer a)+ -> Printer a+withOperatorFormatting ctx op opp fn = do+ force <- getConfig (wsForceLinebreak . cfgOpWs ctx op . cfgOp)+ if force then vert else hor <|> vert+ where+ hor = withOperatorFormattingH ctx op opp fn++ vert = withOperatorFormattingV ctx op opp fn++withOperatorFormattingH :: LayoutContext+ -> ByteString+ -> Printer ()+ -> (Printer () -> Printer a)+ -> Printer a+withOperatorFormattingH ctx op opp fn = do+ ws <- getConfig (cfgOpWs ctx op . cfgOp)+ nl <- gets psNewline+ eol <- gets psEolComment+ when (wsSpace Before ws && not nl && not eol) space+ fn $ do+ opp+ when (wsSpace After ws) space++withOperatorFormattingV :: LayoutContext+ -> ByteString+ -> Printer ()+ -> (Printer () -> Printer a)+ -> Printer a+withOperatorFormattingV ctx op opp fn = do+ ws <- getConfig (cfgOpWs ctx op . cfgOp)+ nl <- gets psNewline+ eol <- gets psEolComment+ if wsLinebreak Before ws+ then newline+ else when (wsSpace Before ws && not nl && not eol) space+ fn $ do+ opp+ if wsLinebreak After ws then newline else when (wsSpace After ws) space++operatorSectionL :: LayoutContext -> ByteString -> Printer () -> Printer ()+operatorSectionL ctx op opp = do+ ws <- getConfig (cfgOpWs ctx op . cfgOp)+ when (wsSpace Before ws) space+ opp++operatorSectionR :: LayoutContext -> ByteString -> Printer () -> Printer ()+operatorSectionR ctx op opp = do+ ws <- getConfig (cfgOpWs ctx op . cfgOp)+ opp+ when (wsSpace After ws) space++comma :: Printer ()+comma = operator Expression ","
+ src/Floskell/Styles.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Floskell.Styles ( styles ) where++import qualified Data.Map as Map++import Floskell.Config+import Floskell.Types++chrisDoneCfg :: FlexConfig+chrisDoneCfg = safeFlexConfig $+ defaultFlexConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }+ where+ cfgIndent =+ IndentConfig { cfgIndentOnside = 2+ , cfgIndentDeriving = 2+ , cfgIndentWhere = 2+ , cfgIndentApp = Align+ , cfgIndentCase = IndentBy 2+ , cfgIndentClass = IndentBy 2+ , cfgIndentDo = Align+ , cfgIndentIf = IndentBy 3+ , cfgIndentLet = Align+ , cfgIndentLetBinds = Align+ , cfgIndentLetIn = Align+ , cfgIndentMultiIf = IndentBy 2+ , cfgIndentWhereBinds = Align+ , cfgIndentExportSpecList = IndentBy 2+ , cfgIndentImportSpecList = IndentBy 7+ }++ cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline+ , cfgLayoutConDecls = Vertical+ , cfgLayoutDeclaration = TryOneline+ , cfgLayoutExportSpecList = TryOneline+ , cfgLayoutIf = Vertical+ , cfgLayoutImportSpecList = TryOneline+ , cfgLayoutInfixApp = TryOneline+ , cfgLayoutLet = Vertical+ , cfgLayoutListComp = Flex+ , cfgLayoutRecord = Vertical+ , cfgLayoutTypesig = TryOneline+ }++ cfgOp =+ OpConfig ConfigMap { cfgMapDefault = Whitespace WsBoth WsBefore False+ , cfgMapOverrides = Map.fromList opWsOverrides+ }++ opWsOverrides =+ [ (ConfigMapKey (Just ",") Nothing, Whitespace WsNone WsBefore False)+ , ( ConfigMapKey (Just "record") Nothing+ , Whitespace WsAfter WsAfter False+ )+ , ( ConfigMapKey (Just ".") (Just Type)+ , Whitespace WsAfter WsAfter False+ )+ , (ConfigMapKey (Just "=") Nothing, Whitespace WsBoth WsAfter False)+ , (ConfigMapKey (Just "<-") Nothing, Whitespace WsBoth WsAfter False)+ , (ConfigMapKey (Just ":") Nothing, Whitespace WsNone WsBefore False)+ ]++ cfgGroup =+ GroupConfig ConfigMap { cfgMapDefault =+ Whitespace WsNone WsNone False+ , cfgMapOverrides = Map.fromList groupWsOverrides+ }++ groupWsOverrides = []++ cfgOptions = OptionConfig { cfgOptionSortPragmas = False+ , cfgOptionSplitLanguagePragmas = False+ , cfgOptionSortImports = False+ , cfgOptionSortImportLists = False+ , cfgOptionPreserveVerticalSpace = False+ }++cramerCfg :: FlexConfig+cramerCfg = safeFlexConfig $+ defaultFlexConfig { cfgAlign+ , cfgIndent+ , cfgLayout+ , cfgOp+ , cfgGroup+ , cfgOptions+ }+ where+ cfgAlign = AlignConfig { cfgAlignLimits = (10, 25)+ , cfgAlignCase = False+ , cfgAlignClass = False+ , cfgAlignImportModule = True+ , cfgAlignImportSpec = True+ , cfgAlignLetBinds = False+ , cfgAlignRecordFields = True+ , cfgAlignWhere = False+ }++ cfgIndent =+ IndentConfig { cfgIndentOnside = 4+ , cfgIndentDeriving = 4+ , cfgIndentWhere = 2+ , cfgIndentApp = Align+ , cfgIndentCase = IndentBy 4+ , cfgIndentClass = IndentBy 4+ , cfgIndentDo = IndentBy 4+ , cfgIndentIf = Align+ , cfgIndentLet = Align+ , cfgIndentLetBinds = Align+ , cfgIndentLetIn = IndentBy 4+ , cfgIndentMultiIf = IndentBy 4+ , cfgIndentWhereBinds = IndentBy 2+ , cfgIndentExportSpecList = IndentBy 4+ , cfgIndentImportSpecList = AlignOrIndentBy 17+ }++ cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline+ , cfgLayoutConDecls = TryOneline+ , cfgLayoutDeclaration = Flex+ , cfgLayoutExportSpecList = TryOneline+ , cfgLayoutIf = TryOneline+ , cfgLayoutImportSpecList = TryOneline+ , cfgLayoutInfixApp = Flex+ , cfgLayoutLet = TryOneline+ , cfgLayoutListComp = TryOneline+ , cfgLayoutRecord = TryOneline+ , cfgLayoutTypesig = TryOneline+ }++ cfgOp =+ OpConfig ConfigMap { cfgMapDefault = Whitespace WsBoth WsBefore False+ , cfgMapOverrides = Map.fromList opWsOverrides+ }++ opWsOverrides =+ [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)+ , ( ConfigMapKey (Just "record") Nothing+ , Whitespace WsAfter WsNone False+ )+ , ( ConfigMapKey (Just ".") (Just Type)+ , Whitespace WsAfter WsAfter False+ )+ , (ConfigMapKey (Just "=") Nothing, Whitespace WsBoth WsAfter False)+ , (ConfigMapKey (Just "$") Nothing, Whitespace WsBoth WsAfter False)+ , (ConfigMapKey (Just "@") Nothing, Whitespace WsNone WsNone False)+ , ( ConfigMapKey (Just "->") (Just Expression)+ , Whitespace WsBoth WsAfter False+ )+ , ( ConfigMapKey (Just "record") (Just Pattern)+ , Whitespace WsNone WsNone False+ )+ ]++ cfgGroup =+ GroupConfig ConfigMap { cfgMapDefault =+ Whitespace WsBoth WsAfter False+ , cfgMapOverrides = Map.fromList groupWsOverrides+ }++ groupWsOverrides =+ [ (ConfigMapKey Nothing (Just Type), Whitespace WsNone WsAfter False)+ , ( ConfigMapKey Nothing (Just Pattern)+ , Whitespace WsNone WsAfter False+ )+ , (ConfigMapKey (Just "$(") Nothing, Whitespace WsNone WsNone False)+ , (ConfigMapKey (Just "[|") Nothing, Whitespace WsNone WsNone False)+ , (ConfigMapKey (Just "[d|") Nothing, Whitespace WsNone WsNone False)+ , (ConfigMapKey (Just "[p|") Nothing, Whitespace WsNone WsNone False)+ , (ConfigMapKey (Just "[t|") Nothing, Whitespace WsNone WsNone False)+ , (ConfigMapKey (Just "(") Nothing, Whitespace WsNone WsAfter False)+ , ( ConfigMapKey (Just "(") (Just Other)+ , Whitespace WsBoth WsAfter False+ )+ , ( ConfigMapKey (Just "[") (Just Pattern)+ , Whitespace WsBoth WsAfter False+ )+ ]++ cfgOptions = OptionConfig { cfgOptionSortPragmas = True+ , cfgOptionSplitLanguagePragmas = True+ , cfgOptionSortImports = True+ , cfgOptionSortImportLists = True+ , cfgOptionPreserveVerticalSpace = True+ }++gibianskyCfg :: FlexConfig+gibianskyCfg = safeFlexConfig $+ defaultFlexConfig { cfgAlign+ , cfgIndent+ , cfgLayout+ , cfgOp+ , cfgGroup+ , cfgOptions+ }+ where+ cfgAlign = AlignConfig { cfgAlignLimits = (10, 25)+ , cfgAlignCase = True+ , cfgAlignClass = False+ , cfgAlignImportModule = True+ , cfgAlignImportSpec = False+ , cfgAlignLetBinds = False+ , cfgAlignRecordFields = False+ , cfgAlignWhere = False+ }++ cfgIndent =+ IndentConfig { cfgIndentOnside = 2+ , cfgIndentDeriving = 2+ , cfgIndentWhere = 2+ , cfgIndentApp = IndentBy 2+ , cfgIndentCase = IndentBy 2+ , cfgIndentClass = IndentBy 2+ , cfgIndentDo = IndentBy 2+ , cfgIndentIf = Align+ , cfgIndentLet = Align+ , cfgIndentLetBinds = Align+ , cfgIndentLetIn = Align+ , cfgIndentMultiIf = IndentBy 2+ , cfgIndentWhereBinds = IndentBy 2+ , cfgIndentExportSpecList = IndentBy 4+ , cfgIndentImportSpecList = IndentBy 4+ }++ cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline+ , cfgLayoutConDecls = Vertical+ , cfgLayoutDeclaration = Flex+ , cfgLayoutExportSpecList = TryOneline+ , cfgLayoutIf = Vertical+ , cfgLayoutImportSpecList = Flex+ , cfgLayoutInfixApp = TryOneline+ , cfgLayoutLet = Vertical+ , cfgLayoutListComp = TryOneline+ , cfgLayoutRecord = TryOneline+ , cfgLayoutTypesig = TryOneline+ }++ cfgOp =+ OpConfig ConfigMap { cfgMapDefault = Whitespace WsBoth WsBefore False+ , cfgMapOverrides = Map.fromList opWsOverrides+ }++ opWsOverrides =+ [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)+ , ( ConfigMapKey (Just "record") Nothing+ , Whitespace WsAfter WsAfter False+ )+ , ( ConfigMapKey (Just ".") (Just Type)+ , Whitespace WsAfter WsAfter False+ )+ , (ConfigMapKey (Just "=") Nothing, Whitespace WsBoth WsAfter False)+ , (ConfigMapKey (Just ":") Nothing, Whitespace WsNone WsBefore False)+ ]++ cfgGroup =+ GroupConfig ConfigMap { cfgMapDefault =+ Whitespace WsNone WsNone False+ , cfgMapOverrides = Map.fromList groupWsOverrides+ }++ groupWsOverrides =+ [ (ConfigMapKey (Just "{") Nothing, Whitespace WsBoth WsAfter False) ]++ cfgOptions = OptionConfig { cfgOptionSortPragmas = False+ , cfgOptionSplitLanguagePragmas = False+ , cfgOptionSortImports = False+ , cfgOptionSortImportLists = False+ , cfgOptionPreserveVerticalSpace = False+ }++johanTibellCfg :: FlexConfig+johanTibellCfg = safeFlexConfig $+ defaultFlexConfig { cfgIndent, cfgLayout, cfgOp, cfgGroup, cfgOptions }+ where+ cfgIndent =+ IndentConfig { cfgIndentOnside = 4+ , cfgIndentDeriving = 4+ , cfgIndentWhere = 2+ , cfgIndentApp = IndentBy 4+ , cfgIndentCase = IndentBy 4+ , cfgIndentClass = IndentBy 4+ , cfgIndentDo = IndentBy 4+ , cfgIndentIf = IndentBy 4+ , cfgIndentLet = Align+ , cfgIndentLetBinds = Align+ , cfgIndentLetIn = Align+ , cfgIndentMultiIf = IndentBy 2+ , cfgIndentWhereBinds = IndentBy 2+ , cfgIndentExportSpecList = IndentBy 2+ , cfgIndentImportSpecList = IndentBy 7+ }++ cfgLayout = LayoutConfig { cfgLayoutApp = TryOneline+ , cfgLayoutConDecls = Vertical+ , cfgLayoutDeclaration = TryOneline+ , cfgLayoutExportSpecList = TryOneline+ , cfgLayoutIf = Vertical+ , cfgLayoutImportSpecList = TryOneline+ , cfgLayoutInfixApp = TryOneline+ , cfgLayoutLet = Vertical+ , cfgLayoutListComp = Flex+ , cfgLayoutRecord = Vertical+ , cfgLayoutTypesig = TryOneline+ }++ cfgOp =+ OpConfig ConfigMap { cfgMapDefault = Whitespace WsBoth WsBefore False+ , cfgMapOverrides = Map.fromList opWsOverrides+ }++ opWsOverrides =+ [ (ConfigMapKey (Just ",") Nothing, Whitespace WsAfter WsBefore False)+ , ( ConfigMapKey (Just "record") Nothing+ , Whitespace WsAfter WsAfter True+ )+ , ( ConfigMapKey (Just ".") (Just Type)+ , Whitespace WsAfter WsAfter False+ )+ , (ConfigMapKey (Just "=") Nothing, Whitespace WsBoth WsAfter False)+ , ( ConfigMapKey (Just ":") (Just Pattern)+ , Whitespace WsNone WsBefore False+ )+ , ( ConfigMapKey (Just ",") (Just Pattern)+ , Whitespace WsNone WsBefore False+ )+ , ( ConfigMapKey (Just ",") (Just Other)+ , Whitespace WsNone WsBefore False+ )+ , ( ConfigMapKey (Just "record") (Just Pattern)+ , Whitespace WsAfter WsAfter False+ )+ ]++ cfgGroup =+ GroupConfig ConfigMap { cfgMapDefault =+ Whitespace WsNone WsNone False+ , cfgMapOverrides = Map.fromList groupWsOverrides+ }++ groupWsOverrides =+ [ (ConfigMapKey (Just "{") Nothing, Whitespace WsBoth WsAfter False)+ , ( ConfigMapKey (Just "{") (Just Pattern)+ , Whitespace WsNone WsNone False+ )+ ]++ cfgOptions = OptionConfig { cfgOptionSortPragmas = False+ , cfgOptionSplitLanguagePragmas = False+ , cfgOptionSortImports = False+ , cfgOptionSortImportLists = False+ , cfgOptionPreserveVerticalSpace = False+ }++-- | Base style definition.+base :: Style+base = Style { styleName = "base"+ , styleAuthor = "Enno Cramer"+ , styleDescription = "Configurable formatting style"+ , styleInitialState = safeFlexConfig defaultFlexConfig+ }++chrisDone :: Style+chrisDone = Style { styleName = "chris-done"+ , styleAuthor = "Chris Done"+ , styleDescription = "Chris Done's style"+ , styleInitialState = chrisDoneCfg+ }++cramer :: Style+cramer = Style { styleName = "cramer"+ , styleAuthor = "Enno Cramer"+ , styleDescription = "Enno Cramer's style"+ , styleInitialState = cramerCfg+ }++gibiansky :: Style+gibiansky = Style { styleName = "gibiansky"+ , styleAuthor = "Andrew Gibiansky"+ , styleDescription = "Andrew Gibiansky's style"+ , styleInitialState = gibianskyCfg+ }++johanTibell :: Style+johanTibell = Style { styleName = "johan-tibell"+ , styleAuthor = "Johan Tibell"+ , styleDescription = "Johan Tibell's style"+ , styleInitialState = johanTibellCfg+ }++-- | Styles list, useful for programmatically choosing.+styles :: [Style]+styles = [ base, chrisDone, johanTibell, gibiansky, cramer ]
+ src/Floskell/Types.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | All types.+module Floskell.Types+ ( OutputRestriction(..)+ , Penalty(..)+ , TabStop(..)+ , Printer(..)+ , execPrinter+ , runPrinter+ , PrintState(..)+ , psLine+ , psColumn+ , psNewline+ , Style(..)+ , FlexConfig(..)+ , NodeInfo(..)+ , ComInfo(..)+ , Location(..)+ ) where++import Control.Applicative+import Control.Monad++import Control.Monad.Search+ ( MonadSearch, Search, runSearchBest )+import Control.Monad.State.Strict+ ( MonadState(..), StateT, execStateT, runStateT )++import Data.Int ( Int64 )+import Data.Map.Strict ( Map )++import Data.Semigroup as Sem+import Data.Text ( Text )++import Floskell.Buffer ( Buffer )+import qualified Floskell.Buffer as Buffer+import Floskell.Config ( FlexConfig(..), Location(..) )++import Language.Haskell.Exts.Comments+import Language.Haskell.Exts.SrcLoc++data OutputRestriction = Anything | NoOverflow | NoOverflowOrLinebreak+ deriving ( Eq, Ord, Show )++newtype Penalty = Penalty Int+ deriving ( Eq, Ord, Num, Show )++newtype TabStop = TabStop String+ deriving ( Eq, Ord, Show )++instance Sem.Semigroup Penalty where+ (<>) = (+)++instance Monoid Penalty where+ mempty = 0+#if !(MIN_VERSION_base(4,11,0))++ mappend = (<>)+#endif++-- | A pretty printing monad.+newtype Printer a =+ Printer { unPrinter :: StateT PrintState (Search Penalty) a }+ deriving ( Applicative, Monad, Functor, MonadState PrintState+ , MonadSearch Penalty, MonadPlus, Alternative )++execPrinter :: Printer a -> PrintState -> Maybe (Penalty, PrintState)+execPrinter m s = runSearchBest $ execStateT (unPrinter m) s++runPrinter :: Printer a -> PrintState -> Maybe (Penalty, (a, PrintState))+runPrinter m s = runSearchBest $ runStateT (unPrinter m) s++-- | The state of the pretty printer.+data PrintState =+ PrintState { psBuffer :: !Buffer -- ^ Output buffer+ , psIndentLevel :: !Int64 -- ^ Current indentation level.+ , psOnside :: !Int64 -- ^ Extra indentation is necessary with next line break.+ , psTabStops :: !(Map TabStop Int64) -- ^ Tab stops for alignment.+ , psUserState :: !FlexConfig -- ^ User state.+ , psEolComment :: !Bool -- ^ An end of line comment has just been outputted.+ , psOutputRestriction :: OutputRestriction+ }++psLine :: PrintState -> Int64+psLine = Buffer.line . psBuffer++psColumn :: PrintState -> Int64+psColumn = Buffer.column . psBuffer++psNewline :: PrintState -> Bool+psNewline = (== 0) . Buffer.column . psBuffer++-- | A printer style.+data Style =+ Style { styleName :: !Text -- ^ Name of the style, used in the commandline interface.+ , styleAuthor :: !Text -- ^ Author of the printer (as opposed to the author of the style).+ , styleDescription :: !Text -- ^ Description of the style.+ , styleInitialState :: !FlexConfig -- ^ User state, if needed.+ }++-- | Information for each node in the AST.+data NodeInfo =+ NodeInfo { nodeInfoSpan :: !SrcSpanInfo -- ^ Location info from the parser.+ , nodeInfoComments :: ![ComInfo] -- ^ Comments which are attached to this node.+ }+ deriving ( Show )++-- | Comment with some more info.+data ComInfo =+ ComInfo { comInfoComment :: !Comment -- ^ The normal comment type.+ , comInfoLocation :: !(Maybe Location) -- ^ Where the comment lies relative to the node.+ }+ deriving ( Show )
+ src/main/Benchmark.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Benchmark the pretty printer.+module Main where++import Control.DeepSeq++import Criterion+import Criterion.Main++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.Text as T++import Floskell++import Language.Haskell.Exts ( Language(Haskell2010) )++import Markdone++-- | Main benchmarks.+main :: IO ()+main = do+ bytes <- S.readFile "BENCHMARK.md"+ !forest <- fmap force (parse (tokenize bytes))+ defaultMain [ bgroup (T.unpack $ styleName style) $+ toCriterion style forest+ | style <- styles+ ]++-- | Convert the Markdone document to Criterion benchmarks.+toCriterion :: Style -> [Markdone] -> [Benchmark]+toCriterion style = go+ where+ go (Section name children : next) = bgroup (S8.unpack name) (go children)+ : go next+ go (PlainText desc : CodeFence lang code : next) =+ if lang == "haskell"+ then bench (UTF8.toString desc)+ (nf (either error id . reformat style+ Haskell2010+ defaultExtensions+ (Just "BENCHMARK.md"))+ code) : go next+ else go next+ go (PlainText{} : next) = go next+ go (CodeFence{} : next) = go next+ go [] = []
+ src/main/Main.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Main entry point to floskell.+module Main ( main ) where++import Control.Applicative ( (<|>), many, optional )+import Control.Exception ( catch, throw )++import Data.Aeson+ ( (.:?), (.=), FromJSON(..), ToJSON(..) )+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Encode.Pretty as JSON ( encodePretty )+import qualified Data.Aeson.Types as JSON ( typeMismatch )+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Lazy as HashMap+import Data.List ( inits, sort )+import Data.Maybe ( isJust )+import Data.Monoid ( (<>) )++import qualified Data.Text as T+import Data.Version ( showVersion )++import Floskell ( reformat, styles )+import Floskell.Types+ ( Style(styleName, styleInitialState) )++import Foreign.C.Error ( Errno(..), eXDEV )++import GHC.IO.Exception ( ioe_errno )++import Language.Haskell.Exts+ ( Extension(..), Language(..), classifyExtension+ , classifyLanguage, knownExtensions, knownLanguages )++import Options.Applicative+ ( ParseError(..), abortOption, argument, execParser, footerDoc+ , fullDesc, header, help, helper, hidden, info, long, metavar+ , option, progDesc, short, str, switch )+import qualified Options.Applicative.Help.Pretty as PP++import Paths_floskell ( version )++import System.Directory+ ( XdgDirectory(..), copyFile, copyPermissions, doesFileExist+ , findFileWith, getAppUserDataDirectory, getCurrentDirectory+ , getHomeDirectory, getTemporaryDirectory, getXdgDirectory+ , removeFile, renameFile )+import System.FilePath ( joinPath, splitDirectories )+import System.IO+ ( FilePath, hClose, hFlush, openTempFile )++-- | Program options.+data Options = Options { optStyle :: Maybe String+ , optLanguage :: Maybe String+ , optExtensions :: [String]+ , optConfig :: Maybe FilePath+ , optPrintConfig :: Bool+ , optFiles :: [FilePath]+ }++-- | Program configuration.+data Config = Config { cfgStyle :: Style+ , cfgLanguage :: Language+ , cfgExtensions :: [Extension]+ }++instance ToJSON Config where+ toJSON Config{..} = JSON.object [ "style" .= styleName cfgStyle+ , "language" .= show cfgLanguage+ , "extensions" .= map showExt cfgExtensions+ , "formatting" .= styleInitialState cfgStyle+ ]+ where+ showExt (EnableExtension x) = show x+ showExt (DisableExtension x) = "No" ++ show x+ showExt (UnknownExtension x) = x++instance FromJSON Config where+ parseJSON (JSON.Object o) = do+ style <- maybe (cfgStyle defaultConfig) lookupStyle <$> o .:? "style"+ language <- maybe (cfgLanguage defaultConfig) lookupLanguage+ <$> o .:? "language"+ extensions <- maybe (cfgExtensions defaultConfig) (map lookupExtension)+ <$> o .:? "extensions"+ let flex = styleInitialState style+ flex' <- maybe flex (updateFlexConfig flex) <$> o .:? "formatting"+ let style' = style { styleInitialState = flex' }+ return $ Config style' language extensions+ where+ updateFlexConfig cfg v =+ case JSON.fromJSON $ mergeJSON (toJSON cfg) v of+ JSON.Error e -> error e+ JSON.Success x -> x++ mergeJSON JSON.Null r = r+ mergeJSON l JSON.Null = l+ mergeJSON (JSON.Object l) (JSON.Object r) =+ JSON.Object (HashMap.unionWith mergeJSON l r)+ mergeJSON _ r = r++ parseJSON v = JSON.typeMismatch "Config" v++-- | Default program configuration.+defaultConfig :: Config+defaultConfig = Config (head styles) Haskell2010 []++-- | Main entry point.+main :: IO ()+main = do+ opts <- execParser parser+ mconfig <- case optConfig opts of+ Just c -> return $ Just c+ Nothing ->+ if isJust (optStyle opts) then return Nothing else findConfig+ baseConfig <- case mconfig of+ Just path -> readConfig path+ Nothing -> return defaultConfig+ let config = mergeConfig baseConfig opts+ if optPrintConfig opts+ then BL.putStr $ JSON.encodePretty config+ else run config (optFiles opts)+ where+ parser = info (helper <*> versioner <*> options)+ (fullDesc+ <> progDesc "Floskell reformats one or more Haskell modules."+ <> header "floskell - A Haskell Source Code Pretty Printer"+ <> footerDoc (Just (footerStyles PP.<$$> footerLanguages+ PP.<$$> footerExtensions)))++ versioner = abortOption (InfoMsg $ "floskell " ++ showVersion version)+ (long "version"+ <> help "Display program version number" <> hidden)++ options = Options+ <$> optional (option str+ (long "style" <> short 's' <> metavar "STYLE"+ <> help "Formatting style"))+ <*> optional (option str+ (long "language" <> short 'L' <> metavar "LANGUAGE"+ <> help "Select base language"))+ <*> many (option str+ (long "extension" <> short 'X' <> metavar "EXTENSION"+ <> help "Enable or disable language extensions"))+ <*> optional (option str+ (long "config" <> short 'c' <> metavar "FILE"+ <> help "Configuration file"))+ <*> switch (long "print-config" <> help "Print configuration")+ <*> many (argument str+ (metavar "FILES"+ <> help "Input files (will be replaced)"))++ footerStyles =+ makeFooter "Supported styles:" (map (T.unpack . styleName) styles)++ footerLanguages =+ makeFooter "Supported languages:" (map show knownLanguages)++ footerExtensions =+ makeFooter "Supported extensions:"+ [ show e | EnableExtension e <- knownExtensions ]++ makeFooter hdr xs =+ PP.empty PP.<$$> PP.text hdr PP.<$$> (PP.indent 2 . PP.fillSep+ . PP.punctuate PP.comma+ . map PP.text $ sort xs)++-- | Reformat files or stdin based on provided configuration.+run :: Config -> [FilePath] -> IO ()+run Config{..} files = case files of+ [] -> reformatStdin cfgStyle cfgLanguage cfgExtensions+ _ -> mapM_ (reformatFile cfgStyle cfgLanguage cfgExtensions) files++-- | Reformat stdin according to Style, Language, and Extensions.+reformatStdin :: Style -> Language -> [Extension] -> IO ()+reformatStdin style language extensions = BL.interact $+ reformatByteString style language extensions Nothing . BL.toStrict++-- | Reformat a file according to Style, Language, and Extensions.+reformatFile :: Style -> Language -> [Extension] -> FilePath -> IO ()+reformatFile style language extensions file = do+ text <- BS.readFile file+ tmpDir <- getTemporaryDirectory+ (fp, h) <- openTempFile tmpDir "floskell.hs"+ BL.hPutStr h $+ reformatByteString style language extensions (Just file) text+ hFlush h+ hClose h+ let exdev e = if ioe_errno e == Just ((\(Errno a) -> a) eXDEV)+ then copyFile fp file >> removeFile fp+ else throw e+ copyPermissions file fp+ renameFile fp file `catch` exdev++-- | Reformat a ByteString according to Style, Language, and Extensions.+reformatByteString :: Style+ -> Language+ -> [Extension]+ -> Maybe FilePath+ -> BS.ByteString+ -> BL.ByteString+reformatByteString style language extensions mpath text =+ either error id $ reformat style language extensions mpath text++-- | Try to find a configuration file based on current working+-- directory, or in one of the application configuration directories.+findConfig :: IO (Maybe FilePath)+findConfig = do+ dotfilePaths <- sequence [ getHomeDirectory, getXdgDirectory XdgConfig "" ]+ dotfileConfig <- findFileWith doesFileExist dotfilePaths ".floskell.json"+ userPaths <- sequence [ getAppUserDataDirectory "floskell"+ , getXdgDirectory XdgConfig "floskell"+ ]+ userConfig <- findFileWith doesFileExist userPaths "config.json"+ localPaths <- map joinPath . reverse . drop 1 . inits . splitDirectories+ <$> getCurrentDirectory+ localConfig <- findFileWith doesFileExist localPaths "floskell.json"+ return $ localConfig <|> userConfig <|> dotfileConfig++-- | Load a configuration file.+readConfig :: FilePath -> IO Config+readConfig file = do+ text <- BS.readFile file+ either (error . (++) (file ++ ": ")) return $ JSON.eitherDecodeStrict text++-- | Update the program configuration from the program options.+mergeConfig :: Config -> Options -> Config+mergeConfig cfg@Config{..} Options{..} =+ cfg { cfgStyle = maybe cfgStyle lookupStyle optStyle+ , cfgLanguage = maybe cfgLanguage lookupLanguage optLanguage+ , cfgExtensions = cfgExtensions ++ map lookupExtension optExtensions+ }++-- | Lookup a style by name.+lookupStyle :: String -> Style+lookupStyle name = case filter ((== T.pack name) . styleName) styles of+ [] -> error $ "Unknown style: " ++ name+ x : _ -> x++-- | Lookup a language by name.+lookupLanguage :: String -> Language+lookupLanguage name = case classifyLanguage name of+ UnknownLanguage _ -> error $ "Unknown language: " ++ name+ x -> x++-- | Lookup an extension by name.+lookupExtension :: String -> Extension+lookupExtension name = case classifyExtension name of+ UnknownExtension _ -> error $ "Unkown extension: " ++ name+ x -> x
+ src/main/Markdone.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE DeriveGeneric #-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A subset of markdown that only supports @#headings@ and code+-- fences.+--+-- All content must be in section headings with proper hierarchy,+-- anything else is rejected.+module Markdone where++import Control.DeepSeq+import Control.Monad.Catch++import Data.ByteString ( ByteString )+import Data.ByteString.Builder as B+import qualified Data.ByteString.Char8 as S8+import Data.Char+import Data.Monoid ( (<>) )+import Data.Typeable++import GHC.Generics++-- | A markdone token.+data Token = Heading !Int !ByteString+ | PlainLine !ByteString+ | BeginFence !ByteString+ | EndFence+ deriving ( Show )++-- | A markdone document.+data Markdone = Section !ByteString ![Markdone]+ | CodeFence !ByteString !ByteString+ | PlainText !ByteString+ deriving ( Show, Generic )++instance NFData Markdone++-- | Parse error.+data MarkdownError = NoFenceEnd | ExpectedSection+ deriving ( Typeable, Show )++instance Exception MarkdownError++-- | Tokenize the bytestring.+tokenize :: ByteString -> [Token]+tokenize = map token . S8.lines+ where+ token line+ | S8.isPrefixOf "#" line =+ let (hashes, title) = S8.span (== '#') line+ in+ Heading (S8.length hashes) (S8.dropWhile isSpace title)+ | S8.isPrefixOf "```" line =+ if line == "```"+ then EndFence+ else BeginFence (S8.dropWhile (\c -> c == '`' || c == ' ') line)+ | otherwise = PlainLine line++-- | Parse into a forest.+parse :: MonadThrow m => [Token] -> m [Markdone]+parse = go (0 :: Int)+ where+ go level = \case+ (Heading n label : rest) ->+ let (children, rest') = span (\case+ Heading nextN _ -> nextN > n+ _ -> True)+ rest+ in+ do+ childs <- go (level + 1) children+ siblings <- go level rest'+ return (Section label childs : siblings)+ (BeginFence label : rest)+ | level > 0 ->+ let (content, rest') = span (\case+ PlainLine{} -> True+ _ -> False)+ rest+ in+ case rest' of+ (EndFence : rest'') ->+ fmap (CodeFence label+ (S8.intercalate "\n"+ (map getPlain+ content)) :)+ (go level rest'')+ _ -> throwM NoFenceEnd+ PlainLine p : rest+ | level > 0 ->+ let (content, rest') = span (\case+ PlainLine{} -> True+ _ -> False)+ (PlainLine p : rest)+ in+ fmap (PlainText (S8.intercalate "\n" (map getPlain content)) :)+ (go level rest')+ [] -> return []+ _ -> throwM ExpectedSection++ getPlain (PlainLine x) = x+ getPlain _ = ""++print :: [Markdone] -> B.Builder+print = mconcat . map (go (0 :: Int))+ where+ go level = \case+ (Section heading children) ->+ let level' = level + 1+ in+ B.byteString (S8.replicate level' '#') <> B.char7 ' '+ <> B.byteString heading <> B.byteString "\n"+ <> mconcat (map (go level') children)+ (CodeFence lang code) -> B.byteString "``` " <> B.byteString lang+ <> B.char7 '\n' <> B.byteString code <> B.byteString "\n```\n"+ (PlainText text) -> B.byteString text <> B.byteString "\n"
+ src/main/Test.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Test the pretty printer.+module Main where++import Control.Monad ( forM_, guard )++import Data.ByteString ( ByteString )+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Builder as L+import qualified Data.ByteString.UTF8 as UTF8+import Data.Maybe ( mapMaybe )+import qualified Data.Text as T++import Floskell++import Language.Haskell.Exts ( Language(Haskell2010) )++import Markdone ( Markdone(..) )+import qualified Markdone as MD++import System.Environment ( getArgs )++import Test.Hspec++data TestTree =+ TestSection String [TestTree] | TestSnippet ByteString | TestMismatchMarker++-- | Prints a string without quoting and escaping.+newtype Readable = Readable ByteString+ deriving ( Eq )++instance Show Readable where+ show (Readable x) = "\n" ++ UTF8.toString x++-- | Version of 'shouldBe' that prints strings in a readable way,+-- better for our use-case.+shouldBeReadable :: ByteString -> ByteString -> Expectation+shouldBeReadable x y = Readable x `shouldBe` Readable y++haskell :: ByteString+haskell = "haskell"++referenceFile :: Style -> String+referenceFile style = "styles/" ++ name ++ ".md"+ where+ name = T.unpack $ styleName style++loadMarkdone :: String -> IO [Markdone]+loadMarkdone filename = do+ bytes <- S.readFile filename+ MD.parse (MD.tokenize bytes)++saveMarkdone :: String -> [Markdone] -> IO ()+saveMarkdone filename doc =+ S.writeFile filename $ L.toStrict $ L.toLazyByteString $ MD.print doc++-- | Extract code snippets from a Markdone document.+extractSnippets :: ByteString -> [Markdone] -> [TestTree]+extractSnippets lang = mapMaybe convert+ where+ convert (Section name children) =+ return $ TestSection (UTF8.toString name) $+ extractSnippets lang children+ convert (CodeFence l c) = do+ guard $ l == lang+ return $ TestSnippet c+ convert _ = Nothing++-- | Load haskell code snippets from Markdone document.+loadSnippets :: String -> IO [TestTree]+loadSnippets filename = do+ doc <- loadMarkdone filename+ return $ extractSnippets haskell doc++-- | Some styles are broken and will fail the idempotency test.+expectedFailures :: [(T.Text, [Int])]+expectedFailures = []++-- | Convert the Markdone document to Spec benchmarks.+toSpec :: Style -> [Int] -> [TestTree] -> [TestTree] -> Spec+toSpec style path inp ref =+ forM_ (zip3 [ 1 :: Int .. ] inp (ref ++ repeat TestMismatchMarker)) $ \case+ (n, TestSection title children, TestSection _ children') ->+ describe title $ toSpec style (path ++ [ n ]) children children'+ (n, TestSnippet code, TestSnippet code') -> do+ let path' = (styleName style, path ++ [ n ])+ it (name n "formats as expected") $+ case reformatSnippet style code of+ Left e -> error e+ Right b -> b `shouldBeReadable` code'+ it (name n "formatting is idempotent") $+ if path' `elem` expectedFailures+ then pending+ else case reformatSnippet style+ code >>= reformatSnippet style of+ Left e -> error e+ Right b -> b `shouldBeReadable` code'+ (n, _, _) -> error $ name n "structure mismatch in reference file"+ where+ name n desc = "Snippet " ++ show n ++ " - " ++ desc++-- | Main tests.+testAll :: IO ()+testAll = do+ input <- loadSnippets "TEST.md"+ refs <- mapM loadRef styles+ hspec $ forM_ refs $+ \(name, style, ref) -> context name $ toSpec style [] input ref+ where+ loadRef style = do+ let name = T.unpack $ styleName style+ tree <- loadSnippets $ referenceFile style+ return (name, style, tree)++reformatSnippet :: Style -> ByteString -> Either String ByteString+reformatSnippet style code = L.toStrict+ <$> reformat style Haskell2010 defaultExtensions (Just "TEST.md") code++regenerate :: Style -> [Markdone] -> [Markdone]+regenerate style = map fmt+ where+ fmt (CodeFence lang code) =+ if lang == haskell+ then CodeFence lang $ either (UTF8.fromString . ("-- " ++) . show) id $+ reformatSnippet style code+ else CodeFence lang code+ fmt (Section heading children) =+ Section heading $ regenerate style children+ fmt x = x++-- | Regenerate style reference files.+regenerateAll :: IO ()+regenerateAll = do+ doc <- loadMarkdone "TEST.md"+ forM_ styles $ \style -> saveMarkdone (referenceFile style) $+ regenerate style doc++main :: IO ()+main = do+ args <- getArgs+ case args of+ [ "regenerate" ] -> regenerateAll+ _ -> testAll