module Components.Parsers.ServerSchemaJsonParser (fetchArguments) where

import Control.Exception (throw)
import Text.JSON (
    JSValue(JSObject),
    JSObject,
    Result(Ok),
    valFromObj,
    decode
  )
import Model.ServerExceptions (
    SchemaException(
      ReadSchemaFileException,
      SchemaDuplicateServerObjectException,
      SchemaDuplicateInterfaceException,
      ReadJsonObjectsException,
      ReadServerNameStringException,
      ReadScalarFieldException,
      ReadDatabaseTableException,
      ReadJsonStringException,
      ReadPseudonymsException,
      ReadInterfaceInstancesException,
      ReadDatabaseIdsException,
      ReadJsonStringListException,
      ReadDatabaseRelationshipsException,
      ScalarFieldDataTypeException,
      ReadDatabaseRelationshipsCardinalityException,
      PrimaryObjectNotFoundException,
      SchemaDuplicateException,
      InterfaceScalarTypesException
    )
  )
import Components.Util (snd3,fst3,fst4)


fetchArguments :: FilePath -> IO ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])])
fetchArguments fp = do 
    schema <- Prelude.readFile fp
    return $ parseSchema schema
parseSchema :: String -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])])
parseSchema str = parseHelper $ checkJSValueListValue (decode str :: Result (JSObject JSValue))
checkJSValueListValue :: Result (JSObject JSValue) -> (JSObject JSValue)
checkJSValueListValue (Ok a) = a
checkJSValueListValue _ = throw ReadSchemaFileException
parseHelper :: JSObject JSValue -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])],[(String,[String],[String])])
parseHelper json 
    | (isValidParentScalars soa sss)==False = throw InterfaceScalarTypesException
    | (isWithoutDups svrobjs sss sos sor soa)==False = throw SchemaDuplicateException
    | otherwise = (svrobjs,sss,sos,sdbn,sor,soa)
  where
    (svrobjs,sss,sos,sdbn,sor) = parsePrimitivesIterator [] [] [] [] [] $ getObjects (valFromObj "PrimaryObjects" json :: Result [JSObject JSValue])
    soa = parseParentsIterator [] $ getObjects (valFromObj "Interfaces" json :: Result [JSObject JSValue])
parsePrimitivesIterator :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[(String,[String])])] -> [(String,[String],String)] -> [(String,String,[String])] -> [JSObject JSValue] -> ([(String,[String])],[(String,[(String,String,[(String,[(String,String,String,String)])])])],[(String,[(String,[String])])],[(String,[String],String)],[(String,String,[String])])
parsePrimitivesIterator svrobjs sss sos sdbn sor [] = (svrobjs,sss,sos,sdbn,sor)
parsePrimitivesIterator svrobjs sss sos sdbn sor (obj:t) = if any ((==) name . fst3) sdbn then throw SchemaDuplicateServerObjectException else parsePrimitivesIterator ((name,pseudonyms):svrobjs) ((name,scalars):sss) ((name,nestedobjects):sos) ((name,uids,table):sdbn) (sor++(processRelationships relationships)) t
  where
    name = getString (valFromObj "ServerName" obj :: Result String) 0
    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
    scalars = getScalars $ getObjects (valFromObj "ScalarFields" obj :: Result [JSObject JSValue])
    nestedobjects = getObjectFields $ getObjects (valFromObj "ObjectFields" obj :: Result [JSObject JSValue])
    uids = getStringList (valFromObj "UniqueIds" obj :: Result [String]) 2
    table = getString (valFromObj "DatabaseTable" obj :: Result String) 2
    relationships = getListStringList (valFromObj "DatabaseRelationships" obj :: Result [[String]])
parseParentsIterator :: [(String,[String],[String])] -> [JSObject JSValue] -> [(String,[String],[String])]
parseParentsIterator soa (obj:t) = if any ((==) name . fst3) soa then throw SchemaDuplicateInterfaceException else parseParentsIterator ((name,pseudonyms,children):soa) t
  where
    name = getString (valFromObj "ServerName" obj :: Result String) 0
    pseudonyms = getStringList (valFromObj "Pseudonyms" obj :: Result [String]) 0
    children = getStringList (valFromObj "ServerChildren" obj :: Result [String]) 1
parseParentsIterator soa [] = soa
getObjects :: Result [JSObject JSValue] -> [JSObject JSValue]
getObjects (Ok objects) = objects
getObjects _ = throw ReadJsonObjectsException
getString :: Result String -> Int -> String
getString (Ok str) _ = str
getString _ 0 = throw ReadServerNameStringException
getString _ 1 = throw ReadScalarFieldException
getString _ 2 = throw ReadDatabaseTableException
getString _ _ = throw ReadJsonStringException
getStringList :: Result [String] -> Int -> [String]
getStringList (Ok rlt) _ = rlt
getStringList _ 0 = throw ReadPseudonymsException
getStringList _ 1 = throw ReadInterfaceInstancesException
getStringList _ 2 = throw ReadDatabaseIdsException
getStringList _ _ = throw ReadJsonStringListException
getListStringList :: Result [[String]] -> [[String]]
getListStringList (Ok rlt) = rlt
getListStringList _ = throw ReadDatabaseRelationshipsException
checkScalars :: Result [JSObject JSValue] -> [(String,String,[(String,[(String,String,String,String)])])]
checkScalars = getScalars . getObjects
getScalars :: [JSObject JSValue] -> [(String,String,[(String,[(String,String,String,String)])])]
getScalars [] = []
getScalars (obj:t) = (getString (valFromObj "Name" obj :: Result String) 1,getType (valFromObj "Type" obj :: Result String),getScalarArguments $ getObjects (valFromObj "Arguments" obj :: Result [JSObject JSValue])):getScalars t
getScalarArguments :: [JSObject JSValue] -> [(String,[(String,String,String,String)])]
getScalarArguments [] = []
getScalarArguments (h:t) = (name,options):getScalarArguments t
  where
    name = getString (valFromObj "Name" h :: Result String) 1
    options = getScalarArgumentOptions (getObjects (valFromObj "Options" h :: Result [JSObject JSValue]))
getScalarArgumentOptions :: [JSObject JSValue] -> [(String,String,String,String)]
getScalarArgumentOptions (h:t) = (name,typ,prefix,suffix):getScalarArgumentOptions t
  where
    name = getString (valFromObj "Name" h :: Result String) 1
    typ = getType (valFromObj "Type" h :: Result String)
    prefix = getString (valFromObj "Prefix" h :: Result String) 1
    suffix = getString (valFromObj "Suffix" h :: Result String) 1
getScalarArgumentOptions [] = []
getObjectFields :: [JSObject JSValue] -> [(String,[String])]
getObjectFields (h:t) = (obj, names):getObjectFields t
  where
    obj = getString (valFromObj "ServerName" h :: Result String) 0
    names = getStringList (valFromObj "Names" h :: Result [String]) 0
getObjectFields [] = []
getType :: Result String -> String
getType (Ok "Text") = "Text"
getType (Ok "Double") = "Double"
getType (Ok "Int64") = "Int64"
getType (Ok "Boolean") = "Boolean"
getType _ = throw ScalarFieldDataTypeException
processRelationships :: [[String]] -> [(String,String,[String])]
processRelationships = map (\x->(getFirst x,getThird x, x))
getFirst :: [String] -> String
getFirst (h:t) = h
getFirst _ = throw ReadDatabaseRelationshipsCardinalityException
getThird :: [String] -> String
getThird (h1:h2:h3:t) = h3
getThird _ = throw ReadDatabaseRelationshipsCardinalityException
-- no duplicated names in schema
isWithoutDups :: [(String,[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,[(String,[String])])] -> [(String,String,[String])] -> [(String,[String],[String])] -> Bool
isWithoutDups sobjs sss sos sor soa = (isNoDupsNames $ concat $ (++) (map snd sobjs) $ map snd3 soa)&&(isNoDupsScalars sss)&&(isNoDupsNestedObjects sos)&&(isNoDupsRelationships sor)
isNoDupsNames :: [String] -> Bool
isNoDupsNames (nm:rst) = (elem nm rst==False)&&isNoDupsNames rst
isNoDupsNames [] = True
isNoDupsScalars :: [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
isNoDupsScalars = all (isNoDupsScalarNames . snd)
isNoDupsScalarNames :: [(String,String,[(String,[(String,String,String,String)])])] -> Bool
isNoDupsScalarNames ((name,_,args):rst) = (all ((/=) name . fst3) rst)&&(isNoDupsScalarArguments args)&&isNoDupsScalarNames rst
isNoDupsScalarNames [] = True
isNoDupsScalarArguments :: [(String,[(String,String,String,String)])] -> Bool
isNoDupsScalarArguments ((name,opts):rst) = (all (\(n,o)->n/=name&&isNoDupsArgumentOptions o) rst)&&isNoDupsScalarArguments rst
isNoDupsScalarArguments [] = True
isNoDupsArgumentOptions :: [(String,String,String,String)] -> Bool
isNoDupsArgumentOptions ((name,_,_,_):rst) = (all ((/=) name . fst4) rst)&&isNoDupsArgumentOptions rst
isNoDupsArgumentOptions [] = True
isNoDupsNestedObjects :: [(String,[(String,[String])])] -> Bool
isNoDupsNestedObjects ((_,[]):rst) = isNoDupsNestedObjects rst
isNoDupsNestedObjects ((obj,(no,nms):objs):rst) = noDupObj&&noDupNms&&isNoDupsNestedObjects ((obj,objs):rst)
  where
    noDupObj = all ((/=) no . fst) objs
    noDupNms = isNoDupsNames nms
isNoDupsNestedObjects [] = True
isNoDupsRelationships :: [(String,String,[String])] -> Bool
isNoDupsRelationships ((from,to,_):rst) = (all (\(a,b,_)->from/=a||to/=b) rst)&&isNoDupsRelationships rst
isNoDupsRelationships [] = True
-- shared scalars are same type
isValidParentScalars :: [(String,[String],[String])] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
isValidParentScalars ((_,_,(h:nxt:cld)):t) sss = (isValidScalarsType (getPrimitiveScalars h sss) (nxt:cld) sss)&&isValidParentScalars t sss
isValidParentScalars ((_,_,_:[]):t) sss = isValidParentScalars t sss
isValidParentScalars ((_,_,[]):t) sss = isValidParentScalars t sss
isValidParentScalars [] _ = True
getPrimitiveScalars :: String -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> [(String,String)]
getPrimitiveScalars name ((nm,st):t) = if name==nm then map (\(n,tp,_)->(n,tp)) st else getPrimitiveScalars name t
getPrimitiveScalars _ [] = throw PrimaryObjectNotFoundException
isValidScalarsType :: [(String,String)] -> [String] -> [(String,[(String,String,[(String,[(String,String,String,String)])])])] -> Bool
isValidScalarsType ((name,typ):t) cld sss = all (\chld->all (\(n,tp)->(n==name&&tp==typ)||n/=name) $ getPrimitiveScalars chld sss) cld
isValidScalarsType [] _ _ = True