{-# OPTIONS_GHC -XScopedTypeVariables -XStandaloneDeriving -XDeriveDataTypeable -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Serializable -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : Jutaro -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Core.Serializable ( ) where import Distribution.Text (simpleParse,display) import Control.Monad (liftM) import Data.Maybe (fromJust) import Data.Binary.Shared (BinaryShared(..)) import Data.Typeable (Typeable(..)) import Distribution.Package (PackageName(..),PackageIdentifier(..)) import Data.Version (Version(..)) import Distribution.ModuleName (ModuleName) import MyMissing (forceJust) import IDE.Core.CTypes deriving instance Typeable PackageIdentifier deriving instance Typeable ModuleName deriving instance Typeable PackageName ----------------------------------------------------------- instance BinaryShared PackModule where put = putShared (\ (PM pack' modu') -> do (put pack') (put modu')) get = getShared (do pack' <- get modu' <- get return (PM pack' modu')) instance BinaryShared PackageIdentifier where put = putShared (\ (PackageIdentifier name' version') -> do put name' put version') get = getShared (do name' <- get version' <- get return (PackageIdentifier name' version')) instance BinaryShared Version where put = putShared (\ (Version branch' tags') -> do put branch' put tags') get = getShared (do branch' <- get tags' <- get return (Version branch' tags')) instance BinaryShared PackageDescr where put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD') -> do put packagePD' put exposedModulesPD' put buildDependsPD' put mbSourcePathPD') get = getShared (do packagePD' <- get exposedModulesPD' <- get buildDependsPD' <- get mbSourcePathPD' <- get return (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD')) instance BinaryShared ModuleDescr where put = putShared (\ (ModuleDescr moduleIdMD' mbSourcePathMD' usagesMD' idDescriptionsMD') -> do put moduleIdMD' put mbSourcePathMD' put usagesMD' put idDescriptionsMD') get = getShared (do moduleIdMD' <- get mbSourcePathMD' <- get usagesMD' <- get idDescriptionsMD' <- get return (ModuleDescr moduleIdMD' mbSourcePathMD' usagesMD' idDescriptionsMD')) instance BinaryShared Descr where put (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2 isExp)) = do put (1:: Int) put descrName2 put typeInfo2 put descrModu2 put mbLocation2 put mbComment2 put details2 put isExp put (Reexported (ReexportedDescr reexpModu' impDescr')) = do put (2:: Int) put reexpModu' put impDescr' get = do (typeHint :: Int) <- get case typeHint of 1 -> do descrName2 <- get typeInfo2 <- get descrModu2 <- get mbLocation2 <- get mbComment2 <- get details2 <- get isExp2 <- get return (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2 isExp2)) 2 -> do reexpModu' <- get impDescr' <- get return (Reexported (ReexportedDescr reexpModu' impDescr')) _ -> error "Impossible in Binary Descr get" instance BinaryShared TypeDescr where put VariableDescr = do put (1:: Int) put (FieldDescr typeDescrF') = do put (2:: Int) put typeDescrF' put (ConstructorDescr typeDescrC') = do put (3:: Int) put typeDescrC' put (DataDescr constructors' fields') = do put (4:: Int) put constructors' put fields' put TypeDescr = do put (5:: Int) put (NewtypeDescr constructor' mbField') = do put (6:: Int) put constructor' put mbField' put (ClassDescr super' methods') = do put (7:: Int) put super' put methods' put (MethodDescr classDescrM') = do put (8:: Int) put classDescrM' put (InstanceDescr binds') = do put (9:: Int) put binds' put KeywordDescr = do put (10:: Int) put ExtensionDescr = do put (11:: Int) put ModNameDescr = do put (12:: Int) put QualModNameDescr = do put (13:: Int) put ErrorDescr = do put (14:: Int) get = do (typeHint :: Int) <- get case typeHint of 1 -> return VariableDescr 2 -> do typeDescrF' <- get return (FieldDescr typeDescrF') 3 -> do typeDescrC' <- get return (ConstructorDescr typeDescrC') 4 -> do constructors' <- get fields' <- get return (DataDescr constructors' fields') 5 -> return TypeDescr 6 -> do constructor' <- get mbField' <- get return (NewtypeDescr constructor' mbField') 7 -> do super' <- get methods' <- get return (ClassDescr super' methods') 8 -> do classDescrM' <- get return (MethodDescr classDescrM') 9 -> do binds' <- get return (InstanceDescr binds') 10 -> return KeywordDescr 11 -> return ExtensionDescr 12 -> return ModNameDescr 13 -> return QualModNameDescr 14 -> return ErrorDescr _ -> error "Impossible in Binary SpDescr get" instance BinaryShared SimpleDescr where put (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported') = do put sdName' put sdType' put sdLocation' put sdComment' put sdExported' get = do sdName' <- get sdType' <- get sdLocation' <- get sdComment' <- get sdExported' <- get return (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported') instance BinaryShared Location where put (Location locationSLine' locationSCol' locationELine' locationECol') = do put locationSLine' put locationSCol' put locationELine' put locationECol' get = do locationSLine' <- get locationSCol' <- get locationELine' <- get locationECol' <- get return (Location locationSLine' locationSCol' locationELine' locationECol') instance BinaryShared ModuleName where put = put . display get = liftM (flip forceJust "BinaryShared>>get(ModuleName)" . simpleParse) get instance BinaryShared PackageName where put (PackageName pn) = put pn get = liftM PackageName get