{-# LANGUAGE DeriveAnyClass            #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TupleSections             #-}

-- |Permanently register and retrieve absolute type definitions
module Network.Top.Repo (RepoProtocol(..), recordType, solveType, knownTypes) where

import           Control.Monad
import           Data.Either.Extra (lefts)
import           Data.List         (nub)
import qualified Data.Map          as M
import           Network.Top.Run
import           Network.Top.Types
import           Network.Top.Util
import           Repo.Types
import           ZM

{-|
A (simplistic) protocol to permanently store and retrieve ADT definitions.
-}
data RepoProtocol = Record AbsADT                      -- ^Permanently record an absolute type
                  | Solve AbsRef                       -- ^Retrieve the absolute type
                  | Solved AbsRef AbsADT               -- ^Return the absolute type identified by an absolute reference
                  | AskDataTypes                       -- ^Request the list of all known data types
                  | KnownDataTypes [(AbsRef, AbsADT)]  -- ^Return the list of all known data types
  deriving (Eq, Ord, Show, Generic, Flat, Model)

--instance Flat [(AbsRef,AbsADT)]

type RefSolver = AbsRef -> IO (Either RepoError AbsADT)
-- type TypeSolver = AbsType -> IO (Either RepoError AbsTypeModel)
type RepoError = String -- SomeException

-- |Permanently record an ADT definition
recordType :: Model a => Config -> Proxy a -> IO ()
recordType cfg proxy = runApp cfg ByType $ \conn -> mapM_ (output conn . Record) . absADTs $ proxy

-- |Retrieve all known data types
knownTypes :: Config -> IO (Either String [(AbsRef, AbsADT)])
knownTypes cfg = runApp cfg ByType $ \conn -> do
  output conn AskDataTypes

  let loop = do
        msg <- input conn
        case msg of
          KnownDataTypes ts -> return ts
          _                 -> loop

  withTimeout 30 loop

-- |Retrieve the full type model for the given absolute type
-- from Top's RepoProtocol channel, using the given Repo as a cache
solveType :: Repo -> Config -> AbsType -> IO (Either RepoError AbsTypeModel)
solveType repo cfg t = ((TypeModel t . M.fromList) <$>) <$> solveType_ repo cfg t
  where
    solveType_ :: Repo -> Config -> AbsType -> IO (Either RepoError [(AbsRef,AbsADT)])
    solveType_ repo cfg t = runApp cfg ByType $ \conn -> (solveRefsRec repo (resolveRef__ conn)) (references t)

    solveRefsRec :: Repo -> RefSolver -> [AbsRef] -> IO (Either RepoError [(AbsRef,AbsADT)])
    solveRefsRec _     _     [] = return $ Right []
    solveRefsRec repo solver refs = do
      er <- allErrs <$> mapM (solveRef repo solver) refs
      case er of
        Left err -> return $ Left err
        Right ros -> (nub . (ros ++) <$>) <$> solveRefsRec repo solver (concatMap (innerReferences . snd) ros)

    allErrs :: [Either String r] -> Either String [r]
    allErrs rs =
      let errs = lefts rs
      in if null errs
         then sequence rs
         else Left (unlines errs)

    solveRef :: Repo -> RefSolver -> AbsRef -> IO (Either RepoError (AbsRef,AbsADT))
    solveRef repo solver ref = ((ref,) <$> )<$> do
      rr <- get repo ref
      case rr of
        Nothing -> solver ref >>= mapM (\o -> put repo o >> return o)
        Just o  -> return $ Right o

resolveRef :: Config -> AbsRef -> IO (Either String AbsADT)
resolveRef cfg ref = checked $ resolveRef_ cfg ref

resolveRef_ cfg ref = runApp cfg ByType (flip resolveRef__ ref)

resolveRef__ :: Connection RepoProtocol -> AbsRef -> IO (Either String AbsADT)
resolveRef__ conn ref = checked $ resolveRef___ conn ref

resolveRef___ :: Connection RepoProtocol -> AbsRef -> IO (Either String AbsADT)
resolveRef___ conn ref = do
    output conn (Solve ref)

    let loop = do
          msg <- input conn
          case msg of
            -- Solved t r | t == typ -> return $ (\e -> AbsoluteType (M.fromList e) typ) <$> r
            Solved sref sadt | ref == sref && absRef sadt == sref -> return $ Right sadt
            _ -> loop

    join <$> withTimeout 25 loop

absADTs :: Model a => Proxy a -> [AbsADT]
absADTs = typeADTs . absTypeModel

checked :: NFData b => IO (Either String b) -> IO (Either String b)
checked f = either (Left . show) id <$> strictTry f