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
data RepoProtocol = Record AbsADT
| Solve AbsRef
| Solved AbsRef AbsADT
| AskDataTypes
| KnownDataTypes [(AbsRef, AbsADT)]
deriving (Eq, Ord, Show, Generic, Flat, Model)
type RefSolver = AbsRef -> IO (Either RepoError AbsADT)
type RepoError = String
recordType :: Model a => Config -> Proxy a -> IO ()
recordType cfg proxy = runApp cfg ByType $ \conn -> mapM_ (output conn . Record) . absADTs $ proxy
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
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 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