module Futhark.Fmt.Monad
  ( Fmt,
    -- functions for building fmt
    nil,
    nest,
    stdNest,
    text,
    space,
    hardline,
    line,
    sep,
    brackets,
    braces,
    parens,
    (<|>),
    (<+>),
    (</>),
    (<:/>),
    hardIndent,
    indent,
    hardStdIndent,
    stdIndent,
    FmtM,
    popComments,
    runFormat,
    align,
    fmtCopyLoc,
    comment,
    sepArgs,
    localLayout,
    localLayoutList,
    sepDecs,
    fmtByLayout,
    addComments,
    sepComments,
    sepLineComments,
    sepLine,

    -- * Formatting styles
    commentStyle,
    constantStyle,
    keywordStyle,
    bindingStyle,
    infixStyle,
  )
where

import Control.Monad (liftM2)
import Control.Monad.Reader
  ( MonadReader (..),
    ReaderT (..),
  )
import Control.Monad.State
  ( MonadState (..),
    State,
    evalState,
    gets,
    modify,
  )
import Data.ByteString qualified as BS
import Data.List.NonEmpty qualified as NE
import Data.Loc (Loc (..), Located (..), locStart, posCoff, posLine)
import Data.Maybe (fromMaybe)
import Data.String
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Language.Futhark.Parser.Monad (Comment (..))
import Prettyprinter qualified as P
import Prettyprinter.Render.Terminal
  ( AnsiStyle,
    Color (..),
    bold,
    color,
    colorDull,
    italicized,
  )

-- These are right associative since we want to evaluate the monadic
-- computation from left to right. Since the left most expression is
-- printed first and our monad is checking if a comment should be
-- printed.

infixr 6 <:/>

infixr 6 <+>

infixr 6 </>

infixr 4 <|>

type Fmt = FmtM (P.Doc AnsiStyle)

instance Semigroup Fmt where
  <> :: Fmt -> Fmt -> Fmt
(<>) = (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle)
-> Fmt -> Fmt -> Fmt
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid Fmt where
  mempty :: Fmt
mempty = Fmt
nil

instance IsString Fmt where
  fromString :: String -> Fmt
fromString String
s = AnsiStyle -> Text -> Fmt
text AnsiStyle
style Text
s'
    where
      s' :: Text
s' = String -> Text
forall a. IsString a => String -> a
fromString String
s
      style :: AnsiStyle
style =
        if Text
s' Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
keywords
          then AnsiStyle
keywordStyle
          else AnsiStyle
forall a. Monoid a => a
mempty
      keywords :: [Text]
keywords =
        [ Text
"true",
          Text
"false",
          Text
"if",
          Text
"then",
          Text
"else",
          Text
"def",
          Text
"let",
          Text
"loop",
          Text
"in",
          Text
"val",
          Text
"for",
          Text
"do",
          Text
"with",
          Text
"local",
          Text
"open",
          Text
"include",
          Text
"import",
          Text
"type",
          Text
"entry",
          Text
"module",
          Text
"while",
          Text
"assert",
          Text
"match",
          Text
"case"
        ]

commentStyle, keywordStyle, constantStyle, bindingStyle, infixStyle :: AnsiStyle
commentStyle :: AnsiStyle
commentStyle = AnsiStyle
italicized
keywordStyle :: AnsiStyle
keywordStyle = Color -> AnsiStyle
color Color
Magenta AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold
constantStyle :: AnsiStyle
constantStyle = Color -> AnsiStyle
color Color
Green
bindingStyle :: AnsiStyle
bindingStyle = Color -> AnsiStyle
colorDull Color
Blue
infixStyle :: AnsiStyle
infixStyle = Color -> AnsiStyle
colorDull Color
Cyan

-- | This function allows to inspect the layout of an expression @a@ and if it
-- is singleline line then use format @s@ and if it is multiline format @m@.
fmtByLayout ::
  (Located a) => a -> Fmt -> Fmt -> Fmt
fmtByLayout :: forall a. Located a => a -> Fmt -> Fmt -> Fmt
fmtByLayout a
a Fmt
s Fmt
m =
  Fmt
s
    Fmt -> Fmt -> Fmt
<|> ( case a -> Maybe Layout
forall a. Located a => a -> Maybe Layout
lineLayout a
a of
            Just Layout
SingleLine -> Fmt
s
            Maybe Layout
_any -> Fmt
m
        )

-- | This function determines the Layout of @a@ and updates the monads
-- environment to format in the appropriate style. It determines this
-- by checking if the location of @a@ spans over two or more lines.
localLayout :: (Located a) => a -> FmtM b -> FmtM b
localLayout :: forall a b. Located a => a -> FmtM b -> FmtM b
localLayout a
a = (Layout -> Layout)
-> ReaderT Layout (State FmtState) b
-> ReaderT Layout (State FmtState) b
forall a.
(Layout -> Layout)
-> ReaderT Layout (State FmtState) a
-> ReaderT Layout (State FmtState) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Layout
lo -> Layout -> Maybe Layout -> Layout
forall a. a -> Maybe a -> a
fromMaybe Layout
lo (Maybe Layout -> Layout) -> Maybe Layout -> Layout
forall a b. (a -> b) -> a -> b
$ a -> Maybe Layout
forall a. Located a => a -> Maybe Layout
lineLayout a
a)

-- | This function determines the Layout of @[a]@ and if it is singleline then it
-- updates the monads enviroment to format singleline style otherwise format using
-- multiline style. It determines this by checking if the locations of @[a]@
-- start and end at any different line number.
localLayoutList :: (Located a) => [a] -> FmtM b -> FmtM b
localLayoutList :: forall a b. Located a => [a] -> FmtM b -> FmtM b
localLayoutList [a]
a FmtM b
m = do
  Layout
lo <- ReaderT Layout (State FmtState) Layout
forall r (m :: * -> *). MonadReader r m => m r
ask
  case Layout
lo of
    Layout
MultiLine -> (Layout -> Layout) -> FmtM b -> FmtM b
forall a.
(Layout -> Layout)
-> ReaderT Layout (State FmtState) a
-> ReaderT Layout (State FmtState) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Layout -> Layout -> Layout
forall a b. a -> b -> a
const (Layout -> Layout -> Layout) -> Layout -> Layout -> Layout
forall a b. (a -> b) -> a -> b
$ Layout -> Maybe Layout -> Layout
forall a. a -> Maybe a -> a
fromMaybe Layout
lo (Maybe Layout -> Layout) -> Maybe Layout -> Layout
forall a b. (a -> b) -> a -> b
$ [a] -> Maybe Layout
forall a. Located a => [a] -> Maybe Layout
lineLayoutList [a]
a) FmtM b
m
    Layout
SingleLine -> FmtM b
m

-- | This function uses the location of @a@ and prepends comments if
-- the comments location is less than the location of @a@. It format
-- @b@ in accordance with if @a@ is singleline or multiline using
-- 'localLayout'. It currently does not handle trailing comment
-- perfectly. See tests/fmt/traillingComments*.fut.
addComments :: (Located a) => a -> Fmt -> Fmt
addComments :: forall a. Located a => a -> Fmt -> Fmt
addComments a
a Fmt
b = a -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout a
a (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ do
  Doc AnsiStyle
c <- a -> Fmt
forall a. Located a => a -> Fmt
fmtComments a
a
  Doc AnsiStyle
f <- Fmt
b
  Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> Fmt) -> Doc AnsiStyle -> Fmt
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
c Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
f

prependComments :: (a -> Loc) -> (a -> Fmt) -> a -> Fmt
prependComments :: forall a. (a -> Loc) -> (a -> Fmt) -> a -> Fmt
prependComments a -> Loc
floc a -> Fmt
fmt a
a = do
  Maybe (Doc AnsiStyle)
fmcs <- ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
fcs
  Doc AnsiStyle
f <- a -> Fmt
fmt a
a
  Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> Fmt) -> Doc AnsiStyle -> Fmt
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Maybe (Doc AnsiStyle) -> Doc AnsiStyle
forall a. a -> Maybe a -> a
fromMaybe Doc AnsiStyle
forall a. Monoid a => a
mempty Maybe (Doc AnsiStyle)
fmcs Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
f
  where
    fcs :: ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
fcs = do
      FmtState
s <- ReaderT Layout (State FmtState) FmtState
forall s (m :: * -> *). MonadState s m => m s
get
      case FmtState -> [Comment]
comments FmtState
s of
        Comment
c : [Comment]
cs | a -> Loc
floc a
a Loc -> Loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Loc
NoLoc Bool -> Bool -> Bool
&& a -> Loc
floc a
a Loc -> Loc -> Bool
forall a. Ord a => a -> a -> Bool
> Comment -> Loc
forall a. Located a => a -> Loc
locOf Comment
c -> do
          FmtState -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (FmtState -> ReaderT Layout (State FmtState) ())
-> FmtState -> ReaderT Layout (State FmtState) ()
forall a b. (a -> b) -> a -> b
$ FmtState
s {comments = cs}
          Maybe (Doc AnsiStyle)
mcs <- ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
fcs
          Doc AnsiStyle
pre' <- Fmt
pre
          Maybe (Doc AnsiStyle)
-> ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Doc AnsiStyle)
 -> ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle)))
-> Maybe (Doc AnsiStyle)
-> ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just (Doc AnsiStyle -> Maybe (Doc AnsiStyle))
-> Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
pre' Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Comment -> Doc AnsiStyle
forall {ann}. Comment -> Doc ann
fmtNoLine Comment
c Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
-> (Doc AnsiStyle -> Doc AnsiStyle)
-> Maybe (Doc AnsiStyle)
-> Doc AnsiStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc AnsiStyle
forall a. Monoid a => a
mempty (Doc AnsiStyle
forall ann. Doc ann
P.line <>) Maybe (Doc AnsiStyle)
mcs
        [Comment]
_any -> Maybe (Doc AnsiStyle)
-> ReaderT Layout (State FmtState) (Maybe (Doc AnsiStyle))
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Doc AnsiStyle)
forall a. Maybe a
Nothing
    fmtNoLine :: Comment -> Doc ann
fmtNoLine = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
P.pretty (Text -> Doc ann) -> (Comment -> Text) -> Comment -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Comment -> Text
commentText
    pre :: Fmt
pre = do
      Maybe LastOutput
lastO <- (FmtState -> Maybe LastOutput)
-> ReaderT Layout (State FmtState) (Maybe LastOutput)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FmtState -> Maybe LastOutput
lastOutput
      case Maybe LastOutput
lastO of
        Maybe LastOutput
Nothing -> Fmt
nil
        Just LastOutput
Line -> Fmt
nil
        Just LastOutput
_ -> (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {lastOutput = Just Line}) ReaderT Layout (State FmtState) () -> Fmt -> Fmt
forall a b.
ReaderT Layout (State FmtState) a
-> ReaderT Layout (State FmtState) b
-> ReaderT Layout (State FmtState) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Fmt
hardline

-- | The internal state of the formatter monad 'FmtM'.
data FmtState = FmtState
  { -- | The comments that will be inserted, ordered by increasing order in regards to location.
    FmtState -> [Comment]
comments :: [Comment],
    -- | The original source file that is being formatted.
    FmtState -> ByteString
file :: BS.ByteString,
    -- | Keeps track of what type the last output was.
    FmtState -> Maybe LastOutput
lastOutput :: !(Maybe LastOutput)
  }
  deriving (Int -> FmtState -> ShowS
[FmtState] -> ShowS
FmtState -> String
(Int -> FmtState -> ShowS)
-> (FmtState -> String) -> ([FmtState] -> ShowS) -> Show FmtState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FmtState -> ShowS
showsPrec :: Int -> FmtState -> ShowS
$cshow :: FmtState -> String
show :: FmtState -> String
$cshowList :: [FmtState] -> ShowS
showList :: [FmtState] -> ShowS
Show, FmtState -> FmtState -> Bool
(FmtState -> FmtState -> Bool)
-> (FmtState -> FmtState -> Bool) -> Eq FmtState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FmtState -> FmtState -> Bool
== :: FmtState -> FmtState -> Bool
$c/= :: FmtState -> FmtState -> Bool
/= :: FmtState -> FmtState -> Bool
Eq, Eq FmtState
Eq FmtState =>
(FmtState -> FmtState -> Ordering)
-> (FmtState -> FmtState -> Bool)
-> (FmtState -> FmtState -> Bool)
-> (FmtState -> FmtState -> Bool)
-> (FmtState -> FmtState -> Bool)
-> (FmtState -> FmtState -> FmtState)
-> (FmtState -> FmtState -> FmtState)
-> Ord FmtState
FmtState -> FmtState -> Bool
FmtState -> FmtState -> Ordering
FmtState -> FmtState -> FmtState
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FmtState -> FmtState -> Ordering
compare :: FmtState -> FmtState -> Ordering
$c< :: FmtState -> FmtState -> Bool
< :: FmtState -> FmtState -> Bool
$c<= :: FmtState -> FmtState -> Bool
<= :: FmtState -> FmtState -> Bool
$c> :: FmtState -> FmtState -> Bool
> :: FmtState -> FmtState -> Bool
$c>= :: FmtState -> FmtState -> Bool
>= :: FmtState -> FmtState -> Bool
$cmax :: FmtState -> FmtState -> FmtState
max :: FmtState -> FmtState -> FmtState
$cmin :: FmtState -> FmtState -> FmtState
min :: FmtState -> FmtState -> FmtState
Ord)

-- | A data type to describe the last output used during formatting.
data LastOutput = Line | Space | Text | Comm deriving (Int -> LastOutput -> ShowS
[LastOutput] -> ShowS
LastOutput -> String
(Int -> LastOutput -> ShowS)
-> (LastOutput -> String)
-> ([LastOutput] -> ShowS)
-> Show LastOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LastOutput -> ShowS
showsPrec :: Int -> LastOutput -> ShowS
$cshow :: LastOutput -> String
show :: LastOutput -> String
$cshowList :: [LastOutput] -> ShowS
showList :: [LastOutput] -> ShowS
Show, LastOutput -> LastOutput -> Bool
(LastOutput -> LastOutput -> Bool)
-> (LastOutput -> LastOutput -> Bool) -> Eq LastOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LastOutput -> LastOutput -> Bool
== :: LastOutput -> LastOutput -> Bool
$c/= :: LastOutput -> LastOutput -> Bool
/= :: LastOutput -> LastOutput -> Bool
Eq, Eq LastOutput
Eq LastOutput =>
(LastOutput -> LastOutput -> Ordering)
-> (LastOutput -> LastOutput -> Bool)
-> (LastOutput -> LastOutput -> Bool)
-> (LastOutput -> LastOutput -> Bool)
-> (LastOutput -> LastOutput -> Bool)
-> (LastOutput -> LastOutput -> LastOutput)
-> (LastOutput -> LastOutput -> LastOutput)
-> Ord LastOutput
LastOutput -> LastOutput -> Bool
LastOutput -> LastOutput -> Ordering
LastOutput -> LastOutput -> LastOutput
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LastOutput -> LastOutput -> Ordering
compare :: LastOutput -> LastOutput -> Ordering
$c< :: LastOutput -> LastOutput -> Bool
< :: LastOutput -> LastOutput -> Bool
$c<= :: LastOutput -> LastOutput -> Bool
<= :: LastOutput -> LastOutput -> Bool
$c> :: LastOutput -> LastOutput -> Bool
> :: LastOutput -> LastOutput -> Bool
$c>= :: LastOutput -> LastOutput -> Bool
>= :: LastOutput -> LastOutput -> Bool
$cmax :: LastOutput -> LastOutput -> LastOutput
max :: LastOutput -> LastOutput -> LastOutput
$cmin :: LastOutput -> LastOutput -> LastOutput
min :: LastOutput -> LastOutput -> LastOutput
Ord)

-- | A data type to describe the layout the formatter is using currently.
data Layout = MultiLine | SingleLine deriving (Int -> Layout -> ShowS
[Layout] -> ShowS
Layout -> String
(Int -> Layout -> ShowS)
-> (Layout -> String) -> ([Layout] -> ShowS) -> Show Layout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Layout -> ShowS
showsPrec :: Int -> Layout -> ShowS
$cshow :: Layout -> String
show :: Layout -> String
$cshowList :: [Layout] -> ShowS
showList :: [Layout] -> ShowS
Show, Layout -> Layout -> Bool
(Layout -> Layout -> Bool)
-> (Layout -> Layout -> Bool) -> Eq Layout
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Layout -> Layout -> Bool
== :: Layout -> Layout -> Bool
$c/= :: Layout -> Layout -> Bool
/= :: Layout -> Layout -> Bool
Eq)

-- | The format monad used to keep track of comments and layout. It is a a
-- combincation of a reader and state monad. The comments and reading from the
-- input file are the state monads job to deal with. While the reader monad
-- deals with the propagating the current layout.
type FmtM a = ReaderT Layout (State FmtState) a

fmtComment :: Comment -> Fmt
fmtComment :: Comment -> Fmt
fmtComment Comment
c = Text -> Fmt
comment (Text -> Fmt) -> Text -> Fmt
forall a b. (a -> b) -> a -> b
$ Comment -> Text
commentText Comment
c

fmtCommentList :: [Comment] -> Fmt
fmtCommentList :: [Comment] -> Fmt
fmtCommentList [] = Fmt
nil
fmtCommentList (Comment
c : [Comment]
cs) =
  (Fmt, Loc) -> Fmt
forall a b. (a, b) -> a
fst ((Fmt, Loc) -> Fmt) -> (Fmt, Loc) -> Fmt
forall a b. (a -> b) -> a -> b
$ ((Fmt, Loc) -> Comment -> (Fmt, Loc))
-> (Fmt, Loc) -> [Comment] -> (Fmt, Loc)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Fmt, Loc) -> Comment -> (Fmt, Loc)
f (Comment -> Fmt
fmtComment Comment
c, Comment -> Loc
forall a. Located a => a -> Loc
locOf Comment
c) [Comment]
cs
  where
    f :: (Fmt, Loc) -> Comment -> (Fmt, Loc)
f (Fmt
acc, Loc
loc) Comment
c' =
      if Loc -> Loc -> Bool
consecutive Loc
loc (Comment -> Loc
forall a. Located a => a -> Loc
locOf Comment
c')
        then (Fmt
acc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Comment -> Fmt
fmtComment Comment
c', Comment -> Loc
forall a. Located a => a -> Loc
locOf Comment
c')
        else (Fmt
acc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
hardline Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Comment -> Fmt
fmtComment Comment
c', Comment -> Loc
forall a. Located a => a -> Loc
locOf Comment
c')

hasComment :: (Located a) => a -> FmtM Bool
hasComment :: forall a. Located a => a -> FmtM Bool
hasComment a
a =
  (FmtState -> Bool) -> FmtM Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FmtState -> Bool) -> FmtM Bool)
-> (FmtState -> Bool) -> FmtM Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> (FmtState -> Bool) -> FmtState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Comment] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Comment] -> Bool) -> (FmtState -> [Comment]) -> FmtState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comment -> Bool) -> [Comment] -> [Comment]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile Comment -> Bool
forall {a}. Located a => a -> Bool
relevant ([Comment] -> [Comment])
-> (FmtState -> [Comment]) -> FmtState -> [Comment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FmtState -> [Comment]
comments
  where
    relevant :: a -> Bool
relevant a
c = a -> Loc
forall a. Located a => a -> Loc
locOf a
a Loc -> Loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Loc
NoLoc Bool -> Bool -> Bool
&& a -> Loc
forall a. Located a => a -> Loc
locOf a
a Loc -> Loc -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Loc
forall a. Located a => a -> Loc
locOf a
c

-- | Prepends comments.
fmtComments :: (Located a) => a -> Fmt
fmtComments :: forall a. Located a => a -> Fmt
fmtComments a
a = do
  ([Comment]
here, [Comment]
later) <- (FmtState -> ([Comment], [Comment]))
-> ReaderT Layout (State FmtState) ([Comment], [Comment])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FmtState -> ([Comment], [Comment]))
 -> ReaderT Layout (State FmtState) ([Comment], [Comment]))
-> (FmtState -> ([Comment], [Comment]))
-> ReaderT Layout (State FmtState) ([Comment], [Comment])
forall a b. (a -> b) -> a -> b
$ (Comment -> Bool) -> [Comment] -> ([Comment], [Comment])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Comment -> Bool
forall {a}. Located a => a -> Bool
relevant ([Comment] -> ([Comment], [Comment]))
-> (FmtState -> [Comment]) -> FmtState -> ([Comment], [Comment])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FmtState -> [Comment]
comments
  if [Comment] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Comment]
here
    then Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc AnsiStyle
forall a. Monoid a => a
mempty
    else do
      (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FmtState -> FmtState) -> ReaderT Layout (State FmtState) ())
-> (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall a b. (a -> b) -> a -> b
$ \FmtState
s -> FmtState
s {comments = later}
      [Comment] -> Fmt
fmtCommentList [Comment]
here
        Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> if Loc -> Loc -> Bool
consecutive ([Comment] -> Loc
forall a. Located a => a -> Loc
locOf [Comment]
here) (a -> Loc
forall a. Located a => a -> Loc
locOf a
a) then Fmt
nil else Fmt
hardline
  where
    relevant :: a -> Bool
relevant a
c = a -> Loc
forall a. Located a => a -> Loc
locOf a
a Loc -> Loc -> Bool
forall a. Eq a => a -> a -> Bool
/= Loc
NoLoc Bool -> Bool -> Bool
&& a -> Loc
forall a. Located a => a -> Loc
locOf a
a Loc -> Loc -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Loc
forall a. Located a => a -> Loc
locOf a
c

-- | Determines the layout of @a@ by checking if it spans a single line or two
-- or more lines.
lineLayout :: (Located a) => a -> Maybe Layout
lineLayout :: forall a. Located a => a -> Maybe Layout
lineLayout a
a =
  case a -> Loc
forall a. Located a => a -> Loc
locOf a
a of
    Loc Pos
start Pos
end ->
      if Pos -> Int
posLine Pos
start Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Pos -> Int
posLine Pos
end
        then Layout -> Maybe Layout
forall a. a -> Maybe a
Just Layout
SingleLine
        else Layout -> Maybe Layout
forall a. a -> Maybe a
Just Layout
MultiLine
    Loc
NoLoc -> Maybe Layout
forall a. Maybe a
Nothing -- error "Formatting term without location."

-- | Determines the layout of @[a]@ by checking if it spans a single line or two
-- or more lines.
lineLayoutList :: (Located a) => [a] -> Maybe Layout
lineLayoutList :: forall a. Located a => [a] -> Maybe Layout
lineLayoutList [a]
as =
  case (a -> [Int]) -> [a] -> [Int]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [Int]
forall {a}. Located a => a -> [Int]
auxiliary [a]
as of
    [] -> Maybe Layout
forall a. Maybe a
Nothing
    (Int
t : [Int]
ts) | (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
t) [Int]
ts -> Layout -> Maybe Layout
forall a. a -> Maybe a
Just Layout
MultiLine
    [Int]
_ -> Layout -> Maybe Layout
forall a. a -> Maybe a
Just Layout
SingleLine
  where
    auxiliary :: a -> [Int]
auxiliary a
a =
      case a -> Loc
forall a. Located a => a -> Loc
locOf a
a of
        Loc Pos
start Pos
end -> [Pos -> Int
posLine Pos
start, Pos -> Int
posLine Pos
end]
        Loc
NoLoc -> [] -- error "Formatting term without location"

-- | Retrieves the last comments from the monad and concatenates them together.
popComments :: Fmt
popComments :: Fmt
popComments = do
  [Comment]
cs <- (FmtState -> [Comment])
-> ReaderT Layout (State FmtState) [Comment]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FmtState -> [Comment]
comments
  (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {comments = []})
  Maybe LastOutput
lastO <- (FmtState -> Maybe LastOutput)
-> ReaderT Layout (State FmtState) (Maybe LastOutput)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FmtState -> Maybe LastOutput
lastOutput
  case Maybe LastOutput
lastO of
    Maybe LastOutput
Nothing ->
      [Comment] -> Fmt
fmtCommentList [Comment]
cs -- Happens when file has only comments.
    Maybe LastOutput
_
      | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Comment] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Comment]
cs -> Fmt
hardline Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> [Comment] -> Fmt
fmtCommentList [Comment]
cs
      | Bool
otherwise -> Fmt
nil

-- | Using the location of @a@ get the segment of text in the original file to
-- create a @Fmt@.
fmtCopyLoc :: (Located a) => AnsiStyle -> a -> Fmt
fmtCopyLoc :: forall a. Located a => AnsiStyle -> a -> Fmt
fmtCopyLoc AnsiStyle
style a
a = do
  ByteString
f <- (FmtState -> ByteString)
-> ReaderT Layout (State FmtState) ByteString
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FmtState -> ByteString
file
  case a -> Loc
forall a. Located a => a -> Loc
locOf a
a of
    Loc Pos
sPos Pos
ePos ->
      let sOff :: Int
sOff = Pos -> Int
posCoff Pos
sPos
          eOff :: Int
eOff = Pos -> Int
posCoff Pos
ePos
       in case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take (Int
eOff Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
sOff) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop Int
sOff ByteString
f of
            Left UnicodeException
err -> String -> Fmt
forall a. HasCallStack => String -> a
error (String -> Fmt) -> String -> Fmt
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err
            Right Text
lit -> AnsiStyle -> Text -> Fmt
text AnsiStyle
style Text
lit
    Loc
NoLoc -> String -> Fmt
forall a. HasCallStack => String -> a
error String
"Formatting term without location"

-- | Given a formatter @FmtM a@, a sequence of comments ordered in increasing
-- order by location, and the original text files content. Run the formatter and
-- create @a@.
runFormat :: FmtM a -> [Comment] -> T.Text -> a
runFormat :: forall a. FmtM a -> [Comment] -> Text -> a
runFormat FmtM a
format [Comment]
cs Text
file = State FmtState a -> FmtState -> a
forall s a. State s a -> s -> a
evalState (FmtM a -> Layout -> State FmtState a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT FmtM a
format Layout
e) FmtState
s
  where
    s :: FmtState
s =
      FmtState
        { comments :: [Comment]
comments = [Comment]
cs,
          file :: ByteString
file = Text -> ByteString
T.encodeUtf8 Text
file,
          lastOutput :: Maybe LastOutput
lastOutput = Maybe LastOutput
forall a. Maybe a
Nothing
        }
    e :: Layout
e = Layout
MultiLine

-- | An empty input.
nil :: Fmt
nil :: Fmt
nil = Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc AnsiStyle
forall a. Monoid a => a
mempty

-- | Indents everything after a line occurs if in multiline and if in singleline
-- then indent.
nest :: Int -> Fmt -> Fmt
nest :: Int -> Fmt -> Fmt
nest Int
i Fmt
a = Fmt
a Fmt -> Fmt -> Fmt
<|> (Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
i (Doc AnsiStyle -> Doc AnsiStyle) -> Fmt -> Fmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fmt
a)

-- | A space.
space :: Fmt
space :: Fmt
space = (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {lastOutput = Just Space}) ReaderT Layout (State FmtState) () -> Fmt -> Fmt
forall a b.
ReaderT Layout (State FmtState) a
-> ReaderT Layout (State FmtState) b
-> ReaderT Layout (State FmtState) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc AnsiStyle
forall ann. Doc ann
P.space

-- | Forces a line to be used regardless of layout, this should
-- ideally not be used.
hardline :: Fmt
hardline :: Fmt
hardline = do
  (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FmtState -> FmtState) -> ReaderT Layout (State FmtState) ())
-> (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall a b. (a -> b) -> a -> b
$ \FmtState
s -> FmtState
s {lastOutput = Just Line}
  Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc AnsiStyle
forall ann. Doc ann
P.line

-- | A line or a space depending on layout.
line :: Fmt
line :: Fmt
line = Fmt
space Fmt -> Fmt -> Fmt
<|> Fmt
hardline

-- | Seperates element by a @s@ followed by a space in singleline layout and
-- seperates by a line followed by a @s@ in multine layout.
sepLine :: Fmt -> [Fmt] -> Fmt
sepLine :: Fmt -> [Fmt] -> Fmt
sepLine Fmt
s = Fmt -> [Fmt] -> Fmt
sep (Fmt
s Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space Fmt -> Fmt -> Fmt
<|> Fmt
hardline Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
s)

-- | A comment.
comment :: T.Text -> Fmt
comment :: Text -> Fmt
comment Text
c = do
  (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {lastOutput = Just Line})
  Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> Fmt) -> Doc AnsiStyle -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
P.annotate AnsiStyle
commentStyle (Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
P.pretty (Text -> Text
T.stripEnd Text
c)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
P.line

sep :: Fmt -> [Fmt] -> Fmt
sep :: Fmt -> [Fmt] -> Fmt
sep Fmt
_ [] = Fmt
nil
sep Fmt
s (Fmt
a : [Fmt]
as) = Fmt -> [Fmt] -> Fmt
auxiliary Fmt
a [Fmt]
as
  where
    auxiliary :: Fmt -> [Fmt] -> Fmt
auxiliary Fmt
acc [] = Fmt
acc
    auxiliary Fmt
acc (Fmt
x : [Fmt]
xs) = Fmt -> [Fmt] -> Fmt
auxiliary (Fmt
acc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
s Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
x) [Fmt]
xs

sepComments :: (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
sepComments :: forall a. (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
sepComments a -> Loc
_ a -> Fmt
_ Fmt
_ [] = Fmt
nil
sepComments a -> Loc
floc a -> Fmt
fmt Fmt
s (a
a : [a]
as) = Fmt -> [a] -> Fmt
auxiliary (a -> Fmt
fmt a
a) [a]
as
  where
    auxiliary :: Fmt -> [a] -> Fmt
auxiliary Fmt
acc [] = Fmt
acc
    auxiliary Fmt
acc (a
x : [a]
xs) =
      Fmt -> [a] -> Fmt
auxiliary (Fmt
acc Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (a -> Loc) -> (a -> Fmt) -> a -> Fmt
forall a. (a -> Loc) -> (a -> Fmt) -> a -> Fmt
prependComments a -> Loc
floc (\a
y -> Fmt
s Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> a -> Fmt
fmt a
y) a
x) [a]
xs

sepLineComments :: (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
sepLineComments :: forall a. (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
sepLineComments a -> Loc
floc a -> Fmt
fmt Fmt
s =
  (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
forall a. (a -> Loc) -> (a -> Fmt) -> Fmt -> [a] -> Fmt
sepComments a -> Loc
floc a -> Fmt
fmt (Fmt
s Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space Fmt -> Fmt -> Fmt
<|> Fmt
hardline Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
s)

-- | This is used for function arguments. It seperates multiline
-- arguments by lines and singleline arguments by spaces. We specially
-- handle the case where all the arguments are on a single line except
-- for the last one, which may continue to the next line.
sepArgs :: (Located a) => (a -> Fmt) -> NE.NonEmpty a -> Fmt
sepArgs :: forall a. Located a => (a -> Fmt) -> NonEmpty a -> Fmt
sepArgs a -> Fmt
fmt NonEmpty a
ls =
  [Loc] -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout [Loc]
locs (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> Fmt
align' (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ Fmt -> [Fmt] -> Fmt
sep Fmt
line ([Fmt] -> Fmt) -> [Fmt] -> Fmt
forall a b. (a -> b) -> a -> b
$ (a -> Fmt) -> [a] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map a -> Fmt
fmtArg [a]
ls'
  where
    locs :: [Loc]
locs = (a -> Loc) -> [a] -> [Loc]
forall a b. (a -> b) -> [a] -> [b]
map (Loc -> Loc
locStart (Loc -> Loc) -> (a -> Loc) -> a -> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Loc
forall a. Located a => a -> Loc
locOf) [a]
ls'
    align' :: Fmt -> Fmt
align' = case [Loc] -> Maybe Layout
forall a. Located a => a -> Maybe Layout
lineLayout [Loc]
locs of
      Just Layout
SingleLine -> Fmt -> Fmt
forall a. a -> a
id
      Maybe Layout
_ -> Fmt -> Fmt
align
    fmtArg :: a -> Fmt
fmtArg a
x = a -> Fmt -> Fmt
forall a b. Located a => a -> FmtM b -> FmtM b
localLayout a
x (Fmt -> Fmt) -> Fmt -> Fmt
forall a b. (a -> b) -> a -> b
$ a -> Fmt
fmt a
x
    ls' :: [a]
ls' = NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ls

-- | Nest but with the standard value of two spaces.
stdNest :: Fmt -> Fmt
stdNest :: Fmt -> Fmt
stdNest = Int -> Fmt -> Fmt
nest Int
2

-- | Aligns line by line.
align :: Fmt -> Fmt
align :: Fmt -> Fmt
align Fmt
a = do
  (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {lastOutput = Just Line}) -- XXX?
  Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
P.align (Doc AnsiStyle -> Doc AnsiStyle) -> Fmt -> Fmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fmt
a

-- | Indents everything by @i@, should never be used.
hardIndent :: Int -> Fmt -> Fmt
hardIndent :: Int -> Fmt -> Fmt
hardIndent Int
i Fmt
a = Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
P.indent Int
i (Doc AnsiStyle -> Doc AnsiStyle) -> Fmt -> Fmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fmt
a

-- | Indents if in multiline by @i@ if in singleline it does not indent.
indent :: Int -> Fmt -> Fmt
indent :: Int -> Fmt -> Fmt
indent Int
i Fmt
a = Fmt
a Fmt -> Fmt -> Fmt
<|> Int -> Fmt -> Fmt
hardIndent Int
i Fmt
a

-- | Hard indents with the standard size of two.
hardStdIndent :: Fmt -> Fmt
hardStdIndent :: Fmt -> Fmt
hardStdIndent = Int -> Fmt -> Fmt
hardIndent Int
2

-- | Idents with the standard size of two.
stdIndent :: Fmt -> Fmt
stdIndent :: Fmt -> Fmt
stdIndent = Int -> Fmt -> Fmt
indent Int
2

-- | Creates a piece of text, it should not contain any new lines.
text :: AnsiStyle -> T.Text -> Fmt
text :: AnsiStyle -> Text -> Fmt
text AnsiStyle
style Text
t = do
  (FmtState -> FmtState) -> ReaderT Layout (State FmtState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\FmtState
s -> FmtState
s {lastOutput = Just Text})
  Doc AnsiStyle -> Fmt
forall a. a -> ReaderT Layout (State FmtState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc AnsiStyle -> Fmt) -> Doc AnsiStyle -> Fmt
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
P.annotate AnsiStyle
style (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
P.pretty Text
t

-- | Adds brackets.
brackets :: Fmt -> Fmt
brackets :: Fmt -> Fmt
brackets Fmt
a = Fmt
"[" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"]"

-- | Adds braces.
braces :: Fmt -> Fmt
braces :: Fmt -> Fmt
braces Fmt
a = Fmt
"{" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
"}"

-- | Add parenthesis.
parens :: Fmt -> Fmt
parens :: Fmt -> Fmt
parens Fmt
a = Fmt
"(" Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
")"

-- | If in a singleline layout then concatenate with 'nil' and in multiline
-- concatenate by a line.
(<:/>) :: Fmt -> Fmt -> Fmt
Fmt
a <:/> :: Fmt -> Fmt -> Fmt
<:/> Fmt
b = Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> (Fmt
nil Fmt -> Fmt -> Fmt
<|> Fmt
hardline) Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
b

-- | Concatenate with a space between.
(<+>) :: Fmt -> Fmt -> Fmt
Fmt
a <+> :: Fmt -> Fmt -> Fmt
<+> Fmt
b = Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
space Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
b

-- | Concatenate with a space if in singleline layout and concatenate by a
-- line in multiline.
(</>) :: Fmt -> Fmt -> Fmt
Fmt
a </> :: Fmt -> Fmt -> Fmt
</> Fmt
b = Fmt
a Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
line Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
b

-- | If in a singleline layout then choose @a@, if in a multiline layout choose
-- @b@.
(<|>) :: Fmt -> Fmt -> Fmt
Fmt
a <|> :: Fmt -> Fmt -> Fmt
<|> Fmt
b = do
  Layout
lo <- ReaderT Layout (State FmtState) Layout
forall r (m :: * -> *). MonadReader r m => m r
ask
  if Layout
lo Layout -> Layout -> Bool
forall a. Eq a => a -> a -> Bool
== Layout
SingleLine
    then Fmt
a
    else Fmt
b

-- | Are these locations on consecutive lines?
consecutive :: Loc -> Loc -> Bool
consecutive :: Loc -> Loc -> Bool
consecutive (Loc Pos
_ Pos
end) (Loc Pos
beg Pos
_) = Pos -> Int
posLine Pos
end Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Pos -> Int
posLine Pos
beg
consecutive Loc
_ Loc
_ = Bool
False

-- | If in singleline layout seperate by spaces. In a multiline layout seperate
-- by a single line if two neighbouring elements are singleline. Otherwise
-- sepereate by two lines.
sepDecs :: (Located a) => (a -> Fmt) -> [a] -> Fmt
sepDecs :: forall a. Located a => (a -> Fmt) -> [a] -> Fmt
sepDecs a -> Fmt
_ [] = Fmt
nil
sepDecs a -> Fmt
fmt decs :: [a]
decs@(a
x : [a]
xs) =
  Fmt -> [Fmt] -> Fmt
sep Fmt
space ((a -> Fmt) -> [a] -> [Fmt]
forall a b. (a -> b) -> [a] -> [b]
map a -> Fmt
fmt [a]
decs) Fmt -> Fmt -> Fmt
<|> (a -> Fmt
fmt a
x Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> a -> [a] -> Fmt
auxiliary a
x [a]
xs)
  where
    auxiliary :: a -> [a] -> Fmt
auxiliary a
_ [] = Fmt
nil
    auxiliary a
prev (a
y : [a]
ys) = Fmt
p Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> a -> Fmt
fmt a
y Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> a -> [a] -> Fmt
auxiliary a
y [a]
ys
      where
        p :: Fmt
p = do
          Bool
commented <- a -> FmtM Bool
forall a. Located a => a -> FmtM Bool
hasComment a
y
          case (Bool
commented, a -> Maybe Layout
forall a. Located a => a -> Maybe Layout
lineLayout a
y, a -> Maybe Layout
forall a. Located a => a -> Maybe Layout
lineLayout a
prev) of
            (Bool
False, Just Layout
SingleLine, Just Layout
SingleLine)
              | Loc -> Loc -> Bool
consecutive (a -> Loc
forall a. Located a => a -> Loc
locOf a
prev) (a -> Loc
forall a. Located a => a -> Loc
locOf a
y) -> Fmt
hardline
            (Bool, Maybe Layout, Maybe Layout)
_any -> Fmt
hardline Fmt -> Fmt -> Fmt
forall a. Semigroup a => a -> a -> a
<> Fmt
hardline