hssqlppp-0.6.2: src/Database/HsSqlPpp/Internals/Catalog/CatalogBuilder.lhs
> {-# LANGUAGE DeriveDataTypeable,OverloadedStrings #-}
>
> module Database.HsSqlPpp.Internals.Catalog.CatalogBuilder
> (updateCatalog
> ,deconstructCatalog
> -- todo: temporary export before the basecatalog is fixed not to use
> -- the catalog internals
> ,insertOperators
> ) where
>
> import Control.Monad
> --import Data.List
> --import Data.Data
> --import Data.Char
> --import Data.Maybe
> import qualified Data.Map as M
> import qualified Data.Set as S
> import Database.HsSqlPpp.Internals.TypesInternal
> --import Database.HsSqlPpp.Utils.Utils
> --import Data.Text (Text)
> import qualified Data.Text as T
> --import qualified Data.Text.Lazy as LT
> import Database.HsSqlPpp.Internals.Catalog.CatalogTypes
> --import Database.HsSqlPpp.Dialects.BaseCatalog
> import Database.HsSqlPpp.Internals.Catalog.CatalogUtils
> -- | Applies a list of 'CatalogUpdate's to an 'Catalog' value
> -- to produce a new Catalog value. TODO: there will be a split
> -- between the individual low level updates which just update
> -- one 'row' in the catalog type, and the high level updates
> -- which correspond to ddl (e.g. create type will also add the
> -- array type, create table will add a table, supply the
> -- private columns automatically, and add the composite type)
> -- highlevel not implemented yet. You must use the correct case and
> -- the canonical names for identifiers/types
> updateCatalog :: [CatalogUpdate]
> -> Catalog
> -> Either [TypeError] Catalog
> updateCatalog eus cat' =
> foldM updateCat' (cat' {catUpdates = catUpdates cat' ++ eus}) eus
> where
> updateCat' cat u = case u of
> CatCreateSchema n ->
> if S.member n (catSchemas cat)
> then Left [SchemaAlreadyExists n]
> else Right $ cat {catSchemas = S.insert n (catSchemas cat)}
> CatCreateScalarType n ->
> if S.member n (catScalarTypeNames cat)
> -- todo: need to check all the type lists
> -- and maybe need to check the name doesn't conflict with pseudo names or something?
> -- this should happen with other cases as well
> -- also: needs to take into account alias, so int and int4 are
> -- both disallowed for new types, and lookup of either finds int4
> then Left [InternalError $ "type already exists: " ++ show n]
> else Right $ cat {catScalarTypeNames = S.insert n (catScalarTypeNames cat)}
> CatCreateDomainType n b ->
> Right $ cat {catDomainTypes = M.insert n b (catDomainTypes cat)}
> CatCreateArrayType n b ->
> Right $ cat {catArrayTypes = M.insert n b (catArrayTypes cat)}
> -- todo: check the uniqueness of operator names (can overload by type)
> -- also check the name of the operator is a valid operator name
> -- and that the op has the correct number of args (1 or 2 resp.)
> CatCreatePrefixOp n lt ret -> do
> ltt <- catLookupType cat [QNmc $ T.unpack lt]
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> Right $ cat {catPrefixOps = insertOperators
> [(n,(n,[ltt],rett,False))]
> (catPrefixOps cat)}
> CatCreatePostfixOp n rt ret -> do
> rtt <- catLookupType cat [QNmc $ T.unpack rt]
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> Right $ cat {catPostfixOps = insertOperators
> [(n,(n,[rtt],rett,False))]
> (catPostfixOps cat)}
> CatCreateBinaryOp n lt rt ret -> do
> ltt <- catLookupType cat [QNmc $ T.unpack lt]
> rtt <- catLookupType cat [QNmc $ T.unpack rt]
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> Right $ cat {catBinaryOps = insertOperators
> [(n,(n,[ltt,rtt],rett,False))]
> (catBinaryOps cat)}
> CatCreateSpecialOp n ps rs ret -> do
> pst <- mapM (\nc -> catLookupType cat [QNmc $ T.unpack nc]) ps
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> let rett' = if rs
> then Pseudo $ SetOfType rett
> else rett
> -- thrown into the binary ops atm, todo: add a new namespace
> Right $ cat {catBinaryOps = insertOperators
> [(n,(n,pst,rett',False))]
> (catBinaryOps cat)}
> CatCreateFunction n ps rs ret -> do
> pst <- mapM (\nc -> catLookupType cat [QNmc $ T.unpack nc]) ps
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> let rett' = if rs
> then Pseudo $ SetOfType rett
> else rett
> Right $ cat {catFunctions = insertOperators
> [(n,(n,pst,rett',False))]
> (catFunctions cat)}
> -- this wraps the last parameter in the array type for now
> CatCreateVariadicFunction n ps rs ret -> do
> let promoteLastType [] = []
> promoteLastType [a] = [ArrayType a]
> promoteLastType (a:as) = a : promoteLastType as
> pst <- promoteLastType `fmap` mapM (\nc -> catLookupType cat [QNmc $ T.unpack nc]) ps
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> let rett' = if rs
> then Pseudo $ SetOfType rett
> else rett
> Right $ cat {catFunctions = insertOperators
> [(n,(n,pst,rett',True))]
> (catFunctions cat)}
> CatCreateAggregate n ps ret -> do
> pst <- mapM (\nc -> catLookupType cat [QNmc $ T.unpack nc]) ps
> rett <- catLookupType cat [QNmc $ T.unpack ret]
> Right $ cat {catAggregateFunctions = insertOperators
> [(n,(n,pst,rett,False))]
> (catAggregateFunctions cat)}
> CatCreateTable n cs -> do
> cts <- mapM (\(cn,te) -> do
> t' <- catLookupType cat [QNmc $ T.unpack $ catName te]
> -- for composite types, the information added here (about precision
> -- and nullability) is redundant
> let te' = TypeExtra t' (catPrecision te) (catScale te) (catNullable te)
> return (cn,te')) cs
> Right $ cat {catTables = M.insert n (cts,[]) (catTables cat)}
> CatCreateCast n0 n1 ctx -> do
> t0 <- catLookupType cat [QNmc $ T.unpack n0]
> t1 <- catLookupType cat [QNmc $ T.unpack n1]
> Right $ cat {catCasts = S.insert (t0,t1,ctx) (catCasts cat)}
> CatCreateTypeCategoryEntry n (c,p) -> do
> t <- catLookupType cat [QNmc $ T.unpack n]
> Right $ cat {catTypeCategories = M.insert t (c,p) $ catTypeCategories cat}
> deconstructCatalog :: Catalog -> [CatalogUpdate]
> deconstructCatalog = catUpdates
> insertOperators :: [(CatName,OperatorPrototype)]
> -> M.Map CatName [OperatorPrototype]
> -> M.Map CatName [OperatorPrototype]
> insertOperators vs m =
> foldr i m vs
> where
> i (k,v) = M.insertWith (++) k [v]