{-# LANGUAGE DefaultSignatures, TypeFamilies, TypeOperators, PolyKinds, FlexibleInstances, ScopedTypeVariables, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module ProjectM36.Atomable where
--http://stackoverflow.com/questions/13448361/type-families-with-ghc-generics-or-data-data
--instances to marshal Haskell ADTs to ConstructedAtoms and back
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

-- | All database values ("atoms") adhere to the 'Atomable' typeclass. This class is derivable allowing new datatypes to be easily marshaling between Haskell values and database values.
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 = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG (forall a x. Generic a => a -> Rep a x
from a
v) (forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG (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 TypeConstructorName
_ AtomType
_ [Atom]
args) = case forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
v [Atom]
args of
    Maybe (Rep a Any)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"no fromAtomG traversal found"
    Just Rep a Any
x -> forall a x. Generic a => Rep a x -> a
to Rep a Any
x
  fromAtom Atom
v = case forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
v [] of
    Maybe (Rep a Any)
Nothing -> forall a. HasCallStack => [Char] -> a
error [Char]
"no fromAtomG for Atom found"
    Just Rep a Any
x -> 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
_ = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG (forall a x. Generic a => a -> Rep a x
from (forall a. HasCallStack => a
undefined :: a))
                      
  -- | Creates DatabaseContextExpr necessary to load the type constructor and data constructor into the database.
  toAddTypeExpr :: proxy a -> DatabaseContextExpr
  default toAddTypeExpr :: (Generic a, AtomableG (Rep a)) => proxy a -> DatabaseContextExpr
  toAddTypeExpr proxy a
_ = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> DatabaseContextExpr
toAddTypeExprG (forall a x. Generic a => a -> Rep a x
from (forall a. HasCallStack => [Char] -> a
error [Char]
"insufficient laziness" :: a)) (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (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 = forall a. HasCallStack => [Char] -> a
error ([Char]
"improper fromAtom" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Atom
e)
  toAtomType :: forall (proxy :: * -> *). proxy Integer -> AtomType
toAtomType proxy Integer
_ = AtomType
IntegerAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy Integer -> DatabaseContextExpr
toAddTypeExpr proxy Integer
_ = 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 = forall a. HasCallStack => [Char] -> a
error ([Char]
"improper fromAtom" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Atom
e)
  toAtomType :: forall (proxy :: * -> *). proxy Int -> AtomType
toAtomType proxy Int
_ = AtomType
IntAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy Int -> DatabaseContextExpr
toAddTypeExpr proxy Int
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy Double -> AtomType
toAtomType proxy Double
_ = AtomType
DoubleAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy Double -> DatabaseContextExpr
toAddTypeExpr proxy Double
_ = forall a. DatabaseContextExprBase a
NoOperation

instance Atomable T.Text where
  toAtom :: TypeConstructorName -> Atom
toAtom = TypeConstructorName -> Atom
TextAtom
  fromAtom :: Atom -> TypeConstructorName
fromAtom (TextAtom TypeConstructorName
t) = TypeConstructorName
t
  fromAtom Atom
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"  
  toAtomType :: forall (proxy :: * -> *). proxy TypeConstructorName -> AtomType
toAtomType proxy TypeConstructorName
_ = AtomType
TextAtomType
  toAddTypeExpr :: forall (proxy :: * -> *).
proxy TypeConstructorName -> DatabaseContextExpr
toAddTypeExpr proxy TypeConstructorName
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy Day -> AtomType
toAtomType proxy Day
_ = AtomType
DayAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy Day -> DatabaseContextExpr
toAddTypeExpr proxy Day
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy UTCTime -> AtomType
toAtomType proxy UTCTime
_ = AtomType
DateTimeAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy UTCTime -> DatabaseContextExpr
toAddTypeExpr proxy UTCTime
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy ByteString -> AtomType
toAtomType proxy ByteString
_ = AtomType
ByteStringAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy ByteString -> DatabaseContextExpr
toAddTypeExpr proxy ByteString
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy Bool -> AtomType
toAtomType proxy Bool
_ = AtomType
BoolAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy Bool -> DatabaseContextExpr
toAddTypeExpr proxy Bool
_ = 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
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"UUID: Improper fromAtom"
  toAtomType :: forall (proxy :: * -> *). proxy UUID -> AtomType
toAtomType proxy UUID
_ = AtomType
UUIDAtomType
  toAddTypeExpr :: forall (proxy :: * -> *). proxy UUID -> DatabaseContextExpr
toAddTypeExpr proxy UUID
_ = forall a. DatabaseContextExprBase a
NoOperation

{-
instance Atomable Relation where
  toAtom = RelationAtom
  fromAtom (RelationAtom r) = r
  fromAtom _ = error "improper fromAtom"
  --warning: cannot be used with undefined "Relation"
  toAtomType rel = RelationAtomType (attributes rel) 
  toAddTypeExpr _ = NoOperation
-}
  
instance Atomable a => Atomable (Maybe a) where
  toAtom :: Maybe a -> Atom
toAtom (Just a
v) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Just" (AtomType -> AtomType
maybeAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) [forall a. Atomable a => a -> Atom
toAtom a
v]
  toAtom Maybe a
Nothing = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Nothing" (AtomType -> AtomType
maybeAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) []
  
  fromAtom :: Atom -> Maybe a
fromAtom (ConstructedAtom TypeConstructorName
"Just" AtomType
_ [Atom
val]) = forall a. a -> Maybe a
Just (forall a. Atomable a => Atom -> a
fromAtom Atom
val)
  fromAtom (ConstructedAtom TypeConstructorName
"Nothing" AtomType
_ []) = forall a. Maybe a
Nothing
  fromAtom Atom
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (Maybe a)"
  
  toAtomType :: forall (proxy :: * -> *). proxy (Maybe a) -> AtomType
toAtomType proxy (Maybe a)
_ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"Maybe" (forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
  toAddTypeExpr :: forall (proxy :: * -> *). proxy (Maybe a) -> DatabaseContextExpr
toAddTypeExpr proxy (Maybe a)
_ = forall a. DatabaseContextExprBase a
NoOperation
  
instance (Atomable a, Atomable b) => Atomable (Either a b) where
  toAtom :: Either a b -> Atom
toAtom (Left a
l) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Left" (AtomType -> AtomType -> AtomType
eitherAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) 
                                            (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))) [forall a. Atomable a => a -> Atom
toAtom a
l]
  toAtom (Right b
r) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Right" (AtomType -> AtomType -> AtomType
eitherAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) 
                                              (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))) [forall a. Atomable a => a -> Atom
toAtom b
r]
  
  fromAtom :: Atom -> Either a b
fromAtom (ConstructedAtom TypeConstructorName
"Left" AtomType
_ [Atom
val]) = forall a b. a -> Either a b
Left (forall a. Atomable a => Atom -> a
fromAtom Atom
val)
  fromAtom (ConstructedAtom TypeConstructorName
"Right" AtomType
_ [Atom
val]) = forall a b. b -> Either a b
Right (forall a. Atomable a => Atom -> a
fromAtom Atom
val)
  fromAtom Atom
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (Either a b)"
  
  toAtomType :: forall (proxy :: * -> *). proxy (Either a b) -> AtomType
toAtomType proxy (Either a b)
_ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"Either" (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(TypeConstructorName
"a", forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)),
                                                           (TypeConstructorName
"b", forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))])

  
--convert to ADT list  
instance Atomable a => Atomable [a] where
  toAtom :: [a] -> Atom
toAtom [] = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Empty" (AtomType -> AtomType
listAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) []
  toAtom (a
x:[a]
xs) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"Cons" (AtomType -> AtomType
listAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) (forall a. Atomable a => a -> Atom
toAtom a
xforall a. a -> [a] -> [a]
: [forall a. Atomable a => a -> Atom
toAtom [a]
xs])
  
  fromAtom :: Atom -> [a]
fromAtom (ConstructedAtom TypeConstructorName
"Empty" AtomType
_ [Atom]
_) = []
  fromAtom (ConstructedAtom TypeConstructorName
"Cons" AtomType
_ [Atom
x,Atom
y]) = forall a. Atomable a => Atom -> a
fromAtom Atom
xforall a. a -> [a] -> [a]
:forall a. Atomable a => Atom -> a
fromAtom Atom
y
  fromAtom Atom
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom [a]"
  
  toAtomType :: forall (proxy :: * -> *). proxy [a] -> AtomType
toAtomType proxy [a]
_ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"List" (forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
  toAddTypeExpr :: forall (proxy :: * -> *). proxy [a] -> DatabaseContextExpr
toAddTypeExpr proxy [a]
_ = forall a. DatabaseContextExprBase a
NoOperation

instance Atomable a => Atomable (NE.NonEmpty a) where
  toAtom :: NonEmpty a -> Atom
toAtom (a
x NE.:| []) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"NECons" (AtomType -> AtomType
nonEmptyListAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) [forall a. Atomable a => a -> Atom
toAtom a
x]
  toAtom (a
x NE.:| [a]
xs) = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom TypeConstructorName
"NECons" (AtomType -> AtomType
nonEmptyListAtomType (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))) [forall a. Atomable a => a -> Atom
toAtom a
x, forall a. Atomable a => a -> Atom
toAtom [a]
xs]
  fromAtom :: Atom -> NonEmpty a
fromAtom (ConstructedAtom TypeConstructorName
"NECons" AtomType
_ [Atom
x]) = forall a. Atomable a => Atom -> a
fromAtom Atom
x forall a. a -> [a] -> NonEmpty a
NE.:| []
  fromAtom (ConstructedAtom TypeConstructorName
"NECons" AtomType
_ [Atom
x,Atom
y] ) = forall a. Atomable a => Atom -> a
fromAtom Atom
x forall a. a -> [a] -> NonEmpty a
NE.:| forall a. Atomable a => Atom -> a
fromAtom Atom
y
  fromAtom Atom
_x = forall a. HasCallStack => [Char] -> a
error [Char]
"improper fromAtom (NonEmptyList a)"

  toAtomType :: forall (proxy :: * -> *). proxy (NonEmpty a) -> AtomType
toAtomType proxy (NonEmpty a)
_ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType TypeConstructorName
"NonEmptyList" (forall k a. k -> a -> Map k a
M.singleton TypeConstructorName
"a" (forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)))
  toAddTypeExpr :: forall (proxy :: * -> *). proxy (NonEmpty a) -> DatabaseContextExpr
toAddTypeExpr proxy (NonEmpty a)
_ = forall a. DatabaseContextExprBase a
NoOperation

-- Generics
class AtomableG g where
  --type AtomTG g
  toAtomG :: g a -> AtomType -> Atom
  fromAtomG :: Atom -> [Atom] -> Maybe (g a)
  toAtomTypeG :: g a -> AtomType --overall ConstructedAtomType
  toAtomsG :: g a -> [Atom]
  toAddTypeExprG :: g a -> AtomType -> DatabaseContextExpr
  getConstructorsG :: g a -> [DataConstructorDef]
  getConstructorArgsG :: g a -> [DataConstructorDefArg]
  
--data type metadata
instance (Datatype c, AtomableG a) => AtomableG (M1 D c a) where  
  toAtomG :: forall (a :: k). M1 D c a a -> AtomType -> Atom
toAtomG (M1 a a
v) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG a a
v
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe (M1 D c a a)
fromAtomG Atom
atom [Atom]
args = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
  toAtomsG :: forall (a :: k). M1 D c a a -> [Atom]
toAtomsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomsG in M1 D"
  toAtomTypeG :: forall (a :: k). M1 D c a a -> AtomType
toAtomTypeG M1 D c a a
_ = TypeConstructorName -> TypeVarMap -> AtomType
ConstructedAtomType ([Char] -> TypeConstructorName
T.pack [Char]
typeName) forall k a. Map k a
M.empty -- generics don't allow us to get the type constructor variables- alternatives?
    where
      typeName :: [Char]
typeName = forall {k} (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
datatypeName (forall a. HasCallStack => a
undefined :: M1 D c a x)
  toAddTypeExprG :: forall (a :: k). M1 D c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG ~(M1 a a
v) (ConstructedAtomType TypeConstructorName
tcName TypeVarMap
_) = forall a.
TypeConstructorDef
-> [DataConstructorDef] -> DatabaseContextExprBase a
AddTypeConstructor TypeConstructorDef
tcDef [DataConstructorDef]
dataConstructors
    where
      tcDef :: TypeConstructorDef
tcDef = TypeConstructorName -> [TypeConstructorName] -> TypeConstructorDef
ADTypeConstructorDef TypeConstructorName
tcName []
      dataConstructors :: [DataConstructorDef]
dataConstructors = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG a a
v
  toAddTypeExprG M1 D c a a
_ AtomType
_ = forall a. DatabaseContextExprBase a
NoOperation      
  getConstructorsG :: forall (a :: k). M1 D c a a -> [DataConstructorDef]
getConstructorsG ~(M1 a a
v) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG a a
v
  getConstructorArgsG :: forall (a :: k). M1 D c a a -> [DataConstructorDefArg]
getConstructorArgsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorArgsG in M1 D"
  
--constructor metadata
instance (Constructor c, AtomableG a) => AtomableG (M1 C c a) where
  --constructor name needed for Atom but not for atomType
  toAtomG :: forall (a :: k). M1 C c a a -> AtomType -> Atom
toAtomG (M1 a a
v) AtomType
t = TypeConstructorName -> AtomType -> [Atom] -> Atom
ConstructedAtom ([Char] -> TypeConstructorName
T.pack [Char]
constructorName) AtomType
t [Atom]
atoms
    where
      atoms :: [Atom]
atoms = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
v
      constructorName :: [Char]
constructorName = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall a. HasCallStack => a
undefined :: M1 C c a x)
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe (M1 C c a a)
fromAtomG atom :: Atom
atom@(ConstructedAtom TypeConstructorName
dConsName AtomType
_ [Atom]
_) [Atom]
args = if TypeConstructorName
dName forall a. Eq a => a -> a -> Bool
== TypeConstructorName
dConsName then
                                                      forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
                                                   else
                                                     forall a. Maybe a
Nothing
    where
      dName :: TypeConstructorName
dName = [Char] -> TypeConstructorName
T.pack (forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall a. HasCallStack => a
undefined :: M1 C c a x))
  fromAtomG Atom
_ [Atom]
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid fromAtomG in M1 C"
  toAtomsG :: forall (a :: k). M1 C c a a -> [Atom]
toAtomsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomsG in M1 C"
  toAtomTypeG :: forall (a :: k). M1 C c a a -> AtomType
toAtomTypeG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in M1 C"
  toAddTypeExprG :: forall (a :: k). M1 C c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in M1 C"
  getConstructorsG :: forall (a :: k). M1 C c a a -> [DataConstructorDef]
getConstructorsG ~(M1 a a
v) = [TypeConstructorName
-> [DataConstructorDefArg] -> DataConstructorDef
DataConstructorDef ([Char] -> TypeConstructorName
T.pack [Char]
dName) [DataConstructorDefArg]
dArgs]
    where
      dName :: [Char]
dName = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> [Char]
conName (forall a. HasCallStack => a
undefined :: M1 C c a x)
      dArgs :: [DataConstructorDefArg]
dArgs = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
v
  getConstructorArgsG :: forall (a :: k). M1 C c a a -> [DataConstructorDefArg]
getConstructorArgsG = forall a. HasCallStack => a
undefined

--field metadata
instance (Selector c, AtomableG a) => AtomableG (M1 S c a) where
  toAtomG :: forall (a :: k). M1 S c a a -> AtomType -> Atom
toAtomG = forall a. HasCallStack => a
undefined
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe (M1 S c a a)
fromAtomG Atom
atom [Atom]
args = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args
  toAtomsG :: forall (a :: k). M1 S c a a -> [Atom]
toAtomsG (M1 a a
v) = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
v
  toAtomTypeG :: forall (a :: k). M1 S c a a -> AtomType
toAtomTypeG (M1 a a
v) = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> AtomType
toAtomTypeG a a
v
  toAddTypeExprG :: forall (a :: k). M1 S c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in M1 S"  
  getConstructorsG :: forall (a :: k). M1 S c a a -> [DataConstructorDef]
getConstructorsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in M1 S"
  getConstructorArgsG :: forall (a :: k). M1 S c a a -> [DataConstructorDefArg]
getConstructorArgsG ~(M1 a a
v) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
v

-- field data metadata
instance (Atomable a) => AtomableG (K1 c a) where
  toAtomG :: forall (a :: k). K1 c a a -> AtomType -> Atom
toAtomG (K1 a
v) AtomType
_ = forall a. Atomable a => a -> Atom
toAtom a
v
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe (K1 c a a)
fromAtomG Atom
_ [Atom]
args = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a
Just (forall a. Atomable a => Atom -> a
fromAtom (forall {a}. [a] -> a
headatom [Atom]
args))
                     where headatom :: [a] -> a
headatom (a
x:[a]
_) = a
x
                           headatom [] = forall a. HasCallStack => [Char] -> a
error [Char]
"no more atoms for constructor!"
  toAtomsG :: forall (a :: k). K1 c a a -> [Atom]
toAtomsG (K1 a
v) = [forall a. Atomable a => a -> Atom
toAtom a
v]
  toAtomTypeG :: forall (a :: k). K1 c a a -> AtomType
toAtomTypeG K1 c a a
_ = forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  toAddTypeExprG :: forall (a :: k). K1 c a a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in K1"    
  getConstructorsG :: forall (a :: k). K1 c a a -> [DataConstructorDef]
getConstructorsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in K1"
  getConstructorArgsG :: forall (a :: k). K1 c a a -> [DataConstructorDefArg]
getConstructorArgsG ~(K1 a
_) = [TypeConstructor -> DataConstructorDefArg
DataConstructorDefTypeConstructorArg TypeConstructor
tCons]
    where
      tCons :: TypeConstructor
tCons = AtomType -> TypeConstructor
typeToTypeConstructor forall a b. (a -> b) -> a -> b
$ forall a (proxy :: * -> *). Atomable a => proxy a -> AtomType
toAtomType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

typeToTypeConstructor :: AtomType -> TypeConstructor
typeToTypeConstructor :: AtomType -> TypeConstructor
typeToTypeConstructor x :: AtomType
x@AtomType
IntAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Int" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
IntegerAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Integer" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
ScientificAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Scientific" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DoubleAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Double" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
TextAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Text" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DayAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Day" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
DateTimeAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"DateTime" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
ByteStringAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"ByteString" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
BoolAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"Bool" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
UUIDAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"UUID" AtomType
x
typeToTypeConstructor x :: AtomType
x@AtomType
RelationalExprAtomType = forall a. TypeConstructorName -> AtomType -> TypeConstructorBase a
PrimitiveTypeConstructor TypeConstructorName
"RelationalExpr" AtomType
x
typeToTypeConstructor (RelationAtomType Attributes
attrs)
  = forall a. [AttributeExprBase a] -> TypeConstructorBase a
RelationAtomTypeConstructor forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Attribute -> AttributeExprBase ()
attrToAttrExpr forall a b. (a -> b) -> a -> b
$ forall a. Vector a -> [a]
V.toList (Attributes -> Vector Attribute
attributesVec Attributes
attrs)
  where
    attrToAttrExpr :: Attribute -> AttributeExprBase ()
attrToAttrExpr (Attribute TypeConstructorName
n AtomType
t) = forall a.
TypeConstructorName -> TypeConstructor -> a -> AttributeExprBase a
AttributeAndTypeNameExpr TypeConstructorName
n (AtomType -> TypeConstructor
typeToTypeConstructor AtomType
t) ()
typeToTypeConstructor (SubrelationFoldAtomType AtomType
_typ) =
  forall a. HasCallStack => [Char] -> a
error [Char]
"typeToTypeConstructor for SubrelationFoldAtomType is nonsense"
typeToTypeConstructor (ConstructedAtomType TypeConstructorName
tcName TypeVarMap
tvMap)
  = forall a.
TypeConstructorName -> [TypeConstructor] -> TypeConstructorBase a
ADTypeConstructor TypeConstructorName
tcName forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map AtomType -> TypeConstructor
typeToTypeConstructor (forall k a. Map k a -> [a]
M.elems TypeVarMap
tvMap)
typeToTypeConstructor (TypeVariableType TypeConstructorName
tvName) = forall a. TypeConstructorName -> TypeConstructorBase a
TypeVariable TypeConstructorName
tvName

instance AtomableG U1 where
  toAtomG :: forall (a :: k). U1 a -> AtomType -> Atom
toAtomG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomG in U1"
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe (U1 a)
fromAtomG Atom
_ [Atom]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1
  toAtomsG :: forall (a :: k). U1 a -> [Atom]
toAtomsG U1 a
_ = []
  toAtomTypeG :: forall (a :: k). U1 a -> AtomType
toAtomTypeG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in U1"
  toAddTypeExprG :: forall (a :: k). U1 a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in U1"
  getConstructorsG :: forall (a :: k). U1 a -> [DataConstructorDef]
getConstructorsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in U1"
  getConstructorArgsG :: forall (a :: k). U1 a -> [DataConstructorDefArg]
getConstructorArgsG U1 a
_ = []
  
-- product types
instance (AtomableG a, AtomableG b) => AtomableG (a :*: b) where
  toAtomG :: forall (a :: k). (:*:) a b a -> AtomType -> Atom
toAtomG = forall a. HasCallStack => a
undefined
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe ((:*:) a b a)
fromAtomG Atom
atom [Atom]
args = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
splitargs1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
splitargs2
    where splitargs1 :: [Atom]
splitargs1 = forall a. Int -> [a] -> [a]
take Int
splitpoint [Atom]
args 
          splitargs2 :: [Atom]
splitargs2 = forall a. Int -> [a] -> [a]
drop Int
splitpoint [Atom]
args
          splitpoint :: Int
splitpoint = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Atom]
args forall a. Integral a => a -> a -> a
`div` Int
2
  toAtomTypeG :: forall (a :: k). (:*:) a b a -> AtomType
toAtomTypeG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in :*:"
  toAtomsG :: forall (a :: k). (:*:) a b a -> [Atom]
toAtomsG (a a
x :*: b a
y) = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
x forall a. [a] -> [a] -> [a]
++ forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG b a
y
  toAddTypeExprG :: forall (a :: k). (:*:) a b a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in :*:"
  getConstructorsG :: forall (a :: k). (:*:) a b a -> [DataConstructorDef]
getConstructorsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorsG in :*:"
  getConstructorArgsG :: forall (a :: k). (:*:) a b a -> [DataConstructorDefArg]
getConstructorArgsG ~(a a
x :*: b a
y) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG a a
x forall a. [a] -> [a] -> [a]
++ forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDefArg]
getConstructorArgsG b a
y

-- sum types
instance (AtomableG a, AtomableG b) => AtomableG (a :+: b) where
  toAtomG :: forall (a :: k). (:+:) a b a -> AtomType -> Atom
toAtomG (L1 a a
x) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG a a
x
  toAtomG (R1 b a
x) = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> AtomType -> Atom
toAtomG b a
x
  fromAtomG :: forall (a :: k). Atom -> [Atom] -> Maybe ((:+:) a b a)
fromAtomG Atom
atom [Atom]
args = (forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
Atom -> [Atom] -> Maybe (g a)
fromAtomG Atom
atom [Atom]
args)
  toAtomTypeG :: forall (a :: k). (:+:) a b a -> AtomType
toAtomTypeG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAtomTypeG in :+:"
  toAtomsG :: forall (a :: k). (:+:) a b a -> [Atom]
toAtomsG (L1 a a
x) = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG a a
x
  toAtomsG (R1 b a
x) = forall {k} (g :: k -> *) (a :: k). AtomableG g => g a -> [Atom]
toAtomsG b a
x
  toAddTypeExprG :: forall (a :: k). (:+:) a b a -> AtomType -> DatabaseContextExpr
toAddTypeExprG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid toAddTypeExprG in :+:"
  getConstructorsG :: forall (a :: k). (:+:) a b a -> [DataConstructorDef]
getConstructorsG (:+:) a b a
_ = forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG (forall a. HasCallStack => a
undefined :: a x) forall a. [a] -> [a] -> [a]
++ forall {k} (g :: k -> *) (a :: k).
AtomableG g =>
g a -> [DataConstructorDef]
getConstructorsG (forall a. HasCallStack => a
undefined :: b x)
  getConstructorArgsG :: forall (a :: k). (:+:) a b a -> [DataConstructorDefArg]
getConstructorArgsG = forall a. HasCallStack => [Char] -> a
error [Char]
"invalid getConstructorArgsG in :+:" 
  
--this represents the unimplemented generics traversals which should never be called
{-
missingError :: a
missingError = error "missing generics traversal"
-}