{-# LANGUAGE FlexibleContexts #-} module PGIP.GraphQL.Resolver.SignatureMorphism (resolve) where import PGIP.GraphQL.Resolver.ToResult import PGIP.GraphQL.Result as GraphQLResult import PGIP.GraphQL.Result.LanguageMapping as GraphQLResultLanguageMapping import PGIP.GraphQL.Result.LogicMapping as GraphQLResultLogicMapping import PGIP.GraphQL.Result.Mapping as GraphQLResultMapping import PGIP.GraphQL.Result.SymbolMapping as GraphQLResultSymbolMapping import PGIP.Shared import Driver.Options import Persistence.Database import Persistence.Utils import Persistence.Schema as DatabaseSchema import Database.Esqueleto import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fail resolve :: HetcatsOpts -> Cache -> Int -> IO (Maybe GraphQLResult.Result) resolve opts _ idVar = onDatabase (databaseConfig opts) $ resolveDB idVar resolveDB :: (MonadIO m, MonadFail m) => Int -> DBMonad m (Maybe GraphQLResult.Result) resolveDB idVar = do signatureMorphismL <- select $ from $ \(signature_morphisms `InnerJoin` signaturesSource `InnerJoin` signaturesTarget) -> do on (signaturesTarget ^. SignatureId ==. signature_morphisms ^. SignatureMorphismTargetId) on (signaturesSource ^. SignatureId ==. signature_morphisms ^. SignatureMorphismSourceId) where_ (signature_morphisms ^. SignatureMorphismId ==. val (toSqlKey $ fromIntegral idVar)) return (signature_morphisms, signaturesSource, signaturesTarget) case signatureMorphismL of [] -> return Nothing (signatureMorphismEntity@(Entity signatureMorphismKey _), signatureSource, signatureTarget) : _ -> do logicMappingResult <- getLogicMappingResult signatureMorphismKey mappingResults <- getMappingsResults signatureMorphismKey symbolMappingResults <- getSymbolMappingResults signatureMorphismKey return $ Just $ GraphQLResult.SignatureMorphismResult $ signatureMorphismToResult signatureMorphismEntity signatureSource signatureTarget logicMappingResult mappingResults symbolMappingResults getLogicMappingResult :: (MonadIO m, MonadFail m) => SignatureMorphismId -> DBMonad m GraphQLResultLogicMapping.LogicMapping getLogicMappingResult signatureMorphismKey = do (logicMappingEntity@(Entity logicMappingKey _), logicSource, logicTarget) : _ <- select $ from $ \ (signature_morphisms `InnerJoin` logic_mappings `InnerJoin` logicsSource `InnerJoin` logicsTarget) -> do on (logic_mappings ^. LogicMappingTargetId ==. logicsTarget ^. LogicId) on (logic_mappings ^. LogicMappingSourceId ==. logicsSource ^. LogicId) on (signature_morphisms ^. SignatureMorphismLogicMappingId ==. logic_mappings ^. LogicMappingId) where_ (signature_morphisms ^. SignatureMorphismId ==. val signatureMorphismKey) return (logic_mappings, logicsSource, logicsTarget) languageMappingResult <- getLanguageMapping logicMappingKey return $ logicMappingToResult logicMappingEntity logicSource logicTarget languageMappingResult getMappingsResults :: MonadIO m => SignatureMorphismId -> DBMonad m [GraphQLResultMapping.Mapping] getMappingsResults signatureMorphismKey = do mappingData <- select $ from $ \(signature_morphisms `InnerJoin` mappingsSql `InnerJoin` loc_id_bases `LeftOuterJoin` conservativity_statuses `InnerJoin` loc_id_basesSource `InnerJoin` loc_id_basesTarget `LeftOuterJoin` loc_id_basesOMS `LeftOuterJoin` languages) -> do on (languages ?. LanguageId ==. mappingsSql ^. MappingFreenessParameterLanguageId) on (loc_id_basesOMS ?. LocIdBaseId ==. mappingsSql ^. MappingFreenessParameterOMSId) on (loc_id_basesTarget ^. LocIdBaseId ==. mappingsSql ^. MappingTargetId) on (loc_id_basesSource ^. LocIdBaseId ==. mappingsSql ^. MappingSourceId) on (conservativity_statuses ?. ConservativityStatusId ==. mappingsSql ^. MappingConservativityStatusId) on (loc_id_bases ^. LocIdBaseId ==. coerceId (mappingsSql ^. MappingId)) on (mappingsSql ^. MappingSignatureMorphismId ==. signature_morphisms ^. SignatureMorphismId) where_ (signature_morphisms ^. SignatureMorphismId ==. val signatureMorphismKey) return (mappingsSql, loc_id_bases, signature_morphisms, conservativity_statuses, loc_id_basesSource, loc_id_basesTarget, loc_id_basesOMS, languages) return $ map (\ (mapping, locIdBase, signatureMorphismEntity, conservativityStatusM, locIdBaseSource, locIdBaseTarget, freenesParameterOMSLocIdM, freenessParameterLanguageM) -> mappingToResult mapping locIdBase signatureMorphismEntity conservativityStatusM locIdBaseSource locIdBaseTarget freenesParameterOMSLocIdM freenessParameterLanguageM ) mappingData getSymbolMappingResults :: MonadIO m => SignatureMorphismId -> DBMonad m [GraphQLResultSymbolMapping.SymbolMapping] getSymbolMappingResults signatureMorphismKey = do symbolData <- select $ from $ \(signature_morphisms `InnerJoin` symbol_mappings `InnerJoin` symbolsSource `InnerJoin` symbolsTarget `InnerJoin` symbolLoc_id_basesSource `InnerJoin` symbolLoc_id_basesTarget `LeftOuterJoin` file_rangesSource `LeftOuterJoin` file_rangesTarget) -> do on (file_rangesTarget ?. FileRangeId ==. symbolsTarget ^. SymbolFileRangeId) on (file_rangesSource ?. FileRangeId ==. symbolsSource ^. SymbolFileRangeId) on (symbolLoc_id_basesTarget ^. LocIdBaseId ==. coerceId (symbolsTarget ^. SymbolId)) on (symbolLoc_id_basesSource ^. LocIdBaseId ==. coerceId (symbolsSource ^. SymbolId)) on (coerceId (symbolsTarget ^. SymbolId) ==. symbol_mappings ^. SymbolMappingTargetId) on (coerceId (symbolsSource ^. SymbolId) ==. symbol_mappings ^. SymbolMappingSourceId) on (signature_morphisms ^. SignatureMorphismId ==. symbol_mappings ^. SymbolMappingSignatureMorphismId) where_ (signature_morphisms ^. SignatureMorphismId ==. val signatureMorphismKey) return ( (symbolLoc_id_basesSource, symbolsSource, file_rangesSource) , (symbolLoc_id_basesTarget, symbolsTarget, file_rangesTarget) ) return $ map (uncurry symbolMappingToResult) symbolData getLanguageMapping :: (MonadIO m, MonadFail m) => LogicMappingId -> DBMonad m GraphQLResultLanguageMapping.LanguageMapping getLanguageMapping logicMappingKey = do (languageMappingEntity, languageSource, languageTarget) : _ <- select $ from $ \(logic_mappings `InnerJoin` language_mappings `InnerJoin` languagesSource `InnerJoin` languagesTarget) -> do on (language_mappings ^. LanguageMappingTargetId ==. languagesTarget ^. LanguageId) on (language_mappings ^. LanguageMappingSourceId ==. languagesSource ^. LanguageId) on (logic_mappings ^. LogicMappingLanguageMappingId ==. language_mappings ^. LanguageMappingId) where_ (logic_mappings ^. LogicMappingId ==. val logicMappingKey) return (language_mappings, languagesSource, languagesTarget) return $ languageMappingToResult languageMappingEntity languageSource languageTarget