module Database.Design.Ampersand.Prototype.ValidateEdit where

import Prelude hiding (putStr, putStrLn)
import Data.List
import Data.Maybe
import System.FilePath hiding (isValid)
import Database.Design.Ampersand
import Database.Design.Ampersand.Basics
import Database.Design.Ampersand.Prototype.PHP
import Database.Design.Ampersand.FSpec.SQL
import qualified Database.Design.Ampersand.Misc.Options as Opts

fatal :: Int -> String -> a
fatal = fatalMsg "Prototype.ValidateEdit"


tempDbName :: String
tempDbName = "ampersand_temporaryeditvalidationdb"

validateEditScript :: FSpec -> [Population] -> [Population] -> [Char] -> IO Bool
validateEditScript fSpec beforePops afterPops editScriptPath =
 do { mFileContents <- readUTF8File editScriptPath
    ; case mFileContents of
        Left err -> error $ "ERROR reading file " ++ editScriptPath ++ ":\n" ++ err
        Right editScript ->
         do { --putStrLn $ "Population before edit operations:\n" ++ show beforePops
            ; --putStrLn $ "Expected population after edit operations:\n" ++ show afterPops
            ; putStrLn $ "Edit script:\n" ++ editScript
            
            ; createTempDatabase fSpec beforePops
            ; let phpDir = Opts.dirPrototype (getOpts fSpec) </> "php"
            ; let phpScript = "ValidateEdit.php"
            ; putStrLn $ "Executing php script "++ phpDir </> phpScript
            ; _ <- executePHP (Just phpDir) phpScript [editScript] -- TODO: escape
            
            ; let expectedConceptTables  = [ (c,atoms) | PCptPopu c atoms <- afterPops ]
            ; let expectedRelationTables = [ (d,pairs) | PRelPopu d pairs <- afterPops ]
            ; let actualConcepts = [ c | c<- allConcepts fSpec, c /= ONE, name c /= "SESSION" ] -- TODO: are these the right concepts and decls?
            ; let actualRelations = allDecls fSpec            --
            ; actualConceptTables <- mapM (getSqlConceptTable fSpec) actualConcepts
            ; actualRelationTables <- mapM (getSqlRelationTable fSpec) actualRelations
            ; let commonConcepts = getCommons expectedConceptTables actualConceptTables
            ; let commonRelations = getCommons expectedRelationTables actualRelationTables
            
            ; putStrLn $ "\n--- Validation results ---\n" 
            ; putStrLn $ "Actual concept tables:\n" ++ unlines [ name c ++ ": " ++ show atoms | (c,atoms) <- actualConceptTables ] 
            ; putStrLn $ "Actual relations:\n" ++ unlines [ name d ++ ": " ++ show pairs | (d,pairs) <- actualRelationTables ]

            ; putStrLn $ "Expected concept tables:\n" ++ unlines [ name c ++ ": " ++ show atoms | (c,atoms) <- expectedConceptTables ] 
            ; putStrLn $ "Expected relations:\n" ++ unlines [ name d ++ ": " ++ show pairs | (d,pairs) <- expectedRelationTables ] 

            ; let conceptDiffs  = showDiff "Actual population" "concepts" (map fst expectedConceptTables) (map fst actualConceptTables)
            ; let relationDiffs = showDiff "Actual population" "relations" (map fst expectedRelationTables) (map fst actualRelationTables)
            
            ; let commonConceptDiffs  = concat [ showDiff (name c) "atoms" expAtoms resAtoms | (c, expAtoms, resAtoms) <- commonConcepts ]
            ; let commonRelationDiffs = concat [ showDiff (name r) "pairs" expPairs resPairs | (r, expPairs, resPairs) <- commonRelations ]

            ; putStrLn $ "\n--- Validation summary ---\n" 
            
            ; if null conceptDiffs 
              then putStrLn "Expected and actual populations contain the same concepts"
              else putStrLn $ unlines $ conceptDiffs
            ; putStrLn ""
            ; if null relationDiffs 
              then putStrLn "Expected and actual populations contain the same relations"
              else putStrLn $ unlines $ relationDiffs
            ; putStrLn ""            
            ; if null commonConceptDiffs 
              then putStrLn "Common concepts are equal"
              else putStrLn $ unlines $ "Differences for common concepts:"  : commonConceptDiffs 
            ; putStrLn ""            
            ; if null commonRelationDiffs
              then putStrLn "Common relations are equal"
              else putStrLn $ unlines $ "Differences for common relations:" : commonRelationDiffs 
            
            ; let isValid = null $ conceptDiffs ++ relationDiffs ++ commonConceptDiffs ++ commonRelationDiffs
            ; putStrLn $ "\nValidation " ++ if isValid then "was successful." else "failed."
            ; return  isValid
            }
    }

createTempDatabase :: FSpec -> [Population] -> IO ()
createTempDatabase fSpec pops =
 do { _ <- executePHPStr . showPHP $ sqlServerConnectPHP fSpec ++
                                     createTempDbPHP tempDbName ++
                                     createTablesPHP fSpec ++
                                     populateTablesWithPopsPHP fSpec pops
    ; return ()
    }

getSqlConceptTable :: FSpec -> A_Concept -> IO (A_Concept, [String])
getSqlConceptTable fSpec c =
 do { -- to prevent needing a unary query function, we add a dummy NULL column and use `src` and `tgt` as column names (in line with what performQuery expects)
      let query = case lookupCpt fSpec c of
                    []                      -> fatal 58  "No concept table for concept \"" ++ name c ++ "\""
                    (table,conceptField):_ -> "SELECT DISTINCT `" ++ fldname conceptField ++ "` as `src`, NULL as `tgt`"++
                                              " FROM `" ++ name table ++ "`" ++
                                              " WHERE `" ++ fldname conceptField ++ "` IS NOT NULL"
    --; putStrLn $ "Query for concept " ++ name c ++ ":" ++ query 
    ; atomsDummies <- performQuery (getOpts fSpec) tempDbName query
    ; return (c, map fst atomsDummies)
    }

getSqlRelationTable :: FSpec -> Declaration -> IO (Declaration, [Paire])
getSqlRelationTable fSpec d =
 do { let query = prettySQLQuery fSpec 0 d
 
    --; putStrLn $ "Query for decl " ++ name d ++ ":" ++ query 
    ; pairs <- performQuery (getOpts fSpec) tempDbName query
    ; return (d, [mkPair src tgt | (src,tgt) <-pairs])
    }
-- TODO: are we going to use this data type?

type EditScript = [SQLEditOp]

data SQLEditOp = SQLAddToConcept { atomNm :: String, conceptNm :: String }
               | SQLDelete { relationNm :: String, relationIsFlipped :: Bool
                           , parentAtomNm :: String, childAtomNm :: String }
               | SQLUpdate { relationNm :: String, relationIsFlipped :: Bool
                           , parentAtomNm :: String, parentConceptNm ::String
                           , childAtomNm :: String, childConceptNm ::String
                           , parentOrChild :: ParentOrChild, originalAtomNm :: String 
                           }

data ParentOrChild = Parent | Child deriving Show

{- JSON for edit commands from Database.PHP:

 { dbCmd: 'addToConcept', atom:atom, concept:concept }

 { dbCmd: 'update', relation:relation, isFlipped:relationIsFlipped
 , parentAtom:parentAtom, parentConcept:parentConcept
 , childAtom:childAtom, childConcept:childConcept
 , parentOrChild:parentOrChild, originalAtom:originalAtom
 }

 { dbCmd: 'delete', relation:relation, isFlipped:relationIsFlipped
 , parentAtom:parentAtom, childAtom:childAtom
 } 
 
-}

-- Utils

getCommons :: Eq a => [(a,bs)] -> [(a,bs)] -> [(a,bs,bs)]
getCommons elts1 elts2 = catMaybes
  [ case find (\(a',_)-> a' == a) elts2 of
      Just (_,bs2) -> Just (a, bs1, bs2)
      Nothing      -> Nothing 
  | (a,bs1) <- elts1 
  ]
  
showDiff :: (Eq a, Show a) => String -> String -> [a] -> [a] -> [String]
showDiff entityStr elementsStr expected actual =
  let unexpected = actual \\ expected
      missing    = expected \\ actual
  in  [ "!! " ++ entityStr ++ " is missing expected " ++ elementsStr ++ ": " ++ show missing | not . null $ missing ] ++
      [ "!! " ++ entityStr ++ " has unexpected " ++ elementsStr ++ ": " ++ show unexpected | not . null $ unexpected ]