module HIndent.Styles.ChrisDone
(chrisDone)
where
import HIndent.Pretty
import HIndent.Types
import Control.Monad.State.Class
import Data.Int
import Language.Haskell.Exts.Annotated.Syntax
import Prelude hiding (exp)
shortName :: Int64
shortName = 10
smallColumnLimit :: Int64
smallColumnLimit = 50
data State = State
chrisDone :: Style
chrisDone =
Style {styleName = "chris-done"
,styleAuthor = "Chris Done"
,styleDescription = "Chris Done's personal style. Documented here: <https://github.com/chrisdone/haskell-style-guide>"
,styleInitialState = State
,styleExtenders =
[Extender exp
,Extender fieldupdate
,Extender rhs
,Extender guardedrhs
,Extender guardedalt
,Extender unguardedalt]
,styleDefConfig =
Config {configMaxColumns = 80
,configIndentSpaces = 2}}
fieldupdate :: t -> FieldUpdate NodeInfo -> Printer ()
fieldupdate _ e =
case e of
FieldUpdate _ n e' ->
dependOrNewline
(do pretty n
write " = ")
e'
pretty
_ -> prettyNoExt e
rhs :: State -> Rhs NodeInfo -> Printer ()
rhs _ (UnGuardedRhs _ e) =
do indentSpaces <- getIndentSpaces
indented indentSpaces
(dependOrNewline (write " = ")
e
pretty)
rhs _ e = prettyNoExt e
guardedrhs :: State -> GuardedRhs NodeInfo -> Printer ()
guardedrhs _ (GuardedRhs _ stmts e) =
indented 1
(do prefixedLined
','
(map (\p ->
do space
pretty p)
stmts)
dependOrNewline
(write " = ")
e
(indented 1 .
pretty))
guardedalt :: State -> GuardedAlt NodeInfo -> Printer ()
guardedalt _ (GuardedAlt _ stmts e) =
indented 1
(do (prefixedLined
','
(map (\p ->
do space
pretty p)
stmts))
dependOrNewline
(write " -> ")
e
(indented 1 .
pretty))
unguardedalt :: State -> GuardedAlts NodeInfo -> Printer ()
unguardedalt _ (UnGuardedAlt _ e) =
dependOrNewline
(write " -> ")
e
(indented 2 .
pretty)
unguardedalt _ e = prettyNoExt e
exp :: State -> Exp NodeInfo -> Printer ()
exp _ e@(InfixApp _ a op b) =
do is <- isFlat e
overflow <- isOverflow
(depend (do pretty a
space
pretty op
space)
(do pretty b))
if is && not overflow
then do depend (do pretty a
space
pretty op
space)
(do pretty b)
else do pretty a
space
pretty op
newline
pretty b
exp _ (App _ op a) =
do orig <- gets psIndentLevel
headIsShort <- isShort f
depend (do pretty f
space)
(do flats <- mapM isFlat args
flatish <- fmap ((< 2) . length . filter not)
(return flats)
singleLiner <- isSingleLiner (spaced (map pretty args))
overflow <- isOverflowMax (spaced (map pretty args))
if singleLiner &&
((headIsShort && flatish) ||
all id flats) && not overflow
then spaced (map pretty args)
else do allSingleLiners <- fmap (all id)
(mapM (isSingleLiner . pretty) args)
if headIsShort || allSingleLiners
then lined (map pretty args)
else do newline
indentSpaces <- getIndentSpaces
column (orig + indentSpaces)
(lined (map pretty args)))
where (f,args) = flatten op [a]
flatten :: Exp NodeInfo -> [Exp NodeInfo] -> (Exp NodeInfo,[Exp NodeInfo])
flatten (App _ f' a') b =
flatten f' (a' : b)
flatten f' as = (f',as)
exp _ (Lambda _ ps b) =
depend (write "\\")
(do spaced (map pretty ps)
dependOrNewline
(write " -> ")
b
(indented 1 .
pretty))
exp _ (Tuple _ boxed exps) =
depend (write (case boxed of
Unboxed -> "(#"
Boxed -> "("))
(do single <- isSingleLiner p
underflow <- fmap not (isOverflow p)
if single && underflow
then p
else parens (prefixedLined ',' (map pretty exps))
write (case boxed of
Unboxed -> "#)"
Boxed -> ")"))
where p = commas (map pretty exps)
exp _ (List _ es) =
do single <- isSingleLiner p
underflow <- fmap not (isOverflow p)
if single && underflow
then p
else brackets (prefixedLined ','
(map pretty es))
where p = brackets (commas (map pretty es))
exp _ e = prettyNoExt e
isShort :: (Pretty ast) => ast NodeInfo -> Printer Bool
isShort p =
do line <- gets psLine
orig <- fmap psColumn (sandbox (write ""))
st <- sandbox (pretty p)
return (psLine st ==
line &&
(psColumn st <
orig +
shortName))
isSmall :: MonadState PrintState m => m a -> m Bool
isSmall p =
do line <- gets psLine
st <- sandbox p
return (psLine st ==
line &&
psColumn st <
smallColumnLimit)
dependOrNewline :: Printer () -> Exp NodeInfo -> (Exp NodeInfo -> Printer ()) -> Printer ()
dependOrNewline left right f =
do flat <- isFlat right
small <- isSmall (depend left (f right))
if flat || small
then depend left (f right)
else do left
newline
(f right)
isFlat :: Exp NodeInfo -> Printer Bool
isFlat (Lambda _ _ e) = isFlat e
isFlat (App _ a b) = return (isName a && isName b)
where isName (Var{}) = True
isName _ = False
isFlat (InfixApp _ a _ b) =
do a' <- isFlat a
b' <- isFlat b
return (a' && b')
isFlat (NegApp _ a) = isFlat a
isFlat VarQuote{} = return True
isFlat TypQuote{} = return True
isFlat (List _ []) = return True
isFlat Var{} = return True
isFlat Lit{} = return True
isFlat Con{} = return True
isFlat (LeftSection _ e _) = isFlat e
isFlat (RightSection _ _ e) = isFlat e
isFlat _ = return False
isOverflow :: Printer a -> Printer Bool
isOverflow p =
do st <- sandbox p
columnLimit <- getColumnLimit
return (psColumn st >
columnLimit)
isOverflowMax :: Printer a -> Printer Bool
isOverflowMax p =
do st <- sandbox p
columnLimit <- getColumnLimit
return (psColumn st >
columnLimit + 20)
isSingleLiner :: MonadState PrintState m => m a -> m Bool
isSingleLiner p =
do line <- gets psLine
st <- sandbox p
return (psLine st ==
line)