{-# LANGUAGE CPP #-}
{-# 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
#include "HsVersions.h"
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
hsep [forall a. Outputable a => a -> SDoc
ppr PmAltCon
alt, [SDoc] -> SDoc
hsep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [Id]
con_args), String -> SDoc
text String
"<-", forall a. Outputable a => a -> SDoc
ppr Id
x]
ppr (PmBang Id
x Maybe SrcInfo
_loc) = Char -> SDoc
char Char
'!' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
x
ppr (PmLet Id
x CoreExpr
expr) = [SDoc] -> SDoc
hsep [String -> SDoc
text String
"let", forall a. Outputable a => a -> SDoc
ppr Id
x, String -> SDoc
text String
"=", 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
_)) = forall a. Outputable a => a -> SDoc
ppr (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
rss)
ppr (SrcInfo (L SrcSpan
s SDoc
_)) = forall a. Outputable a => a -> SDoc
ppr SrcSpan
s
instance Outputable GrdVec where
ppr :: GrdVec -> SDoc
ppr (GrdVec []) = SDoc
empty
ppr (GrdVec (PmGrd
g:[PmGrd]
gs)) = [SDoc] -> SDoc
fsep (Char -> SDoc
char Char
'|' SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr PmGrd
g forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map ((SDoc
comma SDoc -> SDoc -> SDoc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr) [PmGrd]
gs)
pprLygSequence :: Outputable a => NonEmpty a -> SDoc
pprLygSequence :: forall a. Outputable a => NonEmpty a -> SDoc
pprLygSequence (forall a. NonEmpty a -> [a]
NE.toList -> [a]
as) =
SDoc -> SDoc
braces (SDoc
space SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
fsep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
semi (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [a]
as)) SDoc -> SDoc -> SDoc
<> SDoc
space)
instance Outputable p => Outputable (PmMatchGroup p) where
ppr :: PmMatchGroup p -> SDoc
ppr (PmMatchGroup NonEmpty (PmMatch p)
matches) = 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 }) =
forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> 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 }) =
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 }) =
forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"->" SDoc -> SDoc -> 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 }) =
forall a. Outputable a => a -> SDoc
ppr SrcInfo
bind SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr p
grds SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"=" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"..."
instance Outputable PmEmptyCase where
ppr :: PmEmptyCase -> SDoc
ppr (PmEmptyCase { pe_var :: PmEmptyCase -> Id
pe_var = Id
var }) =
String -> SDoc
text String
"<empty case on " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
var SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
">"
data Precision = Approximate | Precise
deriving (Precision -> Precision -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Precision -> Precision -> Bool
$c/= :: Precision -> Precision -> Bool
== :: Precision -> Precision -> Bool
$c== :: Precision -> Precision -> Bool
Eq, Int -> Precision -> ShowS
[Precision] -> ShowS
Precision -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Precision] -> ShowS
$cshowList :: [Precision] -> ShowS
show :: Precision -> String
$cshow :: Precision -> String
showsPrec :: Int -> Precision -> ShowS
$cshowsPrec :: Int -> Precision -> ShowS
Show)
instance Outputable Precision where
ppr :: Precision -> SDoc
ppr = String -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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
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 -> 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
<$ :: forall a b. a -> CheckResult b -> CheckResult a
$c<$ :: forall a b. a -> CheckResult b -> CheckResult a
fmap :: forall a b. (a -> b) -> CheckResult a -> CheckResult b
$cfmap :: forall a b. (a -> b) -> CheckResult a -> CheckResult b
Functor
instance Outputable a => Outputable (CheckResult a) where
ppr :: CheckResult a -> SDoc
ppr (CheckResult a
c Nablas
unc Precision
pc)
= String -> SDoc
text String
"CheckResult" SDoc -> SDoc -> SDoc
<+> Precision -> SDoc
ppr_precision Precision
pc SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
fsep
[ forall {a}. Outputable a => String -> a -> SDoc
field String
"ret" a
c SDoc -> SDoc -> SDoc
<> SDoc
comma
, forall {a}. Outputable a => String -> a -> SDoc
field String
"uncov" Nablas
unc])
where
ppr_precision :: Precision -> SDoc
ppr_precision Precision
Precise = SDoc
empty
ppr_precision Precision
Approximate = String -> SDoc
text String
"(Approximate)"
field :: String -> a -> SDoc
field String
name a
value = String -> SDoc
text String
name SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr a
value
type Pre = GrdVec
type Post = RedSets