-- |
--
-- Module:      Language.Egison.Pretty.Pattern
-- Description: Pretty printer for Egison patterns
-- Stability:   experimental
--
-- A pretty printer for Egison patterns.

module Language.Egison.Pretty.Pattern
  ( prettyExpr
  -- * Re-exports
  , module X
  )
where

-- re-exports
import           Language.Egison.Pretty.Pattern.Error
                                               as X
                                                ( Error(..) )
import           Language.Egison.Pretty.Pattern.PrintMode
                                               as X
                                                ( ExtPrinter
                                                , PrintMode(..)
                                                , PageMode(..)
                                                , PrintFixity(..)
                                                )
import           Language.Egison.Syntax.Pattern.Fixity
                                               as X
                                                ( Fixity(..)
                                                , Associativity(..)
                                                , Precedence(..)
                                                )

-- main
import           Data.Semigroup                 ( (<>) )
import           Data.Text                      ( Text )
import           Control.Monad.Except           ( MonadError(..) )
import           Language.Egison.Pretty.Pattern.Prim
                                                ( Doc
                                                , hsep
                                                , list
                                                , tupled
                                                , text
                                                , parens
                                                , (<+>)
                                                , renderDoc
                                                )
import           Language.Egison.Pretty.Pattern.Error
                                                ( Error(UnknownInfixOperator) )
import           Language.Egison.Pretty.Pattern.External
                                                ( name
                                                , varName
                                                , valueExpr
                                                )
import           Language.Egison.Pretty.Pattern.Print
                                                ( Print
                                                , runPrint
                                                , askContext
                                                , withContext
                                                , operatorOf
                                                )
import           Language.Egison.Pretty.Pattern.Context
                                                ( Context(..)
                                                , Side(..)
                                                )
import           Language.Egison.Pretty.Pattern.Operator
                                                ( Operator(..) )
import qualified Language.Egison.Syntax.Pattern.Fixity.Primitive
                                               as PrimOp
import           Language.Egison.Syntax.Pattern ( Expr(..) )


parensIf :: Bool -> Doc -> Doc
parensIf :: Bool -> Doc -> Doc
parensIf Bool
True  = Doc -> Doc
forall ann. Doc ann -> Doc ann
parens
parensIf Bool
False = Doc -> Doc
forall a. a -> a
id

parensWhen :: (Context -> Bool) -> Doc -> Print n v e Doc
parensWhen :: (Context -> Bool) -> Doc -> Print n v e Doc
parensWhen Context -> Bool
f Doc
doc = do
  Context
ctx <- Print n v e Context
forall n v e. Print n v e Context
askContext
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Bool -> Doc -> Doc
parensIf (Context -> Bool
f Context
ctx) Doc
doc

smartParens :: Operator -> Doc -> Print n v e Doc
smartParens :: Operator -> Doc -> Print n v e Doc
smartParens Operator
opr = (Context -> Bool) -> Doc -> Print n v e Doc
forall n v e. (Context -> Bool) -> Doc -> Print n v e Doc
parensWhen (Operator -> Context -> Bool
check Operator
opr)
 where
  check :: Operator -> Context -> Bool
check Operator
_          Context
World = Bool
False
  check PrefixOp{} Context
Atom  = Bool
False
  check Operator
_          Context
Atom  = Bool
True
  check InfixOp { Precedence
$sel:precedence:InfixOp :: Operator -> Precedence
precedence :: Precedence
precedence, Associativity
$sel:associativity:InfixOp :: Operator -> Associativity
associativity :: Associativity
associativity } (Under Precedence
uPrec Side
side)
    | Precedence
uPrec Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
> Precedence
precedence = Bool
True
    | Precedence
uPrec Precedence -> Precedence -> Bool
forall a. Eq a => a -> a -> Bool
== Precedence
precedence Bool -> Bool -> Bool
&& Bool -> Bool
not (Associativity -> Side -> Bool
matching Associativity
associativity Side
side) = Bool
True
    | Bool
otherwise          = Bool
False
  check PrefixOp { Precedence
precedence :: Precedence
$sel:precedence:InfixOp :: Operator -> Precedence
precedence } (Under Precedence
uPrec Side
_) | Precedence
uPrec Precedence -> Precedence -> Bool
forall a. Ord a => a -> a -> Bool
>= Precedence
precedence = Bool
True
                                                | Bool
otherwise           = Bool
False
  matching :: Associativity -> Side -> Bool
matching Associativity
AssocRight Side
RightSide = Bool
True
  matching Associativity
AssocLeft  Side
LeftSide  = Bool
True
  matching Associativity
_          Side
_         = Bool
False

expr :: Ord n => Expr n v e -> Print n v e Doc
expr :: Expr n v e -> Print n v e Doc
expr Expr n v e
Wildcard     = Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure Doc
"_"
expr (Variable v
v) = do
  Doc
dv <- v -> Print n v e Doc
forall v n e. v -> Print n v e Doc
varName v
v
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
"$" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
dv
expr (Value e
e) = do
  Doc
de <- e -> Print n v e Doc
forall e n v. e -> Print n v e Doc
valueExpr e
e
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
"#" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
de
expr (Predicate e
e) = do
  Doc
de <- e -> Print n v e Doc
forall e n v. e -> Print n v e Doc
valueExpr e
e
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
"?" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
de
expr (And Expr n v e
e1 Expr n v e
e2) = do
  Doc
d1 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
PrimOp.andPrecedence Side
LeftSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e1
  Doc
d2 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
PrimOp.andPrecedence Side
RightSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e2
  Operator -> Doc -> Print n v e Doc
forall n v e. Operator -> Doc -> Print n v e Doc
smartParens Operator
opr (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
d1 Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
"&" Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
d2
 where
  opr :: Operator
opr = InfixOp :: Associativity -> Precedence -> Text -> Operator
InfixOp { $sel:precedence:InfixOp :: Precedence
precedence    = Precedence
PrimOp.andPrecedence
                , $sel:associativity:InfixOp :: Associativity
associativity = Associativity
PrimOp.andAssociativity
                , $sel:symbol:InfixOp :: Text
symbol        = Text
"&"
                }
expr (Or Expr n v e
e1 Expr n v e
e2) = do
  Doc
d1 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
PrimOp.orPrecedence Side
LeftSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e1
  Doc
d2 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
PrimOp.orPrecedence Side
RightSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e2
  Operator -> Doc -> Print n v e Doc
forall n v e. Operator -> Doc -> Print n v e Doc
smartParens Operator
opr (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
d1 Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
"|" Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
d2
 where
  opr :: Operator
opr = InfixOp :: Associativity -> Precedence -> Text -> Operator
InfixOp { $sel:precedence:InfixOp :: Precedence
precedence    = Precedence
PrimOp.orPrecedence
                , $sel:associativity:InfixOp :: Associativity
associativity = Associativity
PrimOp.orAssociativity
                , $sel:symbol:InfixOp :: Text
symbol        = Text
"|"
                }
expr (Not Expr n v e
e) = do
  Doc
d <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext Context
Atom (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e
  Doc -> Print n v e Doc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
"!" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d
expr (Tuple      [Expr n v e]
es) = [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
tupled ([Doc] -> Doc) -> Print n v e [Doc] -> Print n v e Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr n v e -> Print n v e Doc)
-> [Expr n v e] -> Print n v e [Doc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr [Expr n v e]
es
expr (Collection [Expr n v e]
es) = [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
list ([Doc] -> Doc) -> Print n v e [Doc] -> Print n v e Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr n v e -> Print n v e Doc)
-> [Expr n v e] -> Print n v e [Doc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr [Expr n v e]
es
expr (Infix n
n Expr n v e
e1 Expr n v e
e2) = do
  Operator
opr <- n -> Print n v e Operator
forall n v e. Ord n => n -> Print n v e Operator
operatorOf n
n
  case Operator
opr of
    InfixOp { Precedence
precedence :: Precedence
$sel:precedence:InfixOp :: Operator -> Precedence
precedence, Text
symbol :: Text
$sel:symbol:InfixOp :: Operator -> Text
symbol } -> do
      Doc
d1 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
precedence Side
LeftSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e1
      Doc
d2 <- Context -> Print n v e Doc -> Print n v e Doc
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext (Precedence -> Side -> Context
Under Precedence
precedence Side
RightSide) (Print n v e Doc -> Print n v e Doc)
-> Print n v e Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e2
      Operator -> Doc -> Print n v e Doc
forall n v e. Operator -> Doc -> Print n v e Doc
smartParens Operator
opr (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
d1 Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc
text Text
symbol Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc
d2
    Operator
_ -> Error n -> Print n v e Doc
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Error n -> Print n v e Doc) -> Error n -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ n -> Error n
forall n. n -> Error n
UnknownInfixOperator n
n
expr (Pattern n
n []) = n -> Print n v e Doc
forall n v e. n -> Print n v e Doc
name n
n
expr (Pattern n
n [Expr n v e]
es) = do
  Doc
dn <- n -> Print n v e Doc
forall n v e. n -> Print n v e Doc
name n
n
  [Doc]
ds <- Context -> Print n v e [Doc] -> Print n v e [Doc]
forall n v e a. Context -> Print n v e a -> Print n v e a
withContext Context
Atom (Print n v e [Doc] -> Print n v e [Doc])
-> Print n v e [Doc] -> Print n v e [Doc]
forall a b. (a -> b) -> a -> b
$ (Expr n v e -> Print n v e Doc)
-> [Expr n v e] -> Print n v e [Doc]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr [Expr n v e]
es
  (Context -> Bool) -> Doc -> Print n v e Doc
forall n v e. (Context -> Bool) -> Doc -> Print n v e Doc
parensWhen Context -> Bool
check (Doc -> Print n v e Doc) -> Doc -> Print n v e Doc
forall a b. (a -> b) -> a -> b
$ Doc
dn Doc -> Doc -> Doc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc] -> Doc
forall ann. [Doc ann] -> Doc ann
hsep [Doc]
ds
 where
  check :: Context -> Bool
check Context
Atom = Bool
True
  check Context
_    = Bool
False

-- | Pretty print 'Expr'.
prettyExpr
  :: (MonadError (Error n) m, Ord n) => PrintMode n v e -> Expr n v e -> m Text
prettyExpr :: PrintMode n v e -> Expr n v e -> m Text
prettyExpr PrintMode n v e
mode Expr n v e
e = do
  Doc
doc <- Print n v e Doc -> PrintMode n v e -> m Doc
forall n (m :: * -> *) v e a.
(Ord n, MonadError (Error n) m) =>
Print n v e a -> PrintMode n v e -> m a
runPrint (Expr n v e -> Print n v e Doc
forall n v e. Ord n => Expr n v e -> Print n v e Doc
expr Expr n v e
e) PrintMode n v e
mode
  Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ PrintMode n v e -> Doc -> Text
forall n v e. PrintMode n v e -> Doc -> Text
renderDoc PrintMode n v e
mode Doc
doc