module DDC.Build.Interface.Store
( Store
, new, wrap, load
, Meta (..)
, getMeta
, getModuleNames
, getInterfaces
, Super (..)
, findSuper)
where
import DDC.Base.Pretty
import DDC.Build.Interface.Base
import DDC.Build.Interface.Load
import DDC.Core.Call
import DDC.Core.Module
import DDC.Type.Exp
import System.Directory
import Data.Time.Clock
import Data.IORef
import Data.Maybe
import Data.Map (Map)
import qualified DDC.Core.Tetra as E
import qualified DDC.Core.Salt as A
import qualified Data.Map as Map
data Store
= Store
{
storeMeta :: IORef [Meta]
, storeSupers :: IORef (Map ModuleName (Map E.Name Super))
, storeInterfaces :: IORef [InterfaceAA] }
data Meta
= Meta
{ metaFilePath :: FilePath
, metaTimeStamp :: UTCTime
, metaModuleName :: ModuleName }
deriving Show
instance Pretty Meta where
ppr (Meta path stamp name)
= hsep [ padL 60 $ text (show path)
, padL 30 $ text (show stamp)
, text (show name)]
data Super
= Super
{
superName :: E.Name
, superModuleName :: ModuleName
, superTetraType :: Type E.Name
, superSaltType :: Type A.Name
, superImportValue :: ImportValue E.Name }
new :: IO Store
new
= do refMeta <- newIORef []
refSupers <- newIORef Map.empty
refInterfaces <- newIORef []
return $ Store
{ storeMeta = refMeta
, storeSupers = refSupers
, storeInterfaces = refInterfaces }
wrap :: Store -> InterfaceAA -> IO ()
wrap store ii
= do modifyIORef (storeMeta store)
$ \meta -> meta ++ [metaOfInterface ii]
modifyIORef (storeSupers store)
$ \supers -> Map.insert (interfaceModuleName ii)
(supersOfInterface ii)
supers
modifyIORef (storeInterfaces store)
$ \iis -> iis ++ [ii]
load :: FilePath -> IO (Either Error InterfaceAA)
load filePath
= do timeStamp <- getModificationTime filePath
str <- readFile filePath
return $ loadInterface filePath timeStamp str
getMeta :: Store -> IO [Meta]
getMeta store
= do mm <- readIORef (storeMeta store)
return $ mm
getModuleNames :: Store -> IO [ModuleName]
getModuleNames store
= do supers <- readIORef (storeSupers store)
return $ Map.keys supers
getInterfaces :: Store -> IO [InterfaceAA]
getInterfaces store
= do ints <- readIORef (storeInterfaces store)
return ints
findSuper
:: Store
-> E.Name
-> [ModuleName]
-> IO [Super]
findSuper store n modNames
= do supers <- readIORef (storeSupers store)
return $ mapMaybe
(\modName -> do
nSupers <- Map.lookup modName supers
Map.lookup n nSupers)
modNames
metaOfInterface :: InterfaceAA -> Meta
metaOfInterface ii
= Meta
{ metaFilePath = interfaceFilePath ii
, metaTimeStamp = interfaceTimeStamp ii
, metaModuleName = interfaceModuleName ii }
supersOfInterface :: InterfaceAA -> Map E.Name Super
supersOfInterface ii
| Just mmTetra <- interfaceTetraModule ii
, Just mmSalt <- interfaceSaltModule ii
= let
modName = interfaceModuleName ii
ntsTetra
= Map.fromList
[ (n, t) | (n, esrc) <- moduleExportValues mmTetra
, let Just t = takeTypeOfExportSource esrc ]
ntsSalt
= Map.fromList
[ (n, t) | (n, esrc) <- moduleExportValues mmSalt
, let Just t = takeTypeOfExportSource esrc ]
makeLocalArity b x
| BName nSuper _ <- b
, cs <- takeCallConsFromExp x
, Just (csType, csValue, csBox) <- splitStdCallCons cs
= (nSuper, (length csType, length csValue, length csBox))
| otherwise = error "ddc-build.supersOfInterface: type is not in prenex form."
nsLocalArities :: Map E.Name (Int, Int, Int)
= Map.fromList
$ mapTopBinds makeLocalArity
$ mmTetra
makeImportValue n
| Just (aType, aValue, nBoxes) <- Map.lookup n nsLocalArities
, Just tTetra <- Map.lookup n ntsTetra
= ImportValueModule modName n tTetra (Just (aType, aValue, nBoxes))
| Just impt <- lookup n (moduleImportValues mmTetra)
= impt
| otherwise = error $ "ddc-build.supersOfInterface: no source" ++ show n
makeSuper n tTetra
| E.NameVar s <- n
= Just $ Super
{ superName = n
, superModuleName = moduleName mmTetra
, superTetraType = tTetra
, superSaltType = let Just t = Map.lookup (A.NameVar s) ntsSalt in t
, superImportValue = makeImportValue n }
| otherwise = Nothing
in Map.fromList
[ (n, super) | (n, tTetra) <- Map.toList ntsTetra
, let Just super = makeSuper n tTetra ]
| otherwise
= Map.empty