module Language.Egison.Pretty.Pattern
( prettyExpr
, module X
)
where
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(..)
)
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
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