{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module PmExpr (
PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit,
truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther,
lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex,
pprPmExprWithParens, runPmPprM
) where
#include "GhclibHsVersions.h"
import GhcPrelude
import BasicTypes (SourceText)
import FastString (FastString, unpackFS)
import HsSyn
import Id
import Name
import NameSet
import DataCon
import ConLike
import TcType (isStringTy)
import TysWiredIn
import Outputable
import Util
import SrcLoc
import Data.Maybe (mapMaybe)
import Data.List (groupBy, sortBy, nubBy)
import Control.Monad.Trans.State.Lazy
data PmExpr = PmExprVar Name
| PmExprCon ConLike [PmExpr]
| PmExprLit PmLit
| PmExprEq PmExpr PmExpr
| PmExprOther (HsExpr GhcTc)
mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
mkPmExprData :: DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
dc [PmExpr]
args = ConLike -> [PmExpr] -> PmExpr
PmExprCon (DataCon -> ConLike
RealDataCon DataCon
dc) [PmExpr]
args
data PmLit = PmSLit (HsLit GhcTc)
| PmOLit Bool (HsOverLit GhcTc)
eqPmLit :: PmLit -> PmLit -> Bool
eqPmLit :: PmLit -> PmLit -> Bool
eqPmLit (PmSLit HsLit GhcTc
l1) (PmSLit HsLit GhcTc
l2) = HsLit GhcTc
l1 HsLit GhcTc -> HsLit GhcTc -> Bool
forall a. Eq a => a -> a -> Bool
== HsLit GhcTc
l2
eqPmLit (PmOLit Bool
b1 HsOverLit GhcTc
l1) (PmOLit Bool
b2 HsOverLit GhcTc
l2) = Bool
b1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b2 Bool -> Bool -> Bool
&& HsOverLit GhcTc
l1 HsOverLit GhcTc -> HsOverLit GhcTc -> Bool
forall a. Eq a => a -> a -> Bool
== HsOverLit GhcTc
l2
eqPmLit PmLit
_ PmLit
_ = Bool
False
nubPmLit :: [PmLit] -> [PmLit]
nubPmLit :: [PmLit] -> [PmLit]
nubPmLit = (PmLit -> PmLit -> Bool) -> [PmLit] -> [PmLit]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy PmLit -> PmLit -> Bool
eqPmLit
type SimpleEq = (Id, PmExpr)
type ComplexEq = (PmExpr, PmExpr)
toComplex :: SimpleEq -> ComplexEq
toComplex :: SimpleEq -> ComplexEq
toComplex (Id
x,PmExpr
e) = (Name -> PmExpr
PmExprVar (Id -> Name
idName Id
x), PmExpr
e)
truePmExpr :: PmExpr
truePmExpr :: PmExpr
truePmExpr = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
trueDataCon []
falsePmExpr :: PmExpr
falsePmExpr :: PmExpr
falsePmExpr = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
falseDataCon []
isNotPmExprOther :: PmExpr -> Bool
isNotPmExprOther :: PmExpr -> Bool
isNotPmExprOther (PmExprOther HsExpr GhcTc
_) = Bool
False
isNotPmExprOther PmExpr
_expr = Bool
True
isNegatedPmLit :: PmLit -> Bool
isNegatedPmLit :: PmLit -> Bool
isNegatedPmLit (PmOLit Bool
b HsOverLit GhcTc
_) = Bool
b
isNegatedPmLit PmLit
_other_lit = Bool
False
isTruePmExpr :: PmExpr -> Bool
isTruePmExpr :: PmExpr -> Bool
isTruePmExpr (PmExprCon ConLike
c []) = ConLike
c ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> ConLike
RealDataCon DataCon
trueDataCon
isTruePmExpr PmExpr
_other_expr = Bool
False
isFalsePmExpr :: PmExpr -> Bool
isFalsePmExpr :: PmExpr -> Bool
isFalsePmExpr (PmExprCon ConLike
c []) = ConLike
c ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> ConLike
RealDataCon DataCon
falseDataCon
isFalsePmExpr PmExpr
_other_expr = Bool
False
isNilPmExpr :: PmExpr -> Bool
isNilPmExpr :: PmExpr -> Bool
isNilPmExpr (PmExprCon ConLike
c [PmExpr]
_) = ConLike
c ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> ConLike
RealDataCon DataCon
nilDataCon
isNilPmExpr PmExpr
_other_expr = Bool
False
isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr)
isPmExprEq :: PmExpr -> Maybe ComplexEq
isPmExprEq (PmExprEq PmExpr
e1 PmExpr
e2) = ComplexEq -> Maybe ComplexEq
forall a. a -> Maybe a
Just (PmExpr
e1,PmExpr
e2)
isPmExprEq PmExpr
_other_expr = Maybe ComplexEq
forall a. Maybe a
Nothing
isConsDataCon :: DataCon -> Bool
isConsDataCon :: DataCon -> Bool
isConsDataCon DataCon
con = DataCon
consDataCon DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
con
substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e1 PmExpr
e =
case PmExpr
e of
PmExprVar Name
z | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
z -> (PmExpr
e1, Bool
True)
| Bool
otherwise -> (PmExpr
e, Bool
False)
PmExprCon ConLike
c [PmExpr]
ps -> let ([PmExpr]
ps', [Bool]
bs) = (PmExpr -> (PmExpr, Bool)) -> [PmExpr] -> ([PmExpr], [Bool])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip (Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e1) [PmExpr]
ps
in (ConLike -> [PmExpr] -> PmExpr
PmExprCon ConLike
c [PmExpr]
ps', [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
bs)
PmExprEq PmExpr
ex PmExpr
ey -> let (PmExpr
ex', Bool
bx) = Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e1 PmExpr
ex
(PmExpr
ey', Bool
by) = Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e1 PmExpr
ey
in (PmExpr -> PmExpr -> PmExpr
PmExprEq PmExpr
ex' PmExpr
ey', Bool
bx Bool -> Bool -> Bool
|| Bool
by)
PmExpr
_other_expr -> (PmExpr
e, Bool
False)
substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq
substComplexEq Name
x PmExpr
e (PmExpr
ex, PmExpr
ey)
| Bool
bx Bool -> Bool -> Bool
|| Bool
by = ComplexEq -> Either ComplexEq ComplexEq
forall a b. a -> Either a b
Left (PmExpr
ex', PmExpr
ey')
| Bool
otherwise = ComplexEq -> Either ComplexEq ComplexEq
forall a b. b -> Either a b
Right (PmExpr
ex', PmExpr
ey')
where
(PmExpr
ex', Bool
bx) = Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e PmExpr
ex
(PmExpr
ey', Bool
by) = Name -> PmExpr -> PmExpr -> (PmExpr, Bool)
substPmExpr Name
x PmExpr
e PmExpr
ey
lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsExpr GhcTc)
e) = HsExpr GhcTc -> PmExpr
hsExprToPmExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e
hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
hsExprToPmExpr (HsVar XVar GhcTc
_ Located (IdP GhcTc)
x) = Name -> PmExpr
PmExprVar (Id -> Name
idName (Located Id -> SrcSpanLess (Located Id)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Id
Located (IdP GhcTc)
x))
hsExprToPmExpr (HsConLikeOut XConLikeOut GhcTc
_ ConLike
c) = Name -> PmExpr
PmExprVar (ConLike -> Name
conLikeName ConLike
c)
hsExprToPmExpr (HsOverLit XOverLitE GhcTc
_ HsOverLit GhcTc
olit)
| OverLit (OverLitTc False ty) (HsIsString SourceText
src FastString
s) HsExpr GhcTc
_ <- HsOverLit GhcTc
olit, Type -> Bool
isStringTy Type
ty
= SourceText -> FastString -> PmExpr
stringExprToList SourceText
src FastString
s
| Bool
otherwise = PmLit -> PmExpr
PmExprLit (Bool -> HsOverLit GhcTc -> PmLit
PmOLit Bool
False HsOverLit GhcTc
olit)
hsExprToPmExpr (HsLit XLitE GhcTc
_ HsLit GhcTc
lit)
| HsString XHsString GhcTc
src FastString
s <- HsLit GhcTc
lit
= SourceText -> FastString -> PmExpr
stringExprToList SourceText
XHsString GhcTc
src FastString
s
| Bool
otherwise = PmLit -> PmExpr
PmExprLit (HsLit GhcTc -> PmLit
PmSLit HsLit GhcTc
lit)
hsExprToPmExpr e :: HsExpr GhcTc
e@(NegApp XNegApp GhcTc
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsExpr GhcTc)
neg_expr) SyntaxExpr GhcTc
_)
| PmExprLit (PmOLit Bool
False HsOverLit GhcTc
olit) <- HsExpr GhcTc -> PmExpr
hsExprToPmExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
neg_expr
= PmLit -> PmExpr
PmExprLit (Bool -> HsOverLit GhcTc -> PmLit
PmOLit Bool
True HsOverLit GhcTc
olit)
| Bool
otherwise = HsExpr GhcTc -> PmExpr
PmExprOther HsExpr GhcTc
e
hsExprToPmExpr (HsPar XPar GhcTc
_ (LHsExpr GhcTc -> Located (SrcSpanLess (LHsExpr GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsExpr GhcTc)
e)) = HsExpr GhcTc -> PmExpr
hsExprToPmExpr SrcSpanLess (LHsExpr GhcTc)
HsExpr GhcTc
e
hsExprToPmExpr e :: HsExpr GhcTc
e@(ExplicitTuple XExplicitTuple GhcTc
_ [LHsTupArg GhcTc]
ps Boxity
boxity)
| (LHsTupArg GhcTc -> Bool) -> [LHsTupArg GhcTc] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsTupArg GhcTc -> Bool
forall id. LHsTupArg id -> Bool
tupArgPresent [LHsTupArg GhcTc]
ps = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
tuple_con [PmExpr]
tuple_args
| Bool
otherwise = HsExpr GhcTc -> PmExpr
PmExprOther HsExpr GhcTc
e
where
tuple_con :: DataCon
tuple_con = Boxity -> Arity -> DataCon
tupleDataCon Boxity
boxity ([LHsTupArg GhcTc] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [LHsTupArg GhcTc]
ps)
tuple_args :: [PmExpr]
tuple_args = [ LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e | (LHsTupArg GhcTc -> Located (SrcSpanLess (LHsTupArg GhcTc))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Present _ e)) <- [LHsTupArg GhcTc]
ps ]
hsExprToPmExpr e :: HsExpr GhcTc
e@(ExplicitList XExplicitList GhcTc
_ Maybe (SyntaxExpr GhcTc)
mb_ol [LHsExpr GhcTc]
elems)
| Maybe (SyntaxExpr GhcTc)
Nothing <- Maybe (SyntaxExpr GhcTc)
mb_ol = (PmExpr -> PmExpr -> PmExpr) -> PmExpr -> [PmExpr] -> PmExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PmExpr -> PmExpr -> PmExpr
cons PmExpr
nil ((LHsExpr GhcTc -> PmExpr) -> [LHsExpr GhcTc] -> [PmExpr]
forall a b. (a -> b) -> [a] -> [b]
map LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr [LHsExpr GhcTc]
elems)
| Bool
otherwise = HsExpr GhcTc -> PmExpr
PmExprOther HsExpr GhcTc
e
where
cons :: PmExpr -> PmExpr -> PmExpr
cons PmExpr
x PmExpr
xs = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
consDataCon [PmExpr
x,PmExpr
xs]
nil :: PmExpr
nil = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
nilDataCon []
hsExprToPmExpr e :: HsExpr GhcTc
e@(RecordCon {}) = HsExpr GhcTc -> PmExpr
PmExprOther HsExpr GhcTc
e
hsExprToPmExpr (HsTick XTick GhcTc
_ Tickish (IdP GhcTc)
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (HsBinTick XBinTick GhcTc
_ Arity
_ Arity
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (HsTickPragma XTickPragma GhcTc
_ SourceText
_ (StringLiteral, (Arity, Arity), (Arity, Arity))
_ ((SourceText, SourceText), (SourceText, SourceText))
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (HsSCC XSCC GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (HsCoreAnn XCoreAnn GhcTc
_ SourceText
_ StringLiteral
_ LHsExpr GhcTc
e) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (ExprWithTySig XExprWithTySig GhcTc
_ LHsExpr GhcTc
e LHsSigWcType (NoGhcTc GhcTc)
_) = LHsExpr GhcTc -> PmExpr
lhsExprToPmExpr LHsExpr GhcTc
e
hsExprToPmExpr (HsWrap XWrap GhcTc
_ HsWrapper
_ HsExpr GhcTc
e) = HsExpr GhcTc -> PmExpr
hsExprToPmExpr HsExpr GhcTc
e
hsExprToPmExpr HsExpr GhcTc
e = HsExpr GhcTc -> PmExpr
PmExprOther HsExpr GhcTc
e
stringExprToList :: SourceText -> FastString -> PmExpr
stringExprToList :: SourceText -> FastString -> PmExpr
stringExprToList SourceText
src FastString
s = (PmExpr -> PmExpr -> PmExpr) -> PmExpr -> [PmExpr] -> PmExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PmExpr -> PmExpr -> PmExpr
cons PmExpr
nil ((Char -> PmExpr) -> [Char] -> [PmExpr]
forall a b. (a -> b) -> [a] -> [b]
map Char -> PmExpr
charToPmExpr (FastString -> [Char]
unpackFS FastString
s))
where
cons :: PmExpr -> PmExpr -> PmExpr
cons PmExpr
x PmExpr
xs = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
consDataCon [PmExpr
x,PmExpr
xs]
nil :: PmExpr
nil = DataCon -> [PmExpr] -> PmExpr
mkPmExprData DataCon
nilDataCon []
charToPmExpr :: Char -> PmExpr
charToPmExpr Char
c = PmLit -> PmExpr
PmExprLit (HsLit GhcTc -> PmLit
PmSLit (XHsChar GhcTc -> Char -> HsLit GhcTc
forall x. XHsChar x -> Char -> HsLit x
HsChar SourceText
XHsChar GhcTc
src Char
c))
type PmNegLitCt = (Name, (SDoc, [PmLit]))
filterComplex :: [ComplexEq] -> [PmNegLitCt]
filterComplex :: [ComplexEq] -> [PmNegLitCt]
filterComplex = (SDoc -> (Name, [PmLit]) -> PmNegLitCt)
-> [SDoc] -> [(Name, [PmLit])] -> [PmNegLitCt]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith SDoc -> (Name, [PmLit]) -> PmNegLitCt
forall a a b. a -> (a, b) -> (a, (a, b))
rename [SDoc]
nameList ([(Name, [PmLit])] -> [PmNegLitCt])
-> ([ComplexEq] -> [(Name, [PmLit])])
-> [ComplexEq]
-> [PmNegLitCt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Name, PmLit)] -> (Name, [PmLit]))
-> [[(Name, PmLit)]] -> [(Name, [PmLit])]
forall a b. (a -> b) -> [a] -> [b]
map [(Name, PmLit)] -> (Name, [PmLit])
forall a. [(a, PmLit)] -> (a, [PmLit])
mkGroup
([[(Name, PmLit)]] -> [(Name, [PmLit])])
-> ([ComplexEq] -> [[(Name, PmLit)]])
-> [ComplexEq]
-> [(Name, [PmLit])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, PmLit) -> (Name, PmLit) -> Bool)
-> [(Name, PmLit)] -> [[(Name, PmLit)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Name, PmLit) -> (Name, PmLit) -> Bool
forall a b b. Eq a => (a, b) -> (a, b) -> Bool
name ([(Name, PmLit)] -> [[(Name, PmLit)]])
-> ([ComplexEq] -> [(Name, PmLit)])
-> [ComplexEq]
-> [[(Name, PmLit)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Name, PmLit) -> (Name, PmLit) -> Ordering)
-> [(Name, PmLit)] -> [(Name, PmLit)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Name, PmLit) -> (Name, PmLit) -> Ordering
forall a b b. Ord a => (a, b) -> (a, b) -> Ordering
order ([(Name, PmLit)] -> [(Name, PmLit)])
-> ([ComplexEq] -> [(Name, PmLit)])
-> [ComplexEq]
-> [(Name, PmLit)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComplexEq -> Maybe (Name, PmLit))
-> [ComplexEq] -> [(Name, PmLit)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ComplexEq -> Maybe (Name, PmLit)
isNegLitCs
where
order :: (a, b) -> (a, b) -> Ordering
order (a, b)
x (a, b)
y = a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
x) ((a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
y)
name :: (a, b) -> (a, b) -> Bool
name (a, b)
x (a, b)
y = (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
y
mkGroup :: [(a, PmLit)] -> (a, [PmLit])
mkGroup [(a, PmLit)]
l = ((a, PmLit) -> a
forall a b. (a, b) -> a
fst ([(a, PmLit)] -> (a, PmLit)
forall a. [a] -> a
head [(a, PmLit)]
l), [PmLit] -> [PmLit]
nubPmLit ([PmLit] -> [PmLit]) -> [PmLit] -> [PmLit]
forall a b. (a -> b) -> a -> b
$ ((a, PmLit) -> PmLit) -> [(a, PmLit)] -> [PmLit]
forall a b. (a -> b) -> [a] -> [b]
map (a, PmLit) -> PmLit
forall a b. (a, b) -> b
snd [(a, PmLit)]
l)
rename :: a -> (a, b) -> (a, (a, b))
rename a
new (a
old, b
lits) = (a
old, (a
new, b
lits))
isNegLitCs :: ComplexEq -> Maybe (Name, PmLit)
isNegLitCs (PmExpr
e1,PmExpr
e2)
| PmExpr -> Bool
isFalsePmExpr PmExpr
e1, Just (PmExpr
x,PmExpr
y) <- PmExpr -> Maybe ComplexEq
isPmExprEq PmExpr
e2 = PmExpr -> PmExpr -> Maybe (Name, PmLit)
isNegLitCs' PmExpr
x PmExpr
y
| PmExpr -> Bool
isFalsePmExpr PmExpr
e2, Just (PmExpr
x,PmExpr
y) <- PmExpr -> Maybe ComplexEq
isPmExprEq PmExpr
e1 = PmExpr -> PmExpr -> Maybe (Name, PmLit)
isNegLitCs' PmExpr
x PmExpr
y
| Bool
otherwise = Maybe (Name, PmLit)
forall a. Maybe a
Nothing
isNegLitCs' :: PmExpr -> PmExpr -> Maybe (Name, PmLit)
isNegLitCs' (PmExprVar Name
x) (PmExprLit PmLit
l) = (Name, PmLit) -> Maybe (Name, PmLit)
forall a. a -> Maybe a
Just (Name
x, PmLit
l)
isNegLitCs' (PmExprLit PmLit
l) (PmExprVar Name
x) = (Name, PmLit) -> Maybe (Name, PmLit)
forall a. a -> Maybe a
Just (Name
x, PmLit
l)
isNegLitCs' PmExpr
_ PmExpr
_ = Maybe (Name, PmLit)
forall a. Maybe a
Nothing
nameList :: [SDoc]
nameList :: [SDoc]
nameList = ([Char] -> SDoc) -> [[Char]] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> SDoc
text [[Char]
"p",[Char]
"q",[Char]
"r",[Char]
"s",[Char]
"t"] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
[ [Char] -> SDoc
text (Char
't'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:Arity -> [Char]
forall a. Show a => a -> [Char]
show Arity
u) | Arity
u <- [(Arity
0 :: Int)..] ]
runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])])
runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc, [PmLit])])
runPmPprM PmPprM a
m [PmNegLitCt]
lit_env = (a
result, (PmNegLitCt -> Maybe (SDoc, [PmLit]))
-> [PmNegLitCt] -> [(SDoc, [PmLit])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PmNegLitCt -> Maybe (SDoc, [PmLit])
forall a b. (Name, (a, b)) -> Maybe (a, b)
is_used [PmNegLitCt]
lit_env)
where
(a
result, ([PmNegLitCt]
_lit_env, NameSet
used)) = PmPprM a -> ([PmNegLitCt], NameSet) -> (a, ([PmNegLitCt], NameSet))
forall s a. State s a -> s -> (a, s)
runState PmPprM a
m ([PmNegLitCt]
lit_env, NameSet
emptyNameSet)
is_used :: (Name, (a, b)) -> Maybe (a, b)
is_used (Name
x,(a
name, b
lits))
| Name -> NameSet -> Bool
elemNameSet Name
x NameSet
used = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
name, b
lits)
| Bool
otherwise = Maybe (a, b)
forall a. Maybe a
Nothing
type PmPprM a = State ([PmNegLitCt], NameSet) a
addUsed :: Name -> PmPprM ()
addUsed :: Name -> PmPprM ()
addUsed Name
x = (([PmNegLitCt], NameSet) -> ([PmNegLitCt], NameSet)) -> PmPprM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (\([PmNegLitCt]
negated, NameSet
used) -> ([PmNegLitCt]
negated, NameSet -> Name -> NameSet
extendNameSet NameSet
used Name
x))
checkNegation :: Name -> PmPprM (Maybe SDoc)
checkNegation :: Name -> PmPprM (Maybe SDoc)
checkNegation Name
x = do
[PmNegLitCt]
negated <- (([PmNegLitCt], NameSet) -> [PmNegLitCt])
-> StateT ([PmNegLitCt], NameSet) Identity [PmNegLitCt]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ([PmNegLitCt], NameSet) -> [PmNegLitCt]
forall a b. (a, b) -> a
fst
Maybe SDoc -> PmPprM (Maybe SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SDoc -> PmPprM (Maybe SDoc))
-> Maybe SDoc -> PmPprM (Maybe SDoc)
forall a b. (a -> b) -> a -> b
$ case Name -> [PmNegLitCt] -> Maybe (SDoc, [PmLit])
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
x [PmNegLitCt]
negated of
Just (SDoc
new, [PmLit]
_) -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
new
Maybe (SDoc, [PmLit])
Nothing -> Maybe SDoc
forall a. Maybe a
Nothing
pprPmExpr :: PmExpr -> PmPprM SDoc
pprPmExpr :: PmExpr -> PmPprM SDoc
pprPmExpr (PmExprVar Name
x) = do
Maybe SDoc
mb_name <- Name -> PmPprM (Maybe SDoc)
checkNegation Name
x
case Maybe SDoc
mb_name of
Just SDoc
name -> Name -> PmPprM ()
addUsed Name
x PmPprM () -> PmPprM SDoc -> PmPprM SDoc
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
name
Maybe SDoc
Nothing -> SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
underscore
pprPmExpr (PmExprCon ConLike
con [PmExpr]
args) = ConLike -> [PmExpr] -> PmPprM SDoc
pprPmExprCon ConLike
con [PmExpr]
args
pprPmExpr (PmExprLit PmLit
l) = SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (PmLit -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmLit
l)
pprPmExpr (PmExprEq PmExpr
_ PmExpr
_) = SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
underscore
pprPmExpr (PmExprOther HsExpr GhcTc
_) = SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return SDoc
underscore
needsParens :: PmExpr -> Bool
needsParens :: PmExpr -> Bool
needsParens (PmExprVar {}) = Bool
False
needsParens (PmExprLit PmLit
l) = PmLit -> Bool
isNegatedPmLit PmLit
l
needsParens (PmExprEq {}) = Bool
False
needsParens (PmExprOther {}) = Bool
False
needsParens (PmExprCon (RealDataCon DataCon
c) [PmExpr]
es)
| DataCon -> Bool
isTupleDataCon DataCon
c
Bool -> Bool -> Bool
|| DataCon -> Bool
isConsDataCon DataCon
c Bool -> Bool -> Bool
|| [PmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PmExpr]
es = Bool
False
| Bool
otherwise = Bool
True
needsParens (PmExprCon (PatSynCon PatSyn
_) [PmExpr]
es) = Bool -> Bool
not ([PmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PmExpr]
es)
pprPmExprWithParens :: PmExpr -> PmPprM SDoc
pprPmExprWithParens :: PmExpr -> PmPprM SDoc
pprPmExprWithParens PmExpr
expr
| PmExpr -> Bool
needsParens PmExpr
expr = SDoc -> SDoc
parens (SDoc -> SDoc) -> PmPprM SDoc -> PmPprM SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PmExpr -> PmPprM SDoc
pprPmExpr PmExpr
expr
| Bool
otherwise = PmExpr -> PmPprM SDoc
pprPmExpr PmExpr
expr
pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
pprPmExprCon :: ConLike -> [PmExpr] -> PmPprM SDoc
pprPmExprCon (RealDataCon DataCon
con) [PmExpr]
args
| DataCon -> Bool
isTupleDataCon DataCon
con = [SDoc] -> SDoc
mkTuple ([SDoc] -> SDoc)
-> StateT ([PmNegLitCt], NameSet) Identity [SDoc] -> PmPprM SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PmExpr -> PmPprM SDoc)
-> [PmExpr] -> StateT ([PmNegLitCt], NameSet) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PmExpr -> PmPprM SDoc
pprPmExpr [PmExpr]
args
| DataCon -> Bool
isConsDataCon DataCon
con = PmPprM SDoc
pretty_list
where
mkTuple :: [SDoc] -> SDoc
mkTuple :: [SDoc] -> SDoc
mkTuple = SDoc -> SDoc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
pretty_list :: PmPprM SDoc
pretty_list :: PmPprM SDoc
pretty_list = case PmExpr -> Bool
isNilPmExpr ([PmExpr] -> PmExpr
forall a. [a] -> a
last [PmExpr]
list) of
Bool
True -> SDoc -> SDoc
brackets (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> SDoc)
-> StateT ([PmNegLitCt], NameSet) Identity [SDoc] -> PmPprM SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PmExpr -> PmPprM SDoc)
-> [PmExpr] -> StateT ([PmNegLitCt], NameSet) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PmExpr -> PmPprM SDoc
pprPmExpr ([PmExpr] -> [PmExpr]
forall a. [a] -> [a]
init [PmExpr]
list)
Bool
False -> SDoc -> SDoc
parens (SDoc -> SDoc) -> ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> ([SDoc] -> [SDoc]) -> [SDoc] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
colon ([SDoc] -> SDoc)
-> StateT ([PmNegLitCt], NameSet) Identity [SDoc] -> PmPprM SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PmExpr -> PmPprM SDoc)
-> [PmExpr] -> StateT ([PmNegLitCt], NameSet) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PmExpr -> PmPprM SDoc
pprPmExpr [PmExpr]
list
list :: [PmExpr]
list = [PmExpr] -> [PmExpr]
list_elements [PmExpr]
args
list_elements :: [PmExpr] -> [PmExpr]
list_elements [PmExpr
x,PmExpr
y]
| PmExprCon ConLike
c [PmExpr]
es <- PmExpr
y, DataCon -> ConLike
RealDataCon DataCon
nilDataCon ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== ConLike
c
= ASSERT(null es) [x,y]
| PmExprCon ConLike
c [PmExpr]
es <- PmExpr
y, DataCon -> ConLike
RealDataCon DataCon
consDataCon ConLike -> ConLike -> Bool
forall a. Eq a => a -> a -> Bool
== ConLike
c
= PmExpr
x PmExpr -> [PmExpr] -> [PmExpr]
forall a. a -> [a] -> [a]
: [PmExpr] -> [PmExpr]
list_elements [PmExpr]
es
| Bool
otherwise = [PmExpr
x,PmExpr
y]
list_elements [PmExpr]
list = [Char] -> SDoc -> [PmExpr]
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"list_elements:" ([PmExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PmExpr]
list)
pprPmExprCon ConLike
cl [PmExpr]
args
| ConLike -> Bool
conLikeIsInfix ConLike
cl = case [PmExpr]
args of
[PmExpr
x, PmExpr
y] -> do SDoc
x' <- PmExpr -> PmPprM SDoc
pprPmExprWithParens PmExpr
x
SDoc
y' <- PmExpr -> PmPprM SDoc
pprPmExprWithParens PmExpr
y
SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc
x' SDoc -> SDoc -> SDoc
<+> ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> SDoc -> SDoc
<+> SDoc
y')
[PmExpr]
list -> [Char] -> SDoc -> PmPprM SDoc
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"pprPmExprCon:" ([PmExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PmExpr]
list)
| [PmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PmExpr]
args = SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl)
| Bool
otherwise = do [SDoc]
args' <- (PmExpr -> PmPprM SDoc)
-> [PmExpr] -> StateT ([PmNegLitCt], NameSet) Identity [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PmExpr -> PmPprM SDoc
pprPmExprWithParens [PmExpr]
args
SDoc -> PmPprM SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return ([SDoc] -> SDoc
fsep (ConLike -> SDoc
forall a. Outputable a => a -> SDoc
ppr ConLike
cl SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [SDoc]
args'))
instance Outputable PmLit where
ppr :: PmLit -> SDoc
ppr (PmSLit HsLit GhcTc
l) = HsLit GhcTc -> SDoc
forall (x :: Pass). HsLit (GhcPass x) -> SDoc
pmPprHsLit HsLit GhcTc
l
ppr (PmOLit Bool
neg HsOverLit GhcTc
l) = (if Bool
neg then Char -> SDoc
char Char
'-' else SDoc
empty) SDoc -> SDoc -> SDoc
<> HsOverLit GhcTc -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcTc
l
instance Outputable PmExpr where
ppr :: PmExpr -> SDoc
ppr PmExpr
e = (SDoc, [(SDoc, [PmLit])]) -> SDoc
forall a b. (a, b) -> a
fst ((SDoc, [(SDoc, [PmLit])]) -> SDoc)
-> (SDoc, [(SDoc, [PmLit])]) -> SDoc
forall a b. (a -> b) -> a -> b
$ PmPprM SDoc -> [PmNegLitCt] -> (SDoc, [(SDoc, [PmLit])])
forall a. PmPprM a -> [PmNegLitCt] -> (a, [(SDoc, [PmLit])])
runPmPprM (PmExpr -> PmPprM SDoc
pprPmExpr PmExpr
e) []