{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ProjectM36.Atomable where
import ProjectM36.Base
import ProjectM36.DataTypes.List
import ProjectM36.DataTypes.NonEmptyList
import ProjectM36.DataTypes.Maybe
import ProjectM36.DataTypes.Either
import GHC.Generics
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Vector as V
import Control.DeepSeq (NFData)
import Control.Applicative
import Data.Time.Calendar
import Data.ByteString (ByteString)
import Data.Time.Clock
import Data.Proxy
import qualified Data.List.NonEmpty as NE
import Codec.Winery
import Data.UUID
class (Eq a, NFData a, Serialise a, Show a) => Atomable a where
toAtom :: a -> Atom
default toAtom :: (Generic a, AtomableG (Rep a)) => a -> Atom
toAtom a
v = Rep a Any -> AtomType -> Atom
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v) (Rep a Any -> AtomType
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
v))
fromAtom :: Atom -> a
default fromAtom :: (Generic a, AtomableG (Rep a)) => Atom -> a
fromAtom v :: Atom
v@(ConstructedAtom DataConstructorName
_ AtomType
_ [Atom]
args) = case Atom -> [Atom] -> Maybe (Rep a Any)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
v [Atom]
args of
Maybe (Rep a Any)
Nothing -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"no fromAtomG traversal found"
Just Rep a Any
x -> Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
x
fromAtom Atom
v = case Atom -> [Atom] -> Maybe (Rep a Any)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
v [] of
Maybe (Rep a Any)
Nothing -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"no fromAtomG for Atom found"
Just Rep a Any
x -> Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to Rep a Any
x
toAtomType :: proxy a -> AtomType
default toAtomType :: (Generic a, AtomableG (Rep a)) => proxy a -> AtomType
toAtomType proxy a
_ = Rep a Any -> AtomType
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (a
forall a. HasCallStack => a
undefined :: a))
toAddTypeExpr :: proxy a -> DatabaseContextExpr
default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr
toAddTypeExpr proxy a
_ = Rep a Any -> AtomType -> DatabaseContextExpr
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> DatabaseContextExpr
toAddTypeExprG (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"insufficient laziness" :: a)) (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
instance Atomable Integer where
toAtom :: Integer -> Atom
toAtom = Integer -> Atom
IntegerAtom
fromAtom :: Atom -> Integer
fromAtom (IntegerAtom Integer
i) = Integer
i
fromAtom Atom
e = [Char] -> Integer
forall a. HasCallStack => [Char] -> a
error ([Char]
"improper fromAtom" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Atom -> [Char]
forall a. Show a => a -> [Char]
show Atom
e)
toAtomType :: proxy Integer -> AtomType
toAtomType proxy Integer
_ = AtomType
IntegerAtomType
toAddTypeExpr :: proxy Integer -> DatabaseContextExpr
toAddTypeExpr proxy Integer
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable Int where
toAtom :: Int -> Atom
toAtom = Int -> Atom
IntAtom
fromAtom :: Atom -> Int
fromAtom (IntAtom Int
i) = Int
i
fromAtom Atom
e = [Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char]
"improper fromAtom" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Atom -> [Char]
forall a. Show a => a -> [Char]
show Atom
e)
toAtomType :: proxy Int -> AtomType
toAtomType proxy Int
_ = AtomType
IntAtomType
toAddTypeExpr :: proxy Int -> DatabaseContextExpr
toAddTypeExpr proxy Int
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable Double where
toAtom :: Double -> Atom
toAtom = Double -> Atom
DoubleAtom
fromAtom :: Atom -> Double
fromAtom (DoubleAtom Double
d) = Double
d
fromAtom Atom
_ = [Char] -> Double
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy Double -> AtomType
toAtomType proxy Double
_ = AtomType
DoubleAtomType
toAddTypeExpr :: proxy Double -> DatabaseContextExpr
toAddTypeExpr proxy Double
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable T.Text where
toAtom :: DataConstructorName -> Atom
toAtom = DataConstructorName -> Atom
TextAtom
fromAtom :: Atom -> DataConstructorName
fromAtom (TextAtom DataConstructorName
t) = DataConstructorName
t
fromAtom Atom
_ = [Char] -> DataConstructorName
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy DataConstructorName -> AtomType
toAtomType proxy DataConstructorName
_ = AtomType
TextAtomType
toAddTypeExpr :: proxy DataConstructorName -> DatabaseContextExpr
toAddTypeExpr proxy DataConstructorName
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable Day where
toAtom :: Day -> Atom
toAtom = Day -> Atom
DayAtom
fromAtom :: Atom -> Day
fromAtom (DayAtom Day
d) = Day
d
fromAtom Atom
_ = [Char] -> Day
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy Day -> AtomType
toAtomType proxy Day
_ = AtomType
DayAtomType
toAddTypeExpr :: proxy Day -> DatabaseContextExpr
toAddTypeExpr proxy Day
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable UTCTime where
toAtom :: UTCTime -> Atom
toAtom = UTCTime -> Atom
DateTimeAtom
fromAtom :: Atom -> UTCTime
fromAtom (DateTimeAtom UTCTime
t) = UTCTime
t
fromAtom Atom
_ = [Char] -> UTCTime
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy UTCTime -> AtomType
toAtomType proxy UTCTime
_ = AtomType
DateTimeAtomType
toAddTypeExpr :: proxy UTCTime -> DatabaseContextExpr
toAddTypeExpr proxy UTCTime
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable ByteString where
toAtom :: ByteString -> Atom
toAtom = ByteString -> Atom
ByteStringAtom
fromAtom :: Atom -> ByteString
fromAtom (ByteStringAtom ByteString
b) = ByteString
b
fromAtom Atom
_ = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy ByteString -> AtomType
toAtomType proxy ByteString
_ = AtomType
ByteStringAtomType
toAddTypeExpr :: proxy ByteString -> DatabaseContextExpr
toAddTypeExpr proxy ByteString
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable Bool where
toAtom :: Bool -> Atom
toAtom = Bool -> Atom
BoolAtom
fromAtom :: Atom -> Bool
fromAtom (BoolAtom Bool
b) = Bool
b
fromAtom Atom
_ = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
toAtomType :: proxy Bool -> AtomType
toAtomType proxy Bool
_ = AtomType
BoolAtomType
toAddTypeExpr :: proxy Bool -> DatabaseContextExpr
toAddTypeExpr proxy Bool
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable UUID where
toAtom :: UUID -> Atom
toAtom = UUID -> Atom
UUIDAtom
fromAtom :: Atom -> UUID
fromAtom (UUIDAtom UUID
u) = UUID
u
fromAtom Atom
_ = [Char] -> UUID
forall a. HasCallStack => [Char] -> a
error [Char]
"UUID: Improper fromAtom"
toAtomType :: proxy UUID -> AtomType
toAtomType proxy UUID
_ = AtomType
UUIDAtomType
toAddTypeExpr :: proxy UUID -> DatabaseContextExpr
toAddTypeExpr proxy UUID
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable a => Atomable (Maybe a) where
toAtom :: Maybe a -> Atom
toAtom (Just a
v) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Just" (AtomType -> AtomType
maybeAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) [a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
v]
toAtom Maybe a
Nothing = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Nothing" (AtomType -> AtomType
maybeAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) []
fromAtom :: Atom -> Maybe a
fromAtom (ConstructedAtom DataConstructorName
"Just" AtomType
_ [Atom
val]) = a -> Maybe a
forall a. a -> Maybe a
Just (Atom -> a
forall a. Atomable a => Atom -> a
fromAtom Atom
val)
fromAtom (ConstructedAtom DataConstructorName
"Nothing" AtomType
_ []) = Maybe a
forall a. Maybe a
Nothing
fromAtom Atom
_ = [Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (Maybe a)"
toAtomType :: proxy (Maybe a) -> AtomType
toAtomType proxy (Maybe a)
_ = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"Maybe" (DataConstructorName -> AtomType -> TypeVarMap
forall k a. k -> a -> Map k a
M.singleton DataConstructorName
"a" (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
toAddTypeExpr :: proxy (Maybe a) -> DatabaseContextExpr
toAddTypeExpr proxy (Maybe a)
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance (Atomable a, Atomable b) => Atomable (Either a b) where
toAtom :: Either a b -> Atom
toAtom (Left a
l) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Left" (AtomType -> AtomType -> AtomType
eitherAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
(Proxy b -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b))) [a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
l]
toAtom (Right b
r) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Right" (AtomType -> AtomType -> AtomType
eitherAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))
(Proxy b -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b))) [b -> Atom
forall a. Atomable a => a -> Atom
toAtom b
r]
fromAtom :: Atom -> Either a b
fromAtom (ConstructedAtom DataConstructorName
"Left" AtomType
_ [Atom
val]) = a -> Either a b
forall a b. a -> Either a b
Left (Atom -> a
forall a. Atomable a => Atom -> a
fromAtom Atom
val)
fromAtom (ConstructedAtom DataConstructorName
"Right" AtomType
_ [Atom
val]) = b -> Either a b
forall a b. b -> Either a b
Right (Atom -> b
forall a. Atomable a => Atom -> a
fromAtom Atom
val)
fromAtom Atom
_ = [Char] -> Either a b
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (Either a b)"
toAtomType :: proxy (Either a b) -> AtomType
toAtomType proxy (Either a b)
_ = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"Either" ([(DataConstructorName, AtomType)] -> TypeVarMap
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(DataConstructorName
"a", Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)),
(DataConstructorName
"b", Proxy b -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b))])
instance Atomable a => Atomable [a] where
toAtom :: [a] -> Atom
toAtom [] = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Empty" (AtomType -> AtomType
listAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) []
toAtom (a
x:[a]
xs) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"Cons" (AtomType -> AtomType
listAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) (a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
xAtom -> [Atom] -> [Atom]
forall a. a -> [a] -> [a]
: [[a] -> Atom
forall a. Atomable a => a -> Atom
toAtom [a]
xs])
fromAtom :: Atom -> [a]
fromAtom (ConstructedAtom DataConstructorName
"Empty" AtomType
_ [Atom]
_) = []
fromAtom (ConstructedAtom DataConstructorName
"Cons" AtomType
_ [Atom
x,Atom
y]) = Atom -> a
forall a. Atomable a => Atom -> a
fromAtom Atom
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:Atom -> [a]
forall a. Atomable a => Atom -> a
fromAtom Atom
y
fromAtom Atom
_ = [Char] -> [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom [a]"
toAtomType :: proxy [a] -> AtomType
toAtomType proxy [a]
_ = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"List" (DataConstructorName -> AtomType -> TypeVarMap
forall k a. k -> a -> Map k a
M.singleton DataConstructorName
"a" (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
toAddTypeExpr :: proxy [a] -> DatabaseContextExpr
toAddTypeExpr proxy [a]
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
instance Atomable a => Atomable (NE.NonEmpty a) where
toAtom :: NonEmpty a -> Atom
toAtom (a
x NE.:| []) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"NECons" (AtomType -> AtomType
nonEmptyListAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) [a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
x]
toAtom (a
x NE.:| [a]
xs) = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom DataConstructorName
"NECons" (AtomType -> AtomType
nonEmptyListAtomType (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))) ((a -> Atom) -> [a] -> [Atom]
forall a b. (a -> b) -> [a] -> [b]
map a -> Atom
forall a. Atomable a => a -> Atom
toAtom (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs))
fromAtom :: Atom -> NonEmpty a
fromAtom Atom
_ = [Char] -> NonEmpty a
forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (NonEmptyList a)"
toAtomType :: proxy (NonEmpty a) -> AtomType
toAtomType proxy (NonEmpty a)
_ = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType DataConstructorName
"NonEmptyList" (DataConstructorName -> AtomType -> TypeVarMap
forall k a. k -> a -> Map k a
M.singleton DataConstructorName
"a" (Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
toAddTypeExpr :: proxy (NonEmpty a) -> DatabaseContextExpr
toAddTypeExpr proxy (NonEmpty a)
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
class AtomableG g where
toAtomG :: g a -> AtomType -> Atom
fromAtomG :: Atom -> [Atom] -> Maybe (g a)
toAtomTypeG :: g a -> AtomType
toAtomsG :: g a -> [Atom]
toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr
getConstructorsG :: g a -> [DataConstructorDef]
getConstructorArgsG :: g a -> [DataConstructorDefArg]
instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where
toAtomG :: M1 D c a a -> AtomType -> Atom
toAtomG (M1 a a
v) = a a -> AtomType -> Atom
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG a a
v
fromAtomG :: Atom -> [Atom] -> Maybe (M1 D c a a)
fromAtomG Atom
atom [Atom]
args = a a -> M1 D c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 D c a a) -> Maybe (a a) -> Maybe (M1 D c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (a a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
toAtomsG :: M1 D c a a -> [Atom]
toAtomsG = [Char] -> M1 D c a a -> [Atom]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomsG in M1 D"
toAtomTypeG :: M1 D c a a -> AtomType
toAtomTypeG M1 D c a a
_ = DataConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType ([Char] -> DataConstructorName
T.pack [Char]
typeName) TypeVarMap
forall k a. Map k a
M.empty
where
typeName :: [Char]
typeName = M1 D c a Any -> [Char]
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
datatypeName (forall (x :: k). M1 D c a x
forall a. HasCallStack => a
undefined :: M1 D c a x)
toAddTypeExprG :: M1 D c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG ~(M1 a a
v) (ConstructedAtomType DataConstructorName
tcName TypeVarMap
_) = TypeConstructorDef -> [DataConstructorDef] -> DatabaseContextExpr
forall a.
TypeConstructorDef
-> [DataConstructorDef] -> DatabaseContextExprBase a
AddTypeConstructor TypeConstructorDef
tcDef [DataConstructorDef]
dataConstructors
where
tcDef :: TypeConstructorDef
tcDef = DataConstructorName -> [DataConstructorName] -> TypeConstructorDef
ADTypeConstructorDef DataConstructorName
tcName []
dataConstructors :: [DataConstructorDef]
dataConstructors = a a -> [DataConstructorDef]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG a a
v
toAddTypeExprG M1 D c a a
_ AtomType
_ = DatabaseContextExpr
forall a. DatabaseContextExprBase a
NoOperation
getConstructorsG :: M1 D c a a -> [DataConstructorDef]
getConstructorsG ~(M1 a a
v) = a a -> [DataConstructorDef]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG a a
v
getConstructorArgsG :: M1 D c a a -> [DataConstructorDefArg]
getConstructorArgsG = [Char] -> M1 D c a a -> [DataConstructorDefArg]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorArgsG in M1 D"
instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
toAtomG :: M1 C c a a -> AtomType -> Atom
toAtomG (M1 a a
v) AtomType
t = DataConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom ([Char] -> DataConstructorName
T.pack [Char]
constructorName) AtomType
t [Atom]
atoms
where
atoms :: [Atom]
atoms = a a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
v
constructorName :: [Char]
constructorName = M1 C c a Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall (x :: k). M1 C c a x
forall a. HasCallStack => a
undefined :: M1 C c a x)
fromAtomG :: Atom -> [Atom] -> Maybe (M1 C c a a)
fromAtomG atom :: Atom
atom@(ConstructedAtom DataConstructorName
dConsName AtomType
_ [Atom]
_) [Atom]
args = if DataConstructorName
dName DataConstructorName -> DataConstructorName -> Bool
forall a. Eq a => a -> a -> Bool
== DataConstructorName
dConsName then
a a -> M1 C c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 C c a a) -> Maybe (a a) -> Maybe (M1 C c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (a a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
else
Maybe (M1 C c a a)
forall a. Maybe a
Nothing
where
dName :: DataConstructorName
dName = [Char] -> DataConstructorName
T.pack (M1 C c a Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall (x :: k). M1 C c a x
forall a. HasCallStack => a
undefined :: M1 C c a x))
fromAtomG Atom
_ [Atom]
_ = [Char] -> Maybe (M1 C c a a)
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid fromAtomG in M1 C"
toAtomsG :: M1 C c a a -> [Atom]
toAtomsG = [Char] -> M1 C c a a -> [Atom]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomsG in M1 C"
toAtomTypeG :: M1 C c a a -> AtomType
toAtomTypeG = [Char] -> M1 C c a a -> AtomType
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in M1 C"
toAddTypeExprG :: M1 C c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> M1 C c a a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in M1 C"
getConstructorsG :: M1 C c a a -> [DataConstructorDef]
getConstructorsG ~(M1 a a
v) = [DataConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef ([Char] -> DataConstructorName
T.pack [Char]
dName) [DataConstructorDefArg]
dArgs]
where
dName :: [Char]
dName = M1 C c a Any -> [Char]
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
(f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall (x :: k). M1 C c a x
forall a. HasCallStack => a
undefined :: M1 C c a x)
dArgs :: [DataConstructorDefArg]
dArgs = a a -> [DataConstructorDefArg]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
v
getConstructorArgsG :: M1 C c a a -> [DataConstructorDefArg]
getConstructorArgsG = M1 C c a a -> [DataConstructorDefArg]
forall a. HasCallStack => a
undefined
instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
toAtomG :: M1 S c a a -> AtomType -> Atom
toAtomG = M1 S c a a -> AtomType -> Atom
forall a. HasCallStack => a
undefined
fromAtomG :: Atom -> [Atom] -> Maybe (M1 S c a a)
fromAtomG Atom
atom [Atom]
args = a a -> M1 S c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 S c a a) -> Maybe (a a) -> Maybe (M1 S c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (a a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
toAtomsG :: M1 S c a a -> [Atom]
toAtomsG (M1 a a
v) = a a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
v
toAtomTypeG :: M1 S c a a -> AtomType
toAtomTypeG (M1 a a
v) = a a -> AtomType
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG a a
v
toAddTypeExprG :: M1 S c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> M1 S c a a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in M1 S"
getConstructorsG :: M1 S c a a -> [DataConstructorDef]
getConstructorsG = [Char] -> M1 S c a a -> [DataConstructorDef]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in M1 S"
getConstructorArgsG :: M1 S c a a -> [DataConstructorDefArg]
getConstructorArgsG ~(M1 a a
v) = a a -> [DataConstructorDefArg]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
v
instance (Atomable a) => AtomableG (K1 c a) where
toAtomG :: K1 c a a -> AtomType -> Atom
toAtomG (K1 a
v) AtomType
_ = a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
v
fromAtomG :: Atom -> [Atom] -> Maybe (K1 c a a)
fromAtomG Atom
_ [Atom]
args = a -> K1 c a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 c a a) -> Maybe a -> Maybe (K1 c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a. a -> Maybe a
Just (Atom -> a
forall a. Atomable a => Atom -> a
fromAtom ([Atom] -> Atom
forall p. [p] -> p
headatom [Atom]
args))
where headatom :: [p] -> p
headatom (p
x:[p]
_) = p
x
headatom [] = [Char] -> p
forall a. HasCallStack => [Char] -> a
error [Char]
"no more atoms for constructor!"
toAtomsG :: K1 c a a -> [Atom]
toAtomsG (K1 a
v) = [a -> Atom
forall a. Atomable a => a -> Atom
toAtom a
v]
toAtomTypeG :: K1 c a a -> AtomType
toAtomTypeG K1 c a a
_ = Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
toAddTypeExprG :: K1 c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> K1 c a a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in K1"
getConstructorsG :: K1 c a a -> [DataConstructorDef]
getConstructorsG = [Char] -> K1 c a a -> [DataConstructorDef]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in K1"
getConstructorArgsG :: K1 c a a -> [DataConstructorDefArg]
getConstructorArgsG ~(K1 a
_) = [TypeConstructor -> DataConstructorDefArg
DataConstructorDefTypeConstructorArg TypeConstructor
tCons]
where
tCons :: TypeConstructor
tCons = AtomType -> TypeConstructor
typeToTypeConstructor (AtomType -> TypeConstructor) -> AtomType -> TypeConstructor
forall a b. (a -> b) -> a -> b
$ Proxy a -> AtomType
forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
typeToTypeConstructor :: AtomType -> TypeConstructor
typeToTypeConstructor :: AtomType -> TypeConstructor
typeToTypeConstructor x :: AtomType
x@AtomType
IntAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Int" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
IntegerAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Integer" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
ScientificAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Scientific" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DoubleAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Double" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
TextAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Text" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DayAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Day" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DateTimeAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"DateTime" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
ByteStringAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"ByteString" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
BoolAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"Bool" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
UUIDAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"UUID" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
RelationalExprAtomType = DataConstructorName -> AtomType -> TypeConstructor
forall a. DataConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor DataConstructorName
"RelationalExpr" AtomType
x
typeToTypeConstructor (RelationAtomType Attributes
attrs)
= [AttributeExprBase ()] -> TypeConstructor
forall a. [AttributeExprBase a] -> TypeConstructorBase a
RelationAtomTypeConstructor ([AttributeExprBase ()] -> TypeConstructor)
-> [AttributeExprBase ()] -> TypeConstructor
forall a b. (a -> b) -> a -> b
$ (Attribute -> AttributeExprBase ())
-> [Attribute] -> [AttributeExprBase ()]
forall a b. (a -> b) -> [a] -> [b]
map Attribute -> AttributeExprBase ()
attrToAttrExpr ([Attribute] -> [AttributeExprBase ()])
-> [Attribute] -> [AttributeExprBase ()]
forall a b. (a -> b) -> a -> b
$ Vector Attribute -> [Attribute]
forall a. Vector a -> [a]
V.toList (Attributes -> Vector Attribute
attributesVec Attributes
attrs)
where
attrToAttrExpr :: Attribute -> AttributeExprBase ()
attrToAttrExpr (Attribute DataConstructorName
n AtomType
t) = DataConstructorName
-> TypeConstructor -> () -> AttributeExprBase ()
forall a.
DataConstructorName -> TypeConstructor -> a -> AttributeExprBase a
AttributeAndTypeNameExpr DataConstructorName
n (AtomType -> TypeConstructor
typeToTypeConstructor AtomType
t) ()
typeToTypeConstructor (ConstructedAtomType DataConstructorName
tcName TypeVarMap
tvMap)
= DataConstructorName -> [TypeConstructor] -> TypeConstructor
forall a.
DataConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor DataConstructorName
tcName ([TypeConstructor] -> TypeConstructor)
-> [TypeConstructor] -> TypeConstructor
forall a b. (a -> b) -> a -> b
$ (AtomType -> TypeConstructor) -> [AtomType] -> [TypeConstructor]
forall a b. (a -> b) -> [a] -> [b]
map AtomType -> TypeConstructor
typeToTypeConstructor (TypeVarMap -> [AtomType]
forall k a. Map k a -> [a]
M.elems TypeVarMap
tvMap)
typeToTypeConstructor (TypeVariableType DataConstructorName
tvName) = DataConstructorName -> TypeConstructor
forall a. DataConstructorName -> TypeConstructorBase a
TypeVariable DataConstructorName
tvName
instance AtomableG U1 where
toAtomG :: U1 a -> AtomType -> Atom
toAtomG = [Char] -> U1 a -> AtomType -> Atom
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomG in U1"
fromAtomG :: Atom -> [Atom] -> Maybe (U1 a)
fromAtomG Atom
_ [Atom]
_ = U1 a -> Maybe (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
toAtomsG :: U1 a -> [Atom]
toAtomsG U1 a
_ = []
toAtomTypeG :: U1 a -> AtomType
toAtomTypeG = [Char] -> U1 a -> AtomType
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in U1"
toAddTypeExprG :: U1 a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> U1 a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in U1"
getConstructorsG :: U1 a -> [DataConstructorDef]
getConstructorsG = [Char] -> U1 a -> [DataConstructorDef]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in U1"
getConstructorArgsG :: U1 a -> [DataConstructorDefArg]
getConstructorArgsG U1 a
_ = []
instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
toAtomG :: (:*:) a b a -> AtomType -> Atom
toAtomG = (:*:) a b a -> AtomType -> Atom
forall a. HasCallStack => a
undefined
fromAtomG :: Atom -> [Atom] -> Maybe ((:*:) a b a)
fromAtomG Atom
atom [Atom]
args = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a)
-> Maybe (a a) -> Maybe (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (a a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
splitargs1 Maybe (b a -> (:*:) a b a) -> Maybe (b a) -> Maybe ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Atom -> [Atom] -> Maybe (b a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
splitargs2
where splitargs1 :: [Atom]
splitargs1 = Int -> [Atom] -> [Atom]
forall a. Int -> [a] -> [a]
take Int
splitpoint [Atom]
args
splitargs2 :: [Atom]
splitargs2 = Int -> [Atom] -> [Atom]
forall a. Int -> [a] -> [a]
drop Int
splitpoint [Atom]
args
splitpoint :: Int
splitpoint = [Atom] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Atom]
args Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
toAtomTypeG :: (:*:) a b a -> AtomType
toAtomTypeG = [Char] -> (:*:) a b a -> AtomType
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in :*:"
toAtomsG :: (:*:) a b a -> [Atom]
toAtomsG (a a
x :*: b a
y) = a a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
x [Atom] -> [Atom] -> [Atom]
forall a. [a] -> [a] -> [a]
++ b a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG b a
y
toAddTypeExprG :: (:*:) a b a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> (:*:) a b a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in :*:"
getConstructorsG :: (:*:) a b a -> [DataConstructorDef]
getConstructorsG = [Char] -> (:*:) a b a -> [DataConstructorDef]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in :*:"
getConstructorArgsG :: (:*:) a b a -> [DataConstructorDefArg]
getConstructorArgsG ~(a a
x :*: b a
y) = a a -> [DataConstructorDefArg]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
x [DataConstructorDefArg]
-> [DataConstructorDefArg] -> [DataConstructorDefArg]
forall a. [a] -> [a] -> [a]
++ b a -> [DataConstructorDefArg]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG b a
y
instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
toAtomG :: (:+:) a b a -> AtomType -> Atom
toAtomG (L1 a a
x) = a a -> AtomType -> Atom
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG a a
x
toAtomG (R1 b a
x) = b a -> AtomType -> Atom
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG b a
x
fromAtomG :: Atom -> [Atom] -> Maybe ((:+:) a b a)
fromAtomG Atom
atom [Atom]
args = (a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Maybe (a a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (a a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args) Maybe ((:+:) a b a) -> Maybe ((:+:) a b a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Maybe (b a) -> Maybe ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Atom -> [Atom] -> Maybe (b a)
forall k (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args)
toAtomTypeG :: (:+:) a b a -> AtomType
toAtomTypeG = [Char] -> (:+:) a b a -> AtomType
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in :+:"
toAtomsG :: (:+:) a b a -> [Atom]
toAtomsG (L1 a a
x) = a a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
x
toAtomsG (R1 b a
x) = b a -> [Atom]
forall k (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG b a
x
toAddTypeExprG :: (:+:) a b a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = [Char] -> (:+:) a b a -> AtomType -> DatabaseContextExpr
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in :+:"
getConstructorsG :: (:+:) a b a -> [DataConstructorDef]
getConstructorsG (:+:) a b a
_ = a Any -> [DataConstructorDef]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG (forall (x :: k). a x
forall a. HasCallStack => a
undefined :: a x) [DataConstructorDef]
-> [DataConstructorDef] -> [DataConstructorDef]
forall a. [a] -> [a] -> [a]
++ b Any -> [DataConstructorDef]
forall k (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG (forall (x :: k). b x
forall a. HasCallStack => a
undefined :: b x)
getConstructorArgsG :: (:+:) a b a -> [DataConstructorDefArg]
getConstructorArgsG = [Char] -> (:+:) a b a -> [DataConstructorDefArg]
forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorArgsG in :+:"