content: 
  > {-# 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}
  >       CatDropTable n -> do
  >           let
  >             -- not sure if we should remove from the catUpdates or add to it
  >             isCreate (CatCreateTable tn _) = n == tn
  >             isCreate _ = False
  >             newUpdates = filter (not . isCreate) $ catUpdates cat
  >           Right $ cat {catTables = M.delete n (catTables cat), catUpdates = newUpdates}
  
  > 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]
  