> {-# LANGUAGE DeriveDataTypeable,OverloadedStrings #-}
>
> module Database.HsSqlPpp.Internals.Catalog.CatalogBuilder
> (updateCatalog
> ,deconstructCatalog
>
>
> ,insertOperators
> ) where
>
> import Control.Monad
>
>
>
>
> import qualified Data.Map as M
> import qualified Data.Set as S
> import Database.HsSqlPpp.Internals.TypesInternal
>
>
> import qualified Data.Text as T
>
> import Database.HsSqlPpp.Internals.Catalog.CatalogTypes
>
> import Database.HsSqlPpp.Internals.Catalog.CatalogUtils
>
>
>
>
>
>
>
>
>
> 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)
>
>
>
>
>
> 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)}
>
>
>
> 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
>
> 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)}
>
> 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]
>
>
> 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]