{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
module GHC.HsToCore.Pmc.Types (
SrcInfo(..), PmGrd(..), GrdVec(..),
PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),
RedSets (..), Precision (..), CheckResult (..),
Pre, Post,
module GHC.HsToCore.Pmc.Solver.Types
) where
import GHC.Prelude
import GHC.HsToCore.Pmc.Solver.Types
import GHC.Data.OrdList
import GHC.Types.Id
import GHC.Types.Var (EvVar)
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Core.Type
import GHC.Core
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Semigroup as Semi
data PmGrd
=
PmCon {
PmGrd -> Id
pm_id :: !Id,
PmGrd -> PmAltCon
pm_con_con :: !PmAltCon,
PmGrd -> [Id]
pm_con_tvs :: ![TyVar],
PmGrd -> [Id]
pm_con_dicts :: ![EvVar],
PmGrd -> [Id]
pm_con_args :: ![Id]
}
| PmBang {
pm_id :: !Id,
PmGrd -> Maybe SrcInfo
_pm_loc :: !(Maybe SrcInfo)
}
| PmLet {
pm_id :: !Id,
PmGrd -> CoreExpr
_pm_let_expr :: !CoreExpr
}
instance Outputable PmGrd where
ppr :: PmGrd -> SDoc
ppr (PmCon Id
x PmAltCon
alt [Id]
_tvs [Id]
_con_dicts [Id]
con_args)
= [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [PmAltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmAltCon
alt, [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
con_args), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<-", Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x]
ppr (PmBang Id
x Maybe SrcInfo
_loc) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'!' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x
ppr (PmLet Id
x CoreExpr
expr) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"let", Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=", CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
expr]
newtype SrcInfo = SrcInfo (Located SDoc)
newtype GrdVec = GrdVec [PmGrd]
newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p))
data PmMatch p = PmMatch { forall p. PmMatch p -> p
pm_pats :: !p, forall p. PmMatch p -> PmGRHSs p
pm_grhss :: !(PmGRHSs p) }
data PmGRHSs p = PmGRHSs { forall p. PmGRHSs p -> p
pgs_lcls :: !p, forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
pgs_grhss :: !(NonEmpty (PmGRHS p))}
data PmGRHS p = PmGRHS { forall p. PmGRHS p -> p
pg_grds :: !p, forall p. PmGRHS p -> SrcInfo
pg_rhs :: !SrcInfo }
newtype PmEmptyCase = PmEmptyCase { PmEmptyCase -> Id
pe_var :: Id }
newtype PmPatBind p =
PmPatBind (PmGRHS p)
instance Outputable SrcInfo where
ppr :: SrcInfo -> SDoc
ppr (SrcInfo (L (RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_) SDoc
_)) = Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rss)
ppr (SrcInfo (L SrcSpan
s SDoc
_)) = SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
s
instance Outputable GrdVec where
ppr :: GrdVec -> SDoc
ppr (GrdVec []) = SDoc
forall doc. IsOutput doc => doc
empty
ppr (GrdVec (PmGrd
g:[PmGrd]
gs)) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'|' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PmGrd -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmGrd
g SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: (PmGrd -> SDoc) -> [PmGrd] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ((SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>) (SDoc -> SDoc) -> (PmGrd -> SDoc) -> PmGrd -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PmGrd -> SDoc
forall a. Outputable a => a -> SDoc
ppr) [PmGrd]
gs)
pprLygSequence :: Outputable a => NonEmpty a -> SDoc
pprLygSequence :: forall a. Outputable a => NonEmpty a -> SDoc
pprLygSequence (NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList -> [a]
as) =
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
semi ((a -> SDoc) -> [a] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> SDoc
forall a. Outputable a => a -> SDoc
ppr [a]
as)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
space)
instance Outputable p => Outputable (PmMatchGroup p) where
ppr :: PmMatchGroup p -> SDoc
ppr (PmMatchGroup NonEmpty (PmMatch p)
matches) = NonEmpty (PmMatch p) -> SDoc
forall a. Outputable a => NonEmpty a -> SDoc
pprLygSequence NonEmpty (PmMatch p)
matches
instance Outputable p => Outputable (PmMatch p) where
ppr :: PmMatch p -> SDoc
ppr (PmMatch { pm_pats :: forall p. PmMatch p -> p
pm_pats = p
grds, pm_grhss :: forall p. PmMatch p -> PmGRHSs p
pm_grhss = PmGRHSs p
grhss }) =
p -> SDoc
forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> PmGRHSs p -> SDoc
forall a. Outputable a => a -> SDoc
ppr PmGRHSs p
grhss
instance Outputable p => Outputable (PmGRHSs p) where
ppr :: PmGRHSs p -> SDoc
ppr (PmGRHSs { pgs_lcls :: forall p. PmGRHSs p -> p
pgs_lcls = p
_lcls, pgs_grhss :: forall p. PmGRHSs p -> NonEmpty (PmGRHS p)
pgs_grhss = NonEmpty (PmGRHS p)
grhss }) =
NonEmpty (PmGRHS p) -> SDoc
forall a. Outputable a => a -> SDoc
ppr NonEmpty (PmGRHS p)
grhss
instance Outputable p => Outputable (PmGRHS p) where
ppr :: PmGRHS p -> SDoc
ppr (PmGRHS { pg_grds :: forall p. PmGRHS p -> p
pg_grds = p
grds, pg_rhs :: forall p. PmGRHS p -> SrcInfo
pg_rhs = SrcInfo
rhs }) =
p -> SDoc
forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcInfo
rhs
instance Outputable p => Outputable (PmPatBind p) where
ppr :: PmPatBind p -> SDoc
ppr (PmPatBind PmGRHS { pg_grds :: forall p. PmGRHS p -> p
pg_grds = p
grds, pg_rhs :: forall p. PmGRHS p -> SrcInfo
pg_rhs = SrcInfo
bind }) =
SrcInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcInfo
bind SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> p -> SDoc
forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"..."
instance Outputable PmEmptyCase where
ppr :: PmEmptyCase -> SDoc
ppr (PmEmptyCase { pe_var :: PmEmptyCase -> Id
pe_var = Id
var }) =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<empty case on " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">"
data Precision = Approximate | Precise
deriving (Precision -> Precision -> Bool
(Precision -> Precision -> Bool)
-> (Precision -> Precision -> Bool) -> Eq Precision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Precision -> Precision -> Bool
== :: Precision -> Precision -> Bool
$c/= :: Precision -> Precision -> Bool
/= :: Precision -> Precision -> Bool
Eq, Int -> Precision -> ShowS
[Precision] -> ShowS
Precision -> String
(Int -> Precision -> ShowS)
-> (Precision -> String)
-> ([Precision] -> ShowS)
-> Show Precision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Precision -> ShowS
showsPrec :: Int -> Precision -> ShowS
$cshow :: Precision -> String
show :: Precision -> String
$cshowList :: [Precision] -> ShowS
showList :: [Precision] -> ShowS
Show)
instance Outputable Precision where
ppr :: Precision -> SDoc
ppr = String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> (Precision -> String) -> Precision -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Precision -> String
forall a. Show a => a -> String
show
instance Semi.Semigroup Precision where
Precision
Precise <> :: Precision -> Precision -> Precision
<> Precision
Precise = Precision
Precise
Precision
_ <> Precision
_ = Precision
Approximate
instance Monoid Precision where
mempty :: Precision
mempty = Precision
Precise
mappend :: Precision -> Precision -> Precision
mappend = Precision -> Precision -> Precision
forall a. Semigroup a => a -> a -> a
(Semi.<>)
data RedSets
= RedSets
{ RedSets -> Nablas
rs_cov :: !Nablas
, RedSets -> Nablas
rs_div :: !Nablas
, RedSets -> OrdList (Nablas, SrcInfo)
rs_bangs :: !(OrdList (Nablas, SrcInfo))
}
instance Outputable RedSets where
ppr :: RedSets -> SDoc
ppr RedSets { rs_cov :: RedSets -> Nablas
rs_cov = Nablas
_cov, rs_div :: RedSets -> Nablas
rs_div = Nablas
_div, rs_bangs :: RedSets -> OrdList (Nablas, SrcInfo)
rs_bangs = OrdList (Nablas, SrcInfo)
_bangs }
= SDoc
forall doc. IsOutput doc => doc
empty
data CheckResult a
= CheckResult
{ forall a. CheckResult a -> a
cr_ret :: !a
, forall a. CheckResult a -> Nablas
cr_uncov :: !Nablas
, forall a. CheckResult a -> Precision
cr_approx :: !Precision
} deriving (forall a b. (a -> b) -> CheckResult a -> CheckResult b)
-> (forall a b. a -> CheckResult b -> CheckResult a)
-> Functor CheckResult
forall a b. a -> CheckResult b -> CheckResult a
forall a b. (a -> b) -> CheckResult a -> CheckResult 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) -> CheckResult a -> CheckResult b
fmap :: forall a b. (a -> b) -> CheckResult a -> CheckResult b
$c<$ :: forall a b. a -> CheckResult b -> CheckResult a
<$ :: forall a b. a -> CheckResult b -> CheckResult a
Functor
instance Outputable a => Outputable (CheckResult a) where
ppr :: CheckResult a -> SDoc
ppr (CheckResult a
c Nablas
unc Precision
pc)
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CheckResult" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Precision -> SDoc
forall {doc}. IsLine doc => Precision -> doc
ppr_precision Precision
pc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep
[ String -> a -> SDoc
forall {a}. Outputable a => String -> a -> SDoc
field String
"ret" a
c SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
, String -> Nablas -> SDoc
forall {a}. Outputable a => String -> a -> SDoc
field String
"uncov" Nablas
unc])
where
ppr_precision :: Precision -> doc
ppr_precision Precision
Precise = doc
forall doc. IsOutput doc => doc
empty
ppr_precision Precision
Approximate = String -> doc
forall doc. IsLine doc => String -> doc
text String
"(Approximate)"
field :: String -> a -> SDoc
field String
name a
value = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
value
type Pre = GrdVec
type Post = RedSets