{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Grisette.Internal.Internal.Impl.Core.Data.Class.ExtractSym () where
import Control.Monad.Except (ExceptT)
import Control.Monad.Identity
( Identity,
IdentityT (IdentityT),
)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Control.Monad.Writer.Lazy as WriterLazy
import qualified Control.Monad.Writer.Strict as WriterStrict
import qualified Data.ByteString as B
import Data.Functor.Compose (Compose (Compose))
import Data.Functor.Const (Const)
import Data.Functor.Product (Product)
import Data.Functor.Sum (Sum)
import qualified Data.HashSet as HS
import Data.Int (Int16, Int32, Int64, Int8)
import Data.Monoid (Alt, Ap)
import qualified Data.Monoid as Monoid
import Data.Ord (Down)
import Data.Ratio (Ratio, denominator, numerator)
import qualified Data.Text as T
import Data.Typeable (Proxy, type (:~~:) (HRefl))
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.TypeNats (KnownNat, type (<=))
import Generics.Deriving
( Default (Default),
Default1 (Default1),
K1 (K1),
M1 (M1),
Par1 (Par1),
Rec1 (Rec1),
U1,
V1,
type (:*:),
type (:+:),
type (:.:) (Comp1),
)
import Grisette.Internal.Core.Control.Exception
( AssertionError,
VerificationConditions,
)
import Grisette.Internal.Internal.Decl.Core.Data.Class.ExtractSym
( ExtractSym (extractSymMaybe),
ExtractSym1 (liftExtractSymMaybe),
ExtractSym2,
extractSymMaybe1,
)
import Grisette.Internal.SymPrim.AlgReal (AlgReal)
import Grisette.Internal.SymPrim.BV (IntN, WordN)
import Grisette.Internal.SymPrim.FP
( FP,
FPRoundingMode,
NotRepresentableFPError,
ValidFP,
)
import Grisette.Internal.SymPrim.GeneralFun (type (-->) (GeneralFun))
import Grisette.Internal.SymPrim.Prim.Model
( SymbolSet (SymbolSet),
)
import Grisette.Internal.SymPrim.Prim.Term
( IsSymbolKind (decideSymbolKind),
SymRep (SymType),
someTypedSymbol,
)
import Grisette.Internal.SymPrim.Prim.TermUtils (extractTerm)
import Grisette.Internal.SymPrim.SymAlgReal (SymAlgReal (SymAlgReal))
import Grisette.Internal.SymPrim.SymBV
( SymIntN (SymIntN),
SymWordN (SymWordN),
)
import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool))
import Grisette.Internal.SymPrim.SymFP
( SymFP (SymFP),
SymFPRoundingMode (SymFPRoundingMode),
)
import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun))
import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger))
import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun))
import Grisette.Internal.SymPrim.TabularFun (type (=->) (TabularFun))
import Grisette.Internal.TH.Derivation.Derive (derive)
#define CONCRETE_EXTRACT_SYMBOLICS(type) \
instance ExtractSym type where \
extractSymMaybe _ = return mempty
#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \
instance (KnownNat n, 1 <= n) => ExtractSym (type n) where \
extractSymMaybe _ = return mempty
#if 1
CONCRETE_EXTRACT_SYMBOLICS(Bool)
CONCRETE_EXTRACT_SYMBOLICS(Integer)
CONCRETE_EXTRACT_SYMBOLICS(Char)
CONCRETE_EXTRACT_SYMBOLICS(Int)
CONCRETE_EXTRACT_SYMBOLICS(Int8)
CONCRETE_EXTRACT_SYMBOLICS(Int16)
CONCRETE_EXTRACT_SYMBOLICS(Int32)
CONCRETE_EXTRACT_SYMBOLICS(Int64)
CONCRETE_EXTRACT_SYMBOLICS(Word)
CONCRETE_EXTRACT_SYMBOLICS(Word8)
CONCRETE_EXTRACT_SYMBOLICS(Word16)
CONCRETE_EXTRACT_SYMBOLICS(Word32)
CONCRETE_EXTRACT_SYMBOLICS(Word64)
CONCRETE_EXTRACT_SYMBOLICS(Float)
CONCRETE_EXTRACT_SYMBOLICS(Double)
CONCRETE_EXTRACT_SYMBOLICS(B.ByteString)
CONCRETE_EXTRACT_SYMBOLICS(T.Text)
CONCRETE_EXTRACT_SYMBOLICS(FPRoundingMode)
CONCRETE_EXTRACT_SYMBOLICS(Monoid.All)
CONCRETE_EXTRACT_SYMBOLICS(Monoid.Any)
CONCRETE_EXTRACT_SYMBOLICS(Ordering)
CONCRETE_EXTRACT_SYMBOLICS_BV(WordN)
CONCRETE_EXTRACT_SYMBOLICS_BV(IntN)
CONCRETE_EXTRACT_SYMBOLICS(AlgReal)
#endif
instance ExtractSym (Proxy a) where
extractSymMaybe :: forall (knd :: SymbolKind).
IsSymbolKind knd =>
Proxy a -> Maybe (SymbolSet knd)
extractSymMaybe Proxy a
_ = SymbolSet knd -> Maybe (SymbolSet knd)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolSet knd
forall a. Monoid a => a
mempty
{-# INLINE extractSymMaybe #-}
instance ExtractSym1 Proxy where
liftExtractSymMaybe :: forall (knd :: SymbolKind) a.
IsSymbolKind knd =>
(a -> Maybe (SymbolSet knd)) -> Proxy a -> Maybe (SymbolSet knd)
liftExtractSymMaybe a -> Maybe (SymbolSet knd)
_ Proxy a
_ = SymbolSet knd -> Maybe (SymbolSet knd)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolSet knd
forall a. Monoid a => a
mempty
{-# INLINE liftExtractSymMaybe #-}
instance (ExtractSym a) => ExtractSym (Ratio a) where
extractSymMaybe :: forall (knd :: SymbolKind).
IsSymbolKind knd =>
Ratio a -> Maybe (SymbolSet knd)
extractSymMaybe Ratio a
a =
a -> Maybe (SymbolSet knd)
forall a (knd :: SymbolKind).
(ExtractSym a, IsSymbolKind knd) =>
a -> Maybe (SymbolSet knd)
forall (knd :: SymbolKind).
IsSymbolKind knd =>
a -> Maybe (SymbolSet knd)
extractSymMaybe (Ratio a -> a
forall a. Ratio a -> a
numerator Ratio a
a) Maybe (SymbolSet knd)
-> Maybe (SymbolSet knd) -> Maybe (SymbolSet knd)
forall a. Semigroup a => a -> a -> a
<> a -> Maybe (SymbolSet knd)
forall a (knd :: SymbolKind).
(ExtractSym a, IsSymbolKind knd) =>
a -> Maybe (SymbolSet knd)
forall (knd :: SymbolKind).
IsSymbolKind knd =>
a -> Maybe (SymbolSet knd)
extractSymMaybe (Ratio a -> a
forall a. Ratio a -> a
denominator Ratio a
a)
{-# INLINE extractSymMaybe #-}
instance (ValidFP eb sb) => ExtractSym (FP eb sb) where
extractSymMaybe :: forall (knd :: SymbolKind).
IsSymbolKind knd =>
FP eb sb -> Maybe (SymbolSet knd)
extractSymMaybe FP eb sb
_ = SymbolSet knd -> Maybe (SymbolSet knd)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return SymbolSet knd
forall a. Monoid a => a
mempty
#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \
instance ExtractSym symtype where \
extractSymMaybe :: \
forall knd. (IsSymbolKind knd) => symtype -> Maybe (SymbolSet knd); \
extractSymMaybe (symtype t) = \
case decideSymbolKind @knd of\
Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \
Right HRefl -> SymbolSet <$> extractTerm HS.empty t
#define EXTRACT_SYMBOLICS_BV(symtype) \
instance (KnownNat n, 1 <= n) => ExtractSym (symtype n) where \
extractSymMaybe :: \
forall knd. (IsSymbolKind knd) => symtype n -> Maybe (SymbolSet knd); \
extractSymMaybe (symtype t) = \
case decideSymbolKind @knd of\
Left HRefl -> SymbolSet <$> extractTerm HS.empty t; \
Right HRefl -> SymbolSet <$> extractTerm HS.empty t
#define EXTRACT_SYMBOLICS_FUN(op, cons) \
instance ExtractSym (op sa sb) where \
extractSymMaybe :: \
forall knd. (IsSymbolKind knd) => op sa sb -> Maybe (SymbolSet knd); \
extractSymMaybe (cons t) = \
case decideSymbolKind @knd of \
Left HRefl -> Nothing; \
Right HRefl -> SymbolSet <$> extractTerm HS.empty t
#if 1
EXTRACT_SYMBOLICS_SIMPLE(SymBool)
EXTRACT_SYMBOLICS_SIMPLE(SymInteger)
EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode)
EXTRACT_SYMBOLICS_SIMPLE(SymAlgReal)
EXTRACT_SYMBOLICS_BV(SymIntN)
EXTRACT_SYMBOLICS_BV(SymWordN)
EXTRACT_SYMBOLICS_FUN((=~>), SymTabularFun)
EXTRACT_SYMBOLICS_FUN((-~>), SymGeneralFun)
#endif
instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where
extractSymMaybe ::
forall knd. (IsSymbolKind knd) => SymFP eb fb -> Maybe (SymbolSet knd)
extractSymMaybe :: forall (knd :: SymbolKind).
IsSymbolKind knd =>
SymFP eb fb -> Maybe (SymbolSet knd)
extractSymMaybe (SymFP Term (FP eb fb)
t) =
case forall (knd :: SymbolKind).
IsSymbolKind knd =>
Either (knd :~~: 'ConstantKind) (knd :~~: 'AnyKind)
decideSymbolKind @knd of
Left knd :~~: 'ConstantKind
HRefl -> HashSet (SomeTypedSymbol knd) -> SymbolSet knd
forall (knd :: SymbolKind).
HashSet (SomeTypedSymbol knd) -> SymbolSet knd
SymbolSet (HashSet (SomeTypedSymbol knd) -> SymbolSet knd)
-> Maybe (HashSet (SomeTypedSymbol knd)) -> Maybe (SymbolSet knd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet SomeTypedConstantSymbol
-> Term (FP eb fb) -> Maybe (HashSet (SomeTypedSymbol knd))
forall (knd :: SymbolKind) a.
(IsSymbolKind knd, SymbolKindConstraint knd a, SupportedPrim a) =>
HashSet SomeTypedConstantSymbol
-> Term a -> Maybe (HashSet (SomeTypedSymbol knd))
extractTerm HashSet SomeTypedConstantSymbol
forall a. HashSet a
HS.empty Term (FP eb fb)
t
Right knd :~~: 'AnyKind
HRefl -> HashSet (SomeTypedSymbol knd) -> SymbolSet knd
forall (knd :: SymbolKind).
HashSet (SomeTypedSymbol knd) -> SymbolSet knd
SymbolSet (HashSet (SomeTypedSymbol knd) -> SymbolSet knd)
-> Maybe (HashSet (SomeTypedSymbol knd)) -> Maybe (SymbolSet knd)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet SomeTypedConstantSymbol
-> Term (FP eb fb) -> Maybe (HashSet (SomeTypedSymbol knd))
forall (knd :: SymbolKind) a.
(IsSymbolKind knd, SymbolKindConstraint knd a, SupportedPrim a) =>
HashSet SomeTypedConstantSymbol
-> Term a -> Maybe (HashSet (SomeTypedSymbol knd))
extractTerm HashSet SomeTypedConstantSymbol
forall a. HashSet a
HS.empty Term (FP eb fb)
t
derive
[ ''(),
''AssertionError,
''VerificationConditions,
''NotRepresentableFPError
]
[''ExtractSym]