> {-# 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]