├── classes.schema ├── students.schema ├── classes.table ├── students.table ├── README.md ├── Main.hs ├── Instances.hs ├── ReadDB.hs ├── TH.hs ├── Basics.hs └── DB2.hs /classes.schema: -------------------------------------------------------------------------------- 1 | prof String 2 | students List Int 3 | name String 4 | -------------------------------------------------------------------------------- /students.schema: -------------------------------------------------------------------------------- 1 | last String 2 | first String 3 | id Int 4 | grad_year Int 5 | -------------------------------------------------------------------------------- /classes.table: -------------------------------------------------------------------------------- 1 | "Eisenberg" 2 | [1,2,5,8] 3 | "Programming Languages" 4 | "Zdancewic" 5 | [1,3,4,5] 6 | "Compilers" 7 | "Weirich" 8 | [3,6,7,8] 9 | "Advanced Haskell" 10 | -------------------------------------------------------------------------------- /students.table: -------------------------------------------------------------------------------- 1 | "Matthews" 2 | "Maya" 3 | 1 4 | 2018 5 | "Morley" 6 | "Aimee" 7 | 2 8 | 2017 9 | "Barnett" 10 | "William" 11 | 3 12 | 2016 13 | "Leonard" 14 | "Sienna" 15 | 4 16 | 2019 17 | "Oliveira" 18 | "Pedro" 19 | 5 20 | 2017 21 | "Peng" 22 | "Qi" 23 | 6 24 | 2016 25 | "Chakraborty" 26 | "Sangeeta" 27 | 7 28 | 2018 29 | "Yang" 30 | "Rebecca" 31 | 8 32 | 2019 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Dependent DB 2 | ------------ 3 | 4 | This is the code that accompanies Richard Eisenberg's talk originally from the 5 | winter of 2016 and dissertation. It requires GHC 8.0. It is a proof-of-concept 6 | that a database schema can be inferred, using type inference, from a program 7 | that accesses the database. It is not meant as a serious implementation of 8 | anything. 9 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {- Copyright (c) 2016 Richard Eisenberg 2 | 3 | Main driver for database example. 4 | -} 5 | 6 | {-# LANGUAGE TemplateHaskell, TypeInType #-} 7 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 8 | -- improves error messages during example 9 | 10 | module Main where 11 | 12 | import ReadDB 13 | import Basics 14 | import TH 15 | import DB2 hiding ( Schema ) 16 | 17 | main :: IO () 18 | main = withSchema "classes.schema" $ \classes_sch -> 19 | withSchema "students.schema" $ \students_sch -> 20 | $(checkSchema 'readDB ['classes_sch, 'students_sch]) 21 | -------------------------------------------------------------------------------- /Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, TypeApplications, GADTs #-} 2 | 3 | module Instances where 4 | 5 | import Basics 6 | 7 | -- Finds Read and Show instances for the example 8 | getReadShowInstances :: TypeRep a 9 | -> ((Show a, Read a) => r) 10 | -> r 11 | getReadShowInstances tr thing 12 | | Just HRefl <- eqT tr (typeRep @Int) = thing 13 | | Just HRefl <- eqT tr (typeRep @Bool) = thing 14 | | Just HRefl <- eqT tr (typeRep @Char) = thing 15 | 16 | | TyApp list_rep elt_rep <- tr 17 | , Just HRefl <- eqT list_rep (typeRep @[]) 18 | = getReadShowInstances elt_rep $ thing 19 | 20 | | otherwise = error $ "I don't know how to read or show " ++ show tr 21 | -------------------------------------------------------------------------------- /ReadDB.hs: -------------------------------------------------------------------------------- 1 | {- Copyright (c) 2016 Richard Eisenberg 2 | 3 | This module computes a join of two tables to retrieve the list of students 4 | in a given professor's class. 5 | -} 6 | 7 | {-# LANGUAGE TypeApplications, TypeInType, RankNTypes, ScopedTypeVariables, 8 | FlexibleContexts, TemplateHaskell, ConstraintKinds, GADTs #-} 9 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 10 | -- inference is the whole point! 11 | 12 | module ReadDB where 13 | 14 | import Prelude hiding ( last ) 15 | import DB2 hiding ( Schema ) 16 | 17 | type NameSchema = [ Col "first" String, Col "last" String ] 18 | 19 | printName :: Row NameSchema -> IO () 20 | printName (first ::> last ::> _) = putStrLn (first ++ " " ++ last) 21 | 22 | readDB classes_sch students_sch = do 23 | classes_tab <- loadTable "classes.table" classes_sch 24 | students_tab <- loadTable "students.table" students_sch 25 | 26 | putStr "Whose students do you want to see? " 27 | prof <- getLine 28 | 29 | let joined = Project $ 30 | Select (field @"id" @Int `ElementOf` field @"students") $ 31 | Product (Select (field @"prof" :== Literal prof) (Read classes_tab)) 32 | (Read students_tab) 33 | rows <- query joined 34 | mapM_ printName rows 35 | -------------------------------------------------------------------------------- /TH.hs: -------------------------------------------------------------------------------- 1 | {- Copyright (c) 2016 Richard Eisenberg 2 | 3 | This module defines ways of generating code to establish constraints 4 | found through TH reification of a database-access function. 5 | -} 6 | 7 | {-# LANGUAGE TemplateHaskellQuotes, TypeApplications, FlexibleContexts, 8 | RankNTypes, ScopedTypeVariables #-} 9 | 10 | module TH where 11 | 12 | import DB2 13 | 14 | import Prelude hiding ( pred, head ) 15 | import Language.Haskell.TH.Syntax 16 | import Data.Maybe 17 | import Data.Proxy 18 | import GHC.TypeLits 19 | import Basics 20 | 21 | -- wrapper for checkIn that uses proxy. Necessary only because Template Haskell 22 | -- does not yet support visible type application 23 | checkInProxy :: (KnownSymbol name, Typeable ty) => Proxy name -> Proxy ty 24 | -> Sing sch -> (In name ty sch => r) -> r 25 | checkInProxy (_ :: Proxy name) (_ :: Proxy ty) sch thing 26 | = checkIn (SSym @name) (typeRep @ty) sch thing 27 | 28 | -- `checkSchema 'db_fun ['sch1, 'sch2]` calls the function `db_fun` on `sch1` 29 | -- and `sch2` after establishing the constraints on `db_fun`s type, to the 30 | -- best of `checkSchema`'s ability. 31 | checkSchema :: Name -- name of function that will consume the schemas 32 | -> [Name] -- names of the variables that hold the schemas 33 | -> Q Exp 34 | checkSchema fun_name sch_names = do 35 | VarI _ (ForallT _ cxt inner_ty) _ <- reify fun_name 36 | let sch_ty_names = map getSchemaTypeName (fst $ splitFunTys inner_ty) 37 | calls = mapMaybe (processPred (zip sch_ty_names sch_names)) cxt 38 | return (foldr AppE (foldl AppE (VarE fun_name) (map VarE sch_names)) calls) 39 | 40 | -- association list from type-level schema names to term-level schema names 41 | type SchemaMapping = [(Name, Name)] 42 | 43 | processPred :: SchemaMapping 44 | -> Pred -- predicate to process 45 | -> Maybe Exp -- an function call used to establish the constraint 46 | -- has type ((pred => r) -> r) 47 | processPred sch_name_pairs pred 48 | | ConT cls <- head 49 | , cls == ''In 50 | , [name, ty, sch_ty] <- args 51 | = Just $ 52 | VarE 'checkInProxy `AppE` (ConE 'Proxy `SigE` (ConT ''Proxy `AppT` name)) 53 | `AppE` (ConE 'Proxy `SigE` (ConT ''Proxy `AppT` ty)) 54 | `AppE` schemaExpression sch_ty sch_name_pairs 55 | | ConT cls <- head 56 | , cls == ''AllSchemaTys 57 | , [ConT mapped_class, sch_ty] <- args 58 | , mapped_class == ''Show 59 | = Just $ VarE 'checkShowSchema `AppE` schemaExpression sch_ty sch_name_pairs 60 | 61 | | ConT cls <- head 62 | , cls == ''AllSchemaTys 63 | , [ConT mapped_class, sch_ty] <- args 64 | , mapped_class == ''Read 65 | = Just $ VarE 'checkReadSchema `AppE` schemaExpression sch_ty sch_name_pairs 66 | 67 | | EqualityT <- head 68 | , [left, right] <- args 69 | , (ConT disjoint, [sch_ty1, sch_ty2]) <- splitAppTys left 70 | , disjoint == ''Disjoint 71 | , ConT true <- right 72 | , true == 'True -- NB: just one quote! 73 | = Just $ VarE 'checkDisjoint `AppE` schemaExpression sch_ty1 sch_name_pairs 74 | `AppE` schemaExpression sch_ty2 sch_name_pairs 75 | 76 | | otherwise 77 | = Nothing 78 | 79 | where 80 | (head, args) = splitAppTys pred 81 | 82 | -- convert a type `sch` to an expression of type `Schema sch`. 83 | schemaExpression :: Type -> SchemaMapping -> Exp 84 | schemaExpression (SigT ty _) pairs = schemaExpression ty pairs 85 | schemaExpression (VarT sch_ty) pairs 86 | | Just sch_term <- lookup sch_ty pairs 87 | = VarE sch_term 88 | schemaExpression (ConT append `AppT` sch_ty1 `AppT` sch_ty2) pairs 89 | | append == ''(++) 90 | = InfixE (Just (schemaExpression sch_ty1 pairs)) (VarE '(%:++)) 91 | (Just (schemaExpression sch_ty2 pairs)) 92 | schemaExpression sch_ty _ = error $ "No expression for " ++ show sch_ty 93 | 94 | -- extract the sch from (Schema sch) 95 | getSchemaTypeName :: Type -> Name 96 | getSchemaTypeName (_ `AppT` VarT sch_ty_name) = sch_ty_name 97 | getSchemaTypeName ty = error ("invalid type: " ++ show ty) 98 | 99 | -- given `t a b c`, returns (t, [a,b,c]) 100 | splitAppTys :: Type -> (Type, [Type]) 101 | splitAppTys ty = go [] ty 102 | where 103 | go args (AppT fun arg) = go (arg:args) fun 104 | go args head = (head, args) 105 | 106 | -- given `a -> b -> c`, returns ([a,b], c) 107 | splitFunTys :: Type -> ([Type], Type) 108 | splitFunTys ty = go [] ty 109 | where 110 | go args (AppT (AppT ArrowT arg) res) = go (arg:args) res 111 | go args res = (reverse args, res) 112 | -------------------------------------------------------------------------------- /Basics.hs: -------------------------------------------------------------------------------- 1 | {- Copyright (c) 2016 Richard Eisenberg 2 | 3 | This module defines all the plumbing needed to power the dependent database. 4 | -} 5 | 6 | {-# LANGUAGE TypeOperators, TypeFamilies, TypeApplications, 7 | ExplicitForAll, ScopedTypeVariables, GADTs, TypeFamilyDependencies, 8 | TypeInType, ConstraintKinds, UndecidableInstances, 9 | FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, 10 | FlexibleContexts, StandaloneDeriving, InstanceSigs, 11 | RankNTypes, UndecidableSuperClasses, AllowAmbiguousTypes #-} 12 | 13 | module Basics where 14 | 15 | import Data.Type.Bool 16 | import Data.Type.Equality 17 | import GHC.TypeLits 18 | import Data.Proxy 19 | import GHC.Exts 20 | import Data.Kind 21 | import Unsafe.Coerce 22 | 23 | ------------------------------- 24 | -- Utilities 25 | 26 | -- Heterogeneous propositional equality 27 | data (a :: k1) :~~: (b :: k2) where 28 | HRefl :: a :~~: a 29 | 30 | -- Type-level inequality 31 | type a /= b = Not (a == b) 32 | 33 | -- append type-level lists (schemas) 34 | type family s1 ++ s2 where 35 | '[] ++ s2 = s2 36 | (s ': s1) ++ s2 = s ': (s1 ++ s2) 37 | 38 | -- This is needed in order to prove disjointness, because GHC can't 39 | -- handle inequality well. 40 | assumeEquality :: forall a b r. ((a ~ b) => r) -> r 41 | assumeEquality thing = case unsafeCoerce Refl :: a :~: b of 42 | Refl -> thing 43 | 44 | -- Shorter name for shorter example 45 | eq :: TestEquality f => f a -> f b -> Maybe (a :~: b) 46 | eq = testEquality 47 | 48 | ------------------------------- 49 | -- Singleton lists 50 | 51 | -- Unlike in the singletons paper, we now have injective type 52 | -- families, so we use that to model singletons; it's a bit 53 | -- cleaner than the original approach 54 | type family Sing = (r :: k -> Type) | r -> k 55 | 56 | -- Cute type synonym. 57 | type Π = Sing 58 | 59 | -- Really, just singleton lists. Named Schema for better output 60 | -- during example. 61 | data Schema :: forall k. [k] -> Type where 62 | Nil :: Schema '[] 63 | (:>>) :: Sing h -> Schema t -> Schema (h ': t) 64 | infixr 5 :>> 65 | type instance Sing = Schema 66 | 67 | -- Append singleton lists 68 | (%:++) :: Schema a -> Schema b -> Schema (a ++ b) 69 | Nil %:++ x = x 70 | (a :>> b) %:++ c = a :>> (b %:++ c) 71 | 72 | -------------------------------- 73 | -- Type-indexed type representations 74 | -- Based on "A reflection on types" 75 | 76 | data TyCon (a :: k) where 77 | Int :: TyCon Int 78 | Bool :: TyCon Bool 79 | Char :: TyCon Char 80 | List :: TyCon [] 81 | Maybe :: TyCon Maybe 82 | Arrow :: TyCon (->) 83 | TYPE :: TyCon TYPE 84 | RuntimeRep :: TyCon RuntimeRep 85 | PtrRepLifted' :: TyCon 'PtrRepLifted 86 | -- If extending, add to eqTyCon too 87 | 88 | eqTyCon :: TyCon a -> TyCon b -> Maybe (a :~~: b) 89 | eqTyCon Int Int = Just HRefl 90 | eqTyCon Bool Bool = Just HRefl 91 | eqTyCon Char Char = Just HRefl 92 | eqTyCon List List = Just HRefl 93 | eqTyCon Maybe Maybe = Just HRefl 94 | eqTyCon Arrow Arrow = Just HRefl 95 | eqTyCon TYPE TYPE = Just HRefl 96 | eqTyCon RuntimeRep RuntimeRep = Just HRefl 97 | eqTyCon PtrRepLifted' PtrRepLifted' = Just HRefl 98 | eqTyCon _ _ = Nothing 99 | 100 | -- Check whether or not a type is really a plain old tycon; 101 | -- necessary to avoid warning in kindRep 102 | type family Primitive (a :: k) :: Constraint where 103 | Primitive (_ _) = ('False ~ 'True) 104 | Primitive _ = (() :: Constraint) 105 | 106 | data TypeRep (a :: k) where 107 | TyCon :: forall (a :: k). (Primitive a, Typeable k) => TyCon a -> TypeRep a 108 | TyApp :: TypeRep a -> TypeRep b -> TypeRep (a b) 109 | 110 | -- Equality on TypeReps 111 | eqT :: TypeRep a -> TypeRep b -> Maybe (a :~~: b) 112 | eqT (TyCon tc1) (TyCon tc2) = eqTyCon tc1 tc2 113 | eqT (TyApp f1 a1) (TyApp f2 a2) = do 114 | HRefl <- eqT f1 f2 115 | HRefl <- eqT a1 a2 116 | return HRefl 117 | eqT _ _ = Nothing 118 | 119 | 120 | -------------------------------------- 121 | -- Existentials 122 | 123 | data TyConX where 124 | TyConX :: forall (a :: k). (Primitive a, Typeable k) => TyCon a -> TyConX 125 | 126 | instance Read TyConX where 127 | readsPrec _ "Int" = [(TyConX Int, "")] 128 | readsPrec _ "Bool" = [(TyConX Bool, "")] 129 | readsPrec _ "List" = [(TyConX List, "")] 130 | readsPrec _ _ = [] 131 | 132 | -- This variant of TypeRepX allows you to specify an arbitrary 133 | -- constraint on the inner TypeRep 134 | data TypeRepX :: (forall k. k -> Constraint) -> Type where 135 | TypeRepX :: forall k (c :: forall k'. k' -> Constraint) (a :: k). 136 | c a => TypeRep a -> TypeRepX c 137 | 138 | -- This constraint is always satisfied 139 | class ConstTrue (a :: k) -- needs the :: k to make it a specified tyvar 140 | instance ConstTrue a 141 | 142 | instance Show (TypeRepX ConstTrue) where 143 | show (TypeRepX tr) = show tr 144 | 145 | -- can't write Show (TypeRepX c) because c's kind mentions a forall, 146 | -- and the impredicativity check gets nervous. See #11519 147 | instance Show (TypeRepX IsType) where 148 | show (TypeRepX tr) = show tr 149 | 150 | -- Just enough functionality to get through example. No parentheses 151 | -- or other niceties. 152 | instance Read (TypeRepX ConstTrue) where 153 | readsPrec p s = do 154 | let tokens = words s 155 | tyreps <- mapM read_token tokens 156 | return (foldl1 mk_app tyreps, "") 157 | 158 | where 159 | read_token "String" = return (TypeRepX $ typeRep @String) 160 | read_token other = do 161 | (TyConX tc, _) <- readsPrec p other 162 | return (TypeRepX (TyCon tc)) 163 | 164 | mk_app :: TypeRepX ConstTrue -> TypeRepX ConstTrue -> TypeRepX ConstTrue 165 | mk_app (TypeRepX f) (TypeRepX a) = case kindRep f of 166 | TyCon Arrow `TyApp` k1 `TyApp` _ 167 | | Just HRefl <- k1 `eqT` kindRep a -> TypeRepX (TyApp f a) 168 | _ -> error "ill-kinded type" 169 | 170 | -- instance Read (TypeRepX ((~~) Type)) RAE: need (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint 171 | -- RAE: need kind signatures on classes 172 | 173 | -- TypeRepX ((~~) Type) 174 | -- (~~) :: forall k1 k2. k1 -> k2 -> Constraint 175 | -- I need: (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint 176 | 177 | class k ~~ Type => IsType (x :: k) 178 | instance k ~~ Type => IsType (x :: k) 179 | 180 | instance Read (TypeRepX IsType) where 181 | readsPrec p s = case readsPrec @(TypeRepX ConstTrue) p s of 182 | [(TypeRepX tr, "")] 183 | | Just HRefl <- eqT (kindRep tr) (typeRep @Type) 184 | -> [(TypeRepX tr, "")] 185 | _ -> error "wrong kind" 186 | 187 | ----------------------------- 188 | -- Get the kind of a type 189 | 190 | kindRep :: TypeRep (a :: k) -> TypeRep k 191 | kindRep (TyCon _) = typeRep 192 | kindRep (TyApp (f :: TypeRep (tf :: k1 -> k)) _) = case kindRep f :: TypeRep (k1 -> k) of 193 | TyApp _ res -> res 194 | 195 | -- Convert an explicit TypeRep into an implicit one. Doesn't require unsafeCoerce 196 | -- in Core 197 | withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r 198 | withTypeable tr thing = unsafeCoerce (Don'tInstantiate thing :: DI a r) tr 199 | newtype DI a r = Don'tInstantiate (Typeable a => r) 200 | 201 | ----------------------------- 202 | -- Implicit TypeReps (Typeable) 203 | 204 | class (Primitive a, Typeable k) => TyConAble (a :: k) where 205 | tyCon :: TyCon a 206 | 207 | instance TyConAble Int where tyCon = Int 208 | instance TyConAble Bool where tyCon = Bool 209 | instance TyConAble Char where tyCon = Char 210 | instance TyConAble [] where tyCon = List 211 | instance TyConAble Maybe where tyCon = Maybe 212 | instance TyConAble (->) where tyCon = Arrow 213 | instance TyConAble TYPE where tyCon = TYPE 214 | instance TyConAble 'PtrRepLifted where tyCon = PtrRepLifted' 215 | instance TyConAble RuntimeRep where tyCon = RuntimeRep 216 | 217 | -- Can't just define Typeable the way we want, because the instances 218 | -- overlap. So we have to mock up instance chains via closed type families. 219 | class Typeable' (a :: k) (b :: Bool) where 220 | typeRep' :: TypeRep a 221 | 222 | type family CheckPrim a where 223 | CheckPrim (_ _) = 'False 224 | CheckPrim _ = 'True 225 | 226 | -- NB: We need the ::k and the ::Constraint so that this has a CUSK, allowing 227 | -- the polymorphic recursion with TypeRep. See also #9200, though the requirement 228 | -- for the constraints is correct. 229 | type Typeable (a :: k) = (Typeable' a (CheckPrim a) :: Constraint) 230 | 231 | instance TyConAble a => Typeable' a 'True where 232 | typeRep' = TyCon tyCon 233 | 234 | instance (Typeable a, Typeable b) => Typeable' (a b) 'False where 235 | typeRep' = TyApp typeRep typeRep 236 | 237 | typeRep :: forall a. Typeable a => TypeRep a 238 | typeRep = typeRep' @_ @_ @(CheckPrim a) -- RAE: #11512 says we need the extra @_. 239 | 240 | ----------------------------- 241 | -- Useful instances 242 | 243 | instance Show (TypeRep a) where 244 | show (TyCon tc) = show tc 245 | show (TyApp tr1 tr2) = show tr1 ++ " " ++ show tr2 246 | 247 | deriving instance Show (TyCon a) 248 | 249 | instance TestEquality TypeRep where 250 | testEquality tr1 tr2 251 | | Just HRefl <- eqT tr1 tr2 252 | = Just Refl 253 | | otherwise 254 | = Nothing 255 | 256 | --------------------------- 257 | -- More singletons 258 | 259 | -- a TypeRep really is a singleton 260 | type instance Sing = (TypeRep :: Type -> Type) 261 | 262 | data SSymbol :: Symbol -> Type where 263 | SSym :: KnownSymbol s => SSymbol s 264 | type instance Sing = SSymbol 265 | 266 | instance TestEquality SSymbol where 267 | testEquality :: forall s1 s2. SSymbol s1 -> SSymbol s2 -> Maybe (s1 :~: s2) 268 | testEquality SSym SSym = sameSymbol @s1 @s2 Proxy Proxy 269 | 270 | instance Show (SSymbol name) where 271 | show s@SSym = symbolVal s 272 | -------------------------------------------------------------------------------- /DB2.hs: -------------------------------------------------------------------------------- 1 | {- DB2.hs 2 | 3 | (c) Richard Eisenberg 2016 4 | eir@cis.upenn.edu 5 | 6 | It is based on the database implementation from Oury and Swierstra's 7 | "Power of Pi", ICFP '08. 8 | 9 | -} 10 | 11 | {-# LANGUAGE PolyKinds, DataKinds, TypeFamilies, 12 | GADTs, TypeOperators, RankNTypes, FlexibleContexts, UndecidableInstances, 13 | FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, 14 | ConstraintKinds, CPP, InstanceSigs, TypeInType, TypeApplications, 15 | ParallelListComp, UndecidableSuperClasses, AllowAmbiguousTypes #-} 16 | {-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-} 17 | 18 | module DB2 where 19 | 20 | import Prelude hiding ( tail, id ) 21 | import Data.Kind 22 | import Data.Type.Equality 23 | import Data.Type.Bool 24 | import GHC.TypeLits 25 | import Basics hiding ( Schema ) 26 | import qualified Basics as B 27 | import Data.Char 28 | import Data.Proxy 29 | import Instances 30 | 31 | -- A named column in our database 32 | data Column = Attr Symbol Type 33 | type Col = 'Attr 34 | 35 | -- Singleton for columns 36 | data SColumn :: Column -> Type where 37 | Col :: Sing s -> TypeRep ty -> SColumn (Col s ty) 38 | type instance Sing = SColumn 39 | 40 | -- Extract the type of a column 41 | type family ColType col where 42 | ColType (Col _ ty) = ty 43 | 44 | -- A schema is an ordered list of named attributes 45 | type Schema = [Column] 46 | 47 | -- predicate to check that a schema is free of a certain attribute 48 | type family ColNotIn name s where 49 | ColNotIn _ '[] = 'True 50 | ColNotIn name ((Col name' _) ': t) = 51 | (name /= name') && (ColNotIn name t) 52 | 53 | -- predicate to check that two schemas are disjoint 54 | type family Disjoint s1 s2 where 55 | Disjoint '[] _ = 'True 56 | Disjoint ((Col name ty) ': t) s = (ColNotIn name s) && (Disjoint t s) 57 | 58 | -- A Row is one row of our database table, keyed by its schema. 59 | data Row :: Schema -> Type where 60 | EmptyRow :: Row '[] 61 | (::>) :: ColType col -> Row s -> Row (col ': s) 62 | infixr 5 ::> 63 | 64 | -- Map a predicate over all the types in a schema 65 | type family AllSchemaTys c sch where 66 | AllSchemaTys _ '[] = (() :: Constraint) 67 | AllSchemaTys c (col ': cols) = (c (ColType col), AllSchemaTys c cols) 68 | 69 | -- Convenient abbreviations for being to print and parse the types 70 | -- in a schema 71 | type ShowSchema s = AllSchemaTys Show s 72 | type ReadSchema s = AllSchemaTys Read s 73 | 74 | -- We can easily print out rows, as long as the data are printable 75 | instance ShowSchema s => Show (Row s) where 76 | show EmptyRow = "" 77 | show (h ::> t) = show h ++ " " ++ show t 78 | 79 | -- In our simplistic case, we just store the list of rows. A more 80 | -- sophisticated implementation could store some identifier to the connection 81 | -- to an external database. 82 | data Table :: Schema -> Type where 83 | Table :: [Row s] -> Table s 84 | 85 | instance ShowSchema s => Show (Table s) where 86 | show (Table rows) = unlines (map show rows) 87 | 88 | -- The following functions parse our very simple flat file database format. 89 | 90 | -- The file, with a name ending in ".table", consists of a sequence of lines, 91 | -- where each line contains one entry in the table. There is no row separator; 92 | -- if a row contains n pieces of data, that row is represented in n lines in 93 | -- the file. 94 | 95 | -- A schema is stored in a file ending in ".schema". 96 | -- Each line is a column name followed by its type. 97 | 98 | -- Read a row of a table 99 | readRow :: ReadSchema s => B.Schema s -> [String] -> (Row s, [String]) 100 | readRow Nil strs = (EmptyRow, strs) 101 | readRow (_ :>> _) [] = error "Ran out of data while processing row" 102 | readRow (_ :>> schTail) (sh:st) = (read sh ::> rowTail, strTail) 103 | where (rowTail, strTail) = readRow schTail st 104 | 105 | -- Read in a table 106 | readRows :: ReadSchema s => B.Schema s -> [String] -> [Row s] 107 | readRows _ [] = [] 108 | readRows sch lst = (row : tail) 109 | where (row, strTail) = readRow sch lst 110 | tail = readRows sch strTail 111 | 112 | -- Read in one line of a .schema file. Note that the type read must have kind * 113 | readCol :: String -> (String, TypeRepX IsType) 114 | readCol str = case break isSpace str of 115 | (name, ' ' : ty) -> (name, read ty) 116 | _ -> schemaError $ "Bad parse of " ++ str 117 | 118 | -- Load in a schema. 119 | withSchema :: String 120 | -> (forall (s :: Schema). B.Schema s -> IO a) 121 | -> IO a 122 | withSchema filename thing_inside = do 123 | schString <- readFile filename 124 | let schEntries = lines schString 125 | cols = map readCol schEntries 126 | go cols thing_inside 127 | where 128 | go :: [(String, TypeRepX IsType)] 129 | -> (forall (s :: Schema). B.Schema s -> IO a) 130 | -> IO a 131 | go [] thing = thing Nil 132 | go ((name, TypeRepX tr) : cols) thing 133 | = go cols $ \schema -> 134 | case someSymbolVal name of 135 | SomeSymbol (_ :: Proxy name) -> 136 | thing (Col (SSym @name) tr :>> schema) 137 | 138 | -- Load in a table of a given schema 139 | loadTable :: ReadSchema s => String -> B.Schema s -> IO (Table s) 140 | loadTable name schema = do 141 | dataString <- readFile name 142 | return (Table $ readRows schema (lines dataString)) 143 | 144 | -- In order to define strongly-typed projection from a row, we need to have a notion 145 | -- that one schema is a subset of another. We permit the schemas to have their columns 146 | -- in different orders. We define this subset relation via two inductively defined 147 | -- propositions. In Haskell, these inductively defined propositions take the form of 148 | -- GADTs. In their original form, they would look like this: 149 | {- 150 | data InProof :: Column -> Schema -> * where 151 | InHere :: InProof col (col ': schTail) 152 | InThere :: InProof col cols -> InProof col (a ': cols) 153 | 154 | data SubsetProof :: Schema -> Schema -> * where 155 | SubsetEmpty :: SubsetProof '[] s' 156 | SubsetCons :: InProof col s' -> SubsetProof cols s' 157 | -> SubsetProof (col ': cols) s' 158 | -} 159 | -- However, it would be convenient to users of the database library not to require 160 | -- building these proofs manually. So, we define type classes so that the compiler 161 | -- builds the proofs automatically. To make everything work well together, we also 162 | -- make the parameters to the proof GADT constructors implicit -- i.e. in the form 163 | -- of type class constraints. 164 | 165 | data InProof :: Column -> Schema -> Type where 166 | InHere :: InProof col (col ': schTail) 167 | InThere :: In name u cols => InProof (Col name u) (a ': cols) 168 | 169 | class In (name :: Symbol) (u :: Type) (sch :: Schema) where 170 | inProof :: InProof (Col name u) sch 171 | 172 | -- These instances must be INCOHERENT because they overlap badly. The coherence 173 | -- derives from the fact that one schema will mention a name only once, but this 174 | -- is beyond our capabilities to easily encode, given the lack of a solver for 175 | -- type-level finite maps. 176 | instance {-# INCOHERENT #-} In name u ((Col name u) ': schTail) where 177 | inProof = InHere 178 | instance {-# INCOHERENT #-} In name u cols => In name u (a ': cols) where 179 | inProof = InThere 180 | 181 | data SubsetProof :: Schema -> Schema -> Type where 182 | SubsetEmpty :: SubsetProof '[] s' 183 | SubsetCons :: (In name u s', Subset cols s') 184 | => Proxy name -> Proxy u -> SubsetProof ((Col name u) ': cols) s' 185 | 186 | class SubsetSupport s s' => Subset (s :: Schema) (s' :: Schema) where 187 | subset :: SubsetProof s s' 188 | 189 | -- The use of this constraint family allows us to assume a subset relationship 190 | -- when we recur on the structure of s. 191 | type SubsetSupport s s' :: Constraint 192 | 193 | instance Subset '[] s' where 194 | subset = SubsetEmpty 195 | type SubsetSupport '[] s' = () 196 | 197 | instance (In name u s', Subset cols s') => 198 | Subset ((Col name u) ': cols) s' where 199 | subset = SubsetCons Proxy Proxy 200 | type SubsetSupport ((Col name u) ': cols) s' = Subset cols s' 201 | 202 | -- To access the data in a structured (and well-typed!) way, we use 203 | -- an RA (short for Relational Algebra). An RA is indexed by the schema 204 | -- of the data it produces. 205 | 206 | data RA :: Schema -> Type where 207 | -- The RA includes all data represented by the handle. 208 | Read :: Table s -> RA s 209 | 210 | -- The RA is a Cartesian product of the two RAs provided. Note that 211 | -- the schemas of the two provided RAs must be disjoint. 212 | Product :: (Disjoint s s' ~ 'True) => RA s -> RA s' -> RA (s ++ s') 213 | 214 | -- The RA is a projection conforming to the schema provided. The 215 | -- type-checker ensures that this schema is a subset of the data 216 | -- included in the provided RA. 217 | Project :: Subset s' s => RA s -> RA s' 218 | 219 | -- The RA contains only those rows of the provided RA for which 220 | -- the provided expression evaluates to True. Note that the 221 | -- schema of the provided RA and the resultant RA are the same 222 | -- because the columns of data are the same. Also note that 223 | -- the expression must return a Bool for this to type-check. 224 | Select :: Expr s Bool -> RA s -> RA s 225 | 226 | -- Other constructors would be added in a more robust database 227 | -- implementation. 228 | 229 | -- An Expr is used with the Select constructor to choose some 230 | -- subset of rows from a table. Expressions are indexed by the 231 | -- schema over which they operate and the return value they 232 | -- produce. 233 | data Expr :: Schema -> Type -> Type where 234 | (:+), (:-), (:*), (:/) :: Expr s Int -> Expr s Int -> Expr s Int 235 | 236 | (:<), (:<=), (:>), (:>=), (:==), (:/=) 237 | :: Ord a => Expr s a -> Expr s a -> Expr s Bool 238 | 239 | -- A literal 240 | Literal :: ty -> Expr s ty 241 | 242 | -- element of a list 243 | ElementOf :: Eq ty => Expr s ty -> Expr s [ty] -> Expr s Bool 244 | 245 | -- Projection in an expression -- evaluates to the value 246 | -- of the named column. 247 | Element :: In name ty s => Proxy name -> Expr s ty 248 | 249 | -- Choose the elements of one list based on truth values in another 250 | choose :: [Bool] -> [a] -> [a] 251 | choose bs as = [ a | (a,True) <- zip as bs ] 252 | 253 | -- Project a component of one row, assuming that the desired projection 254 | -- is valid. 255 | projectRow :: forall sub super. 256 | Subset sub super => Row super -> Row sub 257 | projectRow r = case subset @sub @super of 258 | SubsetEmpty -> EmptyRow 259 | SubsetCons (_ :: Proxy name) (_ :: Proxy ty) -> 260 | find_datum inProof r ::> projectRow r 261 | where 262 | find_datum :: InProof (Col name ty) s -> Row s -> ty 263 | find_datum InHere (h ::> _) = h 264 | find_datum InThere (_ ::> t) = find_datum inProof t 265 | 266 | -- Evaluate an Expr 267 | eval :: Expr s ty -> Row s -> ty 268 | eval (a :+ b) r = eval a r + eval b r 269 | eval (a :- b) r = eval a r - eval b r 270 | eval (a :* b) r = eval a r * eval b r 271 | eval (a :/ b) r = eval a r `div` eval b r 272 | eval (a :< b) r = eval a r < eval b r 273 | eval (a :<= b) r = eval a r <= eval b r 274 | eval (a :> b) r = eval a r > eval b r 275 | eval (a :>= b) r = eval a r >= eval b r 276 | eval (a :== b) r = eval a r == eval b r 277 | eval (a :/= b) r = eval a r /= eval b r 278 | eval (Literal n) _ = n 279 | eval (ElementOf elt list) r = eval elt r `elem` eval list r 280 | eval (Element (_ :: Proxy name)) r = get_element inProof r 281 | where 282 | get_element :: InProof (Col name ty) s -> Row s -> ty 283 | get_element InHere (elt ::> _) = elt 284 | get_element InThere (_ ::> tail) = get_element inProof tail 285 | 286 | -- Append two rows. Needed for Cartesian product. 287 | rowAppend :: Row s -> Row s' -> Row (s ++ s') 288 | rowAppend EmptyRow r = r 289 | rowAppend (h ::> t) r = h ::> rowAppend t r 290 | 291 | -- The query function is the eliminator for an RA. It returns a list of 292 | -- rows containing the data produced by the RA. In the IO monad only 293 | -- because more sophisticated implementations would actually go out to 294 | -- a DB server for this. 295 | query :: RA s -> IO [Row s] 296 | query (Read (Table rows)) = return rows 297 | query (Product ra rb) = do 298 | rowsa <- query ra 299 | rowsb <- query rb 300 | return [ rowAppend rowa rowb | rowa <- rowsa, rowb <- rowsb ] 301 | query (Project ra) = map projectRow <$> query ra 302 | query (Select expr ra) = filter (eval expr) <$> query ra 303 | 304 | field :: forall name ty s. In name ty s => Expr s ty 305 | field = Element (Proxy :: Proxy name) 306 | 307 | -- Establish an In constraint 308 | checkIn :: Π name -> Π ty -> Π schema 309 | -> (In name ty schema => r) 310 | -> r 311 | checkIn name _ Nil _ 312 | = schemaError ("Field " ++ show name ++ " not found.") 313 | checkIn name ty ((Col name' ty') :>> rest) callback 314 | = case (name `eq` name', ty `eq` ty') of 315 | (Just Refl, Just Refl) -> callback 316 | (Just _, _) -> schemaError ("Found " ++ show name ++ 317 | " but it maps to " ++ show ty') 318 | _ -> checkIn name ty rest callback 319 | 320 | -- Establish a Subset constraint 321 | checkSubset :: Π sch1 -> Π sch2 -> (Subset sch1 sch2 => r) -> r 322 | checkSubset Nil _ callback = callback 323 | checkSubset (Col name ty :>> rest) super callback 324 | = checkSubset rest super $ 325 | checkIn name ty super $ 326 | callback 327 | 328 | -- Check that two names are distinct 329 | checkNotEqual :: forall (name1 :: Symbol) name2 r. 330 | Π name1 -> Π name2 331 | -> (((name1 /= name2) ~ 'True) => r) -> r 332 | checkNotEqual name1 name2 callback 333 | = case name1 `eq` name2 of 334 | Just Refl -> schemaError $ "Found " ++ show name1 ++ 335 | " in both supposedly disjoint schemas." 336 | Nothing -> assumeEquality @(name1 /= name2) @'True $ 337 | callback 338 | 339 | -- Establish a ColNotIn condition 340 | checkColNotIn :: Π name -> Π sch2 341 | -> ((ColNotIn name sch2 ~ 'True) => r) -> r 342 | checkColNotIn _ Nil callback = callback 343 | checkColNotIn name (Col name' _ :>> rest) callback 344 | = checkNotEqual name name' $ 345 | checkColNotIn name rest $ 346 | callback 347 | 348 | -- Establish a Disjointness constraint 349 | checkDisjoint :: Π sch1 -> Π sch2 350 | -> ((Disjoint sch1 sch2 ~ 'True) => r) -> r 351 | checkDisjoint Nil _ callback = callback 352 | checkDisjoint (Col name _ :>> rest) sch2 callback 353 | = checkColNotIn name sch2 $ 354 | checkDisjoint rest sch2 $ 355 | callback 356 | 357 | -- Establish a ShowSchema constraint 358 | checkShowSchema :: Π sch -> (ShowSchema sch => r) -> r 359 | checkShowSchema Nil callback = callback 360 | checkShowSchema (Col _ ty :>> rest) callback 361 | = getReadShowInstances ty $ 362 | checkShowSchema rest $ 363 | callback 364 | 365 | -- Establish a ReadSchema constraint 366 | checkReadSchema :: Π sch -> (ReadSchema sch => r) -> r 367 | checkReadSchema Nil callback = callback 368 | checkReadSchema (Col _ ty :>> rest) callback 369 | = getReadShowInstances ty $ 370 | checkReadSchema rest $ 371 | callback 372 | 373 | -- Terminate program with an easy-to-understand message 374 | schemaError :: String -> a 375 | schemaError str = errorWithoutStackTrace $ "Schema validation error: " ++ str 376 | --------------------------------------------------------------------------------