{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Lang.Crucible.Syntax.SExpr
  ( pattern A
  , pattern L
  , pattern (:::)
  , Syntax(..)
  , Datum(..)
  , Syntactic(..)
  ,  Parser
  , syntaxPos
  , withPosFrom
  , sexp
  , identifier
  , toText
  , datumToText
  , skipWhitespace
  , PrintRules(..)
  , PrintStyle(..)
  , Layer(..)
  , IsAtom(..)
  ) where

import Data.Char (isDigit, isLetter)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void
import What4.ProgramLoc as C

import Text.Megaparsec as MP
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Prettyprinter as PP
import qualified Prettyprinter.Render.Text as PP (renderStrict)


-- | Syntax objects, in which each layer is annotated with a source position.
newtype Syntax a = Syntax { forall a. Syntax a -> Posd (Layer Syntax a)
unSyntax :: Posd (Layer Syntax a) }
  deriving (Int -> Syntax a -> ShowS
[Syntax a] -> ShowS
Syntax a -> String
(Int -> Syntax a -> ShowS)
-> (Syntax a -> String) -> ([Syntax a] -> ShowS) -> Show (Syntax a)
forall a. Show a => Int -> Syntax a -> ShowS
forall a. Show a => [Syntax a] -> ShowS
forall a. Show a => Syntax a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Syntax a -> ShowS
showsPrec :: Int -> Syntax a -> ShowS
$cshow :: forall a. Show a => Syntax a -> String
show :: Syntax a -> String
$cshowList :: forall a. Show a => [Syntax a] -> ShowS
showList :: [Syntax a] -> ShowS
Show, (forall a b. (a -> b) -> Syntax a -> Syntax b)
-> (forall a b. a -> Syntax b -> Syntax a) -> Functor Syntax
forall a b. a -> Syntax b -> Syntax a
forall a b. (a -> b) -> Syntax a -> Syntax b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Syntax a -> Syntax b
fmap :: forall a b. (a -> b) -> Syntax a -> Syntax b
$c<$ :: forall a b. a -> Syntax b -> Syntax a
<$ :: forall a b. a -> Syntax b -> Syntax a
Functor, Syntax a -> Syntax a -> Bool
(Syntax a -> Syntax a -> Bool)
-> (Syntax a -> Syntax a -> Bool) -> Eq (Syntax a)
forall a. Eq a => Syntax a -> Syntax a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Syntax a -> Syntax a -> Bool
== :: Syntax a -> Syntax a -> Bool
$c/= :: forall a. Eq a => Syntax a -> Syntax a -> Bool
/= :: Syntax a -> Syntax a -> Bool
Eq)

-- | Syntax objects divorced of their source-code context, without source positions.
newtype Datum a = Datum { forall a. Datum a -> Layer Datum a
unDatum :: Layer Datum a}
  deriving (Int -> Datum a -> ShowS
[Datum a] -> ShowS
Datum a -> String
(Int -> Datum a -> ShowS)
-> (Datum a -> String) -> ([Datum a] -> ShowS) -> Show (Datum a)
forall a. Show a => Int -> Datum a -> ShowS
forall a. Show a => [Datum a] -> ShowS
forall a. Show a => Datum a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Datum a -> ShowS
showsPrec :: Int -> Datum a -> ShowS
$cshow :: forall a. Show a => Datum a -> String
show :: Datum a -> String
$cshowList :: forall a. Show a => [Datum a] -> ShowS
showList :: [Datum a] -> ShowS
Show, (forall a b. (a -> b) -> Datum a -> Datum b)
-> (forall a b. a -> Datum b -> Datum a) -> Functor Datum
forall a b. a -> Datum b -> Datum a
forall a b. (a -> b) -> Datum a -> Datum b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Datum a -> Datum b
fmap :: forall a b. (a -> b) -> Datum a -> Datum b
$c<$ :: forall a b. a -> Datum b -> Datum a
<$ :: forall a b. a -> Datum b -> Datum a
Functor, Datum a -> Datum a -> Bool
(Datum a -> Datum a -> Bool)
-> (Datum a -> Datum a -> Bool) -> Eq (Datum a)
forall a. Eq a => Datum a -> Datum a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Datum a -> Datum a -> Bool
== :: Datum a -> Datum a -> Bool
$c/= :: forall a. Eq a => Datum a -> Datum a -> Bool
/= :: Datum a -> Datum a -> Bool
Eq)

-- | Extract the source position from a 'Syntax' object.
syntaxPos :: Syntax a -> Position
syntaxPos :: forall a. Syntax a -> Position
syntaxPos (Syntax (Posd Position
p Layer Syntax a
_)) = Position
p

-- | Use the position from a syntax object around something else.
withPosFrom :: Syntax a -> b -> Posd b
withPosFrom :: forall a b. Syntax a -> b -> Posd b
withPosFrom Syntax a
stx b
x = Position -> b -> Posd b
forall v. Position -> v -> Posd v
Posd (Syntax a -> Position
forall a. Syntax a -> Position
syntaxPos Syntax a
stx) b
x

-- | Instances of 'Syntactic' support observations using the 'L' and 'A' patterns.
class Syntactic a b | a -> b where
  syntaxE :: a -> Layer Syntax b

instance Syntactic (Layer Syntax a) a where
  syntaxE :: Layer Syntax a -> Layer Syntax a
syntaxE = Layer Syntax a -> Layer Syntax a
forall a. a -> a
id


instance Syntactic (Syntax a) a where
  syntaxE :: Syntax a -> Layer Syntax a
syntaxE (Syntax (Posd Position
_ Layer Syntax a
e)) = Layer Syntax a
e

-- | Match an atom from a syntactic structure
pattern A :: Syntactic a b => b -> a
pattern $mA :: forall {r} {a} {b}.
Syntactic a b =>
a -> (b -> r) -> ((# #) -> r) -> r
A x <- (syntaxE -> Atom x)

-- | Match a list from a syntactic structure
pattern L :: Syntactic a b => [Syntax b] -> a
pattern $mL :: forall {r} {a} {b}.
Syntactic a b =>
a -> ([Syntax b] -> r) -> ((# #) -> r) -> r
L xs <- (syntaxE -> List xs)

-- | Match the head and tail of a list-like structure
pattern (:::) :: Syntactic a b => Syntax b -> [Syntax b] -> a
pattern x $m::: :: forall {r} {a} {b}.
Syntactic a b =>
a -> (Syntax b -> [Syntax b] -> r) -> ((# #) -> r) -> r
::: xs <- (syntaxE -> List (x : xs))

-- | The pattern functor for syntax, used both for 'Syntax' and
-- 'Datum'. In 'Syntax', it is composed with another structure that
-- adds source positions.
data Layer f a = List [f a] | Atom a
  deriving (Int -> Layer f a -> ShowS
[Layer f a] -> ShowS
Layer f a -> String
(Int -> Layer f a -> ShowS)
-> (Layer f a -> String)
-> ([Layer f a] -> ShowS)
-> Show (Layer f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> Layer f a -> ShowS
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[Layer f a] -> ShowS
forall (f :: * -> *) a. (Show a, Show (f a)) => Layer f a -> String
$cshowsPrec :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> Layer f a -> ShowS
showsPrec :: Int -> Layer f a -> ShowS
$cshow :: forall (f :: * -> *) a. (Show a, Show (f a)) => Layer f a -> String
show :: Layer f a -> String
$cshowList :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[Layer f a] -> ShowS
showList :: [Layer f a] -> ShowS
Show, (forall a b. (a -> b) -> Layer f a -> Layer f b)
-> (forall a b. a -> Layer f b -> Layer f a) -> Functor (Layer f)
forall a b. a -> Layer f b -> Layer f a
forall a b. (a -> b) -> Layer f a -> Layer f b
forall (f :: * -> *) a b. Functor f => a -> Layer f b -> Layer f a
forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Layer f a -> Layer f b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (f :: * -> *) a b.
Functor f =>
(a -> b) -> Layer f a -> Layer f b
fmap :: forall a b. (a -> b) -> Layer f a -> Layer f b
$c<$ :: forall (f :: * -> *) a b. Functor f => a -> Layer f b -> Layer f a
<$ :: forall a b. a -> Layer f b -> Layer f a
Functor, Layer f a -> Layer f a -> Bool
(Layer f a -> Layer f a -> Bool)
-> (Layer f a -> Layer f a -> Bool) -> Eq (Layer f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Layer f a -> Layer f a -> Bool
$c== :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Layer f a -> Layer f a -> Bool
== :: Layer f a -> Layer f a -> Bool
$c/= :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Layer f a -> Layer f a -> Bool
/= :: Layer f a -> Layer f a -> Bool
Eq)

-- | Convert any syntactic structure to its simplest description.
syntaxToDatum :: Syntactic expr atom => expr -> Datum atom
syntaxToDatum :: forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum (A atom
x) = Layer Datum atom -> Datum atom
forall a. Layer Datum a -> Datum a
Datum (atom -> Layer Datum atom
forall (f :: * -> *) a. a -> Layer f a
Atom atom
x)
syntaxToDatum (L [Syntax atom]
xs) = Layer Datum atom -> Datum atom
forall a. Layer Datum a -> Datum a
Datum ([Datum atom] -> Layer Datum atom
forall (f :: * -> *) a. [f a] -> Layer f a
List ((Syntax atom -> Datum atom) -> [Syntax atom] -> [Datum atom]
forall a b. (a -> b) -> [a] -> [b]
map Syntax atom -> Datum atom
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum [Syntax atom]
xs))
syntaxToDatum expr
_ = String -> Datum atom
forall a. HasCallStack => String -> a
error String
"impossible - bad Syntactic instance"

-- | A parser for s-expressions.
type Parser = Parsec Void Text

-- | Skip whitespace.
skipWhitespace :: Parser ()
skipWhitespace :: Parser ()
skipWhitespace = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 Parser ()
lineComment Parser ()
blockComment
  where lineComment :: Parser ()
lineComment = Tokens Text -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
";"
        blockComment :: Parser ()
blockComment = Tokens Text -> Tokens Text -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens Text
"#|" Tokens Text
"|#"

-- | Skip the whitespace after a token.
lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
skipWhitespace

-- | Parse something with its location.
withPos :: Parser a -> Parser (Posd a)
withPos :: forall a. Parser a -> Parser (Posd a)
withPos Parser a
p =
  do MP.SourcePos String
file Pos
line Pos
col <- ParsecT Void Text Identity SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
     let loc :: Position
loc = Text -> Int -> Int -> Position
C.SourcePos (String -> Text
T.pack String
file) (Pos -> Int
unPos Pos
line) (Pos -> Int
unPos Pos
col)
     a
res <- Parser a
p
     Posd a -> Parser (Posd a)
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Posd a -> Parser (Posd a)) -> Posd a -> Parser (Posd a)
forall a b. (a -> b) -> a -> b
$ Position -> a -> Posd a
forall v. Position -> v -> Posd v
Posd Position
loc a
res

-- | Parse a particular string.
symbol :: Text -> Parser Text
symbol :: Text -> Parser Text
symbol = Parser ()
-> Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
skipWhitespace

-- | Parse a parenthesized list.
list :: Parser (Syntax a) -> Parser (Syntax a)
list :: forall a. Parser (Syntax a) -> Parser (Syntax a)
list Parser (Syntax a)
p =
  do Posd Position
loc Text
_ <- Parser Text -> Parser (Posd Text)
forall a. Parser a -> Parser (Posd a)
withPos (Text -> Parser Text
symbol Text
"(")
     [Syntax a]
xs <- Parser (Syntax a) -> ParsecT Void Text Identity [Syntax a]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser (Syntax a)
p
     Text
_ <- Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text) -> Parser Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text -> Parser Text
symbol Text
")"
     Syntax a -> Parser (Syntax a)
forall a. a -> ParsecT Void Text Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Syntax a -> Parser (Syntax a)) -> Syntax a -> Parser (Syntax a)
forall a b. (a -> b) -> a -> b
$ Posd (Layer Syntax a) -> Syntax a
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Position -> Layer Syntax a -> Posd (Layer Syntax a)
forall v. Position -> v -> Posd v
Posd Position
loc ([Syntax a] -> Layer Syntax a
forall (f :: * -> *) a. [f a] -> Layer f a
List [Syntax a]
xs))

-- | Given a parser for atoms, parse an s-expression that contains them.
sexp :: Parser a -> Parser (Syntax a)
sexp :: forall a. Parser a -> Parser (Syntax a)
sexp Parser a
atom =
  (Posd (Layer Syntax a) -> Syntax a
forall a. Posd (Layer Syntax a) -> Syntax a
Syntax (Posd (Layer Syntax a) -> Syntax a)
-> (Posd a -> Posd (Layer Syntax a)) -> Posd a -> Syntax a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Layer Syntax a) -> Posd a -> Posd (Layer Syntax a)
forall a b. (a -> b) -> Posd a -> Posd b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Layer Syntax a
forall (f :: * -> *) a. a -> Layer f a
Atom (Posd a -> Syntax a)
-> ParsecT Void Text Identity (Posd a)
-> ParsecT Void Text Identity (Syntax a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity (Posd a)
-> ParsecT Void Text Identity (Posd a)
forall a. Parser a -> Parser a
lexeme (Parser a -> ParsecT Void Text Identity (Posd a)
forall a. Parser a -> Parser (Posd a)
withPos Parser a
atom)) ParsecT Void Text Identity (Syntax a)
-> ParsecT Void Text Identity (Syntax a)
-> ParsecT Void Text Identity (Syntax a)
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  ParsecT Void Text Identity (Syntax a)
-> ParsecT Void Text Identity (Syntax a)
forall a. Parser (Syntax a) -> Parser (Syntax a)
list (Parser a -> ParsecT Void Text Identity (Syntax a)
forall a. Parser a -> Parser (Syntax a)
sexp Parser a
atom)

-- | Parse an identifier.
identifier :: Parser Text
identifier :: Parser Text
identifier = String -> Text
T.pack (String -> Text)
-> ParsecT Void Text Identity String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity String
ParsecT Void Text Identity [Token Text]
identString
  where letterLike :: Char -> Bool
letterLike Char
x = Char -> Bool
isLetter Char
x Bool -> Bool -> Bool
|| Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
x (String
"<>=+-*/!_\\?" :: [Char])
        nameChar :: Char -> Bool
nameChar Char
x = Char -> Bool
letterLike Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Char
x (String
"$" :: [Char])
        identString :: ParsecT Void Text Identity [Token Text]
identString = (:) (Token Text -> [Token Text] -> [Token Text])
-> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity ([Token Text] -> [Token Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
letterLike ParsecT Void Text Identity ([Token Text] -> [Token Text])
-> ParsecT Void Text Identity [Token Text]
-> ParsecT Void Text Identity [Token Text]
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity (Token Text)
-> ParsecT Void Text Identity [Token Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
nameChar)

-- | Styles of printing
data PrintStyle =
  -- | Special forms should treat the first n subforms as special, and
  -- the remaining as a body. For instance, for a Lisp-like
  -- let-expression, use 'Special 1' for indentation.
  Special Int

-- | Printing rules describe how to specially format expressions that
-- begin with particular atoms.
newtype PrintRules a = PrintRules (a -> Maybe PrintStyle)

instance Semigroup (PrintRules a) where
  PrintRules a -> Maybe PrintStyle
f <> :: PrintRules a -> PrintRules a -> PrintRules a
<> PrintRules a -> Maybe PrintStyle
g = (a -> Maybe PrintStyle) -> PrintRules a
forall a. (a -> Maybe PrintStyle) -> PrintRules a
PrintRules ((a -> Maybe PrintStyle) -> PrintRules a)
-> (a -> Maybe PrintStyle) -> PrintRules a
forall a b. (a -> b) -> a -> b
$ \a
z -> a -> Maybe PrintStyle
f a
z Maybe PrintStyle -> Maybe PrintStyle -> Maybe PrintStyle
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> a -> Maybe PrintStyle
g a
z

instance Monoid (PrintRules a) where
  mempty :: PrintRules a
mempty = (a -> Maybe PrintStyle) -> PrintRules a
forall a. (a -> Maybe PrintStyle) -> PrintRules a
PrintRules ((a -> Maybe PrintStyle) -> PrintRules a)
-> (a -> Maybe PrintStyle) -> PrintRules a
forall a b. (a -> b) -> a -> b
$ Maybe PrintStyle -> a -> Maybe PrintStyle
forall a b. a -> b -> a
const Maybe PrintStyle
forall a. Maybe a
Nothing


class IsAtom a where
  showAtom :: a -> Text

pprint :: (Syntactic expr a, IsAtom a) => PrintRules a -> expr -> PP.Doc ann
pprint :: forall expr a ann.
(Syntactic expr a, IsAtom a) =>
PrintRules a -> expr -> Doc ann
pprint PrintRules a
rules expr
expr = PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules (expr -> Datum a
forall expr atom. Syntactic expr atom => expr -> Datum atom
syntaxToDatum expr
expr)

pprintDatum :: IsAtom a => PrintRules a -> Datum a -> PP.Doc ann
pprintDatum :: forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum rules :: PrintRules a
rules@(PrintRules a -> Maybe PrintStyle
getLayout) Datum a
stx =
  case Datum a -> Layer Datum a
forall a. Datum a -> Layer Datum a
unDatum Datum a
stx of
    Atom a
at -> a -> Doc ann
forall {ann}. a -> Doc ann
ppAtom a
at
    List [Datum a]
lst ->
      Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.parens (Doc ann -> Doc ann) -> (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.group (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$
      case [Datum a]
lst of
        [] -> Doc ann
forall a. Monoid a => a
mempty
        [Datum a
x] -> PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules Datum a
x
        ((Datum a -> Layer Datum a
forall a. Datum a -> Layer Datum a
unDatum -> Atom a
car) : [Datum a]
xs) ->
          case a -> Maybe PrintStyle
getLayout a
car of
            Maybe PrintStyle
Nothing -> a -> Doc ann
forall {ann}. a -> Doc ann
ppAtom a
car Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
PP.space Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.align ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules (Datum a -> Doc ann) -> [Datum a] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Datum a]
xs)
            Just (Special Int
i) ->
              let ([Datum a]
special, [Datum a]
rest) = Int -> [Datum a] -> ([Datum a], [Datum a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
i [Datum a]
xs
              in Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
                 Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.group (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
PP.hang Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ a -> Doc ann
forall {ann}. a -> Doc ann
ppAtom a
car Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: ((Datum a -> Doc ann) -> [Datum a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules) [Datum a]
special)) Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:
                 (Datum a -> Doc ann) -> [Datum a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules) [Datum a]
rest
        [Datum a]
xs -> [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
PP.vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ PrintRules a -> Datum a -> Doc ann
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules (Datum a -> Doc ann) -> [Datum a] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Datum a]
xs

  where ppAtom :: a -> Doc ann
ppAtom = Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text -> Doc ann) -> (a -> Text) -> a -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Text
forall a. IsAtom a => a -> Text
showAtom

-- | Render a syntactic structure to text, according to rules.
toText :: (Syntactic expr a, IsAtom a) => PrintRules a -> expr -> Text
toText :: forall expr a.
(Syntactic expr a, IsAtom a) =>
PrintRules a -> expr -> Text
toText PrintRules a
rules expr
stx = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
opts (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ PrintRules a -> expr -> Doc Any
forall expr a ann.
(Syntactic expr a, IsAtom a) =>
PrintRules a -> expr -> Doc ann
pprint PrintRules a
rules expr
stx)
  where opts :: LayoutOptions
opts = PageWidth -> LayoutOptions
PP.LayoutOptions (Int -> Double -> PageWidth
PP.AvailablePerLine Int
80 Double
0.8)

-- | Render a datum to text according to rules.
datumToText :: IsAtom a => PrintRules a -> Datum a -> Text
datumToText :: forall a. IsAtom a => PrintRules a -> Datum a -> Text
datumToText PrintRules a
rules Datum a
dat = SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutSmart LayoutOptions
opts (Doc Any -> SimpleDocStream Any) -> Doc Any -> SimpleDocStream Any
forall a b. (a -> b) -> a -> b
$ PrintRules a -> Datum a -> Doc Any
forall a ann. IsAtom a => PrintRules a -> Datum a -> Doc ann
pprintDatum PrintRules a
rules Datum a
dat)
  where opts :: LayoutOptions
opts = PageWidth -> LayoutOptions
PP.LayoutOptions (Int -> Double -> PageWidth
PP.AvailablePerLine Int
80 Double
0.8)