{-| Pretty printing functions.
-}
module Agda.Syntax.Common.Pretty
    ( module Agda.Syntax.Common.Pretty
    , module Text.PrettyPrint.Annotated
    -- This re-export can be removed once <GHC-8.4 is dropped.
    , module Data.Semigroup
    ) where

import Prelude hiding (null)

import qualified Data.List as List
import qualified Data.Foldable as Fold
import qualified Data.IntSet as IntSet
import qualified Data.IntMap as IntMap
import qualified Data.Text as T
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import Data.IntMap (IntMap)
import Data.Word (Word64)
import Data.Text (Text)
import Data.Int (Int32)
import Data.Map (Map)
import Data.Set (Set)

import qualified Text.PrettyPrint.Annotated as P
import Text.PrettyPrint.Annotated hiding
  ( Doc, TextDetails(Str), empty, (<>), sep, fsep, hsep, hcat, vcat, punctuate

  , parens, brackets, braces, quotes, doubleQuotes

  , semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack
  , lbrace, rbrace
  )

import Data.Semigroup ((<>))

import Agda.Utils.Float
import Agda.Utils.List1 (List1)
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Null
import Agda.Utils.Size

import Agda.Syntax.Common.Aspect
import Agda.Syntax.Position
import Agda.Utils.Impossible
import Agda.Utils.FileName


-- * Pretty class

-- | The type of documents. We use documents annotated by 'Aspects' to
-- record syntactic highlighting information that is generated during
-- pretty-printing.
type Doc = P.Doc Aspects

-- | While 'Show' is for rendering data in Haskell syntax,
--   'Pretty' is for displaying data to the world, i.e., the
--   user and the environment.
--
--   Atomic data has no inner document structure, so just
--   implement 'pretty' as @pretty a = text $ ... a ...@.

class Pretty a where
  pretty      :: a -> Doc
  prettyPrec  :: Int -> a -> Doc
  prettyList  :: [a] -> Doc

  pretty      = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
0
  prettyPrec  = (a -> Doc) -> Int -> a -> Doc
forall a b. a -> b -> a
const a -> Doc
forall a. Pretty a => a -> Doc
pretty
  prettyList  = Doc -> Doc
brackets (Doc -> Doc) -> ([a] -> Doc) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_

-- | Use instead of 'show' when printing to world.

prettyShow :: Pretty a => a -> String
prettyShow :: forall a. Pretty a => a -> String
prettyShow = Doc -> String
forall a. Doc a -> String
render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
pretty

-- * Pretty instances

instance Pretty Bool    where pretty :: Bool -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Bool -> String) -> Bool -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show
instance Pretty Int     where pretty :: Int -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Int -> String) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
instance Pretty Int32   where pretty :: Int32 -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Int32 -> String) -> Int32 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> String
forall a. Show a => a -> String
show
instance Pretty Integer where pretty :: Integer -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Integer -> String) -> Integer -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show
instance Pretty Word64  where pretty :: Word64 -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Word64 -> String) -> Word64 -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> String
forall a. Show a => a -> String
show
instance Pretty Double  where pretty :: Double -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Double -> String) -> Double -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
toStringWithoutDotZero
instance Pretty Text    where pretty :: Text -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance Pretty Char where
  pretty :: Char -> Doc
pretty Char
c = String -> Doc
forall a. String -> Doc a
text [Char
c]
  prettyList :: String -> Doc
prettyList = String -> Doc
forall a. String -> Doc a
text


-- The equational constraint forces GHC to pick this instance and unify
-- the type variable, instead of deferring selection to when the type of
-- annotations is solved.
instance a ~ Aspects => Pretty (P.Doc a) where
  pretty :: Doc a -> Doc
pretty = Doc a -> Doc a
Doc a -> Doc
forall a. a -> a
id

instance Pretty () where
  pretty :: () -> Doc
pretty ()
_ = Doc
forall a. Doc a
P.empty

instance Pretty a => Pretty (Maybe a) where
  prettyPrec :: Int -> Maybe a -> Doc
prettyPrec Int
p Maybe a
Nothing  = Doc
forall a. Doc a
P.empty
  prettyPrec Int
p (Just a
x) = Int -> a -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
p a
x

instance Pretty a => Pretty [a] where
  pretty :: [a] -> Doc
pretty = [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList

instance Pretty a => Pretty (List1 a) where
  pretty :: List1 a -> Doc
pretty = [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList ([a] -> Doc) -> (List1 a -> [a]) -> List1 a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 a -> [a]
List1 a -> [Item (List1 a)]
forall l. IsList l => l -> [Item l]
List1.toList

instance Pretty IntSet where
  pretty :: IntSet -> Doc
pretty = [Int] -> Doc
forall a. Pretty a => [a] -> Doc
prettySet ([Int] -> Doc) -> (IntSet -> [Int]) -> IntSet -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntSet -> [Int]
IntSet.toList

instance Pretty a => Pretty (Set a) where
  pretty :: Set a -> Doc
pretty = [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettySet ([a] -> Doc) -> (Set a -> [a]) -> Set a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> [a]
forall a. Set a -> [a]
Set.toList

instance Pretty a => Pretty (IntMap a) where
  pretty :: IntMap a -> Doc
pretty = [(Int, a)] -> Doc
forall k v. (Pretty k, Pretty v) => [(k, v)] -> Doc
prettyMap ([(Int, a)] -> Doc) -> (IntMap a -> [(Int, a)]) -> IntMap a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap a -> [(Int, a)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList

instance (Pretty k, Pretty v) => Pretty (Map k v) where
  pretty :: Map k v -> Doc
pretty = [(k, v)] -> Doc
forall k v. (Pretty k, Pretty v) => [(k, v)] -> Doc
prettyMap ([(k, v)] -> Doc) -> (Map k v -> [(k, v)]) -> Map k v -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- Pretty instances for dependencies of this module (to avoid dependency cycles)

instance Pretty AbsolutePath where
  pretty :: AbsolutePath -> Doc
pretty = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (AbsolutePath -> String) -> AbsolutePath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsolutePath -> String
filePath

instance Pretty RangeFile where
  pretty :: RangeFile -> Doc
pretty = AbsolutePath -> Doc
forall a. Pretty a => a -> Doc
pretty (AbsolutePath -> Doc)
-> (RangeFile -> AbsolutePath) -> RangeFile -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangeFile -> AbsolutePath
rangeFilePath

instance Pretty a => Pretty (Position' (Strict.Maybe a)) where
  pretty :: Position' (Maybe a) -> Doc
pretty (Pn Maybe a
Strict.Nothing  Int32
_ Int32
l Int32
c) = Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"," Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
c
  pretty (Pn (Strict.Just a
f) Int32
_ Int32
l Int32
c) =
    a -> Doc
forall a. Pretty a => a -> Doc
pretty a
f Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
":" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"," Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
c

instance Pretty PositionWithoutFile where
  pretty :: PositionWithoutFile -> Doc
pretty PositionWithoutFile
p = Position -> Doc
forall a. Pretty a => a -> Doc
pretty (PositionWithoutFile
p { srcFile = Strict.Nothing } :: Position)

instance Pretty IntervalWithoutFile where
  pretty :: IntervalWithoutFile -> Doc
pretty (Interval PositionWithoutFile
s PositionWithoutFile
e) = Doc
start Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"-" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
end
    where
      sl :: Int32
sl = PositionWithoutFile -> Int32
forall a. Position' a -> Int32
posLine PositionWithoutFile
s
      el :: Int32
el = PositionWithoutFile -> Int32
forall a. Position' a -> Int32
posLine PositionWithoutFile
e
      sc :: Int32
sc = PositionWithoutFile -> Int32
forall a. Position' a -> Int32
posCol PositionWithoutFile
s
      ec :: Int32
ec = PositionWithoutFile -> Int32
forall a. Position' a -> Int32
posCol PositionWithoutFile
e

      start :: Doc
      start :: Doc
start = Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
sl Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
sc

      Doc
end :: Doc
        | Int32
sl Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
el  = Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
ec
        | Bool
otherwise = Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
el Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
comma Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Int32 -> Doc
forall a. Pretty a => a -> Doc
pretty Int32
ec

instance Pretty a => Pretty (Interval' (Strict.Maybe a)) where
  pretty :: Interval' (Maybe a) -> Doc
pretty i :: Interval' (Maybe a)
i@(Interval Position' (Maybe a)
s Position' (Maybe a)
_) = Doc
file Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> IntervalWithoutFile -> Doc
forall a. Pretty a => a -> Doc
pretty (() -> Interval' (Maybe a) -> IntervalWithoutFile
forall a b. a -> Interval' b -> Interval' a
setIntervalFile () Interval' (Maybe a)
i)
    where
      file :: Doc
      file :: Doc
file = case Position' (Maybe a) -> Maybe a
forall a. Position' a -> a
srcFile Position' (Maybe a)
s of
               Maybe a
Strict.Nothing -> Doc
forall a. Null a => a
empty
               Strict.Just a
f  -> a -> Doc
forall a. Pretty a => a -> Doc
pretty a
f Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon

instance Pretty a => Pretty (Range' (Strict.Maybe a)) where
  pretty :: Range' (Maybe a) -> Doc
pretty Range' (Maybe a)
r = Doc
-> (Interval' (Maybe a) -> Doc)
-> Maybe (Interval' (Maybe a))
-> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. Null a => a
empty Interval' (Maybe a) -> Doc
forall a. Pretty a => a -> Doc
pretty (Range' (Maybe a) -> Maybe (Interval' (Maybe a))
forall a. Range' a -> Maybe (Interval' a)
rangeToIntervalWithFile Range' (Maybe a)
r)

instance (Pretty a, HasRange a) => Pretty (PrintRange a) where
  pretty :: PrintRange a -> Doc
pretty (PrintRange a
a) = a -> Doc
forall a. Pretty a => a -> Doc
pretty a
a Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
parens (Doc
"at" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Range -> Doc
forall a. Pretty a => a -> Doc
pretty (a -> Range
forall a. HasRange a => a -> Range
getRange a
a))


-- * Generalizing the original type from list to Foldable

sep, fsep, hsep, hcat, vcat :: Foldable t => t Doc -> Doc
sep :: forall (t :: * -> *). Foldable t => t Doc -> Doc
sep  = [Doc] -> Doc
forall a. [Doc a] -> Doc a
P.sep  ([Doc] -> Doc) -> (t Doc -> [Doc]) -> t Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList
fsep :: forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep = [Doc] -> Doc
forall a. [Doc a] -> Doc a
P.fsep ([Doc] -> Doc) -> (t Doc -> [Doc]) -> t Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList
hsep :: forall (t :: * -> *). Foldable t => t Doc -> Doc
hsep = [Doc] -> Doc
forall a. [Doc a] -> Doc a
P.hsep ([Doc] -> Doc) -> (t Doc -> [Doc]) -> t Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList
hcat :: forall (t :: * -> *). Foldable t => t Doc -> Doc
hcat = [Doc] -> Doc
forall a. [Doc a] -> Doc a
P.hcat ([Doc] -> Doc) -> (t Doc -> [Doc]) -> t Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList
vcat :: forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat = [Doc] -> Doc
forall a. [Doc a] -> Doc a
P.vcat ([Doc] -> Doc) -> (t Doc -> [Doc]) -> t Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList

punctuate :: Foldable t => Doc -> t Doc -> [Doc]
punctuate :: forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
d = Doc -> [Doc] -> [Doc]
forall a. Doc a -> [Doc a] -> [Doc a]
P.punctuate Doc
d ([Doc] -> [Doc]) -> (t Doc -> [Doc]) -> t Doc -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Doc -> [Doc]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList

-- * 'Doc' utilities

vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
List.intersperse Doc
""

pwords :: String -> [Doc]
pwords :: String -> [Doc]
pwords = (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
forall a. String -> Doc a
text ([String] -> [Doc]) -> (String -> [String]) -> String -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

fwords :: String -> Doc
fwords :: String -> Doc
fwords = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> (String -> [Doc]) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Doc]
pwords

-- | Separate, but only if both separees are not null.

hsepWith :: Doc -> Doc -> Doc -> Doc
hsepWith :: Doc -> Doc -> Doc -> Doc
hsepWith Doc
sep Doc
d1 Doc
d2
  | Doc -> Bool
forall a. Null a => a -> Bool
null Doc
d2   = Doc
d1
  | Doc -> Bool
forall a. Null a => a -> Bool
null Doc
d1   = Doc
d2
  | Bool
otherwise = Doc
d1 Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
sep Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
d2

-- | Comma separated list, without the brackets.
prettyList_ :: Pretty a => [a] -> Doc
prettyList_ :: forall a. Pretty a => [a] -> Doc
prettyList_ = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> ([a] -> [Doc]) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([a] -> [Doc]) -> [a] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> Doc
forall a. Pretty a => a -> Doc
pretty

-- | Pretty print a set.
prettySet :: Pretty a => [a] -> Doc
prettySet :: forall a. Pretty a => [a] -> Doc
prettySet = Doc -> Doc
braces (Doc -> Doc) -> ([a] -> Doc) -> [a] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Doc
forall a. Pretty a => [a] -> Doc
prettyList_

-- | Pretty print an association list.
prettyMap :: (Pretty k, Pretty v) => [(k,v)] -> Doc
prettyMap :: forall k v. (Pretty k, Pretty v) => [(k, v)] -> Doc
prettyMap = Doc -> Doc
braces (Doc -> Doc) -> ([(k, v)] -> Doc) -> [(k, v)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> ([(k, v)] -> [Doc]) -> [(k, v)] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall (t :: * -> *). Foldable t => Doc -> t Doc -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> ([(k, v)] -> [Doc]) -> [(k, v)] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> Doc) -> [(k, v)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (k, v) -> Doc
forall k v. (Pretty k, Pretty v) => (k, v) -> Doc
prettyAssign

-- | Pretty print a single association.
prettyAssign :: (Pretty k, Pretty v) => (k,v) -> Doc
prettyAssign :: forall k v. (Pretty k, Pretty v) => (k, v) -> Doc
prettyAssign (k
k, v
v) = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Int -> k -> Doc
forall a. Pretty a => Int -> a -> Doc
prettyPrec Int
1 k
k Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
hlSymbol Doc
"->", Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ v -> Doc
forall a. Pretty a => a -> Doc
pretty v
v ]

-- ASR (2016-12-13): In pretty >= 1.1.2.0 the below function 'mparens'
-- is called 'maybeParens'. I didn't use that name due to the issue
-- https://github.com/haskell/pretty/issues/40.

-- | Apply 'parens' to 'Doc' if boolean is true.
mparens :: Bool -> Doc -> Doc
mparens :: Bool -> Doc -> Doc
mparens Bool
True  = Doc -> Doc
parens
mparens Bool
False = Doc -> Doc
forall a. a -> a
id

-- | Only wrap in parens if not 'empty'
parensNonEmpty :: Doc -> Doc
parensNonEmpty :: Doc -> Doc
parensNonEmpty Doc
d = if Doc -> Bool
forall a. Null a => a -> Bool
null Doc
d then Doc
forall a. Null a => a
empty else Doc -> Doc
parens Doc
d

-- | @align max rows@ lays out the elements of @rows@ in two columns,
-- with the second components aligned. The alignment column of the
-- second components is at most @max@ characters to the right of the
-- left-most column.
--
-- Precondition: @max > 0@.

align :: Int -> [(String, Doc)] -> Doc
align :: Int -> [(String, Doc)] -> Doc
align Int
max [(String, Doc)]
rows =
  [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((String, Doc) -> Doc) -> [(String, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
s, Doc
d) -> String -> Doc
forall a. String -> Doc a
text String
s Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
$$ Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest (Int
maxLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Doc
d) ([(String, Doc)] -> [Doc]) -> [(String, Doc)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [(String, Doc)]
rows
  where maxLen :: Int
maxLen = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max) (((String, Doc) -> Int) -> [(String, Doc)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, Doc) -> String) -> (String, Doc) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Doc) -> String
forall a b. (a, b) -> a
fst) [(String, Doc)]
rows)

-- | Handles strings with newlines properly (preserving indentation)
multiLineText :: String -> Doc
multiLineText :: String -> Doc
multiLineText = [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> (String -> [Doc]) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
forall a. String -> Doc a
text ([String] -> [Doc]) -> (String -> [String]) -> String -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

infixl 6 <?>
-- | @a <?> b = hang a 2 b@
(<?>) :: Doc -> Doc -> Doc
Doc
a <?> :: Doc -> Doc -> Doc
<?> Doc
b = Doc -> Int -> Doc -> Doc
forall a. Doc a -> Int -> Doc a -> Doc a
hang Doc
a Int
2 Doc
b

-- | @pshow = text . show@
pshow :: Show a => a -> Doc
pshow :: forall a. Show a => a -> Doc
pshow = String -> Doc
forall a. String -> Doc a
text (String -> Doc) -> (a -> String) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show

singPlural :: Sized a => a -> c -> c -> c
singPlural :: forall a c. Sized a => a -> c -> c -> c
singPlural a
xs c
singular c
plural = if a -> Peano
forall a. Sized a => a -> Peano
natSize a
xs Peano -> Peano -> Bool
forall a. Eq a => a -> a -> Bool
== Peano
1 then c
singular else c
plural

-- | Used for with-like 'telescopes'

prefixedThings :: Doc -> [Doc] -> Doc
prefixedThings :: Doc -> [Doc] -> Doc
prefixedThings Doc
kw = \case
  []           -> Doc
forall a. Doc a
P.empty
  (Doc
doc : [Doc]
docs) -> [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc
kw Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
doc) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> Doc
hlSymbol Doc
"|" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+>) [Doc]
docs

-- | Attach a simple 'Aspect', rather than a full set of 'Aspects', to a
-- document.
annotateAspect :: Aspect -> Doc -> Doc
annotateAspect :: Aspect -> Doc -> Doc
annotateAspect Aspect
a = Aspects -> Doc -> Doc
forall a. a -> Doc a -> Doc a
annotate Aspects
a' where
  a' :: Aspects
a' = Aspects
    { aspect :: Maybe Aspect
aspect         = Aspect -> Maybe Aspect
forall a. a -> Maybe a
Just Aspect
a
    , otherAspects :: Set OtherAspect
otherAspects   = Set OtherAspect
forall a. Monoid a => a
mempty
    , note :: String
note           = String
""
    , definitionSite :: Maybe DefinitionSite
definitionSite = Maybe DefinitionSite
forall a. Maybe a
Nothing
    , tokenBased :: TokenBased
tokenBased     = TokenBased
TokenBased
    }

-- * Syntax highlighting helpers

hlComment, hlSymbol, hlKeyword, hlString, hlNumber, hlHole, hlPrimitiveType, hlPragma
  :: Doc -> Doc

hlComment :: Doc -> Doc
hlComment       = Aspect -> Doc -> Doc
annotateAspect Aspect
Comment
hlSymbol :: Doc -> Doc
hlSymbol        = Aspect -> Doc -> Doc
annotateAspect Aspect
Symbol
hlKeyword :: Doc -> Doc
hlKeyword       = Aspect -> Doc -> Doc
annotateAspect Aspect
Keyword
hlString :: Doc -> Doc
hlString        = Aspect -> Doc -> Doc
annotateAspect Aspect
String
hlNumber :: Doc -> Doc
hlNumber        = Aspect -> Doc -> Doc
annotateAspect Aspect
Number
hlHole :: Doc -> Doc
hlHole          = Aspect -> Doc -> Doc
annotateAspect Aspect
Hole
hlPrimitiveType :: Doc -> Doc
hlPrimitiveType = Aspect -> Doc -> Doc
annotateAspect Aspect
PrimitiveType
hlPragma :: Doc -> Doc
hlPragma        = Aspect -> Doc -> Doc
annotateAspect Aspect
Pragma

-- * Delimiter wrappers
--
-- These use the 'Symbol' highlight for the punctuation characters.

parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
braces       :: Doc -> Doc -- ^ Wrap document in @{...}@
quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@
doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
quotes :: Doc -> Doc
quotes Doc
p       = Doc -> Doc
hlSymbol (Char -> Doc
forall a. Char -> Doc a
char Char
'\'') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
hlSymbol (Char -> Doc
forall a. Char -> Doc a
char Char
'\'')
doubleQuotes :: Doc -> Doc
doubleQuotes Doc
p = Doc -> Doc
hlSymbol (Char -> Doc
forall a. Char -> Doc a
char Char
'"') Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
hlSymbol (Char -> Doc
forall a. Char -> Doc a
char Char
'"')
parens :: Doc -> Doc
parens Doc
p       = Doc
lparen Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rparen
brackets :: Doc -> Doc
brackets Doc
p     = Doc
lbrack Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rbrack
braces :: Doc -> Doc
braces Doc
p       = Doc
lbrace Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
p Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rbrace

semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
semi :: Doc
semi   = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
';'
comma :: Doc
comma  = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
','
colon :: Doc
colon  = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
':'
space :: Doc
space  = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
' '
equals :: Doc
equals = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
'='
lparen :: Doc
lparen = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
'('
rparen :: Doc
rparen = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
')'
lbrack :: Doc
lbrack = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
'['
rbrack :: Doc
rbrack = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
']'
lbrace :: Doc
lbrace = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
'{'
rbrace :: Doc
rbrace = Doc -> Doc
hlSymbol (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
forall a. Char -> Doc a
char Char
'}'