diff --git a/src/Network/Top/Repo.hs b/src/Network/Top/Repo.hs --- a/src/Network/Top/Repo.hs +++ b/src/Network/Top/Repo.hs @@ -7,7 +7,14 @@ {-# LANGUAGE TupleSections #-} -- |Permanently register and retrieve absolute type definitions -module Network.Top.Repo (RepoProtocol(..), recordType, solveType, knownTypes) where +module Network.Top.Repo + ( RepoProtocol(..) + , recordType + , recordADTs + , solveType + , solveRefs + , knownTypes + ) where import Control.Monad import Data.Either.Extra (lefts) @@ -35,10 +42,14 @@ -- type TypeSolver = AbsType -> IO (Either RepoError AbsTypeModel) type RepoError = String -- SomeException --- |Permanently record an ADT definition +-- |Permanently record all the ADT definitions referred by a type, with all their dependencies recordType :: Model a => Config -> Proxy a -> IO () -recordType cfg proxy = runApp cfg ByType $ \conn -> mapM_ (output conn . Record) . absADTs $ proxy +recordType cfg proxy = recordADTs cfg $ absADTs $ proxy +-- |Permanently record a set of ADT definitions with all their dependencies +recordADTs :: Foldable t => Config -> t AbsADT -> IO () +recordADTs cfg adts = runApp cfg ByType $ \conn -> mapM_ (output conn . Record) adts + -- |Retrieve all known data types knownTypes :: Config -> IO (Either String [(AbsRef, AbsADT)]) knownTypes cfg = runApp cfg ByType $ \conn -> do @@ -55,18 +66,19 @@ -- |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) +solveType repo cfg t = ((TypeModel t) <$>) <$> solveRefs repo cfg (references t) - solveRefsRec :: Repo -> RefSolver -> [AbsRef] -> IO (Either RepoError [(AbsRef,AbsADT)]) - solveRefsRec _ _ [] = return $ Right [] +-- |Solve ADT references recursively, returning all dependencies. +solveRefs :: Repo -> Config -> [AbsRef] -> IO (Either RepoError (M.Map AbsRef AbsADT)) +solveRefs repo cfg refs = runApp cfg ByType $ \conn -> (solveRefsRec repo (resolveRef__ conn)) refs + where + solveRefsRec :: Repo -> RefSolver -> [AbsRef] -> IO (Either RepoError (M.Map AbsRef AbsADT)) + solveRefsRec _ _ [] = return $ Right M.empty 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) + Right ros -> (M.union (M.fromList ros) <$>) <$> solveRefsRec repo solver (concatMap (innerReferences . snd) ros) allErrs :: [Either String r] -> Either String [r] allErrs rs = @@ -85,6 +97,7 @@ resolveRef :: Config -> AbsRef -> IO (Either String AbsADT) resolveRef cfg ref = checked $ resolveRef_ cfg ref +resolveRef_ :: Config -> AbsRef -> IO (Either String AbsADT) resolveRef_ cfg ref = runApp cfg ByType (flip resolveRef__ ref) resolveRef__ :: Connection RepoProtocol -> AbsRef -> IO (Either String AbsADT) diff --git a/src/Repo/Types.hs b/src/Repo/Types.hs --- a/src/Repo/Types.hs +++ b/src/Repo/Types.hs @@ -1,8 +1,13 @@ -module Repo.Types (Repo(..)) where +module Repo.Types (Repo(..),withRepo) where +import Control.Exception import ZM -- |A repository of absolute types data Repo = Repo { get :: AbsRef -> IO (Maybe AbsADT) , put :: AbsADT -> IO () , close :: IO () } + +-- |Run an IO action on a Repo +withRepo :: IO Repo -> (Repo -> IO c) -> IO c +withRepo new = bracket new close diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,9 @@ resolver: lts-6.35 extra-deps: -- model-0.4.2 +- model-0.4.4 - flat-0.3 -- zm-0.3 +- zm-0.3.2 - cryptonite-0.22 - mono-traversable-1.0.4.0 - +- acid-state-0.14.3 diff --git a/stack710.yaml b/stack710.yaml --- a/stack710.yaml +++ b/stack710.yaml @@ -1,9 +1,9 @@ resolver: lts-6.35 extra-deps: -- model-0.4.2 +- model-0.4.4 - flat-0.3 -- zm-0.3 +- zm-0.3.2 - cryptonite-0.22 - mono-traversable-1.0.4.0 - +- acid-state-0.14.3 diff --git a/stack801.yaml b/stack801.yaml deleted file mode 100644 --- a/stack801.yaml +++ /dev/null @@ -1,8 +0,0 @@ -resolver: lts-7.24 - -extra-deps: -- model-0.4.2 -- flat-0.3 -- zm-0.3 -- cryptonite-0.22 - diff --git a/stack802.yaml b/stack802.yaml --- a/stack802.yaml +++ b/stack802.yaml @@ -1,6 +1,6 @@ -resolver: lts-9.12 +resolver: lts-9.18 extra-deps: -- model-0.4.2 -- zm-0.3 +- model-0.4.4 +- zm-0.3.2 - acid-state-0.14.3 diff --git a/stack821.yaml b/stack821.yaml deleted file mode 100644 --- a/stack821.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: nightly-2017-11-09 - -extra-deps: -- model-0.4.2 -- zm-0.3 -- acid-state-0.14.3 diff --git a/stack822.yaml b/stack822.yaml new file mode 100644 --- /dev/null +++ b/stack822.yaml @@ -0,0 +1,6 @@ +resolver: nightly-2017-12-10 + +extra-deps: +- model-0.4.4 +- zm-0.3.2 +- acid-state-0.14.3 diff --git a/top.cabal b/top.cabal --- a/top.cabal +++ b/top.cabal @@ -1,5 +1,5 @@ name: top -version: 0.2.2 +version: 0.2.4 synopsis: Top (typed oriented protocol) API description: See the . homepage: http://github.com/tittoassini/top @@ -11,13 +11,12 @@ copyright: Copyright: (c) 2016 Pasqualino `Titto` Assini cabal-version: >=1.10 build-type: Simple -Tested-With: GHC == 7.10.3 GHC == 8.0.1 GHC == 8.0.2 GHC == 8.2.1 +Tested-With: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 extra-source-files: stack.yaml stack710.yaml - stack801.yaml stack802.yaml - stack821.yaml + stack822.yaml README.md source-repository head @@ -73,7 +72,7 @@ extra >=1.4.10 && <2, pretty >= 1.1.2 && < 1.2, flat==0.3.*, - zm ==0.3 + zm ==0.3.* default-language: Haskell2010 hs-source-dirs: src @@ -84,7 +83,7 @@ base, directory >=1.2 && <2, tasty >= 0.11 && < 0.13, - tasty-hunit >= 0.8 && < 0.10, + tasty-hunit >= 0.8 && < 0.11, top, zm default-language: Haskell2010