diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -1,5 +1,5 @@ Name: acid-state -Version: 0.12.1 +Version: 0.12.2 Synopsis: Add ACID guarantees to any serializable Haskell data structure. Description: Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage: http://acid-state.seize.it/ diff --git a/examples/HelloDatabase.hs b/examples/HelloDatabase.hs --- a/examples/HelloDatabase.hs +++ b/examples/HelloDatabase.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid +import Data.Acid -import Control.Monad.State ( get, put ) -import Control.Monad.Reader ( ask ) -import Control.Applicative ( (<$>) ) -import System.Environment ( getArgs ) -import Data.SafeCopy +import Control.Applicative ((<$>)) +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) +import Data.SafeCopy +import System.Environment (getArgs) type Message = String data Database = Database [Message] @@ -15,7 +18,7 @@ $(deriveSafeCopy 0 'base ''Database) -- Transactions are defined to run in either the 'Update' monad --- or the 'Query' monad. +-- or the 'Query' monad. addMessage :: Message -> Update Database () addMessage msg = do Database messages <- get diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} -module Main (main) where - -import Data.Acid +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import Data.SafeCopy +module Main (main) where -import Data.Typeable +import Control.Monad.Reader +import Control.Monad.State +import Data.Acid +import Data.SafeCopy +import Data.Typeable +import System.Environment ------------------------------------------------------ -- The Haskell structure that we want to encapsulate @@ -41,4 +42,4 @@ then do string <- query acid QueryState putStrLn $ "The state is: " ++ string else do update acid (WriteState (unwords args)) - putStrLn $ "The state has been modified!" + putStrLn "The state has been modified!" diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -1,15 +1,18 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Advanced +import Data.Acid +import Data.Acid.Advanced -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import Data.SafeCopy +import Control.Monad.Reader +import Control.Monad.State +import Data.SafeCopy +import System.Environment -import Data.Typeable +import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/examples/KeyValue.hs b/examples/KeyValue.hs --- a/examples/KeyValue.hs +++ b/examples/KeyValue.hs @@ -1,21 +1,24 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Remote +import Data.Acid +import Data.Acid.Remote -import Control.Monad.State -import Control.Monad.Reader -import Control.Applicative -import System.Environment -import System.IO -import System.Exit -import Network -import Data.SafeCopy +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.State +import Data.SafeCopy +import Network +import System.Environment +import System.Exit +import System.IO -import Data.Typeable +import Data.Typeable -import qualified Data.Map as Map +import qualified Data.Map as Map ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/examples/KeyValueNoTH.hs b/examples/KeyValueNoTH.hs --- a/examples/KeyValueNoTH.hs +++ b/examples/KeyValueNoTH.hs @@ -1,19 +1,22 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Advanced +import Data.Acid +import Data.Acid.Advanced -import qualified Control.Monad.State as State -import Control.Monad.Reader -import Control.Applicative -import System.Environment -import System.IO -import Data.SafeCopy +import Control.Applicative +import Control.Monad.Reader +import qualified Control.Monad.State as State +import Data.SafeCopy +import System.Environment +import System.IO -import Data.Typeable +import Data.Typeable -import qualified Data.Map as Map +import qualified Data.Map as Map ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/examples/Proxy.hs b/examples/Proxy.hs --- a/examples/Proxy.hs +++ b/examples/Proxy.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Remote -import Data.Acid.Advanced ( scheduleUpdate ) +import Data.Acid +import Data.Acid.Advanced (scheduleUpdate) +import Data.Acid.Remote -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import System.IO -import Network -import Data.SafeCopy +import Control.Monad.Reader +import Control.Monad.State +import Data.SafeCopy +import Network +import System.Environment +import System.IO -import Data.Typeable +import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate @@ -42,17 +45,17 @@ openLocal = openLocalState (StressState 0) openRemote :: String -> IO (AcidState ProxyStressState) -openRemote socket = openRemoteState "localhost" (UnixSocket socket) +openRemote socket = openRemoteState skipAuthenticationPerform "localhost" (UnixSocket socket) main :: IO () main = do args <- getArgs case args of ["server", socket] -> do acid <- openLocal - acidServer acid (UnixSocket socket) - ["proxy", from, to] + acidServer skipAuthenticationCheck (UnixSocket socket) acid + ["proxy", from, to] -> do acid <- openRemote from - acidServer acid (UnixSocket to) + acidServer skipAuthenticationCheck (UnixSocket to) acid ["query", socket] -> do acid <- openRemote socket n <- query acid QueryState diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs --- a/examples/RemoteClient.hs +++ b/examples/RemoteClient.hs @@ -1,83 +1,42 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Control.Monad ( replicateM_ ) -import Data.Acid ( AcidState, closeAcidState, createCheckpoint, createArchive, query, update ) -import Data.Acid.Advanced ( scheduleUpdate ) -import Data.Acid.Remote ( openRemoteState, sharedSecretPerform ) -import Data.ByteString.Char8 ( pack ) -import Network ( PortID(..) ) -import RemoteCommon ( StressState(..), ClearState(..), PokeState(..), QueryState(..) ) -import System.Environment ( getArgs ) -import System.IO ( hFlush, stdout ) +import Control.Monad.Reader +import Data.Acid +import Data.Acid.Advanced +import Data.Acid.Remote +import Network +import RemoteCommon +import System.Environment +import System.IO ------------------------------------------------------ --- printHelp - -printHelp :: IO () -printHelp - = do putStrLn $ "Commands:" - putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 100k transactions." - putStrLn $ " checkpoint Create a new checkpoint." - putStrLn $ " archive Create archive." - putStrLn $ " clear Clear the state and create a new checkpoint." - putStrLn $ " quit Exit with out creating a checkpoint." +-- This is how AcidState is used: ------------------------------------------------------- --- interactive command loop +open :: IO (AcidState StressState) +open = openRemoteState skipAuthenticationPerform "localhost" (PortNumber 8080) -commandLoop :: AcidState StressState -> IO () -commandLoop acid - = do printHelp - go - where - go = do - putStr "> " - hFlush stdout - cmd <- getLine - case cmd of - "checkpoint" - -> do createCheckpoint acid - go - "archive" - -> do createArchive acid - go - "query" - -> do n <- query acid QueryState +main :: IO () +main = do args <- getArgs + case args of + ["checkpoint"] + -> do acid <- open + createCheckpoint acid + ["query"] + -> do acid <- open + n <- query acid QueryState putStrLn $ "State value: " ++ show n - go - "poke" - -> do putStr "Issuing 100k transactions... " + ["poke"] + -> do acid <- open + putStr "Issuing 100k transactions... " hFlush stdout replicateM_ (100000-1) (scheduleUpdate acid PokeState) update acid PokeState putStrLn "Done" - go - "clear" - -> do update acid ClearState + ["clear"] + -> do acid <- open + update acid ClearState createCheckpoint acid - go - "quit" - -> do closeAcidState acid - return () - - _ - -> do printHelp - go - ------------------------------------------------------- --- connect to remote server and start command-loop - -main :: IO () -main - = do args <- getArgs - case args of - [] -> - do acid <- openRemoteState (sharedSecretPerform $ (pack "12345")) "localhost" (PortNumber $ fromIntegral 8080) - commandLoop acid - - [hostname, port] -> - do acid <- openRemoteState (sharedSecretPerform $ (pack "12345")) hostname (PortNumber $ fromIntegral $ read port) - commandLoop acid - _ -> putStrLn "Usage: RemoteClientTLS [ ]" + _ -> do putStrLn $ "Commands:" + putStrLn $ " query Prints out the current state." + putStrLn $ " poke Spawn 100k transactions." + putStrLn $ " checkpoint Create a new checkpoint." diff --git a/examples/RemoteCommon.hs b/examples/RemoteCommon.hs --- a/examples/RemoteCommon.hs +++ b/examples/RemoteCommon.hs @@ -1,21 +1,19 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, TypeFamilies #-} -module RemoteCommon where - -import Data.Acid +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import System.IO -import Data.SafeCopy +module RemoteCommon where -import Data.Typeable +import Control.Monad.Reader +import Control.Monad.State +import Data.Acid +import Data.SafeCopy +import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate -data StressState = StressState !Int - deriving (Typeable) +data StressState = StressState !Int deriving (Typeable) $(deriveSafeCopy 0 'base ''StressState) diff --git a/examples/RemoteServer.hs b/examples/RemoteServer.hs --- a/examples/RemoteServer.hs +++ b/examples/RemoteServer.hs @@ -1,18 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} -module Main (main) where +module Main where -import Control.Exception ( bracket ) -import Data.Acid ( closeAcidState, openLocalState ) -import Data.Acid.Remote ( acidServer, sharedSecretCheck ) -import Data.ByteString.Char8 ( pack ) -import Data.Set ( singleton ) -import Network ( PortID(PortNumber) ) -import RemoteCommon ( StressState(..) ) +import Control.Exception (bracket) +import Data.Acid (closeAcidState, openLocalState) +import Data.Acid.Remote (acidServer, skipAuthenticationCheck) +import Network (PortID (..)) +import RemoteCommon (StressState (..)) --- | open a server on port 8080 main :: IO () -main = - bracket - (openLocalState $ StressState 0) - closeAcidState - (acidServer (sharedSecretCheck (singleton $ pack "12345")) (PortNumber 8080)) +main = bracket (openLocalState $ StressState 0) + closeAcidState $ acidServer skipAuthenticationCheck (PortNumber 8080) diff --git a/examples/SlowCheckpoint.hs b/examples/SlowCheckpoint.hs --- a/examples/SlowCheckpoint.hs +++ b/examples/SlowCheckpoint.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid +import Data.Acid -import Control.Monad.State -import Control.Concurrent -import Data.Time -import System.IO -import Data.SafeCopy +import Control.Concurrent +import Control.Monad.State +import Data.SafeCopy +import Data.Time +import System.IO ------------------------------------------------------ -- The Haskell structure that we want to encapsulate @@ -25,9 +28,8 @@ -- Computing 'last [0..100000000]' takes roughly 2 seconds -- on my machine. XXX Lemmih, 2011-04-26 setComputationallyHeavyData :: Update SlowCheckpoint () -setComputationallyHeavyData - = do SlowCheckpoint _slow tick <- get - put $ SlowCheckpoint (last [0..100000000]) tick +setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get + put $ SlowCheckpoint (last [0..100000000]) tick tick :: Update SlowCheckpoint Int tick = do SlowCheckpoint slow tick <- get diff --git a/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Advanced (groupUpdates) +import Data.Acid +import Data.Acid.Advanced (groupUpdates) -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import System.IO -import Data.SafeCopy +import Control.Monad.Reader +import Control.Monad.State +import Data.SafeCopy +import System.Environment +import System.IO -import Data.Typeable +import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Advanced +import Data.Acid +import Data.Acid.Advanced -import Control.Monad.State -import Control.Monad.Reader -import System.Environment -import System.IO -import Data.SafeCopy +import Control.Monad.Reader +import Control.Monad.State +import Data.SafeCopy +import System.Environment +import System.IO -import Data.Typeable +import Data.Typeable ------------------------------------------------------ -- The Haskell structure that we want to encapsulate @@ -33,7 +36,6 @@ queryState = do StressState i <- ask return i - ------------------------------------------------------ -- This is how AcidState is used: @@ -56,14 +58,12 @@ putStrLn $ " poke Spawn 100k transactions." putStrLn $ " checkpoint Create a new checkpoint." - ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future. data PokeState = PokeState data QueryState = QueryState - deriving instance Typeable PokeState instance SafeCopy PokeState where diff --git a/examples/errors/ChangeState.hs b/examples/errors/ChangeState.hs --- a/examples/errors/ChangeState.hs +++ b/examples/errors/ChangeState.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} -module Main (main) where +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -import Data.Acid +module Main (main) where -import Control.Monad.State -import System.Environment -import Data.SafeCopy +import Data.Acid -import Data.Typeable +import Control.Monad.State +import Data.SafeCopy +import System.Environment -import Control.Exception -import Prelude hiding (catch) +import Data.Typeable -import qualified Data.Text as Text +import Control.Exception +import Prelude hiding (catch) +import qualified Data.Text as Text ------------------------------------------------------ -- The Haskell structure that we want to encapsulate @@ -44,7 +46,6 @@ firstAcid <- openLocalStateFrom "state/ChangeState" (FirstState "first state") createCheckpoint firstAcid closeAcidState firstAcid - secondAcid <- openLocalStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used")) closeAcidState secondAcid putStrLn "If you see this message then something has gone wrong!" diff --git a/examples/errors/Exceptions.hs b/examples/errors/Exceptions.hs --- a/examples/errors/Exceptions.hs +++ b/examples/errors/Exceptions.hs @@ -1,17 +1,20 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid -import Data.Acid.Local ( createCheckpointAndClose ) +import Data.Acid +import Data.Acid.Local (createCheckpointAndClose) -import Control.Monad.State -import System.Environment -import Data.SafeCopy +import Control.Monad.State +import Data.SafeCopy +import System.Environment -import Data.Typeable +import Data.Typeable -import Control.Exception -import Prelude hiding (catch) +import Control.Exception +import Prelude hiding (catch) ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/examples/errors/RemoveEvent.hs b/examples/errors/RemoveEvent.hs --- a/examples/errors/RemoveEvent.hs +++ b/examples/errors/RemoveEvent.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + module Main (main) where -import Data.Acid +import Data.Acid -import Control.Monad.State -import System.Environment -import Data.SafeCopy +import Control.Monad.State +import Data.SafeCopy +import System.Environment -import Data.Typeable +import Data.Typeable -import Control.Exception -import Prelude hiding (catch) +import Control.Exception +import Prelude hiding (catch) ------------------------------------------------------ -- The Haskell structure that we want to encapsulate diff --git a/src/Data/Acid/Abstract.hs b/src/Data/Acid/Abstract.hs --- a/src/Data/Acid/Abstract.hs +++ b/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 Data.ByteString.Lazy ( ByteString ) import Control.Monad ( void ) import Control.Monad.Trans ( MonadIO(liftIO) ) +#if __GLASGOW_HASKELL__ >= 707 +import Data.Typeable ( Typeable, gcast, typeOf ) +#else import Data.Typeable ( Typeable1, gcast1, typeOf1 ) +#endif data AnyState st where +#if __GLASGOW_HASKELL__ >= 707 + 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' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event) query' acidState event = liftIO (query acidState event) +#if __GLASGOW_HASKELL__ >= 707 +mkAnyState :: Typeable sub_st => sub_st st -> AnyState st +#else mkAnyState :: Typeable1 sub_st => sub_st st -> AnyState st +#endif mkAnyState = AnyState +#if __GLASGOW_HASKELL__ >= 707 +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 @@ _ -> error $ "Data.Acid: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) +#endif diff --git a/src/Data/Acid/Local.hs b/src/Data/Acid/Local.hs --- a/src/Data/Acid/Local.hs +++ b/src/Data/Acid/Local.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable, BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable, BangPatterns, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Acid.Local @@ -141,7 +141,7 @@ -- | 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 -> diff --git a/src/Data/Acid/TemplateHaskell.hs b/src/Data/Acid/TemplateHaskell.hs --- a/src/Data/Acid/TemplateHaskell.hs +++ b/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 @@ -- 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 @@ -> 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,7 +158,7 @@ -- | 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 , "" @@ -166,7 +166,7 @@ , "" , 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,14 +202,16 @@ , "" , pprint stateType ] - - + + --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 -- deriving (Typeable) makeEventDataType eventName eventType = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] - dataD (return []) eventStructName tyvars [con] [''Typeable] + case args of + [_] -> newtypeD (return []) eventStructName tyvars con [''Typeable] + _ -> dataD (return []) eventStructName tyvars [con] [''Typeable] where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType eventStructName = mkName (structName (nameBase eventName)) structName [] = [] @@ -257,8 +259,13 @@ 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 __GLASGOW_HASKELL__ >= 707 + [ 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))