GenSelect.hs

-- | '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 [[]]  



-}