|
| 1 | +{-# LANGUAGE TemplateHaskell #-} |
| 2 | +{-# LANGUAGE NamedFieldPuns #-} |
| 3 | +{-# LANGUAGE LambdaCase #-} |
| 4 | +{-# LANGUAGE BlockArguments #-} |
| 5 | +{-# LANGUAGE ViewPatterns #-} |
| 6 | +{-# LANGUAGE TypeFamilies #-} |
| 7 | +{-# LANGUAGE PolyKinds #-} |
| 8 | +{-# LANGUAGE TypeApplications #-} |
| 9 | +{-# LANGUAGE RecordWildCards #-} |
| 10 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 11 | +module Rel8.TH (deriveRel8able, parseDatatype) where |
| 12 | + |
| 13 | +import Prelude |
| 14 | +import Language.Haskell.TH (Q) |
| 15 | +import qualified Language.Haskell.TH as TH |
| 16 | +import qualified Language.Haskell.TH.Syntax as TH |
| 17 | +import Language.Haskell.TH.Datatype (reifyDatatype, ConstructorInfo (ConstructorInfo), DatatypeInfo (..), datatypeCons, constructorFields, ConstructorVariant (RecordConstructor), constructorVariant, constructorName, datatypeVars) |
| 18 | +import qualified Language.Haskell.TH.Datatype as TH.Datatype |
| 19 | +import Rel8.Generic.Rel8able ( Rel8able(..) ,serialize, deserialize) |
| 20 | +import Rel8.Schema.Result (Result) |
| 21 | +import Data.Foldable (foldl', toList ) |
| 22 | +import Rel8.Schema.HTable.Identity (HIdentity(HIdentity)) |
| 23 | +import Rel8.Schema.HTable.Product (HProduct(HProduct)) |
| 24 | +import Data.Traversable (for) |
| 25 | +import Data.Functor.Identity (Identity(Identity), runIdentity) |
| 26 | +import Rel8.Kind.Context (SContext(..)) |
| 27 | +import Data.Functor ( (<&>) ) |
| 28 | +import Data.List.NonEmpty ( NonEmpty( (:|) ) ) |
| 29 | +import Rel8.Column ( Column ) |
| 30 | +import Rel8.Column.Maybe ( HMaybe ) |
| 31 | +import Rel8.Schema.HTable.Maybe ( HMaybeTable ) |
| 32 | +import Rel8.Expr ( Expr ) |
| 33 | +import Rel8.Table (Table, Columns, toColumns, fromColumns, fromResult, toResult, FromExprs) |
| 34 | +import Rel8.Schema.Kind (Context) |
| 35 | +import Data.List (unsnoc) |
| 36 | +import Debug.Trace |
| 37 | +import Rel8.Schema.HTable.Label (HLabel(..)) |
| 38 | +import Data.Data (constrFields) |
| 39 | +import Data.Aeson (parseIndexedJSON) |
| 40 | +import Data.Proxy |
| 41 | +import qualified Data.Map.Strict as M |
| 42 | + |
| 43 | + |
| 44 | +-- We derive a Rel8able instance using TH. |
| 45 | +-- At it's core a Rel8able instance is a bijection between a datatype and the the SQL columns corresponding to its fields. |
| 46 | +-- We only support datatypes with one constructor. |
| 47 | +-- The datatype must have exactly one type arg and it is the index for our HKD stuff. |
| 48 | +-- Question: Can we support multiple type args? |
| 49 | +--- |
| 50 | +-- We have three types of fields: |
| 51 | +-- 1) Column f Text : Directly using Column, easy. This is just a special case of (3) |
| 52 | +-- 2) OtherType f : They embed another Rel8able type |
| 53 | +-- 3) TabledType : They embed a type with a table instance. |
| 54 | +-- eg, we might see something like (Column f Text, Column f Bool). (,) has a Table instance, |
| 55 | +-- so we know how to map this type to SQL columns. |
| 56 | +-- |
| 57 | +-- We represent a vector of SQL columns with basically: |
| 58 | +-- HLabel "field label" (HIdentity Text) `HProduct` HLabel "another field" (HIdentity Bool) ... |
| 59 | +-- Nothing too complicated here. I'm not sure if we are allowed to leave the HLabels out or if that will cause everything to explode. |
| 60 | +-- This H* stuff is also used to thread around contexts if you look at the definitions of these things |
| 61 | + |
| 62 | +data ParsedDatatype = |
| 63 | + ParsedDatatype |
| 64 | + { name :: TH.Name |
| 65 | + , conName :: TH.Name |
| 66 | + , fBinder :: TH.Name |
| 67 | + , fields :: [ParsedField] |
| 68 | + } |
| 69 | + deriving (Show) |
| 70 | + |
| 71 | +data ParsedField = |
| 72 | + ParsedField |
| 73 | + { fieldSelector :: Maybe TH.Name |
| 74 | + , fieldVariant :: ParsedFieldVariant |
| 75 | + , fieldType :: TH.Type |
| 76 | + , fieldColumnType :: TH.Type |
| 77 | + , fieldFreshName :: TH.Name |
| 78 | + } |
| 79 | + deriving (Show) |
| 80 | + |
| 81 | +data ParsedFieldVariant = |
| 82 | + ColumnField |
| 83 | + | Rel8ableField -- TODO rename to table field |
| 84 | + deriving (Show) |
| 85 | + |
| 86 | +-- | 'fail' but indicate that the failure is coming from our code |
| 87 | +prettyFail :: String -> Q a |
| 88 | +prettyFail str = fail $ "deriveRel8able: " ++ str |
| 89 | + |
| 90 | +parseDatatype :: DatatypeInfo -> Q ParsedDatatype |
| 91 | +parseDatatype datatypeInfo = do |
| 92 | + constructor <- |
| 93 | + -- Check that it only has one constructor |
| 94 | + case datatypeCons datatypeInfo of |
| 95 | + [cons] -> pure cons |
| 96 | + _ -> prettyFail "exepecting a datatype with exactly 1 constructor" |
| 97 | + let conName = TH.Datatype.constructorName constructor |
| 98 | + let name = datatypeName datatypeInfo |
| 99 | + fBinder <- case unsnoc $ datatypeInstTypes datatypeInfo of |
| 100 | + Just (_, candidate) -> parseFBinder candidate |
| 101 | + Nothing -> prettyFail "expecting the datatype to have a context type parameter like `data Foo f = ...`" |
| 102 | + let fieldSelectors = case constructorVariant constructor of |
| 103 | + -- Only record constructors have field names |
| 104 | + RecordConstructor names -> map Just names |
| 105 | + _ -> repeat Nothing |
| 106 | + let columnName = ''Column |
| 107 | + fields <- |
| 108 | + mapM (uncurry $ parseField columnName fBinder) $ |
| 109 | + zip (constructorFields constructor) fieldSelectors |
| 110 | + -- TODO: check that we have at least one field, fail otherwise |
| 111 | + pure ParsedDatatype{..} |
| 112 | + |
| 113 | +parseFBinder :: TH.Type -> Q TH.Name |
| 114 | +parseFBinder (TH.SigT x (TH.ConT kind)) |
| 115 | + | kind == ''Context = parseFBinder x |
| 116 | + | otherwise = prettyFail $ "expected kind encountered for the context type argument: " ++ show kind |
| 117 | +parseFBinder (TH.VarT name) = pure name |
| 118 | +parseFBinder typ = prettyFail $ "unexpected type encountered while looking for the context type argument to the datatype: " ++ show typ |
| 119 | + |
| 120 | +typeApps :: TH.Type -> [TH.Type] |
| 121 | +typeApps x = go x [] |
| 122 | + where |
| 123 | + go (TH.AppT x y) args = go x (y:args) |
| 124 | + go x args = x:args |
| 125 | + |
| 126 | +unTypeApps :: TH.Type -> [TH.Type] -> TH.Type |
| 127 | +unTypeApps = foldl' TH.AppT |
| 128 | + |
| 129 | +parseField :: TH.Name -> TH.Name -> TH.Type -> Maybe TH.Name -> Q ParsedField |
| 130 | +parseField columnName fBinder fieldType fieldSelector |
| 131 | + | (TH.ConT columnCandidate `TH.AppT` TH.VarT fBinderCandidate `TH.AppT` subType) <- fieldType |
| 132 | + , columnCandidate == columnName |
| 133 | + , fBinderCandidate == fBinder |
| 134 | + = do |
| 135 | + n <- TH.newName "x" |
| 136 | + pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = ColumnField, fieldType = subType, fieldColumnType = TH.ConT ''HIdentity `TH.AppT` subType, fieldFreshName = n} |
| 137 | + -- | (TH.ConT hmaybeCandidate `TH.AppT` TH.VarT fBinderCandidate `TH.AppT` subType) <- fieldType |
| 138 | + -- , hmaybeCandidate == ''HMaybe |
| 139 | + -- , fBinderCandidate == fBinder |
| 140 | + -- = do |
| 141 | + -- n <- TH.newName "x" |
| 142 | + -- innerType <- [t| Columns $(pure subType)|] |
| 143 | + -- let columnType = TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ TH.ConT ''HMaybeTable `TH.AppT` innerType |
| 144 | + -- pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n} |
| 145 | + -- | subType:(TH.VarT name):other_apps <- typeApps fieldType |
| 146 | + -- , name == fBinder |
| 147 | + -- = do |
| 148 | + -- traceShowM (subType:(TH.VarT name):other_apps) |
| 149 | + -- n <- TH.newName "x" |
| 150 | + -- columnType <- [t|Columns ($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)])$ unTypeApps subType ((TH.ConT ''Expr):other_apps))) |] |
| 151 | + -- traceM $ TH.pprint columnType |
| 152 | + -- pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, fieldType = subType, fieldColumnType = columnType, fieldFreshName = n} |
| 153 | + | otherwise |
| 154 | + = do |
| 155 | + traceShowM fieldType |
| 156 | + n <- TH.newName "x" |
| 157 | + columnType <- [t|Columns ($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ fieldType)) |] |
| 158 | + ft2 <- [t|($(pure $ TH.Datatype.applySubstitution (M.fromList [(fBinder, TH.ConT ''Expr)]) $ fieldType)) |] |
| 159 | + traceM $ TH.pprint columnType |
| 160 | + pure $ ParsedField { fieldSelector = fieldSelector, fieldVariant = Rel8ableField, fieldType = ft2, fieldColumnType = columnType, fieldFreshName = n} |
| 161 | + | otherwise = prettyFail $ "Field of unexpected type: " ++ show fieldType ++ show (typeApps fieldType) |
| 162 | + |
| 163 | +generateGColumns :: ParsedDatatype -> Q TH.Type |
| 164 | +generateGColumns ParsedDatatype{..} = |
| 165 | + foldr1 (\x y -> [t|HProduct $x $y|]) $ map generateGColumn fields |
| 166 | + where |
| 167 | + generateGColumn ParsedField{..} = |
| 168 | + [t| $(pure fieldColumnType)|] |
| 169 | + >>= labelled fieldSelector |
| 170 | + labelled Nothing x = pure x |
| 171 | + labelled (Just (TH.Name (TH.OccName fieldSelector) _)) x = [t|HLabel $(TH.litT $ TH.strTyLit fieldSelector) $(pure x)|] |
| 172 | + |
| 173 | +generateColumnsE :: ParsedDatatype -> (TH.Exp -> TH.Exp) -> (TH.Type -> TH.Exp -> TH.Exp) -> TH.Exp |
| 174 | +generateColumnsE ParsedDatatype{..} f g = |
| 175 | + foldr1 (\x y -> TH.ConE 'HProduct `TH.AppE` x `TH.AppE` y) $ map generateColumnE fields |
| 176 | + where |
| 177 | + generateColumnE ParsedField{..} = |
| 178 | + labelled fieldSelector $ |
| 179 | + case fieldVariant of |
| 180 | + ColumnField -> TH.ConE 'HIdentity `TH.AppE` (f $ TH.VarE fieldFreshName) |
| 181 | + Rel8ableField -> (g fieldType $ TH.VarE fieldFreshName) |
| 182 | + labelled Nothing x = x |
| 183 | + labelled (Just _) x = TH.ConE 'HLabel `TH.AppE`x |
| 184 | + |
| 185 | +generateColumnsP :: ParsedDatatype -> TH.Pat |
| 186 | +generateColumnsP ParsedDatatype{..} = |
| 187 | + foldr1 (\x y -> TH.ConP 'HProduct [] [x, y]) $ map generateColumnP fields |
| 188 | + where |
| 189 | + generateColumnP ParsedField{..} = |
| 190 | + labelled fieldSelector $ |
| 191 | + case fieldVariant of |
| 192 | + ColumnField -> TH.ConP 'HIdentity [] [TH.VarP fieldFreshName] |
| 193 | + Rel8ableField -> TH.VarP fieldFreshName |
| 194 | + labelled Nothing x = x |
| 195 | + labelled (Just _) x = TH.ConP 'HLabel [] [x] |
| 196 | + |
| 197 | +generateConstructorE :: ParsedDatatype -> (TH.Exp -> TH.Exp) -> (TH.Type -> TH.Exp -> TH.Exp) -> Q TH.Exp |
| 198 | +generateConstructorE parsedDatatype f g = |
| 199 | + pure $ foldl' TH.AppE (TH.ConE (conName parsedDatatype)) . map generateFieldE $ fields parsedDatatype |
| 200 | + where |
| 201 | + generateFieldE ParsedField{..} = |
| 202 | + case fieldVariant of |
| 203 | + ColumnField -> f . TH.VarE $ fieldFreshName |
| 204 | + Rel8ableField -> g fieldType $ (TH.VarE fieldFreshName --`TH.SigE` (fieldColumnType `TH.AppT` TH.WildCardT) |
| 205 | + ) |
| 206 | + |
| 207 | +fromResult' :: forall context a. (Table context a) => Proxy a -> Columns a Result -> FromExprs a |
| 208 | +fromResult' _ x = fromResult @_ @a x |
| 209 | + |
| 210 | +deriveRel8able :: TH.Name -> Q [TH.Dec] |
| 211 | +deriveRel8able name = do |
| 212 | + datatypeInfo <- reifyDatatype name |
| 213 | + parsedDatatype <- parseDatatype datatypeInfo |
| 214 | + let gColumns = generateGColumns parsedDatatype |
| 215 | + let constructorE = generateConstructorE parsedDatatype |
| 216 | + let constructorP = pure $ TH.ConP (conName parsedDatatype) [] . map (TH.VarP . fieldFreshName) $ fields parsedDatatype |
| 217 | + let columnsE f g = pure $ generateColumnsE parsedDatatype f g |
| 218 | + let columnsP = pure $ generateColumnsP parsedDatatype |
| 219 | + contextName <- TH.newName "context" |
| 220 | + [d| |
| 221 | + instance Rel8able $(TH.conT name) where |
| 222 | + -- Really the Generic code substitutes Expr for f and then does stuff. Maybe we want to move closer to that? |
| 223 | + type GColumns $( TH.conT name) = |
| 224 | + $( gColumns ) |
| 225 | + |
| 226 | + type GFromExprs $( TH.conT name ) = |
| 227 | + $( TH.conT name ) Result |
| 228 | + |
| 229 | + -- the rest of the definition is just a few functions to go back and forth between Columns and the datatype |
| 230 | + |
| 231 | + gfromColumns :: SContext context -> GColumns $(TH.conT name) context -> $(TH.conT name) context |
| 232 | + gfromColumns $( TH.varP contextName ) x = |
| 233 | + case $( TH.varE contextName ) of |
| 234 | + SResult -> case x of $columnsP -> $(constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x) (\ft x -> TH.VarE 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) |
| 235 | + SExpr -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x)) |
| 236 | + SField -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x)) |
| 237 | + SName -> case x of $columnsP -> $(constructorE id (\_ x -> TH.VarE 'fromColumns `TH.AppE` x)) |
| 238 | + |
| 239 | + gtoColumns $(TH.varP contextName) $( constructorP ) = |
| 240 | + case $( TH.varE contextName ) of |
| 241 | + SExpr -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x)) |
| 242 | + SField -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x)) |
| 243 | + SName -> $(columnsE id (\_ x -> TH.VarE 'toColumns `TH.AppE` x)) |
| 244 | + SResult -> $(columnsE (\x -> TH.ConE 'Identity `TH.AppE` x) (\ft x -> TH.VarE 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) |
| 245 | + |
| 246 | + gfromResult $columnsP = |
| 247 | + -- TODO: get rid of type application. Use a signature that references the generic value instead |
| 248 | + $( constructorE (\x -> TH.VarE 'runIdentity `TH.AppE` x) (\ft x -> TH.VarE 'deserialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) |
| 249 | + |
| 250 | + gtoResult $constructorP = |
| 251 | + -- TODO: get rid of type application. Use a signature that references the generic value instead |
| 252 | + $( columnsE (\x -> TH.ConE 'Identity `TH.AppE` x) (\ft x -> TH.VarE 'serialize `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` ft `TH.AppE` x)) |
| 253 | + |
| 254 | + |] |
0 commit comments