content: {-# LANGUAGE DeriveGeneric   #-}
  {-# LANGUAGE TemplateHaskell #-}
  -- Copyright 2022 United States Government as represented by the Administrator
  -- of the National Aeronautics and Space Administration. All Rights Reserved.
  --
  -- Disclaimers
  --
  -- Licensed under the Apache License, Version 2.0 (the "License"); you may
  -- not use this file except in compliance with the License. You may obtain a
  -- copy of the License at
  --
  --      https://www.apache.org/licenses/LICENSE-2.0
  --
  -- Unless required by applicable law or agreed to in writing, software
  -- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
  -- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
  -- License for the specific language governing permissions and limitations
  -- under the License.
  --
  -- | Variable DBs.
  module Command.VariableDB
      ( VariableDB(..)
      , InputDef(..)
      , Connection(..)
      , TopicDef(..)
      , TypeDef(..)
      , emptyVariableDB
      , findInput
      , findConnection
      , findTopic
      , findType
      , findTypeByType
      , mergeVariableDB
      )
    where
  
  -- External imports
  import Control.Monad.Except (ExceptT, throwError)
  import Data.Aeson           (FromJSON (..))
  import Data.Aeson.TH        (defaultOptions, deriveFromJSON, fieldLabelModifier)
  import Data.Char            (toLower)
  import Data.List            (find)
  import Data.Maybe           (isNothing)
  import GHC.Generics         (Generic)
  
  -- External imports: auxiliary
  import Data.List.Extra (toHead)
  import Data.Location (Location(..))
  
  -- Internal imports
  import Command.Errors (ErrorTriplet(..), ErrorCode)
  
  -- * Variable Databases
  
  -- | A variable database.
  data VariableDB = VariableDB
      { inputs  :: [InputDef]
      , topics  :: [TopicDef]
      , types   :: [TypeDef]
      }
    deriving (Generic, Show)
  
  -- | Definition of an input variable.
  data InputDef = InputDef
      { inputName        :: String
      , inputType        :: Maybe String
      , inputConnections :: [ Connection ]
      }
    deriving (Eq, Show)
  
  -- | Definition of a connection to a topic.
  data Connection = Connection
      { connectionScope :: String
      , connectionTopic :: String
      , connectionField :: Maybe String
      }
    deriving (Eq, Show)
  
  -- | Definition of a topic.
  data TopicDef = TopicDef
      { topicScope :: String
      , topicTopic :: String
      , topicType  :: String
      }
    deriving (Eq, Show)
  
  -- | Definition of a type or type mapping.
  data TypeDef = TypeDef
      { typeFromScope :: String
      , typeFromType  :: String
      , typeFromField :: Maybe String
      , typeToScope   :: String
      , typeToType    :: String
      }
    deriving (Eq, Show)
  
  -- | A variable database with no entries.
  emptyVariableDB :: VariableDB
  emptyVariableDB = VariableDB [] [] []
  
  -- | Find an input with a given name.
  findInput :: VariableDB -> String -> Maybe InputDef
  findInput varDB name =
    find (\x -> inputName x == name) (inputs varDB)
  
  -- | Find a connection a given scope.
  findConnection :: InputDef -> String -> Maybe Connection
  findConnection inputDef scope =
    find (\x -> connectionScope x == scope) (inputConnections inputDef)
  
  -- | Find a topic a given scope and name.
  findTopic :: VariableDB -> String -> String -> Maybe TopicDef
  findTopic varDB scope name =
    find (\x -> topicScope x == scope && topicTopic x == name) (topics varDB)
  
  -- | Find a type with a given input name, scope, and destination system.
  findType :: VariableDB -> String -> String -> String -> Maybe TypeDef
  findType varDB name scope destConn = do
    inputDef <- findInput varDB name
    let connectionDef :: Maybe Connection
        connectionDef = findConnection inputDef scope
  
        field :: Maybe String
        field = connectionField =<< connectionDef
  
        topic :: Maybe String
        topic = connectionTopic <$> connectionDef
  
        topicDef :: Maybe TopicDef
        topicDef = findTopic varDB scope =<< topic
  
        ty :: Maybe String
        ty = topicType <$> topicDef
  
    let match :: TypeDef -> Bool
        match typeDef =
          case (inputType inputDef, ty) of
            (Just ty1, Nothing) ->
                    typeFromScope typeDef == scope
                 && typeFromField typeDef == field
                 && typeToScope typeDef   == destConn
                 && typeToType typeDef    == ty1
            (Just ty1, Just ty2) ->
                    typeFromScope typeDef == scope
                 && typeFromType typeDef  == ty2
                 && typeFromField typeDef == field
                 && typeToScope typeDef   == destConn
                 && typeToType typeDef    == ty1
            (_ ,      Just ty2) ->
                    typeFromScope typeDef == scope
                 && typeFromType typeDef  == ty2
                 && typeFromField typeDef == field
                 && typeToScope typeDef   == destConn
            (Nothing, Nothing) -> False
  
    find match (types varDB)
  
  -- | Find a type definition for a given scope, and destination system, and
  -- destination type.
  findTypeByType :: VariableDB -> String -> String -> String -> Maybe TypeDef
  findTypeByType varDB fromScope toScope toType = do
  
    let match :: TypeDef -> Bool
        match typeDef =
             typeFromScope typeDef == fromScope
          && typeToScope typeDef   == toScope
          && typeToType typeDef    == toType
  
    find match (types varDB)
  
  -- ** Merging of variable DBs
  
  -- | Merge two variable DBs, so long as they do not contain contradictory
  -- information.
  mergeVariableDB :: Monad m
                  => VariableDB -> VariableDB -> ExceptT ErrorTriplet m VariableDB
  mergeVariableDB varDB1 varDB2 = do
    inputs' <- mergeInputs (inputs varDB1) (inputs varDB2)
    topics' <- mergeTopics (topics varDB1) (topics varDB2)
    types'  <- mergeTypes  (types varDB1)  (types varDB2)
    return $ VariableDB inputs' topics' types'
  
  -- | Merge two lists of input definitions, so long as they do not contain
  -- contradictory information.
  mergeInputs :: Monad m
              => [InputDef] -> [InputDef] -> ExceptT ErrorTriplet m [InputDef]
  mergeInputs is1 []     = return is1
  mergeInputs is1 (i2:is2) = do
    is1' <- mergeInput is1 i2
    mergeInputs is1' is2
  
  -- | Merge an input definition into a list of input definitions, so long as it
  -- does not contain contradictory information.
  mergeInput :: Monad m
             => [InputDef] -> InputDef -> ExceptT ErrorTriplet m [InputDef]
  mergeInput []       i2 = return [i2]
  mergeInput (i1:is1) i2
    | inputName i1 == inputName i2
      && (  isNothing (inputType i1)
         || isNothing (inputType i2)
         || inputType i1 == inputType i2
         )
    = do cs <- mergeConnections (inputConnections i1) (inputConnections i2)
         let i1' = i1 { inputType =
                          mergeMaybe (inputType i1) (inputType i2)
                      , inputConnections =
                          cs
                      }
         return (i1' : is1)
  
    | otherwise
    = do is1' <- mergeInput is1 i2
         return $ i1 : is1'
  
  -- | Merge two lists of connections, so long as they do not contain
  -- contradictory information.
  mergeConnections :: Monad m
                   => [Connection] -> [Connection] -> ExceptT ErrorTriplet m [Connection]
  mergeConnections cs1 []       = return cs1
  mergeConnections cs1 (c2:cs2) = do
    cs1' <- mergeConnection cs1 c2
    mergeConnections cs1' cs2
  
  -- | Merge a connection into a list of connections, so long as it does not
  -- contain contradictory information.
  mergeConnection ::  Monad m
                  => [Connection] -> Connection -> ExceptT ErrorTriplet m [Connection]
  mergeConnection []       c2 = return [c2]
  mergeConnection (c1:cs1) c2
    | c1 == c2
    = return $ c1 : cs1
  
    | connectionScope c1 == connectionScope c2
    = throwError $
        cannotMergeVariableDBs "connections with the same scopes"
  
    | otherwise
    = do cs1' <- mergeConnection cs1 c2
         return (c1 : cs1')
  
  -- | Merge two lists of topics, so long as they do not contain contradictory
  -- information.
  mergeTopics :: Monad m
              => [TopicDef] -> [TopicDef] -> ExceptT ErrorTriplet m [TopicDef]
  mergeTopics ts1 [] = return ts1
  mergeTopics ts1 (t2:ts2) = do
    ts1' <- mergeTopic ts1 t2
    mergeTopics ts1' ts2
  
  -- | Merge a topic into a list of topics, so long as it does not contain
  -- contradictory information.
  mergeTopic :: Monad m
             => [TopicDef] -> TopicDef -> ExceptT ErrorTriplet m [TopicDef]
  mergeTopic []       t2 = return [t2]
  mergeTopic (t1:ts1) t2
    | t1 == t2
    = return $ t1 : ts1
  
    | topicScope t1 == topicScope t2 && topicTopic t1 == topicTopic t2
    = throwError $
        cannotMergeVariableDBs "topics with the same scopes and different types"
  
    | otherwise
    = do ts1' <- mergeTopic ts1 t2
         return (t1 : ts1')
  
  -- | Merge two lists of type definitions, so long as they do not contain
  -- contradictory information.
  mergeTypes :: Monad m
             => [TypeDef] -> [TypeDef] -> ExceptT ErrorTriplet m [TypeDef]
  mergeTypes ts1 []       = return ts1
  mergeTypes ts1 (t2:ts2) = do
    ts1' <- mergeType ts1 t2
    mergeTypes ts1' ts2
  
  -- | Merge a type definition into a list of type definitions, so long as it
  -- does not contain contradictory information.
  mergeType :: Monad m
             => [TypeDef] -> TypeDef -> ExceptT ErrorTriplet m [TypeDef]
  mergeType []       t2 = return [t2]
  mergeType (t1:ts1) t2
    | t1 == t2
    = return $ t1 : ts1
  
    |    typeFromScope t1 == typeFromScope t2
      && typeFromType t1  == typeFromType t2
      && typeToScope t1   == typeToScope t2
    = throwError $
        cannotMergeVariableDBs
          "types with the same scopes and from types but otherwise different"
  
    | otherwise
    = do ts1' <- mergeType ts1 t2
         return (t1 : ts1')
  
  -- | Exception handler to deal with the case of variable DB files that cannot
  -- be merged due to having incompatible information.
  cannotMergeVariableDBs :: String -> ErrorTriplet
  cannotMergeVariableDBs element =
      ErrorTriplet ecCannotMergeVariableDB msg LocationNothing
    where
      msg =
        "Reading variable DBs has failed due to them having incompatible"
        ++ " information for " ++ element ++ "."
  
  -- | Error: one of the variable DBs provided cannot be merged.
  ecCannotMergeVariableDB :: ErrorCode
  ecCannotMergeVariableDB = 1
  
  -- | Merge two @Maybe@ values, prefering the left one if two @Just@s are
  -- provided.
  mergeMaybe :: Maybe a -> Maybe a -> Maybe a
  mergeMaybe Nothing x       = x
  mergeMaybe x       Nothing = x
  mergeMaybe x       _       = x
  
  -- | Implement default instances of parser to read variable DB from JSON,
  -- dropping the prefix in each field name.
  deriveFromJSON
    defaultOptions {fieldLabelModifier = toHead toLower . drop 4 }
    ''TypeDef
  
  deriveFromJSON
    defaultOptions {fieldLabelModifier = toHead toLower . drop 5 }
    ''TopicDef
  
  deriveFromJSON
    defaultOptions {fieldLabelModifier = toHead toLower . drop 10 }
    ''Connection
  
  deriveFromJSON
    defaultOptions {fieldLabelModifier = toHead toLower . drop 5 }
    ''InputDef
  
  instance FromJSON VariableDB
  