Conditional Typeable updates. Added conditional typeclass constraints.

Fixes #25

.gitignore

@@ -0,0 +1,2 @@
+dist/**
+*.swp

src/Data/Acid/Abstract.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, TypeFamilies, GADTs #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, GADTs, CPP #-}
 module Data.Acid.Abstract
     ( AcidState(..)
     , scheduleUpdate
@@ -18,10 +18,18 @@ import Control.Concurrent      ( MVar, takeMVar )
 import Data.ByteString.Lazy    ( ByteString )
 import Control.Monad           ( void )
 import Control.Monad.Trans     ( MonadIO(liftIO) )
+#if MIN_VERSION_base(4,7,0)
+import Data.Typeable           ( Typeable, gcast, typeOf )
+#else
 import Data.Typeable           ( Typeable1, gcast1, typeOf1 )
+#endif
 
 data AnyState st where
+#if MIN_VERSION_base(4,7,0)
+  AnyState :: Typeable sub_st => sub_st st -> AnyState st
+#else
   AnyState :: Typeable1 sub_st => sub_st st -> AnyState st
+#endif
 
 -- Haddock doesn't get the types right on its own.
 {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)
@@ -103,9 +111,24 @@ query = _query -- Redirection to make Haddock happy.
 query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)
 query' acidState event = liftIO (query acidState event)
 
+#if MIN_VERSION_base(4,7,0)
+mkAnyState :: Typeable sub_st => sub_st st -> AnyState st
+#else
 mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st
+#endif
 mkAnyState = AnyState
 
+#if MIN_VERSION_base(4,7,0)
+downcast :: (Typeable sub, Typeable st) => AcidState st -> sub st
+downcast AcidState{acidSubState = AnyState sub}
+  = r
+ where
+   r = case gcast (Just sub) of
+         Just (Just x) -> x
+         _ ->
+           error $
+            "Data.Acid: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r)
+#else
 downcast :: Typeable1 sub => AcidState st -> sub st
 downcast AcidState{acidSubState = AnyState sub}
   = r
@@ -115,3 +138,4 @@ downcast AcidState{acidSubState = AnyState sub}
          _ ->
            error $
             "Data.Acid: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r)
+#endif

src/Data/Acid/Local.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Acid.Local
@@ -141,7 +141,7 @@ createLocalCheckpoint acidState
 -- | Save a snapshot to disk and close the AcidState as a single atomic
 --   action. This is useful when you want to make sure that no events
 --   are saved to disk after a checkpoint.
-createCheckpointAndClose :: SafeCopy st => AcidState st -> IO ()
+createCheckpointAndClose :: (SafeCopy st, Typeable st) => AcidState st -> IO ()
 createCheckpointAndClose abstract_state
     = do mvar <- newEmptyMVar
          closeCore' (localCore acidState) $ \st ->

src/Data/Acid/TemplateHaskell.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, CPP #-}
 {- Holy crap this code is messy. -}
 module Data.Acid.TemplateHaskell
     ( makeAcidic
@@ -115,7 +115,7 @@ makeIsAcidic eventNames stateName tyvars constructors
 -- We will get an ambigious type variable when trying to create the
 -- 'IsAcidic' instance, because there is no way to figure out what
 -- type 'b' should be.
--- 
+--
 -- The tricky part of this code is that we need to unify the type
 -- variables.
 --
@@ -133,7 +133,7 @@ eventCxts :: Type        -- ^ State type (used for error messages)
           -> Type        -- ^ 'Type' of the event
           -> [Pred]      -- ^ extra context to add to 'IsAcidic' instance
 eventCxts targetStateType targetTyVars eventName eventType =
-    let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate) 
+    let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate)
                     = analyseType eventName eventType
         eventTyVars = findTyVars stateType -- find the type variable names that this event is using for the State type
         table       = zip eventTyVars (map tyVarBndrName targetTyVars) -- create a lookup table
@@ -158,15 +158,15 @@ eventCxts targetStateType targetTyVars eventName eventType =
 
       -- | rename a 'Name'
       renameName :: Pred -> [(Name, Name)] -> Name -> Name
-      renameName pred table n = 
+      renameName pred table n =
           case lookup n table of
             Nothing -> error $ unlines [ show $ ppr_sig eventName eventType
                                        , ""
                                        , "can not be used as an UpdateEvent because the class context: "
                                        , ""
                                        , pprint pred
                                        , ""
-                                       , "contains a type variable which is not found in the state type: " 
+                                       , "contains a type variable which is not found in the state type: "
                                        , ""
                                        , pprint targetStateType
                                        , ""
@@ -202,8 +202,8 @@ makeEventHandler eventName eventType
                       , ""
                       , pprint stateType
                       ]
-                      
-                      
+
+
 
 --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2
 --  deriving (Typeable)
@@ -257,8 +257,13 @@ makeMethodInstance eventName eventType
              structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ]
          instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context)
                    (return ty)
+#if MIN_VERSION_template_haskell(2,9,0)
+                   [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType))
+                   , tySynInstD ''MethodState  (tySynEqn [structType] (return stateType))
+#else
                    [ tySynInstD ''MethodResult [structType] (return resultType)
                    , tySynInstD ''MethodState  [structType] (return stateType)
+#endif
                    ]
     where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType
           eventStructName = mkName (structName (nameBase eventName))