git.iko.soy/project-m36
on fbfa2ea help sign in
project-m36/src/lib/ProjectM36/Tupleable.hs
129 lines 5.1 kB history raw
1{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeOperators, UndecidableInstances, ScopedTypeVariables, DefaultSignatures #-}
2module ProjectM36.Tupleable where
3import ProjectM36.Base
4import ProjectM36.Error
5import ProjectM36.Tuple
6import ProjectM36.TupleSet
7import ProjectM36.Atomable
8import ProjectM36.DataTypes.Primitive
9import ProjectM36.Attribute hiding (null)
10import GHC.Generics
11import qualified Data.Vector as V
12import qualified Data.Text as T
13import Data.Monoid
14import Data.Foldable
16{-
17data Test1T = Test1C {
18 attrA :: Int
19 }
20 deriving (Generic, Show)
22data Test2T a b = Test2C {
23 attrB :: a,
24 attrC :: b
25 }
26 deriving (Generic, Show)
28instance (Atomable a, Atomable b, Show a, Show b) => Tupleable (Test2T a b)
30instance Tupleable Test1T
32data TestUnnamed1 = TestUnnamed1 Int Double T.Text
33 deriving (Show,Eq, Generic)
35instance Tupleable TestUnnamed1
36-}
38-- | Convert a 'Traverseable' of 'Tupleable's to an 'Insert' 'DatabaseContextExpr'. This is useful for converting, for example, a list of data values to a set of Insert expressions which can be used to add the values to the database.
39toInsertExpr :: (Tupleable a, Traversable t) => t a -> RelVarName -> Either RelationalError DatabaseContextExpr
40toInsertExpr vals rvName = do
41 let attrs = toAttributes (head (toList vals))
42 tuples <- mkTupleSet attrs $ toList (fmap toTuple vals)
43 let rel = MakeStaticRelation attrs tuples
44 pure (Insert rvName rel)
46-- | Convert a 'Tupleable' to a create a 'Define' expression which can be used to create an empty relation variable. Use 'toInsertExpr' to insert the actual tuple data. This function is typically used with 'undefined'.
47toDefineExpr :: Tupleable a => a -> RelVarName -> DatabaseContextExpr
48toDefineExpr val rvName = Define rvName (map NakedAttributeExpr (V.toList attrs))
49 where
50 attrs = toAttributes val
54class Tupleable a where
55 toTuple :: a -> RelationTuple
57 fromTuple :: RelationTuple -> Either RelationalError a
59 toAttributes :: a -> Attributes
61 default toTuple :: (Generic a, TupleableG (Rep a)) => a -> RelationTuple
62 toTuple v = toTupleG (from v)
64 default fromTuple :: (Generic a, TupleableG (Rep a)) => RelationTuple -> Either RelationalError a
65 fromTuple tup = to <$> fromTupleG tup
67 default toAttributes :: (Generic a, TupleableG (Rep a)) => a -> Attributes
68 toAttributes v = toAttributesG (from v)
70class TupleableG g where
71 toTupleG :: g a -> RelationTuple
72 toAttributesG :: g a -> Attributes
73 fromTupleG :: RelationTuple -> Either RelationalError (g a)
75--data type metadata
76instance (Datatype c, TupleableG a) => TupleableG (M1 D c a) where
77 toTupleG (M1 v) = toTupleG v
78 toAttributesG (M1 v) = toAttributesG v
79 fromTupleG v = M1 <$> fromTupleG v
81--constructor metadata
82instance (Constructor c, TupleableG a, AtomableG a) => TupleableG (M1 C c a) where
83 toTupleG (M1 v) = RelationTuple attrs atoms
84 where
85 attrsToCheck = toAttributesG v
86 counter = V.generate (V.length attrsToCheck) id
87 attrs = V.zipWith (\num attr@(Attribute name typ) -> if T.null name then
88 Attribute ("attr" <> T.pack (show (num + 1))) typ
89 else
90 attr) counter attrsToCheck
91 atoms = V.fromList (toAtomsG v)
92 toAttributesG (M1 v) = toAttributesG v
93 fromTupleG tup = M1 <$> fromTupleG tup
95-- product types
96instance (TupleableG a, TupleableG b) => TupleableG (a :*: b) where
97 toTupleG = error "toTupleG"
98 toAttributesG ~(x :*: y) = toAttributesG x V.++ toAttributesG y --a bit of extra laziness prevents whnf so that we can use toAttributes (undefined :: Test2T Int Int) without throwing an exception
99 fromTupleG tup = (:*:) <$> fromTupleG tup <*> fromTupleG (trimTuple 1 tup)
101--selector/record
102instance (Selector c, AtomableG a) => TupleableG (M1 S c a) where
103 toTupleG = error "toTupleG"
104 toAttributesG m@(M1 v) = V.singleton (Attribute name aType)
105 where
106 name = T.pack (selName m)
107 aType = toAtomTypeG v
108 fromTupleG tup = if null name then -- non-record type, just pull off the first tuple item
109 M1 <$> atomv (V.head (tupleAtoms tup))
110 else do
111 atom <- atomForAttributeName (T.pack name) tup
112 val <- atomv atom
113 pure (M1 val)
114 where
115 expectedAtomType = atomType (V.head (toAttributesG (undefined :: M1 S c a x)))
116 atomv atom = maybe (Left (AtomTypeMismatchError
117 expectedAtomType
118 (atomTypeForAtom atom)
119 )) Right (fromAtomG atom [atom])
120 name = selName (undefined :: M1 S c a x)
122--constructors with no arguments
123--basically useless but orthoganal to relationTrue
124instance TupleableG U1 where
125 toTupleG _= emptyTuple
126 toAttributesG _ = emptyAttributes
127 fromTupleG _ = pure U1