ta (empty) → 0.1

raw patch · 21 files changed

+2550/−0 lines, 21 filesdep +Takusendep +basedep +containerssetup-changed

Dependencies added: Takusen, base, containers, ghc-prim, mtl, template-haskell, time

Files

• Database/TA/Core/GenSelect.hs +575/−0
• Database/TA/Core/Infraestructura.hs +298/−0
• Database/TA/Core/MapaBase.hs +423/−0
• Database/TA/Core/Nucleo.hs +125/−0
• Database/TA/Core/Opciones.hs +22/−0
• Database/TA/Core/RIS.hs +79/−0
• Database/TA/Examples/Ex01.lhs +130/−0
• Database/TA/Examples/Ex02.lhs +97/−0
• Database/TA/Examples/Examples.lhs +163/−0
• Database/TA/Examples/RCSdef.lhs +64/−0
• Database/TA/Examples/make_twoColumns.sql +16/−0
• Database/TA/Helper/LiftQ.hs +224/−0
• Database/TA/Helper/TH.lhs +42/−0
• Database/TA/Helper/Text.hs +49/−0
• Database/TA/License.CCA +19/−0
• Database/TA/License.th-lift +26/−0
• Database/TA/TAB.hs +38/−0
• LICENSE +30/−0
• README +29/−0
• Setup.hs +2/−0
• ta.cabal +99/−0

@@ -0,0 +1,575 @@+-- | 'GenSelect'  .  Leonel Fonseca, 2010.
+
+--   Version 0.0.4
+--   Adiciones:
+--     Función 'ambBDCompatible' indica si el ambiente
+--        en la base de datos produce código distinto
+--        al generado durante la compilación.
+--     Función 'verASTS' viejo nuevo muestra dos ASTs.
+
+--  Versión 0.0.3
+--   Cambios:
+--    - empalmar recibe un parámetro que indicará
+--      si el código resultante incluye meta-declaraciones.
+--    - genSelect devuelve (comando relacional,generador)
+
+--   versión 0.0.2
+--   Énfasis en la generación de código con funciones de
+--   biblioteca TH. 
+--   Énfasis en predefinir nombres locales de forma dinámica.
+
+--   versión 0.0.1
+--   Usa mezcla de quotation y funciones de la biblioteca TH
+--   para construir declaraciones.
+
+
+{-# options  -fglasgow-exts      #-}
+{-# language  TemplateHaskell    #-}
+{-# language  PatternGuards      #-}
+{-# language  TupleSections      #-}
+{-# language  NoMonomorphismRestriction  #-}
+{-# language  DisambiguateRecordFields   #-}
+{-# language  StandaloneDeriving #-}
+
+
+ 
+module Database.TA.Core.GenSelect 
+                   ( empalmar
+                   , genSelect
+                   , ambBDCompatible
+                   , verASTs
+                   )
+
+where 
+
+import  Database.Oracle.Enumerator 
+import  Data.Typeable
+import  Data.List   ( intersperse      )
+import  Data.Maybe  ( fromMaybe        )
+import  Data.Char   ( toLower, toUpper ) 
+import  qualified Data.Map as Map
+import  Control.Monad
+import  Control.Monad.Trans (lift, liftIO)
+import  Language.Haskell.TH
+import  Database.TA.Helper.LiftQ
+import  Database.TA.Helper.TH   ( pr, verAST )
+import  Database.TA.Helper.Text ( proper )
+import  qualified Database.TA.Core.MapaBase as MB
+import  qualified Database.TA.Core.RIS      as RIS
+import            Database.TA.Core.RIS
+
+import  Database.TA.Core.Infraestructura 
+          (  describirConsulta
+          ,  collcatM
+          ,  exnAt
+          ,  concatM
+          ,  revertir )
+import  Database.TA.Core.Opciones ( imprimirDepuracion )
+
+-- Para permitir la definición de empalmar.
+
+deriving instance Typeable1 Q
+
+
+{- |
+     En la versión 0.0.3 a la rutina 'empalmar' recibe un parámetro
+     para indicar si el valor Q [Dec] debe contener una 
+     declaración de una variable cuyos contenidos son las
+     declaraciones de acceso a datos.
+     
+     'empalmar' esquema constraseña servicio generadores
+                metaDescriptor
+     evalua la lista de generadores y acumula las citas
+     de declaraciones (Q [Dec]).
+     La evaluación de declaraciones ocurre en el esquema
+     indicado.
+     Si metaDescriptor = Nothing, no se incluye una variable
+     cuyo valor son las declaraciones.
+     Si metaDescriptor = Just nombre, las declaraciones retornadas
+     incluyen una variable "nombre" cuyo valor son las 
+     declaraciones de acceso a la base de datos.
+
+     En el siguiente trozo, en la definición de empalmar:
+             
+        En primera instancia queremos una definición como x.
+             let x = [d|oldCode=decs|] 
+
+        Pero el nombre de las declaraciones siempre sería oldCode.
+        Esa ruta no sirve.
+
+        Tampoco sirve elaborar una declaración como
+              valD (varP mdN) (normalB $(metaLift decs)) []
+        porque 'decs' es un identificador ligado en el contexto.
+        Para que funcione, 'decs' debería ser importado.
+
+        Recuerdo de algún tutorial esta maña:
+              do mdN  <- newName nombre
+                 [ValD _ body _] <- [d|oldCode=decs|]
+                 let md = ValD (VarP mdN) body []
+                 liftM2 (++) decs md
+        donde se rescata el 'body' que interesa y se descarta
+        el identificador y la lista de declaraciones.
+        Enseguida, se contruye md, con el identificador 
+        de nuestras simpatías.
+            
+-}
+
+
+empalmar :: String -> String -> String -> Maybe String ->
+          ( forall mk . [ DBM mk Session (Q [Dec]) ] ) -> Q [Dec]
+
+empalmar usuario contraseña cxn metaDescriptor gs = 
+    join $ runIO $ withSession (connect usuario contraseña cxn) 
+    (do  decs <- (collcatM gs) 
+         return $ case metaDescriptor of
+           Just nombre  ->  
+                do  [ValD _ body _]  <-  [d|oldCode=decs|]
+                    let mdN = mkName nombre
+                        md  = return [ValD (VarP mdN) body []]
+                    liftM2 (++) decs md 
+           Nothing      ->  decs)
+    
+
+{- |
+     Genera las declaraciones de un tipo y una acción apropiados
+     para consultar la base de datos con la consulta especificada.
+-}
+
+
+genSelect :: CR  -> DBM mark Session (Q [Dec])
+genSelect (CR nombre pre suf op) =  
+   
+  case RIS.toString op of
+
+  ""   -> error $ "No pudo generar una operación para "++ show op
+  opOk ->  do 
+
+    qcis <- describirConsulta opOk
+
+    let tipo   = genTipoPS     nombre pre suf qcis
+        select = genSelectWrkr nombre opOk qcis
+        qdecs  = liftM2  (++) tipo  select  -- Declaraciones
+         
+    when  imprimirDepuracion 
+          (do  pr $   "\n* En genSelect: generación fresca para " 
+                  ++  nombre ++ "*"
+               decs <- liftIO $ runQ qdecs
+               pr $  show decs
+               pr "\n") 
+
+    return qdecs
+
+
+-- | Genera un nombre para el tipo de datos del resultado
+--   de una consulta.
+
+genNombreTipo    ::  String -> Name
+genNombreTipo [] =   error $  "Error: En genNombreTipo necesita\
+                           \ un nombre de consulta para derivar\
+                           \ un nombre de tipo."
+genNombreTipo x  =   mkName $ (toUpper $ head x) : (tail x) 
+
+{- | 
+     Una versión que opera con información de un Select.
+  
+     Genera el tipo del resultado de la consulta (estilo registro).
+  
+     Requiere de:
+    
+        - Un nombre  para el tipo registro.
+        - Un prefijo para cada nombre de campo.
+        - Un sufijo  para cada nombre de campo.
+        - Una lista de QueryColInfo con la información de una
+          sentencia SQL.
+-}
+
+
+genTipoPS  ::  String -> String -> String 
+           ->  GeneradorQueryColInfo ( Q [Dec] )
+
+genTipoPS nomConsulta _   _   []    =   return []
+
+genTipoPS nomConsulta pre suf cols  =   do 
+  
+    d <- dataD contexto nombreTipo varTipos registro derivaciones
+
+    return [d] 
+
+    where
+
+    contexto   =  cxt []
+    nombreTipo =  genNombreTipo nomConsulta
+    varTipos   =  []
+    registro   =  [recC nombreTipo campos]
+    campos     =  map  campo  cols 
+    campo      ::  QueryColInfo -> VarStrictTypeQ
+    campo qci  =   
+      varStrictType 
+        ( mkName $ map toLower $ pre ++ col_name qci ++ suf ) 
+        ( strictType notStrict $ genQTipoCol  qci ) 
+
+    derivaciones = map mkName ["Show","Read","Eq","Ord","Typeable"]
+
+
+
+genQTipoCol      ::  QueryColInfo -> TypeQ 
+
+genQTipoCol qci =
+
+    if  col_null_ok qci
+        then  [t| Maybe $tipo |]  -- Es nulificable.
+        else  tipo                -- No es nulificable.
+             
+    where 
+
+    tipo  =  case  MB.dbTC2hs (col_type qci) (col_scale qci)  of
+          Right tipo   ->  tipo
+          Left  causa  ->  error $ 
+            "genQTipoCol no pudo generar un tipo para la columna "
+            ++ (col_name qci) ++ " con tipo (" 
+            ++ show  (col_type qci)
+            ++ ") y escala "  ++ show (col_scale qci)
+            ++ " a causa de " ++ causa
+
+
+-- | 'genNombres' recibe una hilera raiz y genera
+--    n hileras con sufijos que van de 1 a n.
+
+
+genNombres raiz n = map (mkName . (raiz++) . show) [1..n]
+
+
+
+
+-- | 'ambBDCompatible' viejas generadorNuevas
+--
+--   'viejas' es un conjunto de declaraciones generado
+--   previamente.
+--   'generadorNuevas' es una lista de generadores
+--   de declaraciones, como la que se construye cuando
+--   se digita : [ genSelect $ CR "consulta"... $ "select..." ]
+--   A partir del hecho que el generador de código es predecible
+--   y estable, si las declaraciones antiguas no coinciden
+--   con las frescas obtenidas por el generadorNuevas,
+--   significa que hubo un cambio en el ambiente de bases de datos
+--   y que es inseguro ejecutar el código.
+
+
+ambBDCompatible ::  Q [Dec] 
+                ->  [ DBM mark Session (Q [Dec]) ] 
+                ->  DBM mark Session (Bool,[Dec],[Dec])
+
+ambBDCompatible viejas generadorNuevas = do
+
+   newCode <-  collcatM generadorNuevas
+   newAST  <-  liftIO $ runQ newCode 
+   oldAST  <-  liftIO $ runQ viejas
+   return  $   (oldAST /= newAST, oldAST, newAST)
+
+
+
+
+
+-- | 'verASTs' muestra a pantalla dos AST.
+
+
+verASTs :: [Dec] -> [Dec] -> IO ()
+verASTs v n =  do  separar
+                   putStrLn $ show  v 
+                   separar
+                   putStrLn $ show  n
+                   separar
+    where
+
+    separar =  putStrLn "" >> putStrLn linea >> putStrLn ""
+    linea   =  take 70 $ repeat '-'
+    
+    
+     
+
+{-  Relevancia técnica alta.
+
+    Mezcla de estilo de citación:
+     
+    (1) La declaración de XQ usa expresiones parentizadas.
+        incluye dos empalmes de expresiones, como 
+        $(varE pSN), para capturar nombres que estarían
+        en el ambiente.
+        No se usa directamente el nombre 'ps' porque todavía
+        no existe.
+        Aquí mezcla el estilo parentizado con empalmes y 
+        funciones de la biblioteca TH.
+
+    (3) La definición de gR.
+        Aquí mezcla el estilo parentizado con empalmes.
+        gR se define con funciones de la biblioteca TH,
+           cuyo cuerpo es definido con una citación,
+           donde se empalma la definición $cvtf.
+    
+    (4) Una mezcla más ambiciosa (o enriquecida) donde
+        aparecen la declaración se define con reiteraciones 
+        de expresiones parentizadas y funciones de la biblioteca
+        TH. Dos ejemplos: 'topBody' y 'pS'.
+
+
+    En la definición de 'cvtf', 'appsE' hace un foldl entre 
+    el primer elemento de la lista y los elementos subsiguientes.
+    En el módulo TAGenTipo hay una versión para Typ.
+ 
+    La definición de 'bd' de 'ite', es equivalente al uso de 
+    la citación de nombre:
+
+      bd   = appE (varE 'result')
+                    (infixE (Just $ tupE vars)
+                            [|(:)|]
+                            (Just $ varE $ last nom))
+   
+-}    
+
+{-
+qCosa bindingsList = concatM xQ bindingsList `exnAt` "qCosa: "
+where 
+  ite a b acc      = result' ( (a,b):acc )
+  gR gRbnds = liftM (  revertir  ( \(a,b) -> (QCosa a b) ) )
+                    ( doQuery gRbnds ite [] )
+  pS = prepareQuery $ sql $ "select :1 hilera, :2 x from dual"
+  xQ bindings = withPreparedStatement pS
+                   (\bs -> withBoundStatement bs bindings gR)
+-}
+
+
+
+genSelectWrkr :: Nombre -> String -> [QueryColInfo] -> Q [Dec]
+
+genSelectWrkr nomConsulta sqlText cols = do
+
+    qName <- newName topN
+    d1    <- iteD -- Dec <-  DecQ    Recolección de declaraciones.
+    d2    <- gRD  -- Dec <-  DecQ
+    d3    <- pSD  -- Dec <-  Q [Dec]
+    d4    <- xQD  -- Dec <-  DecQ
+
+    let ds1 = [d1] ++ [d2] ++ d3 ++ [d4]  -- [Dec]
+        ds2 = map return ds1              -- [DecQ]
+     
+    top <- funD (mkName topN) [clause [(varP $ mkName "bnds")] 
+                (normalB topBody ) ds2]
+    return [top]
+
+ where
+
+   topBody = [| concatM $(dyn "xQ") $(varE $ mkName "bnds")
+                        `exnAt`  rutina 
+                 |]
+ 
+   k      =  length cols           -- La cantidad de columnas.
+ 
+              -- Preparamos identificadores.
+              -- garantizamos que el nombre de la acción de
+              -- consulta tiene la primer letra minúscula.
+   topN   =   (toLower $ head nomConsulta) : (tail nomConsulta)
+   rutina =   topN ++ ": "
+   iteN   =   mkName "ite"        -- nombre de función de iteración
+   gRN    =   mkName "gR"         -- función getResults
+   pSN    =   mkName "pS"         -- función prepareStatement 
+   xQN    =   mkName "xQ"         -- función executeQuery
+ 
+
+   iteD   ::  DecQ
+   iteD   =   funD iteN [ clause ps (normalB bd) [] ]
+     where
+     nom  =   genNombres "a1" (k+1) -- incluye uno para acumular.
+     ps   =   map varP nom          -- [VarP a1,VarP a2,VarP aN].
+     vars =   map varE (take k nom) -- excluimos el acumulador.
+     bd   =   [|result' ( $(tupE vars) : $(varE $ last nom) )|]
+      
+
+   gRD    ::  DecQ 
+   gRD    =   funD gRN [ clause [varP bnsN] (normalB bd) [] ] 
+     where
+     bnsN =   mkName "gRbnds"     -- parárametro "bindings" en "gR"
+     nom  =   genNombres "a2" k   -- otra tanda de nombres.
+     ps   =   map varP nom        -- [VarP a1,VarP a2,VarP aN].
+     vars =   map varE nom        -- otra tanda de variables.
+     cvtf =   lamE [tupP ps] $ appsE ((conE nomT):vars)
+     nomT =   genNombreTipo nomConsulta
+     bd   =   [|liftM  (revertir $cvtf)
+                       (doQuery $(varE bnsN) $(varE iteN) []) |]
+ 
+
+   pSD    ::  Q [Dec]         -- esta declaración es de tipo ValD. 
+   pSD    =   [d|pS = prepareQuery $ sql sqlText |]
+ 
+   xQD    ::  DecQ
+   xQD    =   funD xQN [ clause [varP bnsN] (normalB bd) [] ]
+     where
+     bnsN =   mkName "xQbnds"     -- parámetro "bindings" en "xQ"
+     bSTN =   mkName "boundSt"    -- nombre boundStatement 
+
+     bd0  =   [| withPreparedStatement $(varE pSN) (\bs -> 
+                 withBoundStatement bs $(varE bnsN) $(varE gRN))
+              |]
+
+     bd   =   [| withPreparedStatement $(varE pSN) $bd2 |]
+     bd2  =   lamE [varP bSTN] 
+                   (appE (appE (appE (varE 'withBoundStatement) 
+                                     (varE bSTN)) 
+                         (varE bnsN)) 
+                   (varE gRN))
+
+
+
+{-
+
+    El modelo de generación: Cada comentario numerado  
+    indica una sub-rutina de generación necesaria.
+
+
+    {-1-} es provisto por genTipoPS
+    {-8-} es la hilera (RIS.toString (op comandoRelacional))
+    
+    En genSelectITE, hay subrutinas
+       ite  -> {-2-},
+       cvtf -> {-2b-},
+       gR   -> {-3-},
+       pS   -> {-4-},
+       xQ   -> {-5-} .
+ 
+{-1-}
+data QCosa :: QCosa {f1 :: tCol1, f2 :: tCol2, .. , fn :: tColn)
+     deriving (Read, Show, Eq, Ord, Typeable)
+
+{-7-}
+qCosa bindings = 
+  
+  concatM xQ bindings `exnAt` "qCosa: "
+
+where {-6-}
+  
+  {-2-} 
+  ite a b acc      = result' ( (a,b):acc )
+  
+  {-3-}
+  gR bs = liftM (  revertir 
+                   {-2b-}  ( \(a,b) -> (QCosa a b) ) 
+                )
+                ( doQuery bs ite [] )
+
+  {-4-}
+  ps = prepareQuery $ 
+         sql $  {-8-}
+         "select :1 hilera, length(:1) largo from dual"
+
+  {-5-}     
+  xQ b = withPreparedStatement ps (\bs->withBoundStatement bs b gR)
+
+-}
+
+{-
+  Si se siente desolado por las abreviaturas, las explico:
+  
+      ite = iterador
+      gR  = getResults
+      ps  = preparedStatement
+      bs  = boundStatement
+      xQ  = executeQuery (bound variables and retrieve results)
+-}
+
+
+{-
+
+  Método de trabajo:
+  
+     Establezca modelo
+     Escriba declaración 'x' con quotes en TATTest01.hs.
+     Cargue TATTest01.hs en GHCi.
+     Obtenga AST del modelo via Aux01.verCodigo x.
+
+     Ahora valide iterativamente:
+        Agruegue (o modifique) una declaración 'y'
+           con sintaxis TH en TATTest01.hs.
+        Recargue en GHCi. 
+        Si coincide el AST de  la declaración 'x' 
+          con el AST de la declaración 'y', adopte el generador
+          de código, por ejemplo, en TAGenSelect.hs.
+-}
+
+{-   
+    Podemos generar sentencias S correctas a partir del tipo T
+    que tenga una consulta O. Las sentencias S son inyectadas 
+    al proceso de compilación y se convierten código objeto.
+
+    Sin embargo si cambia la forma de la tabla o vista que sirven
+    de base para la consulta, las sentencias S estarán incorrectas
+    y no lo sabremos.
+
+    ¿Qué tal si rechequeamos todo?
+
+    Para ello necesitamos guardar S y O. Luego generar 
+    una acción 'comprobarAmbiente' que haga lo siguiente:
+
+       - Genera S' a partir de O invocando genSelect
+         en el ambiente de ejecución actual.
+    
+       - Compara S' con S.
+       
+            - Si son distintos, habrá un error porque 
+              el ambiente actual es distinto del original
+              y ocurrirán errores de ejecución.
+
+            - Si son iguales, el ambiente actual es lo
+              suficiente similar al original para ejecutar
+              las sentencias compiladas.
+       
+      - Para poder invocar genSelect es necesario invocar
+        el compilador GHC en tiempo de ejecución.
+
+-}              
+
+{-
+    Equivalencias de código
+
+    dyn "x" == varE $ mkName "x"
+
+    
+     bd0  =   [| withPreparedStatement $(varE pSN) (\bs -> 
+                 withBoundStatement bs $(varE bnsN) $(varE gRN))
+              |]
+
+     ==
+
+     bd   =   [| withPreparedStatement $(varE pSN) $bd2 |]
+     bd2  =   lamE [varP bSTN] 
+                   (appE (appE (appE (varE 'withBoundStatement) 
+                                     (varE bSTN)) 
+                         (varE bnsN)) 
+                   (varE gRN))
+-}
+
+{-  Generación de código inseguro.
+    
+    Usar mkName "x" posibilita enlace dinámico. La rutina con 
+    nombre "x" más cercana en el árbol de llamadas será invocada.
+
+    Sin embargo, aquí no tiene esos efectos colaterales porque
+    el ambiente más cercano está cerrado: son subrutinas.
+
+    Es necesario operar con mkName y no con newName. mkName 
+    facilita genera nombres repetidos siempres. newName no
+    genera el mismo nombre. Si queremos comparar código en
+    generado en momentos distintos, necesitamos la predictibilidad
+    de mkName.
+ 
+    Este fragmento de código en uf04.hs muestra la insensibilidad
+    a la inclusión dinámica de identificadores.
+    El código opera bien.
+
+    r <- withSession s $ do
+        let  gR = \_ -> [(Just 1, Just "uno"), (Just 2,Just "dos")]
+        pr (show $ gR id)
+        qDosColumnas [[]]  
+
+
+
+-}
+

@@ -0,0 +1,298 @@+{-# options   -fglasgow-exts       #-}+{-# language  OverlappingInstances #-}+++{- |+      Infraestructura necesaria para facilitar++      las interacción.+      ++      Modo de uso:+        (1) Prepare con   : h_ta_query_desc_tmp+        (2) Analice q con : describirConsulta q+        (3) Obtenga resultados con :  ++       Leonel Fonseca. 2010.+-}++module  Database.TA.Core.Infraestructura+        (  exnAt +        ,  concatM+        ,  collcatM+        ,  describirConsulta +        ,  revertir  +        ) ++where++import  Database.TA.Core.Nucleo ( QueryColInfo (..) )+import  Database.TA.Helper.Text+import  Database.Oracle.Enumerator+import  Control.Monad (liftM)+++{- |+      Rutina para atrapar, comentar +      (la hilera @msg@ se usa como prefijo del mensaje) +      y relanzar excepciones.+-}+++act `exnAt` msg = catchDB act (reportRethrowMsg msg)++++{- |++    El trozo de código++       r <- mapM (xQ ps) bindings+       return $ concat r++    es equivalente a +     +       r <- (liftM concat . sequence) (map (xQ ps) bindings)++    y puede resumirse aplicando la factorización de concatDBM++       concatDBM (xQ ps) bindings+-}+++concatM    :: (Monad m) => (a1 -> m [a]) -> [a1] -> m [a]+concatM f  =  liftM concat . sequence . map f++++{- | +    Colecciona y concatena el resultado de aplicar dos +    acciones monádicas.+-}+++collcatM  :: (Monad m, Monad m1) => [m1 (m [a])] -> m1 (m [a])+collcatM  =  liftM (liftM concat . sequence) . sequence ++++{- | +     Se utiliza para aplicar una función de iteración +     con acumulación al frente de una lista +     y revierte el orden del acumulador.+-}+++revertir    :: (Monad m) => (a1 -> a) -> [a1] -> m [a]+revertir f  =  return . reverse . map f+++++-- | Los metadatos que describen una consulta.++describirConsulta    ::  String -> DBM mark Session [QueryColInfo] +describirConsulta q  =   do+    tablaTmp           `exnAt`  "describirConsulta.tablaTmp"+    describirQuery q   `exnAt`  "describirConsulta.describirQuery"+    qQueryColInfo      `exnAt`  "describirConsulta.qQueryColInfo"++++-- |  Estas funciones no se exportan porque deben utilizarse+--    de forma conjunta, tal y como se hace en la acción+--    'describirConsulta'.+++{- |  Construye una tabla temporal+      llamada 'ta_query_desc_tmp' para mantener +      los resultados de la descripción de una consulta. +-}+++tablaTmp  ::  DBM mark Session () +tablaTmp  =   execDDL texto_h_tmp +++{- | 'describirConsulta' obtiene la información de las+      columnas resultantes al analizar la consulta q.+      Precaución: Si se envían instrucciones DDL+      se ejecutarán inmediatamente, en lugar de ser analizadas.+-} +++describirQuery     :: String -> DBM mark Session ()+describirQuery  q  =  execDDL $ cmdbind texto_analizar [bindP q]+++{-  Nos interesan estos datos:+ +    col_type            Int+    col_max_len         Int +    col_name            String +    col_schema_name     String +    col_precision       Int +    col_scale           Int +    col_null_ok         Int (lo convertiremos en Bool) +-}+++qQueryColInfo   ::  DBM mark Session [QueryColInfo] +qQueryColInfo   =   do+    r <- doQuery s ite []+    return $ reverse $ map toQueryColInfo r ++  where++    toQueryColInfo  ::  (Int,Int,String,Maybe String,Int,Int,Int) +                    ->  QueryColInfo++    toQueryColInfo (a,b,c,e,d,f,g) =+        QueryColInfo a b c e d f (if g==1 then True else False)+++    ite ::  (Monad m)  =>+      Int -> Int -> String -> Maybe String -> Int -> Int -> Int ->+      IterAct m [(Int, Int, String, Maybe String, Int, Int, Int)]+ +    ite a b c d e f g acc = result' ( (a,b,c,d,e,f,g):acc )+ +    s   =  "select  /* TABDInfraestructura - desc. query */   \+           \        col_type                                  \+           \     ,  col_max_len                               \+           \     ,  col_name                                  \+           \     ,  col_schema_name                           \+           \     ,  col_precision                             \+           \     ,  col_scale                                 \+           \     ,  col_null_ok                               \+           \  from  ta_query_desc_tmp                         \+           \ where  dbms_session.unique_session_id            \+           \     =  unique_session_id                         \+           \order by  col_position"+ + + +-- | Textos de las consultas.+++texto_h_tmp  ::  String+texto_h_tmp  = ++  "declare \+  \    pragma autonomous_transaction;                        \+  \    /* con persistencia limitada a una transacción. */    \+  \    construirTabla varchar2(600) :=                       \+  \      'create global temporary table ta_query_desc_tmp'   \+  \    ||' (  unique_session_id   VARCHAR2(24)  '            \+  \    ||' ,  col_position        INTEGER       '            \+  \    ||' ,  col_type            INTEGER       '            \+  \    ||' ,  col_max_len         INTEGER       '            \+  \    ||' ,  col_name            VARCHAR2(32)  '            \+  \    ||' ,  col_name_len        INTEGER       '            \+  \    ||' ,  col_schema_name     VARCHAR2(32)  '            \+  \    ||' ,  col_schema_name_len INTEGER       '            \+  \    ||' ,  col_precision       INTEGER       '            \+  \    ||' ,  col_scale           INTEGER       '            \+  \    ||' ,  col_charsetid       INTEGER       '            \+  \    ||' ,  col_charsetform     INTEGER       '            \+  \    ||' ,  col_null_ok         INTEGER     ) '            \+  \    ||' on commit delete rows';                           \+  \    existe       binary_integer := 0;                     \+  \    privilegiado binary_integer := 0;                     \+  \begin                                                     \+  \    /* Puede crear una tabla temporal? */                 \+  \    begin                                                 \+  \        select  1                                         \+  \          into  privilegiado                              \+  \          from  user_sys_privs                            \+  \         where  privilege = 'CREATE TABLE';               \+  \    exception                                             \+  \        when no_data_found then null;                     \+  \        when others        then raise;                    \+  \    end;                                                  \+  \    /* Es necesario crear una tabla temporal? */          \+  \    begin                                                 \+  \        select  1                                         \+  \          into  existe                                    \+  \          from  user_tables                               \+  \         where  table_name = 'TA_QUERY_DESC_TMP';         \+  \    exception                                             \+  \        when no_data_found then null;                     \+  \        when others        then raise;                    \+  \    end;                                                  \+  \    /* La transacción autónoma termina                    \+  \       con el execute immediate o el rollback. */         \+  \    if  existe = 0  then                                  \+  \        if  privilegiado = 1 then                         \+  \            execute immediate construirTabla;             \+  \        else                                              \+  \            rollback;                                     \+  \            raise_application_error (-20000,              \+  \              'Error: el usuario ' || user || ' carece de ' \+  \            ||'privilegios para crear una tabla temporal.');\ +  \        end if;                                           \+  \    else                                                  \+  \        rollback;                                         \+  \    end if;                                               \+  \end;"+++-- | Dentro del siguiente texto hay una variable de substitución+--   con el nombre :1. Debe asociarse con el texto de una+--   consulta por analizar.+++texto_analizar  ::  String+texto_analizar  =+      +   "declare                                                 \+   \   /* Alimenta la tabla ta_query_desc_tmp               \+   \       con la información sobre una consulta :1. */     \+   \    asa          integer;                               \+   \    canColumnas  integer;                               \+   \    queryInfo    dbms_sql.desc_tab;                     \+   \    nullAccepted integer;                               \+   \    idSesion     varchar2(24)                           \+   \                := dbms_session.unique_session_id;      \+   \begin                                                   \+   \    /* Asegura que no hayan descripciones previas.  */  \+   \    delete from ta_query_desc_tmp;                      \+   \    /* Establece área de trabajo  */                    \+   \    asa := dbms_sql.open_cursor;                        \+   \    /* Reconoce la hilera con el motor SQL.  */         \+   \    /* :1 debe ser el texto de una consulta. */         \+   \    dbms_sql.parse(asa, :1, dbms_sql.native);           \+   \    /* Obtiene la descripción en queryInfo  */          \+   \    dbms_sql.describe_columns(asa, canColumnas, queryInfo);\+   \    /* Transforma la descripción al insertarla en una   \+   \       tabla para facilitar su recuperación con una     \+   \       consulta sencilla.                               \+   \       Preservamos idSession para poder tener           \+   \       sesiones concurrentes.  */                       \+   \    for i in queryInfo.first..queryInfo.Last loop       \+   \        nullAccepted := case  queryInfo(i).col_null_ok  \+   \                              when true then 1          \+   \                                        else 0          \+   \                        end;                            \+   \        insert into ta_query_desc_tmp values            \+   \            (  idSesion                                 \+   \            ,  i                                        \+   \            ,  queryInfo(i).col_type                    \+   \            ,  queryInfo(i).col_max_len                 \+   \            ,  queryInfo(i).col_name                    \+   \            ,  queryInfo(i).col_name_len                \+   \            ,  queryInfo(i).col_schema_name             \+   \            ,  queryInfo(i).col_schema_name_len         \+   \            ,  queryInfo(i).col_precision               \+   \            ,  queryInfo(i).col_scale                   \+   \            ,  queryInfo(i).col_charsetid               \+   \            ,  queryInfo(i).col_charsetform             \+   \            ,  nullAccepted                             \+   \            );                                          \+   \    end loop;                                           \+   \    /* Cierra el área de trabajo.  */                   \+   \    dbms_sql.close_cursor(asa);                         \+   \end;"++ +-- eof

@@ -0,0 +1,423 @@+{-# LANGUAGE  TemplateHaskell    #-}
+{-# LANGUAGE  PatternGuards      #-}
+{-# language  DeriveDataTypeable #-} 
+
+-- Versión 0.0.3 Leonel Fonseca. 2010/06/22
+
+{-
+
+    db2hs es para descripciones devueltas por el diccionario de
+          datos. 
+
+    OracleTypeCode, intToTypeCode, typeCodetoInt y dbTC2hs
+    se usan con información devuelta por dbms_sql.parse y
+    dbms_sql.describe_columns.
+
+    dbms_describe.describe_procedure tiene codificaciones
+    distintas manejadas por ODTC (OracleDescribeTypeCode), 
+    intToODTC, odtcToInt y odtc2hs. (añadidas en la versión 0.0.3).
+    
+
+-}
+
+
+{- 
+   Mapea los tipos básicos de una base de datos Oracle a Haskell
+   y viceversa.
+
+   Creación:
+     Autor: Leonel Fonseca Loría
+     Fecha: 26/abr/2010
+-}
+
+module Database.TA.Core.MapaBase  
+                   ( db2hs  
+                   , dbTC2hs 
+                   , intToNUMBER
+                   , floatToNUMBER
+                   , stringToVARCHAR2
+                   , utcTimeToDATE
+                   , OracleTypeCode (..) -- para dbms_sql
+                   , intToTypeCode
+                   , typeCodeToInt 
+                   , ODTC (..)           -- para dbms_describe
+                   , intToODTC
+                   , odtcToInt
+                   , HSTC (..)
+                   ) 
+
+where 
+
+import Language.Haskell.TH
+import Data.Time
+import Data.Typeable
+
+
+{-
+    Para traducir un tipo Oracle a un tipo Haskell son necesarios
+    dos datos:
+      Primero, el nombre del tipo de una columna o función.
+      Segundo, la escala utilizada. Es un número que puede ser cero
+      o puede tener otro valor cuando se describe un tipo
+      TIMESTAMP o NUMBER.
+
+    db2hs aplica para descripciones devueltas por el diccionario de
+    datos.
+-} 
+
+db2hs  ::  String -> Int -> Either String TypeQ 
+
+db2hs tipo escala 
+
+  | tipo == "VARCHAR2"      =  Right [t| String  |]
+  | tipo == "TIMESTAMP"     =  Right [t| UTCTime |]
+  | tipo == "TIMESTAMP(9)"  =  Right [t| UTCTime |]
+  | tipo == "TIMESTAMP(6)"  =  Right [t| UTCTime |]
+  | tipo == "DATE"          =  Right [t| UTCTime |]
+  | tipo == "NUMBER"        
+  , escala == 0             =  Right [t| Int     |]
+  | tipo == "NUMBER"        =  Right [t| Float   |]
+  | tipo == "" = Left "db2hs no puede traducir un tipo nulo."
+  | otherwise  = Left $ "db2hs no sabe como traducir el tipo " 
+                         ++ tipo
+
+
+
+{-
+   En la dirección hs2db se necesitan más parámetros.
+   Así que se especializan las funciones por tipo, en lugar
+   de tener una sola función compleja.
+
+   Por dualidad, sospecho que podría ser más apropiada
+   alguna de estas dos signaturas:
+
+      TypeQ -> p1 -> ... pn -> TypeQ 
+      
+      TypeQ -> p1 -> ... pn -> String
+
+-}
+
+
+-- Recibe el tamaño del NUMBER(n) resultante.
+
+intToNUMBER   ::  Int -> Either String String 
+intToNUMBER   n
+  |  n == 0   =  Right "NUMBER"
+  |  n >  0   =  Right $ "NUMBER(" ++ show n ++ ")"
+  |  n <  0   =  Left $ "Para traducir un Int, indique la cantidad\
+                 \ de bytes. Use algo así: intToNUMBER n.\
+                 \ El valor recibido para n fue: " ++ show n ++ "."
+
+
+
+-- Recibe la precisión y la escala para dar NUMBER(precisión,escala)
+
+
+floatToNUMBER  ::  Int -> Int -> Either String String
+floatToNUMBER  p e
+  | p > 0 
+  , e > 0    =  Right $ "NUMBER(" ++ show p ++ "," ++ show e ++ ")"
+  | otherwise =  Left $ "Para traducir un Float, indique la\
+                 \ cantidad de enteros y la cantidad de decimales.\
+                 \ Use algo así: floatToNUMBER ent dec.\
+                 \ El valor recibido para p fue: " ++ show p ++
+                 " , el valor de e fue: " ++ show e ++ "."
+
+
+-- Recibe la cantidad de bytes para dar VARCHAR2(n)
+
+
+stringToVARCHAR2  ::  Int -> Either String String
+stringToVARCHAR2  n 
+  | n  >  0       =   Right $ "VARCHAR2(" ++ show n ++ ")"
+  | otherwise     =   Left  $ "Para traducir un String, indique\
+                      \ la cantidad de bytes para la hilera. Use\
+                      \  algo así: stringToVARCHAR2 n. \
+                      \ El valor recibido para n fue: "
+                      ++ show n ++ "."
+
+
+-- Recibe un número que puede ser 0, 6 o 9 que dará como resultado
+-- alguno de estos tres tipos: DATE o TIMESTAMP(6) o TIMESTAMP(9).
+
+
+utcTimeToDATE    ::  Int -> Either String String
+utcTimeToDATE    n 
+  | n  ==  0     =  Right "DATE"
+  | n  ==  6     =  Right "TIMESTAMP(6)"
+  | n  ==  9     =  Right "TIMESTAMP(9)"
+  | otherwise    =  Left $ "Para traducir un UTCTime, indique\
+                     \ utcTimeToDate 0 para DATE,\
+                     \ utcTimeToDate 6 para TIMESTAMP(6),\
+                     \ utcTimeToDate 0 para TIMESTAMP(9).\
+                     \ El valor recibido para n fue: " ++ show n
+                     ++ "."
+
+
+-- OracleTypeCode, intToTypeCode, typeCodetoInt y dbTC2hs
+-- se usan con información devuelta por dbms_sql.parse y
+-- dbms_sql.describe_columns.
+
+-- | El procedimiento de descripción de columnas devuelve un entero
+--   que codifica alguno de los siguientes tipos Oracle.
+
+
+data  OracleTypeCode 
+   =  NO_DATA            -- devuelto por operaciones de iteración.
+   |  SUCCESS            -- devuelto por operaciones de iteración.
+   |  TYPECODE_BDOUBLE
+   |  TYPECODE_BFILE 
+   |  TYPECODE_BFLOAT
+   |  TYPECODE_BLOB 
+   |  TYPECODE_CFILE
+   |  TYPECODE_CHAR 
+   |  TYPECODE_CLOB 
+   |  TYPECODE_DATE 
+   |  TYPECODE_INTERVAL_DS 
+   |  TYPECODE_INTERVAL_YM
+   |  TYPECODE_MLSLABEL 
+   |  TYPECODE_NAMEDCOLLECTION 
+   |  TYPECODE_NCHAR 
+   |  TYPECODE_NCLOB
+   |  TYPECODE_NUMBER
+   |  TYPECODE_NVARCHAR2 
+   |  TYPECODE_OBJECT 
+   |  TYPECODE_OPAQUE
+   |  TYPECODE_RAW
+   |  TYPECODE_REF
+   |  TYPECODE_TABLE
+   |  TYPECODE_TIMESTAMP
+   |  TYPECODE_TIMESTAMP_LTZ
+   |  TYPECODE_TIMESTAMP_TZ
+   |  TYPECODE_UROWID
+   |  TYPECODE_VARCHAR2
+   |  TYPECODE_VARCHAR 
+   |  TYPECODE_VARRAY
+      deriving (Show, Read, Eq, Ord)
+
+
+-- |  El 100 tiene asociado dos TYPECODES: 
+--       TYPECODE_SUCCESS y TYPECODE_BFLOAT.
+--    Asumimos que siempre interrogaremos en un contexto de tipos
+--    y no de operaciones.
+      
+
+intToTypeCode    :: Int -> OracleTypeCode
+intToTypeCode i  =  case i of
+      101  ->  TYPECODE_BDOUBLE
+      114  ->  TYPECODE_BFILE
+      100  ->  TYPECODE_BFLOAT
+      113  ->  TYPECODE_BLOB
+      115  ->  TYPECODE_CFILE
+      96   ->  TYPECODE_CHAR
+      112  ->  TYPECODE_CLOB
+      12   ->  TYPECODE_DATE
+      190  ->  TYPECODE_INTERVAL_DS
+      189  ->  TYPECODE_INTERVAL_YM
+      105  ->  TYPECODE_MLSLABEL
+      122  ->  TYPECODE_NAMEDCOLLECTION
+      286  ->  TYPECODE_NCHAR
+      288  ->  TYPECODE_NCLOB
+      2    ->  TYPECODE_NUMBER
+      287  ->  TYPECODE_NVARCHAR2
+      108  ->  TYPECODE_OBJECT
+      58   ->  TYPECODE_OPAQUE
+      95   ->  TYPECODE_RAW
+      110  ->  TYPECODE_REF
+      248  ->  TYPECODE_TABLE
+      187  ->  TYPECODE_TIMESTAMP
+      232  ->  TYPECODE_TIMESTAMP_LTZ
+      188  ->  TYPECODE_TIMESTAMP_TZ
+      104  ->  TYPECODE_UROWID
+      9    ->  TYPECODE_VARCHAR2
+      1    ->  TYPECODE_VARCHAR
+      247  ->  TYPECODE_VARRAY
+      otherwise -> error $ 
+        "En TAMapaBase.intToTypeCode el código " ++ show i ++
+        " no tiene asociado ningún tipo Oracle."
+
+
+typeCodeToInt   :: OracleTypeCode -> Int 
+typeCodeToInt tc  =  case tc of
+      TYPECODE_BDOUBLE          ->  101
+      TYPECODE_BFILE            ->  114
+      TYPECODE_BFLOAT           ->  100
+      TYPECODE_BLOB             ->  113
+      TYPECODE_CFILE            ->  115
+      TYPECODE_CHAR             ->  96 
+      TYPECODE_CLOB             ->  112
+      TYPECODE_DATE             ->  12 
+      TYPECODE_INTERVAL_DS      ->  190
+      TYPECODE_INTERVAL_YM      ->  189
+      TYPECODE_MLSLABEL         ->  105
+      TYPECODE_NAMEDCOLLECTION  ->  122
+      TYPECODE_NCHAR            ->  286
+      TYPECODE_NCLOB            ->  288
+      TYPECODE_NUMBER           ->  2  
+      TYPECODE_NVARCHAR2        ->  287
+      TYPECODE_OBJECT           ->  108
+      TYPECODE_OPAQUE           ->  58 
+      TYPECODE_RAW              ->  95 
+      TYPECODE_REF              ->  110
+      TYPECODE_TABLE            ->  248
+      TYPECODE_TIMESTAMP        ->  187
+      TYPECODE_TIMESTAMP_LTZ    ->  232
+      TYPECODE_TIMESTAMP_TZ     ->  188
+      TYPECODE_UROWID           ->  104
+      TYPECODE_VARCHAR2         ->  9  
+      TYPECODE_VARCHAR          ->  1  
+      TYPECODE_VARRAY           ->  247
+      otherwise -> error $ 
+        "En TAMapaBase.typeCodeToInt el tipo " ++ show tc ++
+        " no tiene asociado ninguna representación numérica."
+
+
+{-
+    Versión que usa OracleTypeCodes para traducir una columna.
+
+    Para traducir un tipo Oracle a un tipo Haskell son necesarios
+    dos datos:
+      Primero, el nombre del tipo de una columna o función.
+      Segundo, la escala utilizada. Es un número que puede ser cero
+      o puede tener otro valor cuando se describe un tipo
+      TIMESTAMP o NUMBER.
+-} 
+
+dbTC2hs  ::  Int -> Int -> Either String TypeQ 
+
+dbTC2hs tipo escala = 
+  let  tc  =  intToTypeCode tipo
+  in   case tc of  
+       TYPECODE_BFLOAT        ->  Right [t| Float   |]
+       TYPECODE_CHAR          ->  Right [t| String  |] -- What oracle says!
+       TYPECODE_DATE          ->  Right [t| UTCTime |]
+       TYPECODE_NCHAR         ->  Right [t| Char    |]
+       TYPECODE_NVARCHAR2     ->  Right [t| String  |]
+       TYPECODE_TIMESTAMP     ->  Right [t| UTCTime |]
+       TYPECODE_TIMESTAMP_LTZ ->  Right [t| UTCTime |]
+       TYPECODE_TIMESTAMP_TZ  ->  Right [t| UTCTime |]
+       TYPECODE_NUMBER        ->  
+               case escala of 
+                    0         ->  Right [t| Int     |]
+                    otherwise ->  Right [t| Float   |]
+       TYPECODE_VARCHAR2      ->  Right [t| String  |]
+       TYPECODE_VARCHAR       ->  Right [t| String  |]
+       otherwise     ->  Left $
+                           "dbTC2hs no sabe como traducir el tipo "
+                           ++ show tc
+
+
+
+{-
+    dbms_describe.describe_procedure tiene codificaciones
+    distintas manejadas por ODTC (OracleDescribeTypeCode), 
+    intToODTC, odtcToInt y odtc2hs. (añadidas en la versión 0.0.3).
+
+-}
+-- OracleDescribeTypeCode
+data  ODTC 
+   =  ODTCNoArgs
+   |  ODTCVarchar2      
+   |  ODTCNumber        
+   |  ODTCPlsInteger    
+   |  ODTCLong          
+   |  ODTCRowId         
+   |  ODTCDate          
+   |  ODTCRaw           
+   |  ODTCLong_raw      
+   |  ODTCOpaque_type   
+   |  ODTCChar          
+   |  ODTCMlslabel      
+   |  ODTCObject        
+   |  ODTCNested_table  
+   |  ODTCVarray        
+   |  ODTCTime          
+   |  ODTCTime_tz       
+   |  ODTCTimestamp     
+   |  ODTCTimestamp_tz  
+   |  ODTCTimestamp_ltz 
+   |  ODTCPlsql_record  
+   |  ODTCPlsql_table   
+   |  ODTCPlsql_boolean 
+      deriving (Show, Read, Eq, Ord, Typeable)
+
+
+intToODTC   ::   Int -> ODTC
+intToODTC x =    case x of
+ 0   -> ODTCNoArgs        -- procs with no arguments
+ 1   -> ODTCVarchar2      -- varchar, varchar, string
+ 2   -> ODTCNumber        -- number, integer, smallint, real, 
+                          -- float, decimal
+ 3   -> ODTCPlsInteger    -- binary_integer, pls_integer, positive,
+                          -- natural
+ 8   -> ODTCLong          -- long
+ 11  -> ODTCRowId         -- rowid
+ 12  -> ODTCDate          -- date
+ 23  -> ODTCRaw           -- raw
+ 24  -> ODTCLong_raw      -- long raw
+ 58  -> ODTCOpaque_type   -- opaque type
+ 96  -> ODTCChar          -- char (ansi fixed char), character
+ 106 -> ODTCMlslabel      -- mlslabel
+ 121 -> ODTCObject        -- object
+ 122 -> ODTCNested_table  -- nested table
+ 123 -> ODTCVarray        -- varray
+ 178 -> ODTCTime          -- time
+ 179 -> ODTCTime_tz       -- time with time zone
+ 180 -> ODTCTimestamp     -- timestamp
+ 181 -> ODTCTimestamp_tz  -- timestamp with time zone
+ 231 -> ODTCTimestamp_ltz -- timestamp with local time zone
+ 250 -> ODTCPlsql_record  -- pl/sql record
+ 251 -> ODTCPlsql_table   -- pl/sql table
+ 252 -> ODTCPlsql_boolean -- pl/sql boolean
+ _   -> error $ "TAMapaBase.intToODTC: el codigo de tipo " 
+                ++ show x ++ " carece de traducción."
+
+
+odtcToInt   :: ODTC -> Int
+odtcToInt x =  case x of
+    ODTCNoArgs         ->   0 
+    ODTCVarchar2       ->   1 
+    ODTCNumber         ->   2 
+    ODTCPlsInteger     ->   3 
+    ODTCLong           ->   8 
+    ODTCRowId          ->  11 
+    ODTCDate           ->  12 
+    ODTCRaw            ->  23 
+    ODTCLong_raw       ->  24 
+    ODTCOpaque_type    ->  58 
+    ODTCChar           ->  96 
+    ODTCMlslabel       -> 106 
+    ODTCObject         -> 121 
+    ODTCNested_table   -> 122 
+    ODTCVarray         -> 123 
+    ODTCTime           -> 178
+    ODTCTime_tz        -> 179 
+    ODTCTimestamp      -> 180 
+    ODTCTimestamp_tz   -> 181 
+    ODTCTimestamp_ltz  -> 231 
+    ODTCPlsql_record   -> 250 
+    ODTCPlsql_table    -> 251 
+    ODTCPlsql_boolean  -> 252 
+
+
+-- odtc2hs : pendiente de escritura
+
+--  Haskell TypeCodes. The resulting mixture with Oracle types.
+--  This will be used  by a serialiser written for PL/SQL 
+--  structures.
+data  HSTC
+   =  HSTCBool    Bool
+   |  HSTCChar    Char
+   |  HSTCString  String
+   |  HSTCInt     Int
+   |  HSTCFloat   Float
+   |  HSTCUTCTime UTCTime
+   |  HSTCUnit    -- () for ODTCNoArgs.
+   |  HSTCList    [HSTC] -- Varray,Nested Table,PLSQL Table
+   |  HSTCRecord  [HSTC] -- for Oracle records
+   |  HSTCObject  [HSTC] -- for Oracle Objects
+   |  HSTCOpaque_type    -- for Oracle opaque types. 
+   |  HSTCBinary  [HSTC] -- for Long, Raw, Long_Raw
+      deriving (Show, Read, Eq, Ord, Typeable)
+
+-- eof

@@ -0,0 +1,125 @@+{-#  language  RankNTypes  #-}
+
+-- | Definiciones básicas utilizadas por otros módulos de TA.
+--   Leonel Fonseca. 2010.
+
+
+module Database.TA.Core.Nucleo  
+                 ( ColInfo (..)
+                 , emptyColInfo
+                 , QueryColInfo (..)
+                 , GeneradorColInfo
+                 , GeneradorQueryColInfo
+                 , ErrorMsg, Nombre, NomTabla, NomColumna, TipoBD
+                 , Declaraciones, Condicion
+                 , InstanciaCR (..)
+                 , CR     (..)
+                 )
+
+where
+
+
+import  Language.Haskell.TH
+
+
+{- | 
+     Descripción de una tabla de la base de datos
+     en términos de las columnas que la componen
+    
+   Se asume que:
+
+   1) Cada elemento ColInfo describe una columna de la tabla.
+
+   2) La información de una tabla se recibe denormalizada, 
+      como una lista de ColInfo. 
+
+   3) La lista viene ordenada por número de columna.
+      Si esta presunción debe removerse, entonces agregue
+      un campo column_id para controlar el orden de las columas.
+-}
+
+
+data  ColInfo  =  ColInfo 
+      {  table_name     :: String
+      ,  column_name    :: String
+      ,  data_type      :: Maybe String 
+      ,  data_length    :: Int
+      ,  data_precision :: Maybe Int
+      ,  data_scale     :: Maybe Int 
+      ,  nullable       :: Maybe String
+      }  deriving  (Read, Show, Eq, Ord) 
+
+
+
+emptyColInfo  ::  ColInfo
+emptyColInfo  =   ColInfo "" "" Nothing 0 Nothing Nothing Nothing
+
+
+
+-- | Usado en TABDInfraestructura.
+--   Para los meta-datos de una consulta.
+
+
+data  QueryColInfo = QueryColInfo 
+      {  col_type         ::  Int
+      ,  col_max_len      ::  Int 
+      ,  col_name         ::  String 
+      ,  col_schema_name  ::  Maybe String 
+      ,  col_precision    ::  Int 
+      ,  col_scale        ::  Int 
+      ,  col_null_ok      ::  Bool
+      }
+      deriving (Eq, Ord, Read, Show)
+
+
+
+-- | La funciones que usan la información de columnas
+--   para generar un nuevo valor o nuevo código. 
+
+
+type  GeneradorColInfo a      = [ColInfo] -> a 
+
+type  GeneradorQueryColInfo a = [QueryColInfo] -> a
+
+
+type  ErrorMsg      =  String
+type  Nombre        =  String
+type  NomTabla      =  String
+type  NomColumna    =  String
+type  TipoBD        =  String
+type  Declaraciones =  String
+type  Condicion     =  String
+
+
+-- | Operaciones Relacionales
+
+data  InstanciaCR 
+   =  Select  { with_    :: [Declaraciones]
+              , select_  :: [NomColumna]
+              , from_    :: [NomTabla]
+              , where_   :: [Condicion]
+              , order_   :: [NomColumna]
+              , group_   :: [NomColumna]
+              , having_  :: [Condicion]
+              }
+   |  Insert String 
+   |  Delete String 
+   |  Update String 
+   |  Block String 
+      deriving (Read, Show, Eq, Ord)
+
+-- | Comando relacional tiene un nombre
+--   prefijo o sufijo en el nombre de cada
+--   columna y una operación relacional.
+
+data  CR         =   CR
+      { nombre   ::  Nombre
+      , prefijo  ::  String
+      , sufijo   ::  String
+      , op       ::  InstanciaCR 
+      }
+      deriving (Read, Show, Eq, Ord)
+     
+
+
+-- eof

@@ -0,0 +1,22 @@+{- | TA Opciones -}
+
+{-  2010/jun/08. LFL. Construcción. -}
+
+module Database.TA.Core.Opciones
+       (
+         imprimirDepuracion 
+       ) 
+
+
+where
+
+
+-- | When this flag is set, at least in version 0.1.0 of
+--   TA library, you'll get console output
+--   from the GenSelect module, each time that generates code.
+
+
+imprimirDepuracion  ::  Bool 
+imprimirDepuracion  =   False
+
+-- eof

@@ -0,0 +1,79 @@+{- | RIS: Representación Intermedia del Select. 
+     
+     El propósito es abstraer el select.
+     Pudo utilizarse un AST, sin embargo, en esta aproximación
+     utilizaremos un registro que denominamos Select.
+
+     Con la abstracción Select introducimos una separación.
+     GenSelect puede refinar en una consulta a partir de un taris.
+     GenSelectDBM puede generar un Select a partir de las especificaciones
+     de consulta.
+
+     Leonel Fonseca. 2010.
+-}
+
+{-# language  NoMonomorphismRestriction  #-}
+
+
+module Database.TA.Core.RIS  
+              ( module Database.TA.Core.Nucleo
+              , emptySelect
+              , toString
+              , maybeString ) 
+
+where
+  
+import Database.TA.Core.Nucleo 
+import Data.List       ( intersperse )
+import Control.Monad   ( liftM, liftM2 )
+
+
+emptySelect   ::   InstanciaCR
+emptySelect   =    Select [] [] [] [] [] [] []
+
+toString      =    maybe "" id . maybeString 
+ 
+maybeString   ::   InstanciaCR ->  Maybe String
+maybeString s =    genWith    (with_    s)
+              +++  genSelect  (select_  s)
+              +++  genFrom    (from_    s)
+              +++  genWhere   (where_   s)
+              +++  genOrder   (order_   s)
+              +++  genGroup   (group_   s)
+              +++  genHaving  (having_  s)
+
+  where
+    
+  infixl +++
+  a +++  b   =  liftM2 (++) a b
+  lista      =  concat . (intersperse ", ")
+  
+             -- concat and wrap aplana una lista de hileras en una
+             -- sola hilera h. Luego le prefija la hilera x. 
+             -- Luego envuelve el resultado en constructor Just.
+  caw        ::  String -> [String] -> Maybe String
+  caw x      =   Just   . (x ++) . lista
+
+             -- Si x es una lista vacia, usa f para genera un valor.
+             -- De lo contrario usa g (x) para generar un valor.
+  tv           ::  b -> ([a] -> b) -> [a] -> b  
+  tv f _ []  =   f
+  tv _ g x   =   g x
+
+
+  --  En algunos RDBMS se puede hacer "select" sin
+  --  especificar un "from". En Oracle siempre es
+  --  obligatorio. Por lo tanto, en las próximas definiciones
+  --  devolver Nothing codifica un caso de error,
+  --  donde ni siquiera aparecen las partes básicas de un
+  --  select.
+ 
+
+  genWith   = tv (Just "") (liftM (++"\n") . (caw "with\n    "))
+  genSelect = tv Nothing   (caw     "select\n    ")
+  genFrom   = tv Nothing   (caw    "\n    /* TA Select */\nfrom\n    ")
+  genWhere  = tv (Just "") (caw    "\nwhere\n    ")
+  genOrder  = tv (Just "") (caw "\norder by\n    ")
+  genGroup  = tv (Just "") (caw "\ngroup by\n    ")
+  genHaving = tv (Just "") (caw   "\nhaving\n    ")
+

@@ -0,0 +1,130 @@+Example $\#$01 of Tránsito Abierto.
+
+\medskip
+
+Leonel Fonseca. 2010/09/15.
+
+\medskip
+
+A simple query.
+
+\medskip
+
+You may compile this program with \verb|ghc --make Ex01|.
+
+
+\medskip
+
+\begin{code}
+
+{-# options  -fglasgow-exts  #-}
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import  Database.TA.TAB
+import  RCSdef 
+
+
+\end{code}
+
+
+We import ``RCSdef'' which provides ``rcs01'', a list of DBM actions that can generate database access code. Each of these DBM actions acts as an AST builder, that when evaluated generates code for two definitions:
+
+  \begin{enumerate}
+  \item A record type that would define the type of the query result.
+  \item An action of type DBM (from Takusen) that would contain an iteratee 
+        function and would perform the parameter binding (if provided), 
+        the query and the fetch (accumulation) of results.
+  \end{enumerate}
+
+
+\begin{code}
+
+empalmar "abel" "cain" "barva" Nothing rcs01
+
+\end{code}
+
+
+\bigskip
+
+This is the second step in cutting boilerplate. By issuing ``empalmar'', ``rcs01'' is evaluated in the DBM monad, and its results are generated code to be spliced.  If we were to consider ``rcs01'' a seed, passing it to ``empalmar'' is akin to planting the seed and making it germinate. New code would spring.
+
+\bigskip
+
+``empalmar'' needs a database connection  in order to infer the type of the result and the Takusen DBM action which will do the query. In this example, we used these three values to represent the database connection: ``abel'' as the database account; its password, ``cain''; and the database
+ service, ``barva''.
+
+\bigskip
+
+We will defer the discussion of what is the ``Nothing'' value in this call to another example.
+
+
+\bigskip
+
+\begin{code}
+
+main :: IO ()
+
+main = do
+   r <-  withSession (connect "abel" "cain" "barva")
+                     ( qTwoColumns [[]] ) 
+
+   mapM_ (putStrLn . show) $ concat r
+
+\end{code}
+
+\bigskip
+
+A fact that may attract reader's attention it is that ``qTwoColumns'' may have binded values as parameters. In this example, no parameters are use, hence we passed an empty list --of lists--.
+
+\bigskip
+
+Three names came along from the module ``RCSdef'':
+
+\begin{enumerate}
+
+   \item ``rcs01'': this a list of DBM actions. When evaluated builds a list of AST's
+          of Haskell code that provide definitions of query types and query functions.
+          It is defined by the programmer by calling functions and constructors
+          of the Tránsito Abierto library.
+
+   \item ``qTwoColumns'': 
+           It is, too, a DBM action that performs the query and 
+           accumulates the results. It has its own iteratee function.
+
+           The name ``qTwoColumns''    was selected by the programmer in the module
+           ``RCSdef'' by means of the call to ``genSelect''.
+           
+   \item ``QTwoColumns'': is a name selected and defined by the Tránsito
+           Abierto library's code generator. 
+           It is a record type for describing the results of the query
+           ``qTwoColumns''. 
+
+\end{enumerate}
+
+\bigskip
+
+Both ``qTwoColumns'' and ``QTwoColumns'' are injected to GHC compiler's structures when this module (``Ex01.lhs'') is compiled. Exactly, they are known in the scope of this program when the action ``empalmar'' is evaluated, because it splices the code built by computing ``rcs01''.
+
+\bigskip
+
+``rcs01'' can be thought as an immutable seed. Its generative properties can be used serveral times to generate code that is dependent of the database environment.
+
+\bigskip
+
+Given that the names for the columns of the table ``twoColumns'' are these:
+
+
+\begin{Verbatim}[frame=lines]
+SQL> desc twoColumns
+ Name                                      Null?    Type
+ ----------------------------------------- -------- --------------
+ NAME                                               VARCHAR2(20)
+ VALUE                                              NUMBER(5)
+\end{Verbatim}
+
+the user of the library would expect that the fields of the record follow similar names.
+
+
+\bigskip

@@ -0,0 +1,97 @@+Example $\#$02 of Tránsito Abierto.
+
+Leonel Fonseca. 2010/09/16.
+
+\medskip
+
+A ``wear the safety belt'' style of program. We ask the code generator to
+save the database access generated code in a variable named ``oldCode'', this happens at compile time. Later, when the program is executed we ask the code generator for a fresh instance of code. Then we compare ``oldCode'' against the new code. If they don't match it means your database environment has changed and it's not safe to execute the program.
+
+\bigskip
+
+You may compile this program with \verb|ghc --make Ex02|.
+
+This example reuses the definitions in ``RCSdef'', but it is independent from the example $\#$01.
+
+
+\begin{code}
+
+{-# options  -fglasgow-exts  #-}
+{-# language TemplateHaskell #-}
+
+module Main where
+
+import  Database.TA.TAB
+import  Control.Monad ( when )
+import  System        ( ExitCode (..), exitWith  )
+import  RCSdef
+
+\end{code}
+
+
+We import ``Database.TA.TAB'' which provides the code generator and utilities.
+
+The import of ``RCSdef'' brings into scope the name ``rcs01'', a list of AST builders (or DBM actions that when evaluated will yield an AST representation of code, whose type is \verb|Q [Dec]|).
+
+
+\begin{code}
+
+empalmar "abel" "cain" "barva" (Just "oldCode") rcs01
+
+\end{code}
+
+
+In the example $\#01$ you will find an explanation for most of the parameters of ``empalmar''. We now explain \verb|(Just "oldCode")|. The type of this parameter is \verb|Maybe String|. This parameter directs the following processing: 
+ 
+  \begin{itemize}
+
+    \item  When given \verb|Nothing|, the code generated has two declarations: one for a datatype and one for DBM action for database access.
+ 
+    \item  When given \verb|(Just "someIdentifierName")|, besides the two cited
+           declarations, a third declaration is elaborated: 
+           The name ``someIdentifierName'' is binded with the value of the 
+           former two declarations. In other words, a snapshot of the ASTs 
+           (of the datatype and the DBM action) is made.
+           
+  \end{itemize}
+
+
+In this particular case, ``rcs01'' has the potential to generate access code and ``oldCode'' has an instance of the code generated at compile time.
+
+
+
+\begin{code}
+
+main :: IO ()
+
+main = do
+   ((stop,_,_), s) <-  withContinuedSession 
+                           (connect "abel" "cain" "barva")
+                           (ambBDCompatible oldCode rcs01)
+
+   when stop ( do  putStrLn stopMessage           
+                   _ <- withSession s $ return ()
+                   exitWith (ExitFailure 1) )  
+   
+   r <- withSession  s  ( qTwoColumns [[]] )
+
+   mapM_ (putStrLn . show) $ concat r
+
+\end{code}
+
+
+``ambBDCompatible'' returns a triple.
+The first value is a boolean value. If both, the old generated (at compile time) code and the new generated code (obtained from evaluating ``rcs01''), are equal the result is true, otherwise false.
+The second and third values are, respectively, the list of old declarations and the list of new declarations.
+
+In this example, we chose to save the returned comparison value for interrogating it later. So, in the case this program is not safe to run due database changes that result in different generated code, it will warn you and stop.
+
+\begin{code}
+
+stopMessage = 
+    "Error: The database environment has changed!\n"
+    ++ " It doesn't match the enviroment this program expects. \n"
+    ++ " As a measure to avoid further errors, this program will finish now."
+
+\end{code}
+

@@ -0,0 +1,163 @@++%% You can build this document by:+%% 1) lhs2TeX -Pc:\ghc\hp10100\data\lhs2tex-1.15;. -o Examples.tex Examples.lhs+%% 2) pdflatex Examples.tex++\documentclass[letterpaper,final,10pt]{paper}+\setlength{\topmargin}{-1.45cm}+\setlength{\topskip}{0.75cm}     % between header and text+\setlength{\textheight}{23cm}    % height of main text+\setlength{\textwidth}{15cm}     % width of text+\setlength{\oddsidemargin}{1cm}  % odd page left margin+\setlength{\evensidemargin}{1cm} % even page left margin+\usepackage[utf8,latin1]{inputenc}+\usepackage[T1]{fontenc}+\usepackage{zefonts}  %%depends on your installation.+\usepackage{graphics,fancyvrb}+\usepackage[spanish]{babel}+\inputencoding{utf8}+%include polycode.fmt+\fvset{frame=single,samepage=true,fontsize=\normalsize}+++\markboth{Leonel Fonseca}{Tránsito Abierto library Version 0.1}+\title{Using the Tránsito Abierto library \\+       \small {Document version 0.1.0. September 16, 2010.}}+\author{Leonel Fonseca \\+        \small Computer Sciences student, ITCR, Costa Rica.}+\pagestyle{myheadings}+\thispagestyle{empty}+\begin{document}+\maketitle++\section{Queries as seeds}++%include ./RCSdef.lhs+++\section{Growing the seeds or using AST builders of queries}++%include ./Ex01.lhs+++\bigskip+++\section{What is generated}++As you are about to see in the following output (edited for the sake of space) that shows the dump of the splicing during the compilation process, the Tránsito Abierto library's code generator reused the names of the table's columns. Whenever clash name arises, there is the possibility of using the prefix or suffix parameters when calling the ``empalmar'' function.+++\bigskip+++Another thing the code generator does when prepares the definition of the ``qTwoColumns'' table is for nullable columns of type \textit{X}, yield a \textit{Maybe X} and for non nullable columns yield the equivalent type without wrapping it into a \textit{Maybe}. ++\bigskip++What are the meaning of the names below? ``ite'' stands for the iteratee function, ``gR'' for ``getResults'', ``pS'' for ``preparedStatement'' and ``xQ'' for ``executeQuery''. Nevertheless, these names are local definitions and are unknown to the rest of the program.++\pagebreak++You now actually see, how much boilerplate is generated by the Tránsito Abierto library.++\begin{Verbatim}[fontsize=\small]+Ex01.lhs:1:0:+ Ex01.lhs:1:0: Splicing declarations+    empalmar "abel" "cain" "barva" Nothing rcs01+  ======>+    Ex01.lhs:26:0-43+    data QTwoColumns+        = QTwoColumns {name :: Maybe String, value :: Maybe Int}+        deriving (Show, Read, Eq, Ord, Typeable)+    qTwoColumns bnds+        = (concatM xQ bnds `exnAt` "qTwoColumns: ")+        where+            ite a11 a12 a13 = result' ((a11, a12) GHC.Types.: a13)+            gR gRbnds+                 = Control.Monad.liftM+                     (revertir (\ (a21, a22) -> QTwoColumns a21 a22))+                     (doQuery gRbnds ite GHC.Types.[])+            pS = (prepareQuery+                $ sql+                    "select\n    *\n    /* TA Select */\nfrom\n\+                    \    twoColumns\norder by\n    value")+            xQ xQbnds+                 = withPreparedStatement+                     pS (\ boundSt -> withBoundStatement boundSt xQbnds gR)+\end{Verbatim}++\bigskip++\section{The result of executing the first example}+++This is the ouput that results from executing the first example.+ +\begin{Verbatim}[fontsize=\small]+QTwoColumns {name = Just "1", value = Just 1}+QTwoColumns {name = Just "2", value = Just 2}+QTwoColumns {name = Just "3", value = Just 3}+QTwoColumns {name = Just "4", value = Just 4}+QTwoColumns {name = Just "5", value = Just 5}+QTwoColumns {name = Just "6", value = Just 6}+QTwoColumns {name = Just "7", value = Just 7}+QTwoColumns {name = Just "8", value = Just 8}+QTwoColumns {name = Just "9", value = Just 9}+QTwoColumns {name = Just "10", value = Just 10}+QTwoColumns {name = Just "11", value = Just 11}+QTwoColumns {name = Just "12", value = Just 12}+QTwoColumns {name = Just "13", value = Just 13}+QTwoColumns {name = Just "14", value = Just 14}+QTwoColumns {name = Just "15", value = Just 15}+QTwoColumns {name = Just "16", value = Just 16}+QTwoColumns {name = Just "17", value = Just 17}+QTwoColumns {name = Just "18", value = Just 18}+QTwoColumns {name = Just "19", value = Just 19}+QTwoColumns {name = Just "20", value = Just 20}+\end{Verbatim}++\bigskip++\section{Reusing seeds for program safety}++%include ./Ex02.lhs++\section{Testing what we claim}++\medskip++Let us test what we claim! First we compile and execute Ex02. It should run fine. Then, let us alter the table by adding an extra column that the compiled program would not be prepared to handle:++\medskip++\begin{Verbatim}++SQL> alter table twocolumns add (c3 varchar2(1));++\end{Verbatim}++\medskip++After that, we execute again Ex02, which handles the failure:++\begin{Verbatim}++Error: The database environment has changed!+ It doesn't match the enviroment this program expects.+ As a measure to avoid further errors, this program will finish now.++\end{Verbatim}++\medskip+++\section{The two columns table}++The table used as target in this examples was created with this SQL script:++\VerbatimInput{make_twoColumns.sql}+++\end{document}+

@@ -0,0 +1,64 @@+This is the first step to cut boilerplate code.
+
+\bigskip
+
+Two background mechanisms are used: Template Haskell and Takusen.
+
+Two Template Haskell key concepts here, are expressions of type \verb|Q [Dec]| and splicing. And one key concept of Takusen is the action monad. We examine them briefly.
+
+\bigskip
+
+A \verb|Q [Dec]| expression is an abstract syntax tree (AST) that represents a list of Haskell declarations. The AST may be rendered into the compiler by splicing it (only at compile time), and would have the equivalent effect of written source code.
+
+\bigskip
+
+As Takusen deals with the world outside of a program, one would expect to find a monad to do so. This monad is named  \textit{DBM}. To use Takusen, one writes DBM actions (or, if you prefer, monadic values).
+
+\bigskip
+
+Template Haskell provides means to construct ASTs. One of the things that the Tránsito Abierto library provides, is the definition of AST builders by specifying queries as lists of DBM actions.
+
+The AST builders may be viewed as seeds. Later, we show the way to make them germinate (in this case, splice these resulting ASTs).
+
+\bigskip
+
+
+\begin{code}
+
+{-# options  -fglasgow-exts  #-}
+
+module RCSdef where
+
+import  Database.TA.TAB
+
+rcs01  =
+   [   genSelect $ CR "qTwoColumns" "" "" $ emptySelect 
+           {  select_  =  ["*"] 
+           ,    from_  =  ["twoColumns"]
+           ,   order_  =  ["value"] 
+           } 
+   ] 
+
+\end{code}
+
+Each ``genSelect'' statement is responsible of generating a DBM action that returns \verb|Q [Dec]| code.
+Its parameter is a \textit{relational command} (CR) record. A CR record is composed of: 
+
+  \begin{itemize}
+        \item A name for the query action.
+        \item A prefix for the fields of the result record datatype.
+        \item A suffix for the fields of the result record datatype.
+        \item A select spelled in terms of an internal record representation
+        (RIS).
+  \end{itemize}
+
+
+\bigskip
+
+In this case the name chosen for the query action was ``qTwoColumns'', no prefix or suffix were indicated. We used the ``emptySelect'' function to construct a new select record expressed in ``RIS'' terms.
+
+The ``TAB'' library was imported because it contains required functionality.
+
+The name ``rcs01'' is our seed and it is a list of DBM actions capable of generating database access code expressed as ASTs.
+
+\bigskip

@@ -0,0 +1,16 @@+-- Leonel Fonseca. 2010/09/10
+
+create table  twoColumns(
+    name   varchar2(20)
+  , value  number  ( 5)
+);
+
+begin
+  for i in  1..20 loop
+      insert into twoColumns 
+         values (  to_char(i) , i );
+  end loop;
+end;
+/
+
+commit;

@@ -0,0 +1,224 @@+{-
+   Copia de un módulo del proyecto CCA.
+
+   Código tomado de:
+   -| Code taken from: |-
+
+   http://hackage.haskell.org/packages/archive/
+   CCA/0.1.3/doc/html/src/Language-Haskell-TH-Instances.html
+
+
+   El original presenta problemas con: 
+   -| The original has problems with: |- 
+    
+    Couldn't match expected type `Language.Haskell.TH.Syntax.Internals.PkgName'
+           against inferred type `[Char]'
+  
+   Código copiado el 9/jun/2010.
+   -| Code copied on 9/jun/2010. |-
+    
+-}
+
+{-# LANGUAGE MagicHash, CPP, TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}
+
+module Database.TA.Helper.LiftQ where
+
+
+import Data.Ratio
+import GHC.Exts
+import GHC.Prim
+import Language.Haskell.TH.Syntax
+
+instance Lift a => Lift (Q a) where
+  lift x = x >>= \x -> [| return x |] 
+
+instance Lift Exp where
+  lift (VarE name) = [|VarE name|]
+  lift (ConE name) = [|ConE name|]
+  lift (LitE lit)  = [|LitE lit|]
+  lift (AppE e1 e2) = [|AppE e1 e2|]
+  lift (InfixE e1 e2 e3) = [|InfixE e1 e2 e3|]
+  lift (LamE p e) = [|LamE p e|]
+  lift (TupE e) = [|TupE e|]
+  lift (CondE e1 e2 e3) = [|CondE e1 e2 e3|]
+  lift (LetE d e) = [|LetE d e|]
+  lift (CaseE e m) = [|CaseE e m|]
+  lift (DoE s) = [|DoE s|]
+  lift (CompE s) = [|CompE s|]
+  lift (ArithSeqE r) = [|ArithSeqE r|]
+  lift (ListE e) = [|ListE e|]
+  lift (SigE e t) = [|SigE e t|]
+  lift (RecConE n f) = [|RecConE n f|]
+  lift (RecUpdE e f) = [|RecUpdE e f|]
+
+
+
+instance Lift Name where
+  lift (Name o f) = [|Name o f|]
+
+-- Original y problemática
+-- -| Original and problematic |- 
+-- instance Lift OccName where
+-- lift s = let s' = occString s in [|mkOccName s'|]
+
+-- Tomada de Ian Lynagh's th-lift
+-- -| Instead we use Ian Lynagh's th-lift |-
+instance Lift OccName where
+   lift n = [| mkOccName $(lift $ occString n) |]
+
+
+fromInt (I# i) = i
+
+#if __GLASGOW_HASKELL__ >= 612
+
+-- Original y problemática
+-- instance Lift ModName where
+--   lift = lift . modString
+
+-- Tomada de Ian Lynagh's th-lift
+instance Lift ModName where
+  lift n = [| mkModName $(lift $ modString n) |]
+
+
+-- Original y problemática.
+-- -| This gives problem. |-
+-- instance Lift PkgName where
+--    lift = lift . pkgString
+
+
+-- Tomada de Ian Lynagh's th-lift
+-- -| Instead we use Ian Lynagh's th-lift |-
+
+instance Lift PkgName where
+  lift n = [| mkPkgName $(lift $ pkgString n) |]
+  
+instance Lift Pred where
+  lift (ClassP n ts) = [|ClassP n ts|]
+  lift (EqualP t t2) = [|EqualP t t2|]
+
+instance Lift Kind where
+  lift StarK = [|StarK|]
+  lift (ArrowK k1 k2) = [|ArrowK k1 k2|]
+
+instance Lift TyVarBndr where
+  lift (PlainTV n) = [|PlainTV n|]
+  lift (KindedTV n k) = [|KindedTV n k|]
+
+#endif
+
+instance Lift NameFlavour where
+  lift NameS = [|NameS|]
+  lift (NameQ n) = [|NameQ n|]
+  lift (NameU i) = let i' = I# i in [|NameU (fromInt i')|]
+  lift (NameL i) = let i' = I# i in [|NameL (fromInt i')|]
+  lift (NameG n p m) = [|NameG n p m|]
+
+instance Lift Range where
+  lift (FromR e) = [|FromR e|]
+  lift (FromThenR e1 e2) = [|FromThenR e1 e2|]
+  lift (FromToR e1 e2) = [|FromToR e1 e2|]
+  lift (FromThenToR e1 e2 e3) = [|FromThenToR e1 e2 e3|]
+
+instance Lift Stmt where
+  lift (BindS p e) = [|BindS p e|]
+  lift (LetS d) = [|LetS d|]
+  lift (NoBindS e) = [|NoBindS e|]
+  lift (ParS s) = [|ParS s|]
+
+instance Lift Match where
+  lift (Match p b d) = [|Match p b d|]
+
+instance Lift Type where
+  lift (ForallT n c t) = [|ForallT n c t|]
+  lift (VarT n) = [|VarT n|]
+  lift (ConT n) = [|ConT n|]
+  lift (TupleT i) = [|TupleT i|]
+  lift (ArrowT) = [|ArrowT|]
+  lift (ListT) = [|ListT|]
+  lift (AppT t1 t2) = [|AppT t1 t2|]
+
+instance Lift Pat where
+  lift (LitP l) = [|LitP l|]
+  lift (VarP n) = [|VarP n|]
+  lift (TupP p) = [|TupP p|]
+  lift (ConP n p) = [|ConP n p|]
+  lift (InfixP p1 n p2) = [|InfixP p1 n p2|]
+  lift (TildeP p) = [|TildeP p|]
+  lift (AsP n p) = [|AsP n p|]
+  lift (WildP) = [|WildP|]
+  lift (RecP n f) = [|RecP n f|]
+  lift (ListP p) = [|ListP p|]
+  lift (SigP p t) = [|SigP p t|]
+
+instance Lift Lit where
+  lift (CharL c) = [|CharL c|]
+  lift (StringL s) = [|StringL s|]
+  lift (IntegerL i) = [|IntegerL i|]
+  lift (RationalL r) = [|RationalL r|]
+  lift (IntPrimL i) = [|IntPrimL i|]
+#if __GLASGOW_HASKELL__ >= 610
+  lift (WordPrimL i) = [|WordPrimL i|]
+#endif
+  lift (FloatPrimL r) = [|FloatPrimL r|]
+  lift (DoublePrimL r) = [|DoublePrimL r|]
+
+instance Lift Dec where
+  lift (FunD n c) = [|FunD n c|]
+  lift (ValD p b d) = [|ValD p b d|]
+  lift (DataD c n l1 l2 l3) = [|DataD c n l1 l2 l3|]
+  lift (NewtypeD c n l1 c' l2) = [|NewtypeD c n l1 c' l2|]
+  lift (TySynD n l t) = [|TySynD n l t|]
+  lift (ClassD c n l1 l2 l3) = [|ClassD c n l1 l2 l3|]
+  lift (InstanceD c t d) = [|InstanceD c t d|]
+  lift (SigD n t) = [|SigD n t|]
+  lift (ForeignD f) = [|ForeignD f|]
+
+instance Lift NameSpace where
+  lift (VarName) = [|VarName|]
+  lift (DataName) = [|DataName|]
+  lift (TcClsName) = [|TcClsName|]
+
+instance Lift Body where
+  lift (GuardedB l) = [|GuardedB l|]
+  lift (NormalB e) = [|NormalB e|]
+
+instance Lift Clause where
+  lift (Clause p b d) = [|Clause p b d|]
+
+instance Lift Con where
+  lift (NormalC n m) = [|NormalC n m|]
+  lift (RecC n s) = [|RecC n s|]
+  lift (InfixC s1 n s2) = [|InfixC s1 n s2|]
+  lift (ForallC n c c') = [|ForallC n c c'|]
+
+instance Lift FunDep where
+  lift (FunDep l1 l) = [|FunDep l1 l|]
+
+instance Lift Foreign where
+  lift (ImportF c f s n t) = [|ImportF c f s n t|]
+  lift (ExportF c s n t) = [|ExportF c s n t|]
+
+instance Lift Guard where
+  lift (NormalG e) = [|NormalG e|]
+  lift (PatG s) = [|PatG s|]
+
+instance Lift Strict where
+  lift (IsStrict) = [|IsStrict|]
+  lift (NotStrict) = [|NotStrict|]
+
+instance Lift Safety where
+  lift (Unsafe) = [|Unsafe|]
+  lift (safe) = [|safe|]
+
+instance Lift Callconv where
+  lift (CCall) = [|CCall|]
+  lift (StdCall) = [|StdCall|]
+
+instance Lift Rational where
+  lift r = let n = numerator r
+               d = denominator r
+           in [|n % d|]
+
+instance Lift Double where
+  lift d = [| D# $(return (LitE (DoublePrimL (toRational d)))) |]    
+-- eof

@@ -0,0 +1,42 @@+\textbf{Rutinas auxiliares}
+
+Leonel Fonseca. 2010.
+
+\begin{code}
+{-# OPTIONS  -fglasgow-exts       #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+module Database.TA.Helper.TH where
+
+import Control.Monad.Trans (liftIO)
+import Database.Oracle.Enumerator
+import Language.Haskell.TH
+
+\end{code} 
+
+import Control.Monad.State.Strict
+import Control.Monad (liftM)
+import Control.Monad.Trans (liftIO, lift)
+
+
+\bigskip
+
+Rutina para imprimir un mensaje desde la mónada @DBM@.
+
+\begin{code}
+
+pr x =  liftIO ( putStrLn x )
+
+\end{code}
+
+
+Para ver código de la mónada Q.
+
+\begin{code}
+
+verCodigo q = runQ q >>= putStrLn . pprint
+
+verAST    q = runQ q
+
+\end{code}
+

@@ -0,0 +1,49 @@+{- |
+      Rutinas auxiliares.
+
+-}
+
+module Database.TA.Helper.Text
+    ( proper
+    , palabras
+    )
+
+where
+
+import Data.Char   ( toLower, toUpper, isSpace )
+import Data.List   ( mapAccumL ) 
+
+
+-- | Función tomada de internet...
+
+ 
+proper :: String -> String
+proper = unwords . map capitalize . words
+  where capitalize (x:xs) = toUpper x : map toLower xs
+                                  
+
+
+{- | 
+       'palabras' divide una hilera en una lista
+        de palabras y espacios en blanco.
+       La división ocurre cuando se encuentra con algún
+       caracter que representa espacio.
+       Los espacios se conservan. 
+       A diferencia con words:
+           donde  (words x) /= concat (words x)
+       'palabras' cumple con
+                  (palabras x) == concat (palabras x)
+-}
+palabras s =  
+    let (acc,l) = mapAccumL dividir [] s 
+     in filter (not . null) $ l ++ [(reverse acc)]
+  where
+    nosp = not . isSpace
+    dividir acc x 
+        | null acc                         =  (x:acc, []   )
+        | isSpace (head acc) && isSpace x  =  (x:acc, []   )
+        | isSpace (head acc) && nosp x     =  ([x]  , reverse acc)
+        | nosp    (head acc) && isSpace x  =  ([x]  , reverse acc)
+        | otherwise                        =  (x:acc, []   ) 
+                                  
+-- eof                                  

@@ -0,0 +1,19 @@+Copyright (c) 2009 Paul H. Liu <paul@thev.net>
+
+This software is provided 'as-is', without any express or implied
+warranty. In no event will the authors be held liable for any damages
+arising from the use of this software.
+
+Permission is granted to anyone to use this software for any purpose,
+including commercial applications, and to alter it and redistribute it
+freely, subject to the following restrictions:
+
+1. The origin of this software must not be misrepresented; you must not
+   claim that you wrote the original software. If you use this software
+   in a product, an acknowledgment in the product documentation would
+   be appreciated but is not required.
+
+2. Altered source versions must be plainly marked as such, and must not
+   be misrepresented as being the original software.
+
+3. This notice may not be removed or altered from any source distribution.

@@ -0,0 +1,26 @@+Copyright (c) Ian Lynagh.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. The names of the author may not be used to endorse or promote
+   products derived from this software without specific prior written
+   permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

@@ -0,0 +1,38 @@+{- | Biblioteca para TA. -}
+
+{-  2010/jun/03. Leonel Fonseca. Construcción. -}
+
+{-# OPTIONS  -fglasgow-exts       #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+module Database.TA.TAB
+       ( module Database.Oracle.Enumerator
+       , module Data.Typeable
+       , CR     (..)
+       , InstanciaCR (..)
+       , ambBDCompatible
+       , collcatM
+       , concatM
+       , empalmar
+       , emptySelect 
+       , exnAt
+       , genSelect
+       , revertir
+       , verASTs
+       ) 
+
+where
+
+import Data.Typeable
+import Control.Monad (liftM)
+import Database.Oracle.Enumerator
+       --  Para especificar qué se quiere consultar. 
+import Database.TA.Core.RIS  
+          ( CR(..), InstanciaCR(..), emptySelect )
+       -- Generador de código
+import Database.TA.Core.GenSelect 
+          ( empalmar, genSelect, ambBDCompatible, verASTs )  
+import Database.TA.Core.Infraestructura 
+          ( exnAt, collcatM, concatM, revertir )
+
+-- eof

@@ -0,0 +1,30 @@+Copyright (c)2010, Leonel Fonseca
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Leonel Fonseca nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,29 @@+  This is Tránsito Abierto Library Version 0.1. (September 2010).
+
+  To install use:
+
+      cabal install ta
+     
+  In case you want to play a bit with the examples, take note of this:
+
+      The examples use a database table that can be created using the
+      script make_twoColumns.sql.
+
+      RCSdef.lhs contains definitions used by Ex01.lhs and Ex02.lhs.
+
+      You can make executables:
+
+         ghc --make Ex01
+         ghc --make Ex02
+ 
+      You download a document with examples at:
+
+         http://proftica.googlegroups.com/web/Examples.pdf
+
+      Or you can use lhs2TeX on Database/TA/Examples/Examples.lhs.
+  
+  If you want to work in the library, you may want a structured way to
+  browse the source files via Haddock: 
+
+         runghc setup haddock --hyperlink-source
+         runghc setup copy

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

@@ -0,0 +1,99 @@+Name:      ta++Version:   0.1++Synopsis:  Transito Abierto: convenience library when using Takusen and Oracle.  ++Description:+    The purpose of this library is to add convenience in database+    accesses when using Takusen and Oracle, by generating boilerplate code.+    It's not a substitute to Takusen.+    .+    Transito Abierto is implemented in the library (Database.TA.TAB) and this+    also provides functionality used by the generated code.+    .+    TA will generate the declarations of: +       .+       1. The datatype declaration for the result of a query,+       .+       2. The DBM action that run the query and accumulates+              the result,+       .+       3.Optionally, a meta-variable whose value is the former two declarations.+    .+    This initial version has the following benefits:+    .+    - TA contains code to test if your program will fail before it runs, based+      on comparing the original generated code versus a fresh+      version of generated code,+    .+    - The user can code queries with more than eight columns length,+    .+    - The code generator process is aware if the column can be null,+      and generate the appropiate code.+    .+    Some TA drawbacks at this point are:+    .+    - The user only can specify queries, that is, select statements.+    . +    - The select specification is awkward.+    .+    - The select specification is a list. You can specify one or many+      under a sole name.+    - You can bind parameters or not (by means of [[]]).+    .+    - Functions names and constructors are named in spanish. ++License:      BSD3+License-file: LICENSE++Author:       Leonel Fonseca++Maintainer:   Leonel Fonseca <leonelfl@gmail.com>++Category:     Database++Build-Type:   Simple++Copyright:    Leonel Fonseca, 2010++Homepage:     not available++Stability:    Experimental++Tested-With:  GHC==6.12++Extra-source-files:+    README, LICENSE, +    Database/TA/License.CCA +    Database/TA/License.th-lift+    Database/TA/Examples/RCSdef.lhs +    Database/TA/Examples/Ex01.lhs +    Database/TA/Examples/Ex02.lhs +    Database/TA/Examples/Examples.lhs+    Database/TA/Examples/make_twoColumns.sql++Cabal-Version:	    >= 1.2.3++Library+  Exposed-modules: +      Database.TA.TAB +    , Database.TA.Helper.TH+    , Database.TA.Helper.Text+    , Database.TA.Helper.LiftQ+    , Database.TA.Core.RIS+    , Database.TA.Core.Opciones+    , Database.TA.Core.Nucleo+    , Database.TA.Core.MapaBase+    , Database.TA.Core.Infraestructura+    , Database.TA.Core.GenSelect+   +  Build-depends:   base >= 4 && < 5, +                   template-haskell >= 2.4 && < 2.5, +                   Takusen >= 0.8.5,+                   mtl >= 1.1, time >= 1.1, containers >= 0.3, ghc-prim++  Extensions:      TemplateHaskell, +                   MagicHash, +                   TypeSynonymInstances+