--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+{- |
+Module : Control.Monad.Cont
+Copyright : (c) The University of Glasgow 2001,
+ (c) Jeff Newbern 2003-2007,
+ (c) Andriy Palamarchuk 2007
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-parameter type classes)
+
+[Computation type:] Computations which can be interrupted and resumed.
+
+[Binding strategy:] Binding a function to a monadic value creates
+a new continuation which uses the function as the continuation of the monadic
+computation.
+
+[Useful for:] Complex control structures, error handling,
+and creating co-routines.
+
+[Zero and plus:] None.
+
+[Example type:] @'Cont' r a@
+
+The Continuation monad represents computations in continuation-passing style
+(CPS).
+In continuation-passing style function result is not returned,
+but instead is passed to another function,
+received as a parameter (continuation).
+Computations are built up from sequences
+of nested continuations, terminated by a final continuation (often @id@)
+which produces the final result.
+Since continuations are functions which represent the future of a computation,
+manipulation of the continuation functions can achieve complex manipulations
+of the future of the computation,
+such as interrupting a computation in the middle, aborting a portion
+of a computation, restarting a computation, and interleaving execution of
+computations.
+The Continuation monad adapts CPS to the structure of a monad.
+
+Before using the Continuation monad, be sure that you have
+a firm understanding of continuation-passing style
+and that continuations represent the best solution to your particular
+design problem.
+Many algorithms which require continuations in other languages do not require
+them in Haskell, due to Haskell's lazy semantics.
+Abuse of the Continuation monad can produce code that is impossible
+to understand and maintain.
+-}
+
+module Control.Monad.Cont (
+ module Control.Monad.Cont.Class,
+ Cont(..),
+ mapCont,
+ withCont,
+ ContT(..),
+ mapContT,
+ withContT,
+ module Control.Monad,
+ module Control.Monad.Trans,
+ -- * Example 1: Simple Continuation Usage
+ -- $simpleContExample
+
+ -- * Example 2: Using @callCC@
+ -- $callCCExample
+
+ -- * Example 3: Using @ContT@ Monad Transformer
+ -- $ContTExample
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+
+{- |
+Continuation monad.
+@Cont r a@ is a CPS computation that produces an intermediate result
+of type @a@ within a CPS computation whose final result type is @r@.
+
+The @return@ function simply creates a continuation which passes the value on.
+
+The @>>=@ operator adds the bound function into the continuation chain.
+-}
+newtype Cont r a = Cont {
+
+ {- | Runs a CPS computation, returns its result after applying
+ the final continuation to it.
+ Parameters:
+
+ * a continuation computation (@Cont@).
+
+ * the final continuation, which produces the final result (often @id@).
+ -}
+ runCont :: (a -> r) -> r
+}
+
+mapCont :: (r -> r) -> Cont r a -> Cont r a
+mapCont f m = Cont $ f . runCont m
+
+withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b
+withCont f m = Cont $ runCont m . f
+
+instance Functor (Cont r) where
+ fmap f m = Cont $ \c -> runCont m (c . f)
+
+instance Monad (Cont r) where
+ return a = Cont ($ a)
+ m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c
+
+instance MonadCont (Cont r) where
+ callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c
+
+{- |
+The continuation monad transformer.
+Can be used to add continuation handling to other monads.
+-}
+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
+
+mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a
+mapContT f m = ContT $ f . runContT m
+
+withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b
+withContT f m = ContT $ runContT m . f
+
+instance (Monad m) => Functor (ContT r m) where
+ fmap f m = ContT $ \c -> runContT m (c . f)
+
+instance (Monad m) => Monad (ContT r m) where
+ return a = ContT ($ a)
+ m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c)
+
+instance (Monad m) => MonadCont (ContT r m) where
+ callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance MonadTrans (ContT r) where
+ lift m = ContT (m >>=)
+
+instance (MonadIO m) => MonadIO (ContT r m) where
+ liftIO = lift . liftIO
+
+-- Needs UndecidableInstances
+instance (MonadReader r' m) => MonadReader r' (ContT r m) where
+ ask = lift ask
+ local f m = ContT $ \c -> do
+ r <- ask
+ local f (runContT m (local (const r) . c))
+
+-- Needs UndecidableInstances
+instance (MonadState s m) => MonadState s (ContT r m) where
+ get = lift get
+ put = lift . put
+
+{- $simpleContExample
+Calculating length of a list continuation-style:
+
+>calculateLength :: [a] -> Cont r Int
+>calculateLength l = return (length l)
+
+Here we use @calculateLength@ by making it to pass its result to @print@:
+
+>main = do
+> runCont (calculateLength "123") print
+> -- result: 3
+
+It is possible to chain 'Cont' blocks with @>>=@.
+
+>double :: Int -> Cont r Int
+>double n = return (n * 2)
+>
+>main = do
+> runCont (calculateLength "123" >>= double) print
+> -- result: 6
+-}
+
+{- $callCCExample
+This example gives a taste of how escape continuations work, shows a typical
+pattern for their usage.
+
+>-- Returns a string depending on the length of the name parameter.
+>-- If the provided string is empty, returns an error.
+>-- Otherwise, returns a welcome message.
+>whatsYourName :: String -> String
+>whatsYourName name =
+> (`runCont` id) $ do -- 1
+> response <- callCC $ \exit -> do -- 2
+> validateName name exit -- 3
+> return $ "Welcome, " ++ name ++ "!" -- 4
+> return response -- 5
+>
+>validateName name exit = do
+> when (null name) (exit "You forgot to tell me your name!")
+
+Here is what this example does:
+
+(1) Runs an anonymous 'Cont' block and extracts value from it with
+@(\`runCont\` id)@. Here @id@ is the continuation, passed to the @Cont@ block.
+
+(1) Binds @response@ to the result of the following 'callCC' block,
+binds @exit@ to the continuation.
+
+(1) Validates @name@.
+This approach illustrates advantage of using 'callCC' over @return@.
+We pass the continuation to @validateName@,
+and interrupt execution of the @Cont@ block from /inside/ of @validateName@.
+
+(1) Returns the welcome message from the @callCC@ block.
+This line is not executed if @validateName@ fails.
+
+(1) Returns from the @Cont@ block.
+-}
+
+{-$ContTExample
+'ContT' can be used to add continuation handling to other monads.
+Here is an example how to combine it with @IO@ monad:
+
+>import Control.Monad.Cont
+>import System.IO
+>
+>main = do
+> hSetBuffering stdout NoBuffering
+> runContT (callCC askString) reportResult
+>
+>askString :: (String -> ContT () IO String) -> ContT () IO String
+>askString next = do
+> liftIO $ putStrLn "Please enter a string"
+> s <- liftIO $ getLine
+> next s
+>
+>reportResult :: String -> IO ()
+>reportResult s = do
+> putStrLn ("You entered: " ++ s)
+
+Action @askString@ requests user to enter a string,
+and passes it to the continuation.
+@askString@ takes as a parameter a continuation taking a string parameter,
+and returning @IO ()@.
+Compare its signature to 'runContT' definition.
+-}
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+{- |
+Module : Control.Monad.Cont.Class
+Copyright : (c) The University of Glasgow 2001,
+ (c) Jeff Newbern 2003-2007,
+ (c) Andriy Palamarchuk 2007
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-parameter type classes)
+
+[Computation type:] Computations which can be interrupted and resumed.
+
+[Binding strategy:] Binding a function to a monadic value creates
+a new continuation which uses the function as the continuation of the monadic
+computation.
+
+[Useful for:] Complex control structures, error handling,
+and creating co-routines.
+
+[Zero and plus:] None.
+
+[Example type:] @'Cont' r a@
+
+The Continuation monad represents computations in continuation-passing style
+(CPS).
+In continuation-passing style function result is not returned,
+but instead is passed to another function,
+received as a parameter (continuation).
+Computations are built up from sequences
+of nested continuations, terminated by a final continuation (often @id@)
+which produces the final result.
+Since continuations are functions which represent the future of a computation,
+manipulation of the continuation functions can achieve complex manipulations
+of the future of the computation,
+such as interrupting a computation in the middle, aborting a portion
+of a computation, restarting a computation, and interleaving execution of
+computations.
+The Continuation monad adapts CPS to the structure of a monad.
+
+Before using the Continuation monad, be sure that you have
+a firm understanding of continuation-passing style
+and that continuations represent the best solution to your particular
+design problem.
+Many algorithms which require continuations in other languages do not require
+them in Haskell, due to Haskell's lazy semantics.
+Abuse of the Continuation monad can produce code that is impossible
+to understand and maintain.
+-}
+
+module Control.Monad.Cont.Class (
+ MonadCont(..),
+ ) where
+
+class (Monad m) => MonadCont m where
+ {- | @callCC@ (call-with-current-continuation)
+ calls a function with the current continuation as its argument.
+ Provides an escape continuation mechanism for use with Continuation monads.
+ Escape continuations allow to abort the current computation and return
+ a value immediately.
+ They achieve a similar effect to 'Control.Monad.Error.throwError'
+ and 'Control.Monad.Error.catchError'
+ within an 'Control.Monad.Error.Error' monad.
+ Advantage of this function over calling @return@ is that it makes
+ the continuation explicit,
+ allowing more flexibility and better control
+ (see examples in "Control.Monad.Cont").
+
+ The standard idiom used with @callCC@ is to provide a lambda-expression
+ to name the continuation. Then calling the named continuation anywhere
+ within its scope will escape from the computation,
+ even if it is many layers deep within nested computations.
+ -}
+ callCC :: ((a -> m b) -> m a) -> m a
+
--- /dev/null
+-- Undecidable instances needed for the same reasons as in Reader, State etc:
+{-# LANGUAGE UndecidableInstances #-}
+-- De-orphaning this module is tricky:
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- To handle instances moved to base:
+{-# LANGUAGE CPP #-}
+
+{- |
+Module : Control.Monad.Error
+Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,
+ (c) Jeff Newbern 2003-2006,
+ (c) Andriy Palamarchuk 2006
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-parameter type classes)
+
+[Computation type:] Computations which may fail or throw exceptions.
+
+[Binding strategy:] Failure records information about the cause\/location
+of the failure. Failure values bypass the bound function,
+other values are used as inputs to the bound function.
+
+[Useful for:] Building computations from sequences of functions that may fail
+or using exception handling to structure error handling.
+
+[Zero and plus:] Zero is represented by an empty error and the plus operation
+executes its second argument if the first fails.
+
+[Example type:] @'Data.Either' String a@
+
+The Error monad (also called the Exception monad).
+-}
+
+{-
+ Rendered by Michael Weber <mailto:michael.weber@post.rwth-aachen.de>,
+ inspired by the Haskell Monad Template Library from
+ Andy Gill (<http://www.cse.ogi.edu/~andy/>)
+-}
+module Control.Monad.Error (
+ module Control.Monad.Error.Class,
+ ErrorT(..),
+ mapErrorT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ -- * Example 1: Custom Error Data Type
+ -- $customErrorExample
+
+ -- * Example 2: Using ErrorT Monad Transformer
+ -- $ErrorTExample
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+import Control.Monad.RWS.Class
+
+import Control.Monad.Instances ()
+
+-- | Note: this instance does not satisfy the second 'MonadPlus' law
+--
+-- > v >> mzero = mzero
+--
+instance MonadPlus IO where
+ mzero = ioError (userError "mzero")
+ m `mplus` n = m `catch` \_ -> n
+
+instance MonadError IOError IO where
+ throwError = ioError
+ catchError = catch
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable error monad
+
+#if !(MIN_VERSION_base(4,2,1))
+
+-- These instances are in base-4.3
+
+instance Monad (Either e) where
+ return = Right
+ Left l >>= _ = Left l
+ Right r >>= k = k r
+
+instance MonadFix (Either e) where
+ mfix f = let
+ a = f $ case a of
+ Right r -> r
+ _ -> error "empty mfix argument"
+ in a
+
+#endif /* base to 4.2.0.x */
+
+instance (Error e) => MonadPlus (Either e) where
+ mzero = Left noMsg
+ Left _ `mplus` n = n
+ m `mplus` _ = m
+
+instance (Error e) => MonadError e (Either e) where
+ throwError = Left
+ Left l `catchError` h = h l
+ Right r `catchError` _ = Right r
+
+{- |
+The error monad transformer. It can be used to add error handling to other
+monads.
+
+The @ErrorT@ Monad structure is parameterized over two things:
+
+ * e - The error type.
+
+ * m - The inner monad.
+
+Here are some examples of use:
+
+> -- wraps IO action that can throw an error e
+> type ErrorWithIO e a = ErrorT e IO a
+> ==> ErrorT (IO (Either e a))
+>
+> -- IO monad wrapped in StateT inside of ErrorT
+> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
+> ==> ErrorT (StateT s IO (Either e a))
+> ==> ErrorT (StateT (s -> IO (Either e a,s)))
+-}
+
+newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }
+
+mapErrorT :: (m (Either e a) -> n (Either e' b))
+ -> ErrorT e m a
+ -> ErrorT e' n b
+mapErrorT f m = ErrorT $ f (runErrorT m)
+
+instance (Monad m) => Functor (ErrorT e m) where
+ fmap f m = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> return (Left l)
+ Right r -> return (Right (f r))
+
+instance (Monad m, Error e) => Monad (ErrorT e m) where
+ return a = ErrorT $ return (Right a)
+ m >>= k = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> return (Left l)
+ Right r -> runErrorT (k r)
+ fail msg = ErrorT $ return (Left (strMsg msg))
+
+instance (Monad m, Error e) => MonadPlus (ErrorT e m) where
+ mzero = ErrorT $ return (Left noMsg)
+ m `mplus` n = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left _ -> runErrorT n
+ Right r -> return (Right r)
+
+instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where
+ mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of
+ Right r -> r
+ _ -> error "empty mfix argument"
+
+instance (Monad m, Error e) => MonadError e (ErrorT e m) where
+ throwError l = ErrorT $ return (Left l)
+ m `catchError` h = ErrorT $ do
+ a <- runErrorT m
+ case a of
+ Left l -> runErrorT (h l)
+ Right r -> return (Right r)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance (Error e) => MonadTrans (ErrorT e) where
+ lift m = ErrorT $ do
+ a <- m
+ return (Right a)
+
+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
+ liftIO = lift . liftIO
+
+instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where
+ callCC f = ErrorT $
+ callCC $ \c ->
+ runErrorT (f (\a -> ErrorT $ c (Right a)))
+
+instance (Error e, MonadRWS r w s m) => MonadRWS r w s (ErrorT e m)
+
+instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where
+ ask = lift ask
+ local f m = ErrorT $ local f (runErrorT m)
+
+instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where
+ get = lift get
+ put = lift . put
+
+instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where
+ tell = lift . tell
+ listen m = ErrorT $ do
+ (a, w) <- listen (runErrorT m)
+ case a of
+ Left l -> return $ Left l
+ Right r -> return $ Right (r, w)
+ pass m = ErrorT $ pass $ do
+ a <- runErrorT m
+ case a of
+ Left l -> return (Left l, id)
+ Right (r, f) -> return (Right r, f)
+
+{- $customErrorExample
+Here is an example that demonstrates the use of a custom 'Error' data type with
+the 'throwError' and 'catchError' exception mechanism from 'MonadError'.
+The example throws an exception if the user enters an empty string
+or a string longer than 5 characters. Otherwise it prints length of the string.
+
+>-- This is the type to represent length calculation error.
+>data LengthError = EmptyString -- Entered string was empty.
+> | StringTooLong Int -- A string is longer than 5 characters.
+> -- Records a length of the string.
+> | OtherError String -- Other error, stores the problem description.
+>
+>-- We make LengthError an instance of the Error class
+>-- to be able to throw it as an exception.
+>instance Error LengthError where
+> noMsg = OtherError "A String Error!"
+> strMsg s = OtherError s
+>
+>-- Converts LengthError to a readable message.
+>instance Show LengthError where
+> show EmptyString = "The string was empty!"
+> show (StringTooLong len) =
+> "The length of the string (" ++ (show len) ++ ") is bigger than 5!"
+> show (OtherError msg) = msg
+>
+>-- For our monad type constructor, we use Either LengthError
+>-- which represents failure using Left LengthError
+>-- or a successful result of type a using Right a.
+>type LengthMonad = Either LengthError
+>
+>main = do
+> putStrLn "Please enter a string:"
+> s <- getLine
+> reportResult (calculateLength s)
+>
+>-- Wraps length calculation to catch the errors.
+>-- Returns either length of the string or an error.
+>calculateLength :: String -> LengthMonad Int
+>calculateLength s = (calculateLengthOrFail s) `catchError` Left
+>
+>-- Attempts to calculate length and throws an error if the provided string is
+>-- empty or longer than 5 characters.
+>-- The processing is done in Either monad.
+>calculateLengthOrFail :: String -> LengthMonad Int
+>calculateLengthOrFail [] = throwError EmptyString
+>calculateLengthOrFail s | len > 5 = throwError (StringTooLong len)
+> | otherwise = return len
+> where len = length s
+>
+>-- Prints result of the string length calculation.
+>reportResult :: LengthMonad Int -> IO ()
+>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len))
+>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e))
+-}
+
+{- $ErrorTExample
+@'ErrorT'@ monad transformer can be used to add error handling to another monad.
+Here is an example how to combine it with an @IO@ monad:
+
+>import Control.Monad.Error
+>
+>-- An IO monad which can return String failure.
+>-- It is convenient to define the monad type of the combined monad,
+>-- especially if we combine more monad transformers.
+>type LengthMonad = ErrorT String IO
+>
+>main = do
+> -- runErrorT removes the ErrorT wrapper
+> r <- runErrorT calculateLength
+> reportResult r
+>
+>-- Asks user for a non-empty string and returns its length.
+>-- Throws an error if user enters an empty string.
+>calculateLength :: LengthMonad Int
+>calculateLength = do
+> -- all the IO operations have to be lifted to the IO monad in the monad stack
+> liftIO $ putStrLn "Please enter a non-empty string: "
+> s <- liftIO getLine
+> if null s
+> then throwError "The string was empty!"
+> else return $ length s
+>
+>-- Prints result of the string length calculation.
+>reportResult :: Either String Int -> IO ()
+>reportResult (Right len) = putStrLn ("The length of the string is " ++ (show len))
+>reportResult (Left e) = putStrLn ("Length calculation failed with error: " ++ (show e))
+-}
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Needed for the same reasons as in Reader, State etc
+
+{- |
+Module : Control.Monad.Error.Class
+Copyright : (c) Michael Weber <michael.weber@post.rwth-aachen.de> 2001,
+ (c) Jeff Newbern 2003-2006,
+ (c) Andriy Palamarchuk 2006
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-parameter type classes)
+
+[Computation type:] Computations which may fail or throw exceptions.
+
+[Binding strategy:] Failure records information about the cause\/location
+of the failure. Failure values bypass the bound function,
+other values are used as inputs to the bound function.
+
+[Useful for:] Building computations from sequences of functions that may fail
+or using exception handling to structure error handling.
+
+[Zero and plus:] Zero is represented by an empty error and the plus operation
+executes its second argument if the first fails.
+
+[Example type:] @'Data.Either' String a@
+
+The Error monad (also called the Exception monad).
+-}
+
+{-
+ Rendered by Michael Weber <mailto:michael.weber@post.rwth-aachen.de>,
+ inspired by the Haskell Monad Template Library from
+ Andy Gill (<http://www.cse.ogi.edu/~andy/>)
+-}
+module Control.Monad.Error.Class (
+ Error(..),
+ MonadError(..),
+ ) where
+
+-- | An exception to be thrown.
+-- An instance must redefine at least one of 'noMsg', 'strMsg'.
+class Error a where
+ -- | Creates an exception without a message.
+ -- Default implementation is @'strMsg' \"\"@.
+ noMsg :: a
+ -- | Creates an exception with a message.
+ -- Default implementation is 'noMsg'.
+ strMsg :: String -> a
+
+ noMsg = strMsg ""
+ strMsg _ = noMsg
+
+-- | A string can be thrown as an error.
+instance Error String where
+ noMsg = ""
+ strMsg = id
+
+instance Error IOError where
+ strMsg = userError
+
+{- |
+The strategy of combining computations that can throw exceptions
+by bypassing bound functions
+from the point an exception is thrown to the point that it is handled.
+
+Is parameterized over the type of error information and
+the monad type constructor.
+It is common to use @'Data.Either' String@ as the monad type constructor
+for an error monad in which error descriptions take the form of strings.
+In that case and many other common cases the resulting monad is already defined
+as an instance of the 'MonadError' class.
+You can also define your own error type and\/or use a monad type constructor
+other than @'Data.Either' String@ or @'Data.Either' IOError@.
+In these cases you will have to explicitly define instances of the 'Error'
+and\/or 'MonadError' classes.
+-}
+class (Monad m) => MonadError e m | m -> e where
+ -- | Is used within a monadic computation to begin exception processing.
+ throwError :: e -> m a
+
+ {- |
+ A handler function to handle previous errors and return to normal execution.
+ A common idiom is:
+
+ > do { action1; action2; action3 } `catchError` handler
+
+ where the @action@ functions can call 'throwError'.
+ Note that @handler@ and the do-block must have the same return type.
+ -}
+ catchError :: m a -> (e -> m a) -> m a
+
--- /dev/null
+{- |
+Module : Control.Monad.Identity
+Copyright : (c) Andy Gill 2001,
+ (c) Oregon Graduate Institute of Science and Technology 2001,
+ (c) Jeff Newbern 2003-2006,
+ (c) Andriy Palamarchuk 2006
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : portable
+
+[Computation type:] Simple function application.
+
+[Binding strategy:] The bound function is applied to the input value.
+@'Identity' x >>= f == 'Identity' (f x)@
+
+[Useful for:] Monads can be derived from monad transformers applied to the
+'Identity' monad.
+
+[Zero and plus:] None.
+
+[Example type:] @'Identity' a@
+
+The @Identity@ monad is a monad that does not embody any computational strategy.
+It simply applies the bound function to its input without any modification.
+Computationally, there is no reason to use the @Identity@ monad
+instead of the much simpler act of simply applying functions to their arguments.
+The purpose of the @Identity@ monad is its fundamental role in the theory
+of monad transformers.
+Any monad transformer applied to the @Identity@ monad yields a non-transformer
+version of that monad.
+
+ Inspired by the paper
+ /Functional Programming with Overloading and
+ Higher-Order Polymorphism/,
+ Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+ Advanced School of Functional Programming, 1995.
+-}
+
+module Control.Monad.Identity (
+ Identity(..),
+
+ module Control.Monad,
+ module Control.Monad.Fix,
+ ) where
+
+import Control.Monad
+import Control.Monad.Fix
+
+{- | Identity wrapper.
+Abstraction for wrapping up a object.
+If you have an monadic function, say:
+
+> example :: Int -> Identity Int
+> example x = return (x*x)
+
+ you can \"run\" it, using
+
+> Main> runIdentity (example 42)
+> 1764 :: Int
+
+A typical use of the Identity monad is to derive a monad
+from a monad transformer.
+
+@
+-- derive the 'Control.Monad.State.State' monad using the 'Control.Monad.State.StateT' monad transformer
+type 'Control.Monad.State.State' s a = 'Control.Monad.State.StateT' s 'Identity' a
+@
+
+The @'runIdentity'@ label is used in the type definition because it follows
+a style of monad definition that explicitly represents monad values as
+computations. In this style, a monadic computation is built up using the monadic
+operators and then the value of the computation is extracted
+using the @run******@ function.
+Because the @Identity@ monad does not do any computation, its definition
+is trivial.
+For a better example of this style of monad,
+see the @'Control.Monad.State.State'@ monad.
+-}
+
+newtype Identity a = Identity { runIdentity :: a }
+
+-- ---------------------------------------------------------------------------
+-- Identity instances for Functor and Monad
+
+instance Functor Identity where
+ fmap f m = Identity (f (runIdentity m))
+
+instance Monad Identity where
+ return a = Identity a
+ m >>= k = k (runIdentity m)
+
+instance MonadFix Identity where
+ mfix f = Identity (fix (runIdentity . f))
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Needed for the same reasons as in Reader, State etc
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.List
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-parameter type classes)
+--
+-- The List monad.
+--
+-----------------------------------------------------------------------------
+
+module Control.Monad.List (
+ ListT(..),
+ mapListT,
+ module Control.Monad,
+ module Control.Monad.Trans,
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable list monad, with an inner monad
+
+newtype ListT m a = ListT { runListT :: m [a] }
+
+mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b
+mapListT f m = ListT $ f (runListT m)
+
+instance (Monad m) => Functor (ListT m) where
+ fmap f m = ListT $ do
+ a <- runListT m
+ return (map f a)
+
+instance (Monad m) => Monad (ListT m) where
+ return a = ListT $ return [a]
+ m >>= k = ListT $ do
+ a <- runListT m
+ b <- mapM (runListT . k) a
+ return (concat b)
+ fail _ = ListT $ return []
+
+instance (Monad m) => MonadPlus (ListT m) where
+ mzero = ListT $ return []
+ m `mplus` n = ListT $ do
+ a <- runListT m
+ b <- runListT n
+ return (a ++ b)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance MonadTrans ListT where
+ lift m = ListT $ do
+ a <- m
+ return [a]
+
+instance (MonadIO m) => MonadIO (ListT m) where
+ liftIO = lift . liftIO
+
+instance (MonadCont m) => MonadCont (ListT m) where
+ callCC f = ListT $
+ callCC $ \c ->
+ runListT (f (\a -> ListT $ c [a]))
+
+instance (MonadError e m) => MonadError e (ListT m) where
+ throwError = lift . throwError
+ m `catchError` h = ListT $ runListT m
+ `catchError` \e -> runListT (h e)
+
+instance (MonadReader s m) => MonadReader s (ListT m) where
+ ask = lift ask
+ local f m = ListT $ local f (runListT m)
+
+instance (MonadState s m) => MonadState s (ListT m) where
+ get = lift get
+ put = lift . put
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.RWS
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Declaration of the MonadRWS class.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS (
+ module Control.Monad.RWS.Lazy
+ ) where
+
+import Control.Monad.RWS.Lazy
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.RWS.Class
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Declaration of the MonadRWS class.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS.Class (
+ MonadRWS,
+ module Control.Monad.Reader.Class,
+ module Control.Monad.State.Class,
+ module Control.Monad.Writer.Class,
+ ) where
+
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Writer.Class
+import Data.Monoid
+
+class (Monoid w, MonadReader r m, MonadWriter w m, MonadState s m)
+ => MonadRWS r w s m | m -> r, m -> w, m -> s
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.RWS.Lazy
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Lazy RWS monad.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS.Lazy (
+ RWS(..),
+ evalRWS,
+ execRWS,
+ mapRWS,
+ withRWS,
+ RWST(..),
+ evalRWST,
+ execRWST,
+ mapRWST,
+ withRWST,
+ module Control.Monad.RWS.Class,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ module Data.Monoid,
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+import Control.Monad.RWS.Class
+import Data.Monoid
+
+newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
+
+evalRWS :: RWS r w s a -> r -> s -> (a, w)
+evalRWS m r s = let
+ (a, _, w) = runRWS m r s
+ in (a, w)
+
+execRWS :: RWS r w s a -> r -> s -> (s, w)
+execRWS m r s = let
+ (_, s', w) = runRWS m r s
+ in (s', w)
+
+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
+mapRWS f m = RWS $ \r s -> f (runRWS m r s)
+
+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
+withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
+
+instance Functor (RWS r w s) where
+ fmap f m = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ in (f a, s', w)
+
+instance (Monoid w) => Monad (RWS r w s) where
+ return a = RWS $ \_ s -> (a, s, mempty)
+ m >>= k = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ (b, s'', w') = runRWS (k a) r s'
+ in (b, s'', w `mappend` w')
+
+instance (Monoid w) => MonadFix (RWS r w s) where
+ mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
+
+instance (Monoid w) => MonadReader r (RWS r w s) where
+ ask = RWS $ \r s -> (r, s, mempty)
+ local f m = RWS $ \r s -> runRWS m (f r) s
+
+instance (Monoid w) => MonadWriter w (RWS r w s) where
+ tell w = RWS $ \_ s -> ((), s, w)
+ listen m = RWS $ \r s -> let
+ (a, s', w) = runRWS m r s
+ in ((a, w), s', w)
+ pass m = RWS $ \r s -> let
+ ((a, f), s', w) = runRWS m r s
+ in (a, s', f w)
+
+instance (Monoid w) => MonadState s (RWS r w s) where
+ get = RWS $ \_ s -> (s, s, mempty)
+ put s = RWS $ \_ _ -> ((), s, mempty)
+
+instance (Monoid w) => MonadRWS r w s (RWS r w s)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable RWS monad, with an inner monad
+
+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
+
+evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
+evalRWST m r s = do
+ ~(a, _, w) <- runRWST m r s
+ return (a, w)
+
+execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
+execRWST m r s = do
+ ~(_, s', w) <- runRWST m r s
+ return (s', w)
+
+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
+mapRWST f m = RWST $ \r s -> f (runRWST m r s)
+
+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)
+
+instance (Monad m) => Functor (RWST r w s m) where
+ fmap f m = RWST $ \r s -> do
+ ~(a, s', w) <- runRWST m r s
+ return (f a, s', w)
+
+instance (Monoid w, Monad m) => Monad (RWST r w s m) where
+ return a = RWST $ \_ s -> return (a, s, mempty)
+ m >>= k = RWST $ \r s -> do
+ ~(a, s', w) <- runRWST m r s
+ ~(b, s'',w') <- runRWST (k a) r s'
+ return (b, s'', w `mappend` w')
+ fail msg = RWST $ \_ _ -> fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
+ mzero = RWST $ \_ _ -> mzero
+ m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
+
+instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
+ mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
+
+instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
+ ask = RWST $ \r s -> return (r, s, mempty)
+ local f m = RWST $ \r s -> runRWST m (f r) s
+
+instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
+ tell w = RWST $ \_ s -> return ((),s,w)
+ listen m = RWST $ \r s -> do
+ ~(a, s', w) <- runRWST m r s
+ return ((a, w), s', w)
+ pass m = RWST $ \r s -> do
+ ~((a, f), s', w) <- runRWST m r s
+ return (a, s', f w)
+
+instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
+ get = RWST $ \_ s -> return (s, s, mempty)
+ put s = RWST $ \_ _ -> return ((), s, mempty)
+
+instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance (Monoid w) => MonadTrans (RWST r w s) where
+ lift m = RWST $ \_ s -> do
+ a <- m
+ return (a, s, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
+ liftIO = lift . liftIO
+
+instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where
+ callCC f = RWST $ \r s ->
+ callCC $ \c ->
+ runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s
+
+instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where
+ throwError = lift . throwError
+ m `catchError` h = RWST $ \r s -> runRWST m r s
+ `catchError` \e -> runRWST (h e) r s
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.RWS.Strict
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Strict RWS Monad.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.RWS.Strict (
+ RWS(..),
+ evalRWS,
+ execRWS,
+ mapRWS,
+ withRWS,
+ RWST(..),
+ evalRWST,
+ execRWST,
+ mapRWST,
+ withRWST,
+ module Control.Monad.RWS.Class,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ module Data.Monoid,
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+import Control.Monad.RWS.Class
+import Data.Monoid
+
+newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) }
+
+evalRWS :: RWS r w s a -> r -> s -> (a, w)
+evalRWS m r s = case runRWS m r s of
+ (a, _, w) -> (a, w)
+
+execRWS :: RWS r w s a -> r -> s -> (s, w)
+execRWS m r s = case runRWS m r s of
+ (_, s', w) -> (s', w)
+
+mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b
+mapRWS f m = RWS $ \r s -> f (runRWS m r s)
+
+withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a
+withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s)
+
+instance Functor (RWS r w s) where
+ fmap f m = RWS $ \r s -> case runRWS m r s of
+ (a, s', w) -> (f a, s', w)
+
+instance (Monoid w) => Monad (RWS r w s) where
+ return a = RWS $ \_ s -> (a, s, mempty)
+ m >>= k = RWS $ \r s -> case runRWS m r s of
+ (a, s', w) ->
+ case runRWS (k a) r s' of
+ (b, s'', w') ->
+ (b, s'', w `mappend` w')
+
+instance (Monoid w) => MonadFix (RWS r w s) where
+ mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w)
+
+instance (Monoid w) => MonadReader r (RWS r w s) where
+ ask = RWS $ \r s -> (r, s, mempty)
+ local f m = RWS $ \r s -> runRWS m (f r) s
+
+instance (Monoid w) => MonadWriter w (RWS r w s) where
+ tell w = RWS $ \_ s -> ((), s, w)
+ listen m = RWS $ \r s -> case runRWS m r s of
+ (a, s', w) -> ((a, w), s', w)
+ pass m = RWS $ \r s -> case runRWS m r s of
+ ((a, f), s', w) -> (a, s', f w)
+
+instance (Monoid w) => MonadState s (RWS r w s) where
+ get = RWS $ \_ s -> (s, s, mempty)
+ put s = RWS $ \_ _ -> ((), s, mempty)
+
+instance (Monoid w) => MonadRWS r w s (RWS r w s)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable RWS monad, with an inner monad
+
+newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) }
+
+evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w)
+evalRWST m r s = do
+ (a, _, w) <- runRWST m r s
+ return (a, w)
+
+execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w)
+execRWST m r s = do
+ (_, s', w) <- runRWST m r s
+ return (s', w)
+
+mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
+mapRWST f m = RWST $ \r s -> f (runRWST m r s)
+
+withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a
+withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s)
+
+instance (Monad m) => Functor (RWST r w s m) where
+ fmap f m = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ return (f a, s', w)
+
+instance (Monoid w, Monad m) => Monad (RWST r w s m) where
+ return a = RWST $ \_ s -> return (a, s, mempty)
+ m >>= k = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ (b, s'',w') <- runRWST (k a) r s'
+ return (b, s'', w `mappend` w')
+ fail msg = RWST $ \_ _ -> fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where
+ mzero = RWST $ \_ _ -> mzero
+ m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s
+
+instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
+ mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s
+
+instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where
+ ask = RWST $ \r s -> return (r, s, mempty)
+ local f m = RWST $ \r s -> runRWST m (f r) s
+
+instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where
+ tell w = RWST $ \_ s -> return ((),s,w)
+ listen m = RWST $ \r s -> do
+ (a, s', w) <- runRWST m r s
+ return ((a, w), s', w)
+ pass m = RWST $ \r s -> do
+ ((a, f), s', w) <- runRWST m r s
+ return (a, s', f w)
+
+instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where
+ get = RWST $ \_ s -> return (s, s, mempty)
+ put s = RWST $ \_ _ -> return ((), s, mempty)
+
+instance (Monoid w, Monad m) => MonadRWS r w s (RWST r w s m)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance (Monoid w) => MonadTrans (RWST r w s) where
+ lift m = RWST $ \_ s -> do
+ a <- m
+ return (a, s, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where
+ liftIO = lift . liftIO
+
+instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where
+ callCC f = RWST $ \r s ->
+ callCC $ \c ->
+ runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s
+
+instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where
+ throwError = lift . throwError
+ m `catchError` h = RWST $ \r s -> runRWST m r s
+ `catchError` \e -> runRWST (h e) r s
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+{- |
+Module : Control.Monad.Reader
+Copyright : (c) Andy Gill 2001,
+ (c) Oregon Graduate Institute of Science and Technology 2001,
+ (c) Jeff Newbern 2003-2007,
+ (c) Andriy Palamarchuk 2007
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-param classes, functional dependencies)
+
+[Computation type:] Computations which read values from a shared environment.
+
+[Binding strategy:] Monad values are functions from the environment to a value.
+The bound function is applied to the bound value, and both have access
+to the shared environment.
+
+[Useful for:] Maintaining variable bindings, or other shared environment.
+
+[Zero and plus:] None.
+
+[Example type:] @'Reader' [(String,Value)] a@
+
+The 'Reader' monad (also called the Environment monad).
+Represents a computation, which can read values from
+a shared environment, pass values from function to function,
+and execute sub-computations in a modified environment.
+Using 'Reader' monad for such computations is often clearer and easier
+than using the 'Control.Monad.State.State' monad.
+
+ Inspired by the paper
+ /Functional Programming with Overloading and
+ Higher-Order Polymorphism/,
+ Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+ Advanced School of Functional Programming, 1995.
+-}
+
+module Control.Monad.Reader (
+ module Control.Monad.Reader.Class,
+ Reader(..),
+ mapReader,
+ withReader,
+ ReaderT(..),
+ mapReaderT,
+ withReaderT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ -- * Example 1: Simple Reader Usage
+ -- $simpleReaderExample
+
+ -- * Example 2: Modifying Reader Content With @local@
+ -- $localExample
+
+ -- * Example 3: @ReaderT@ Monad Transformer
+ -- $ReaderTExample
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Instances ()
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+
+{- |
+The parameterizable reader monad.
+
+The @return@ function creates a @Reader@ that ignores the environment,
+and produces the given value.
+
+The binding operator @>>=@ produces a @Reader@ that uses the environment
+to extract the value its left-hand side,
+and then applies the bound function to that value in the same environment.
+-}
+newtype Reader r a = Reader {
+ {- |
+ Runs @Reader@ and extracts the final value from it.
+ To extract the value apply @(runReader reader)@ to an environment value.
+ Parameters:
+
+ * A @Reader@ to run.
+
+ * An initial environment.
+ -}
+ runReader :: r -> a
+}
+
+mapReader :: (a -> b) -> Reader r a -> Reader r b
+mapReader f m = Reader $ f . runReader m
+
+-- | A more general version of 'local'.
+
+withReader :: (r' -> r) -> Reader r a -> Reader r' a
+withReader f m = Reader $ runReader m . f
+
+instance Functor (Reader r) where
+ fmap f m = Reader $ \r -> f (runReader m r)
+
+instance Monad (Reader r) where
+ return a = Reader $ \_ -> a
+ m >>= k = Reader $ \r -> runReader (k (runReader m r)) r
+
+instance MonadFix (Reader r) where
+ mfix f = Reader $ \r -> let a = runReader (f a) r in a
+
+instance MonadReader r (Reader r) where
+ ask = Reader id
+ local f m = Reader $ runReader m . f
+
+{- |
+The reader monad transformer.
+Can be used to add environment reading functionality to other monads.
+-}
+newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a }
+
+mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b
+mapReaderT f m = ReaderT $ f . runReaderT m
+
+withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a
+withReaderT f m = ReaderT $ runReaderT m . f
+
+instance (Monad m) => Functor (ReaderT r m) where
+ fmap f m = ReaderT $ \r -> do
+ a <- runReaderT m r
+ return (f a)
+
+instance (Monad m) => Monad (ReaderT r m) where
+ return a = ReaderT $ \_ -> return a
+ m >>= k = ReaderT $ \r -> do
+ a <- runReaderT m r
+ runReaderT (k a) r
+ fail msg = ReaderT $ \_ -> fail msg
+
+instance (MonadPlus m) => MonadPlus (ReaderT r m) where
+ mzero = ReaderT $ \_ -> mzero
+ m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r
+
+instance (MonadFix m) => MonadFix (ReaderT r m) where
+ mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r
+
+instance (Monad m) => MonadReader r (ReaderT r m) where
+ ask = ReaderT return
+ local f m = ReaderT $ \r -> runReaderT m (f r)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance MonadTrans (ReaderT r) where
+ lift m = ReaderT $ \_ -> m
+
+instance (MonadIO m) => MonadIO (ReaderT r m) where
+ liftIO = lift . liftIO
+
+instance (MonadCont m) => MonadCont (ReaderT r m) where
+ callCC f = ReaderT $ \r ->
+ callCC $ \c ->
+ runReaderT (f (\a -> ReaderT $ \_ -> c a)) r
+
+instance (MonadError e m) => MonadError e (ReaderT r m) where
+ throwError = lift . throwError
+ m `catchError` h = ReaderT $ \r -> runReaderT m r
+ `catchError` \e -> runReaderT (h e) r
+
+-- Needs UndecidableInstances
+instance (MonadState s m) => MonadState s (ReaderT r m) where
+ get = lift get
+ put = lift . put
+
+-- This instance needs UndecidableInstances, because
+-- it does not satisfy the coverage condition
+instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where
+ tell = lift . tell
+ listen m = ReaderT $ \w -> listen (runReaderT m w)
+ pass m = ReaderT $ \w -> pass (runReaderT m w)
+
+{- $simpleReaderExample
+
+In this example the @Reader@ monad provides access to variable bindings.
+Bindings are a 'Map' of integer variables.
+The variable @count@ contains number of variables in the bindings.
+You can see how to run a Reader monad and retrieve data from it
+with 'runReader', how to access the Reader data with 'ask' and 'asks'.
+
+> type Bindings = Map String Int;
+>
+>-- Returns True if the "count" variable contains correct bindings size.
+>isCountCorrect :: Bindings -> Bool
+>isCountCorrect bindings = runReader calc_isCountCorrect bindings
+>
+>-- The Reader monad, which implements this complicated check.
+>calc_isCountCorrect :: Reader Bindings Bool
+>calc_isCountCorrect = do
+> count <- asks (lookupVar "count")
+> bindings <- ask
+> return (count == (Map.size bindings))
+>
+>-- The selector function to use with 'asks'.
+>-- Returns value of the variable with specified name.
+>lookupVar :: String -> Bindings -> Int
+>lookupVar name bindings = fromJust (Map.lookup name bindings)
+>
+>sampleBindings = Map.fromList [("count",3), ("1",1), ("b",2)]
+>
+>main = do
+> putStr $ "Count is correct for bindings " ++ (show sampleBindings) ++ ": ";
+> putStrLn $ show (isCountCorrect sampleBindings);
+-}
+
+{- $localExample
+
+Shows how to modify Reader content with 'local'.
+
+>calculateContentLen :: Reader String Int
+>calculateContentLen = do
+> content <- ask
+> return (length content);
+>
+>-- Calls calculateContentLen after adding a prefix to the Reader content.
+>calculateModifiedContentLen :: Reader String Int
+>calculateModifiedContentLen = local ("Prefix " ++) calculateContentLen
+>
+>main = do
+> let s = "12345";
+> let modifiedLen = runReader calculateModifiedContentLen s
+> let len = runReader calculateContentLen s
+> putStrLn $ "Modified 's' length: " ++ (show modifiedLen)
+> putStrLn $ "Original 's' length: " ++ (show len)
+-}
+
+{- $ReaderTExample
+
+Now you are thinking: 'Wow, what a great monad! I wish I could use
+Reader functionality in MyFavoriteComplexMonad!'. Don't worry.
+This can be easy done with the 'ReaderT' monad transformer.
+This example shows how to combine @ReaderT@ with the IO monad.
+
+>-- The Reader/IO combined monad, where Reader stores a string.
+>printReaderContent :: ReaderT String IO ()
+>printReaderContent = do
+> content <- ask
+> liftIO $ putStrLn ("The Reader Content: " ++ content)
+>
+>main = do
+> runReaderT printReaderContent "Some Content"
+-}
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+{- |
+Module : Control.Monad.Reader.Class
+Copyright : (c) Andy Gill 2001,
+ (c) Oregon Graduate Institute of Science and Technology 2001,
+ (c) Jeff Newbern 2003-2007,
+ (c) Andriy Palamarchuk 2007
+License : BSD-style (see the file libraries/base/LICENSE)
+
+Maintainer : libraries@haskell.org
+Stability : experimental
+Portability : non-portable (multi-param classes, functional dependencies)
+
+[Computation type:] Computations which read values from a shared environment.
+
+[Binding strategy:] Monad values are functions from the environment to a value.
+The bound function is applied to the bound value, and both have access
+to the shared environment.
+
+[Useful for:] Maintaining variable bindings, or other shared environment.
+
+[Zero and plus:] None.
+
+[Example type:] @'Reader' [(String,Value)] a@
+
+The 'Reader' monad (also called the Environment monad).
+Represents a computation, which can read values from
+a shared environment, pass values from function to function,
+and execute sub-computations in a modified environment.
+Using 'Reader' monad for such computations is often clearer and easier
+than using the 'Control.Monad.State.State' monad.
+
+ Inspired by the paper
+ /Functional Programming with Overloading and
+ Higher-Order Polymorphism/,
+ Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+ Advanced School of Functional Programming, 1995.
+-}
+
+module Control.Monad.Reader.Class (
+ MonadReader(..),
+ asks,
+ ) where
+
+import Control.Monad.Instances ()
+
+{- |
+See examples in "Control.Monad.Reader".
+Note, the partially applied function type @(->) r@ is a simple reader monad.
+See the @instance@ declaration below.
+-}
+class (Monad m) => MonadReader r m | m -> r where
+ -- | Retrieves the monad environment.
+ ask :: m r
+ {- | Executes a computation in a modified environment. Parameters:
+
+ * The function to modify the environment.
+
+ * @Reader@ to run.
+
+ * The resulting @Reader@.
+ -}
+ local :: (r -> r) -> m a -> m a
+
+-- ----------------------------------------------------------------------------
+-- The partially applied function type is a simple reader monad
+
+instance MonadReader r ((->) r) where
+ ask = id
+ local f m = m . f
+
+{- |
+Retrieves a function of the current environment. Parameters:
+
+* The selector function to apply to the environment.
+
+See an example in "Control.Monad.Reader".
+-}
+asks :: (MonadReader r m) => (r -> a) -> m a
+asks f = do
+ r <- ask
+ return (f r)
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.State
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- State monads.
+--
+-- This module is inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+
+-----------------------------------------------------------------------------
+
+module Control.Monad.State (
+ module Control.Monad.State.Lazy
+ ) where
+
+import Control.Monad.State.Lazy
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.State.Class
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- MonadState class.
+--
+-- This module is inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+
+-----------------------------------------------------------------------------
+
+module Control.Monad.State.Class (
+ -- * MonadState class
+ MonadState(..),
+ modify,
+ gets,
+ ) where
+
+-- ---------------------------------------------------------------------------
+-- | /get/ returns the state from the internals of the monad.
+--
+-- /put/ replaces the state inside the monad.
+
+class (Monad m) => MonadState s m | m -> s where
+ get :: m s
+ put :: s -> m ()
+
+-- | Monadic state transformer.
+--
+-- Maps an old state to a new state inside a state monad.
+-- The old state is thrown away.
+--
+-- > Main> :t modify ((+1) :: Int -> Int)
+-- > modify (...) :: (MonadState Int a) => a ()
+--
+-- This says that @modify (+1)@ acts over any
+-- Monad that is a member of the @MonadState@ class,
+-- with an @Int@ state.
+
+modify :: (MonadState s m) => (s -> s) -> m ()
+modify f = do
+ s <- get
+ put (f s)
+
+-- | Gets specific component of the state, using a projection function
+-- supplied.
+
+gets :: (MonadState s m) => (s -> a) -> m a
+gets f = do
+ s <- get
+ return (f s)
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.State.Lazy
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Lazy state monads.
+--
+-- This module is inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+--
+-- See below for examples.
+
+-----------------------------------------------------------------------------
+
+module Control.Monad.State.Lazy (
+ module Control.Monad.State.Class,
+ -- * The State Monad
+ State(..),
+ evalState,
+ execState,
+ mapState,
+ withState,
+ -- * The StateT Monad
+ StateT(..),
+ evalStateT,
+ execStateT,
+ mapStateT,
+ withStateT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ -- * Examples
+ -- $examples
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+
+-- ---------------------------------------------------------------------------
+-- | A parameterizable state monad where /s/ is the type of the state
+-- to carry and /a/ is the type of the /return value/.
+
+newtype State s a = State { runState :: s -> (a, s) }
+
+-- |Evaluate this state monad with the given initial state,throwing
+-- away the final state. Very much like @fst@ composed with
+-- @runstate@.
+
+evalState :: State s a -- ^The state to evaluate
+ -> s -- ^An initial value
+ -> a -- ^The return value of the state application
+evalState m s = fst (runState m s)
+
+-- |Execute this state and return the new state, throwing away the
+-- return value. Very much like @snd@ composed with
+-- @runstate@.
+
+execState :: State s a -- ^The state to evaluate
+ -> s -- ^An initial value
+ -> s -- ^The new state
+execState m s = snd (runState m s)
+
+-- |Map a stateful computation from one (return value, state) pair to
+-- another. For instance, to convert numberTree from a function that
+-- returns a tree to a function that returns the sum of the numbered
+-- tree (see the Examples section for numberTree and sumTree) you may
+-- write:
+--
+-- > sumNumberedTree :: (Eq a) => Tree a -> State (Table a) Int
+-- > sumNumberedTree = mapState (\ (t, tab) -> (sumTree t, tab)) . numberTree
+
+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
+mapState f m = State $ f . runState m
+
+-- |Apply this function to this state and return the resulting state.
+withState :: (s -> s) -> State s a -> State s a
+withState f m = State $ runState m . f
+
+instance Functor (State s) where
+ fmap f m = State $ \s -> let
+ (a, s') = runState m s
+ in (f a, s')
+
+instance Monad (State s) where
+ return a = State $ \s -> (a, s)
+ m >>= k = State $ \s -> let
+ (a, s') = runState m s
+ in runState (k a) s'
+
+instance MonadFix (State s) where
+ mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s')
+
+instance MonadState s (State s) where
+ get = State $ \s -> (s, s)
+ put s = State $ \_ -> ((), s)
+
+-- ---------------------------------------------------------------------------
+-- | A parameterizable state monad for encapsulating an inner
+-- monad.
+--
+-- The StateT Monad structure is parameterized over two things:
+--
+-- * s - The state.
+--
+-- * m - The inner monad.
+--
+-- Here are some examples of use:
+--
+-- (Parser from ParseLib with Hugs)
+--
+-- > type Parser a = StateT String [] a
+-- > ==> StateT (String -> [(a,String)])
+--
+-- For example, item can be written as:
+--
+-- > item = do (x:xs) <- get
+-- > put xs
+-- > return x
+-- >
+-- > type BoringState s a = StateT s Indentity a
+-- > ==> StateT (s -> Identity (a,s))
+-- >
+-- > type StateWithIO s a = StateT s IO a
+-- > ==> StateT (s -> IO (a,s))
+-- >
+-- > type StateWithErr s a = StateT s Maybe a
+-- > ==> StateT (s -> Maybe (a,s))
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+-- |Similar to 'evalState'
+evalStateT :: (Monad m) => StateT s m a -> s -> m a
+evalStateT m s = do
+ ~(a, _) <- runStateT m s
+ return a
+
+-- |Similar to 'execState'
+execStateT :: (Monad m) => StateT s m a -> s -> m s
+execStateT m s = do
+ ~(_, s') <- runStateT m s
+ return s'
+
+-- |Similar to 'mapState'
+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
+mapStateT f m = StateT $ f . runStateT m
+
+-- |Similar to 'withState'
+withStateT :: (s -> s) -> StateT s m a -> StateT s m a
+withStateT f m = StateT $ runStateT m . f
+
+instance (Monad m) => Functor (StateT s m) where
+ fmap f m = StateT $ \s -> do
+ ~(x, s') <- runStateT m s
+ return (f x, s')
+
+instance (Monad m) => Monad (StateT s m) where
+ return a = StateT $ \s -> return (a, s)
+ m >>= k = StateT $ \s -> do
+ ~(a, s') <- runStateT m s
+ runStateT (k a) s'
+ fail str = StateT $ \_ -> fail str
+
+instance (MonadPlus m) => MonadPlus (StateT s m) where
+ mzero = StateT $ \_ -> mzero
+ m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
+
+instance (MonadFix m) => MonadFix (StateT s m) where
+ mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
+
+instance (Monad m) => MonadState s (StateT s m) where
+ get = StateT $ \s -> return (s, s)
+ put s = StateT $ \_ -> return ((), s)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance MonadTrans (StateT s) where
+ lift m = StateT $ \s -> do
+ a <- m
+ return (a, s)
+
+instance (MonadIO m) => MonadIO (StateT s m) where
+ liftIO = lift . liftIO
+
+instance (MonadCont m) => MonadCont (StateT s m) where
+ callCC f = StateT $ \s ->
+ callCC $ \c ->
+ runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
+
+instance (MonadError e m) => MonadError e (StateT s m) where
+ throwError = lift . throwError
+ m `catchError` h = StateT $ \s -> runStateT m s
+ `catchError` \e -> runStateT (h e) s
+
+-- Needs UndecidableInstances
+instance (MonadReader r m) => MonadReader r (StateT s m) where
+ ask = lift ask
+ local f m = StateT $ \s -> local f (runStateT m s)
+
+-- Needs UndecidableInstances
+instance (MonadWriter w m) => MonadWriter w (StateT s m) where
+ tell = lift . tell
+ listen m = StateT $ \s -> do
+ ~((a, s'), w) <- listen (runStateT m s)
+ return ((a, w), s')
+ pass m = StateT $ \s -> pass $ do
+ ~((a, f), s') <- runStateT m s
+ return ((a, s'), f)
+
+-- ---------------------------------------------------------------------------
+-- $examples
+-- A function to increment a counter. Taken from the paper
+-- /Generalising Monads to Arrows/, John
+-- Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:
+--
+-- > tick :: State Int Int
+-- > tick = do n <- get
+-- > put (n+1)
+-- > return n
+--
+-- Add one to the given number using the state monad:
+--
+-- > plusOne :: Int -> Int
+-- > plusOne n = execState tick n
+--
+-- A contrived addition example. Works only with positive numbers:
+--
+-- > plus :: Int -> Int -> Int
+-- > plus n x = execState (sequence $ replicate n tick) x
+--
+-- An example from /The Craft of Functional Programming/, Simon
+-- Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),
+-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a
+-- tree of integers in which the original elements are replaced by
+-- natural numbers, starting from 0. The same element has to be
+-- replaced by the same number at every occurrence, and when we meet
+-- an as-yet-unvisited element we have to find a \'new\' number to match
+-- it with:\"
+--
+-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
+-- > type Table a = [a]
+--
+-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)
+-- > numberTree Nil = return Nil
+-- > numberTree (Node x t1 t2)
+-- > = do num <- numberNode x
+-- > nt1 <- numberTree t1
+-- > nt2 <- numberTree t2
+-- > return (Node num nt1 nt2)
+-- > where
+-- > numberNode :: Eq a => a -> State (Table a) Int
+-- > numberNode x
+-- > = do table <- get
+-- > (newTable, newPos) <- return (nNode x table)
+-- > put newTable
+-- > return newPos
+-- > nNode:: (Eq a) => a -> Table a -> (Table a, Int)
+-- > nNode x table
+-- > = case (findIndexInList (== x) table) of
+-- > Nothing -> (table ++ [x], length table)
+-- > Just i -> (table, i)
+-- > findIndexInList :: (a -> Bool) -> [a] -> Maybe Int
+-- > findIndexInList = findIndexInListHelp 0
+-- > findIndexInListHelp _ _ [] = Nothing
+-- > findIndexInListHelp count f (h:t)
+-- > = if (f h)
+-- > then Just count
+-- > else findIndexInListHelp (count+1) f t
+--
+-- numTree applies numberTree with an initial state:
+--
+-- > numTree :: (Eq a) => Tree a -> Tree Int
+-- > numTree t = evalState (numberTree t) []
+--
+-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil
+-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil
+--
+-- sumTree is a little helper function that does not use the State monad:
+--
+-- > sumTree :: (Num a) => Tree a -> a
+-- > sumTree Nil = 0
+-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.State.Strict
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Strict state monads.
+--
+-- This module is inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+--
+-- See below for examples.
+
+-----------------------------------------------------------------------------
+
+module Control.Monad.State.Strict (
+ module Control.Monad.State.Class,
+ -- * The State Monad
+ State(..),
+ evalState,
+ execState,
+ mapState,
+ withState,
+ -- * The StateT Monad
+ StateT(..),
+ evalStateT,
+ execStateT,
+ mapStateT,
+ withStateT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ -- * Examples
+ -- $examples
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+
+-- ---------------------------------------------------------------------------
+-- | A parameterizable state monad where /s/ is the type of the state
+-- to carry and /a/ is the type of the /return value/.
+
+newtype State s a = State { runState :: s -> (a, s) }
+
+-- |Evaluate this state monad with the given initial state,throwing
+-- away the final state. Very much like @fst@ composed with
+-- @runstate@.
+
+evalState :: State s a -- ^The state to evaluate
+ -> s -- ^An initial value
+ -> a -- ^The return value of the state application
+evalState m s = fst (runState m s)
+
+-- |Execute this state and return the new state, throwing away the
+-- return value. Very much like @snd@ composed with
+-- @runstate@.
+
+execState :: State s a -- ^The state to evaluate
+ -> s -- ^An initial value
+ -> s -- ^The new state
+execState m s = snd (runState m s)
+
+-- |Map a stateful computation from one (return value, state) pair to
+-- another. For instance, to convert numberTree from a function that
+-- returns a tree to a function that returns the sum of the numbered
+-- tree (see the Examples section for numberTree and sumTree) you may
+-- write:
+--
+-- > sumNumberedTree :: (Eq a) => Tree a -> State (Table a) Int
+-- > sumNumberedTree = mapState (\ (t, tab) -> (sumTree t, tab)) . numberTree
+
+mapState :: ((a, s) -> (b, s)) -> State s a -> State s b
+mapState f m = State $ f . runState m
+
+-- |Apply this function to this state and return the resulting state.
+withState :: (s -> s) -> State s a -> State s a
+withState f m = State $ runState m . f
+
+
+instance Functor (State s) where
+ fmap f m = State $ \s -> case runState m s of
+ (a, s') -> (f a, s')
+
+instance Monad (State s) where
+ return a = State $ \s -> (a, s)
+ m >>= k = State $ \s -> case runState m s of
+ (a, s') -> runState (k a) s'
+
+instance MonadFix (State s) where
+ mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s')
+
+instance MonadState s (State s) where
+ get = State $ \s -> (s, s)
+ put s = State $ \_ -> ((), s)
+
+-- ---------------------------------------------------------------------------
+-- | A parameterizable state monad for encapsulating an inner
+-- monad.
+--
+-- The StateT Monad structure is parameterized over two things:
+--
+-- * s - The state.
+--
+-- * m - The inner monad.
+--
+-- Here are some examples of use:
+--
+-- (Parser from ParseLib with Hugs)
+--
+-- > type Parser a = StateT String [] a
+-- > ==> StateT (String -> [(a,String)])
+--
+-- For example, item can be written as:
+--
+-- > item = do (x:xs) <- get
+-- > put xs
+-- > return x
+-- >
+-- > type BoringState s a = StateT s Indentity a
+-- > ==> StateT (s -> Identity (a,s))
+-- >
+-- > type StateWithIO s a = StateT s IO a
+-- > ==> StateT (s -> IO (a,s))
+-- >
+-- > type StateWithErr s a = StateT s Maybe a
+-- > ==> StateT (s -> Maybe (a,s))
+
+newtype StateT s m a = StateT { runStateT :: s -> m (a,s) }
+
+-- |Similar to 'evalState'
+evalStateT :: (Monad m) => StateT s m a -> s -> m a
+evalStateT m s = do
+ (a, _) <- runStateT m s
+ return a
+
+-- |Similar to 'execState'
+execStateT :: (Monad m) => StateT s m a -> s -> m s
+execStateT m s = do
+ (_, s') <- runStateT m s
+ return s'
+
+-- |Similar to 'mapState'
+mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
+mapStateT f m = StateT $ f . runStateT m
+
+-- |Similar to 'withState'
+withStateT :: (s -> s) -> StateT s m a -> StateT s m a
+withStateT f m = StateT $ runStateT m . f
+
+instance (Monad m) => Functor (StateT s m) where
+ fmap f m = StateT $ \s -> do
+ (x, s') <- runStateT m s
+ return (f x, s')
+
+instance (Monad m) => Monad (StateT s m) where
+ return a = StateT $ \s -> return (a, s)
+ m >>= k = StateT $ \s -> do
+ (a, s') <- runStateT m s
+ runStateT (k a) s'
+ fail str = StateT $ \_ -> fail str
+
+instance (MonadPlus m) => MonadPlus (StateT s m) where
+ mzero = StateT $ \_ -> mzero
+ m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s
+
+instance (MonadFix m) => MonadFix (StateT s m) where
+ mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s
+
+instance (Monad m) => MonadState s (StateT s m) where
+ get = StateT $ \s -> return (s, s)
+ put s = StateT $ \_ -> return ((), s)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance MonadTrans (StateT s) where
+ lift m = StateT $ \s -> do
+ a <- m
+ return (a, s)
+
+instance (MonadIO m) => MonadIO (StateT s m) where
+ liftIO = lift . liftIO
+
+instance (MonadCont m) => MonadCont (StateT s m) where
+ callCC f = StateT $ \s ->
+ callCC $ \c ->
+ runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s
+
+instance (MonadError e m) => MonadError e (StateT s m) where
+ throwError = lift . throwError
+ m `catchError` h = StateT $ \s -> runStateT m s
+ `catchError` \e -> runStateT (h e) s
+
+-- Needs UndecidableInstances
+instance (MonadReader r m) => MonadReader r (StateT s m) where
+ ask = lift ask
+ local f m = StateT $ \s -> local f (runStateT m s)
+
+-- Needs UndecidableInstances
+instance (MonadWriter w m) => MonadWriter w (StateT s m) where
+ tell = lift . tell
+ listen m = StateT $ \s -> do
+ ((a, s'), w) <- listen (runStateT m s)
+ return ((a, w), s')
+ pass m = StateT $ \s -> pass $ do
+ ((a, f), s') <- runStateT m s
+ return ((a, s'), f)
+
+-- ---------------------------------------------------------------------------
+-- $examples
+-- A function to increment a counter. Taken from the paper
+-- /Generalising Monads to Arrows/, John
+-- Hughes (<http://www.math.chalmers.se/~rjmh/>), November 1998:
+--
+-- > tick :: State Int Int
+-- > tick = do n <- get
+-- > put (n+1)
+-- > return n
+--
+-- Add one to the given number using the state monad:
+--
+-- > plusOne :: Int -> Int
+-- > plusOne n = execState tick n
+--
+-- A contrived addition example. Works only with positive numbers:
+--
+-- > plus :: Int -> Int -> Int
+-- > plus n x = execState (sequence $ replicate n tick) x
+--
+-- An example from /The Craft of Functional Programming/, Simon
+-- Thompson (<http://www.cs.kent.ac.uk/people/staff/sjt/>),
+-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a
+-- tree of integers in which the original elements are replaced by
+-- natural numbers, starting from 0. The same element has to be
+-- replaced by the same number at every occurrence, and when we meet
+-- an as-yet-unvisited element we have to find a \'new\' number to match
+-- it with:\"
+--
+-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq)
+-- > type Table a = [a]
+--
+-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int)
+-- > numberTree Nil = return Nil
+-- > numberTree (Node x t1 t2)
+-- > = do num <- numberNode x
+-- > nt1 <- numberTree t1
+-- > nt2 <- numberTree t2
+-- > return (Node num nt1 nt2)
+-- > where
+-- > numberNode :: Eq a => a -> State (Table a) Int
+-- > numberNode x
+-- > = do table <- get
+-- > (newTable, newPos) <- return (nNode x table)
+-- > put newTable
+-- > return newPos
+-- > nNode:: (Eq a) => a -> Table a -> (Table a, Int)
+-- > nNode x table
+-- > = case (findIndexInList (== x) table) of
+-- > Nothing -> (table ++ [x], length table)
+-- > Just i -> (table, i)
+-- > findIndexInList :: (a -> Bool) -> [a] -> Maybe Int
+-- > findIndexInList = findIndexInListHelp 0
+-- > findIndexInListHelp _ _ [] = Nothing
+-- > findIndexInListHelp count f (h:t)
+-- > = if (f h)
+-- > then Just count
+-- > else findIndexInListHelp (count+1) f t
+--
+-- numTree applies numberTree with an initial state:
+--
+-- > numTree :: (Eq a) => Tree a -> Tree Int
+-- > numTree t = evalState (numberTree t) []
+--
+-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil
+-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil
+--
+-- sumTree is a little helper function that does not use the State monad:
+--
+-- > sumTree :: (Num a) => Tree a -> a
+-- > sumTree Nil = 0
+-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Trans
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- The MonadTrans class.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Trans (
+ MonadTrans(..),
+ MonadIO(..),
+ ) where
+
+-- ---------------------------------------------------------------------------
+-- MonadTrans class
+--
+-- Monad to facilitate stackable Monads.
+-- Provides a way of digging into an outer
+-- monad, giving access to (lifting) the inner monad.
+
+class MonadTrans t where
+ lift :: Monad m => m a -> t m a
+
+class (Monad m) => MonadIO m where
+ liftIO :: IO a -> m a
+
+instance MonadIO IO where
+ liftIO = id
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Writer
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- The MonadWriter class.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer (
+ module Control.Monad.Writer.Lazy
+ ) where
+
+import Control.Monad.Writer.Lazy
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Writer.Class
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- The MonadWriter class.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer.Class (
+ MonadWriter(..),
+ listens,
+ censor,
+ ) where
+
+import Data.Monoid
+
+-- ---------------------------------------------------------------------------
+-- MonadWriter class
+--
+-- tell is like tell on the MUD's it shouts to monad
+-- what you want to be heard. The monad carries this 'packet'
+-- upwards, merging it if needed (hence the Monoid requirement)}
+--
+-- listen listens to a monad acting, and returns what the monad "said".
+--
+-- pass lets you provide a writer transformer which changes internals of
+-- the written object.
+
+class (Monoid w, Monad m) => MonadWriter w m | m -> w where
+ tell :: w -> m ()
+ listen :: m a -> m (a, w)
+ pass :: m (a, w -> w) -> m a
+
+listens :: (MonadWriter w m) => (w -> b) -> m a -> m (a, b)
+listens f m = do
+ ~(a, w) <- listen m
+ return (a, f w)
+
+censor :: (MonadWriter w m) => (w -> w) -> m a -> m a
+censor f m = pass $ do
+ a <- m
+ return (a, f)
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Writer.Lazy
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Lazy writer monads.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer.Lazy (
+ module Control.Monad.Writer.Class,
+ Writer(..),
+ execWriter,
+ mapWriter,
+ WriterT(..),
+ execWriterT,
+ mapWriterT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ module Data.Monoid,
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+import Data.Monoid
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad
+
+newtype Writer w a = Writer { runWriter :: (a, w) }
+
+execWriter :: Writer w a -> w
+execWriter m = snd (runWriter m)
+
+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
+mapWriter f m = Writer $ f (runWriter m)
+
+instance Functor (Writer w) where
+ fmap f m = Writer $ let (a, w) = runWriter m in (f a, w)
+
+instance (Monoid w) => Monad (Writer w) where
+ return a = Writer (a, mempty)
+ m >>= k = Writer $ let
+ (a, w) = runWriter m
+ (b, w') = runWriter (k a)
+ in (b, w `mappend` w')
+
+instance (Monoid w) => MonadFix (Writer w) where
+ mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
+
+instance (Monoid w) => MonadWriter w (Writer w) where
+ tell w = Writer ((), w)
+ listen m = Writer $ let (a, w) = runWriter m in ((a, w), w)
+ pass m = Writer $ let ((a, f), w) = runWriter m in (a, f w)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad, with an inner monad
+
+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+
+execWriterT :: Monad m => WriterT w m a -> m w
+execWriterT m = do
+ ~(_, w) <- runWriterT m
+ return w
+
+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
+mapWriterT f m = WriterT $ f (runWriterT m)
+
+instance (Monad m) => Functor (WriterT w m) where
+ fmap f m = WriterT $ do
+ ~(a, w) <- runWriterT m
+ return (f a, w)
+
+instance (Monoid w, Monad m) => Monad (WriterT w m) where
+ return a = WriterT $ return (a, mempty)
+ m >>= k = WriterT $ do
+ ~(a, w) <- runWriterT m
+ ~(b, w') <- runWriterT (k a)
+ return (b, w `mappend` w')
+ fail msg = WriterT $ fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
+ mzero = WriterT mzero
+ m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
+
+instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
+ mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
+
+instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
+ tell w = WriterT $ return ((), w)
+ listen m = WriterT $ do
+ ~(a, w) <- runWriterT m
+ return ((a, w), w)
+ pass m = WriterT $ do
+ ~((a, f), w) <- runWriterT m
+ return (a, f w)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance (Monoid w) => MonadTrans (WriterT w) where
+ lift m = WriterT $ do
+ a <- m
+ return (a, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
+ liftIO = lift . liftIO
+
+instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
+ callCC f = WriterT $
+ callCC $ \c ->
+ runWriterT (f (\a -> WriterT $ c (a, mempty)))
+
+instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
+ throwError = lift . throwError
+ m `catchError` h = WriterT $ runWriterT m
+ `catchError` \e -> runWriterT (h e)
+
+-- This instance needs UndecidableInstances, because
+-- it does not satisfy the coverage condition
+instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
+ ask = lift ask
+ local f m = WriterT $ local f (runWriterT m)
+
+-- Needs UndecidableInstances
+instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
+ get = lift get
+ put = lift . put
+
--- /dev/null
+{-# LANGUAGE UndecidableInstances #-}
+-- Search for UndecidableInstances to see why this is needed
+
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Writer.Strict
+-- Copyright : (c) Andy Gill 2001,
+-- (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : non-portable (multi-param classes, functional dependencies)
+--
+-- Strict writer monads.
+--
+-- Inspired by the paper
+-- /Functional Programming with Overloading and
+-- Higher-Order Polymorphism/,
+-- Mark P Jones (<http://web.cecs.pdx.edu/~mpj/pubs/springschool.html>)
+-- Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Writer.Strict (
+ module Control.Monad.Writer.Class,
+ Writer(..),
+ execWriter,
+ mapWriter,
+ WriterT(..),
+ execWriterT,
+ mapWriterT,
+ module Control.Monad,
+ module Control.Monad.Fix,
+ module Control.Monad.Trans,
+ module Data.Monoid,
+ ) where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.Fix
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Trans
+import Control.Monad.Writer.Class
+import Data.Monoid
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad
+
+newtype Writer w a = Writer { runWriter :: (a, w) }
+
+execWriter :: Writer w a -> w
+execWriter m = snd (runWriter m)
+
+mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
+mapWriter f m = Writer $ f (runWriter m)
+
+instance Functor (Writer w) where
+ fmap f m = Writer $ case runWriter m of
+ (a, w) -> (f a, w)
+
+instance (Monoid w) => Monad (Writer w) where
+ return a = Writer (a, mempty)
+ m >>= k = Writer $ case runWriter m of
+ (a, w) -> case runWriter (k a) of
+ (b, w') -> (b, w `mappend` w')
+
+instance (Monoid w) => MonadFix (Writer w) where
+ mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w)
+
+instance (Monoid w) => MonadWriter w (Writer w) where
+ tell w = Writer ((), w)
+ listen m = Writer $ case runWriter m of
+ (a, w) -> ((a, w), w)
+ pass m = Writer $ case runWriter m of
+ ((a, f), w) -> (a, f w)
+
+-- ---------------------------------------------------------------------------
+-- Our parameterizable writer monad, with an inner monad
+
+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+
+execWriterT :: Monad m => WriterT w m a -> m w
+execWriterT m = do
+ (_, w) <- runWriterT m
+ return w
+
+mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
+mapWriterT f m = WriterT $ f (runWriterT m)
+
+instance (Monad m) => Functor (WriterT w m) where
+ fmap f m = WriterT $ do
+ (a, w) <- runWriterT m
+ return (f a, w)
+
+instance (Monoid w, Monad m) => Monad (WriterT w m) where
+ return a = WriterT $ return (a, mempty)
+ m >>= k = WriterT $ do
+ (a, w) <- runWriterT m
+ (b, w') <- runWriterT (k a)
+ return (b, w `mappend` w')
+ fail msg = WriterT $ fail msg
+
+instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where
+ mzero = WriterT mzero
+ m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n
+
+instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where
+ mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a)
+
+instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where
+ tell w = WriterT $ return ((), w)
+ listen m = WriterT $ do
+ (a, w) <- runWriterT m
+ return ((a, w), w)
+ pass m = WriterT $ do
+ ((a, f), w) <- runWriterT m
+ return (a, f w)
+
+-- ---------------------------------------------------------------------------
+-- Instances for other mtl transformers
+
+instance (Monoid w) => MonadTrans (WriterT w) where
+ lift m = WriterT $ do
+ a <- m
+ return (a, mempty)
+
+instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where
+ liftIO = lift . liftIO
+
+instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where
+ callCC f = WriterT $
+ callCC $ \c ->
+ runWriterT (f (\a -> WriterT $ c (a, mempty)))
+
+instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where
+ throwError = lift . throwError
+ m `catchError` h = WriterT $ runWriterT m
+ `catchError` \e -> runWriterT (h e)
+
+-- This instance needs UndecidableInstances, because
+-- it does not satisfy the coverage condition
+instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where
+ ask = lift ask
+ local f m = WriterT $ local f (runWriterT m)
+
+-- Needs UndecidableInstances
+instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where
+ get = lift get
+ put = lift . put
+
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec
+ ( module Text.Parsec.Prim
+ , module Text.Parsec.Char
+ , module Text.Parsec.Combinator
+ , module Text.Parsec.String
+ , module Text.Parsec.ByteString
+ , module Text.Parsec.ByteString.Lazy
+ , ParseError
+ , errorPos
+ , SourcePos
+ , SourceName, Line, Column
+ , sourceName, sourceLine, sourceColumn
+ , incSourceLine, incSourceColumn
+ , setSourceLine, setSourceColumn, setSourceName
+ ) where
+
+import Text.Parsec.Pos
+import Text.Parsec.Error
+import Text.Parsec.Prim
+import Text.Parsec.Char
+import Text.Parsec.Combinator
+import Text.Parsec.String hiding ( Parser, GenParser, parseFromFile )
+import Text.Parsec.ByteString hiding ( Parser, GenParser, parseFromFile )
+import Text.Parsec.ByteString.Lazy hiding ( Parser, GenParser, parseFromFile )
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.ByteString
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Make strict ByteStrings an instance of 'Stream' with 'Char' token type.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Parsec.ByteString
+ ( Parser, GenParser, parseFromFile
+ ) where
+
+import Text.Parsec.Error
+import Text.Parsec.Prim
+
+import qualified Data.ByteString.Char8 as C
+
+instance (Monad m) => Stream C.ByteString m Char where
+ uncons = return . C.uncons
+
+type Parser = Parsec C.ByteString ()
+type GenParser t st = Parsec C.ByteString st
+
+-- | @parseFromFile p filePath@ runs a strict bytestring parser @p@ on the
+-- input read from @filePath@ using 'ByteString.Char8.readFile'. Returns either a 'ParseError'
+-- ('Left') or a value of type @a@ ('Right').
+--
+-- > main = do{ result <- parseFromFile numbers "digits.txt"
+-- > ; case result of
+-- > Left err -> print err
+-- > Right xs -> print (sum xs)
+-- > }
+
+parseFromFile :: Parser a -> String -> IO (Either ParseError a)
+parseFromFile p fname
+ = do input <- C.readFile fname
+ return (runP p () fname input)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.ByteString.Lazy
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Make lazy ByteStrings an instance of 'Stream' with 'Char' token type.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Parsec.ByteString.Lazy
+ ( Parser, GenParser, parseFromFile
+ ) where
+
+import Text.Parsec.Error
+import Text.Parsec.Prim
+
+import qualified Data.ByteString.Lazy.Char8 as C
+
+instance (Monad m) => Stream C.ByteString m Char where
+ uncons = return . C.uncons
+
+type Parser = Parsec C.ByteString ()
+type GenParser t st = Parsec C.ByteString st
+
+-- | @parseFromFile p filePath@ runs a lazy bytestring parser @p@ on the
+-- input read from @filePath@ using 'ByteString.Lazy.Char8.readFile'. Returns either a 'ParseError'
+-- ('Left') or a value of type @a@ ('Right').
+--
+-- > main = do{ result <- parseFromFile numbers "digits.txt"
+-- > ; case result of
+-- > Left err -> print err
+-- > Right xs -> print (sum xs)
+-- > }
+parseFromFile :: Parser a -> String -> IO (Either ParseError a)
+parseFromFile p fname
+ = do input <- C.readFile fname
+ return (runP p () fname input)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Char
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Commonly used character parsers.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+
+module Text.Parsec.Char where
+
+import Data.Char
+import Text.Parsec.Pos
+import Text.Parsec.Prim
+
+-- | @oneOf cs@ succeeds if the current character is in the supplied
+-- list of characters @cs@. Returns the parsed character. See also
+-- 'satisfy'.
+--
+-- > vowel = oneOf "aeiou"
+
+oneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
+oneOf cs = satisfy (\c -> elem c cs)
+
+-- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current
+-- character /not/ in the supplied list of characters @cs@. Returns the
+-- parsed character.
+--
+-- > consonant = noneOf "aeiou"
+
+noneOf :: (Stream s m Char) => [Char] -> ParsecT s u m Char
+noneOf cs = satisfy (\c -> not (elem c cs))
+
+-- | Skips /zero/ or more white space characters. See also 'skipMany'.
+
+spaces :: (Stream s m Char) => ParsecT s u m ()
+spaces = skipMany space <?> "white space"
+
+-- | Parses a white space character (any character which satisfies 'isSpace')
+-- Returns the parsed character.
+
+space :: (Stream s m Char) => ParsecT s u m Char
+space = satisfy isSpace <?> "space"
+
+-- | Parses a newline character (\'\\n\'). Returns a newline character.
+
+newline :: (Stream s m Char) => ParsecT s u m Char
+newline = char '\n' <?> "new-line"
+
+-- | Parses a tab character (\'\\t\'). Returns a tab character.
+
+tab :: (Stream s m Char) => ParsecT s u m Char
+tab = char '\t' <?> "tab"
+
+-- | Parses an upper case letter (a character between \'A\' and \'Z\').
+-- Returns the parsed character.
+
+upper :: (Stream s m Char) => ParsecT s u m Char
+upper = satisfy isUpper <?> "uppercase letter"
+
+-- | Parses a lower case character (a character between \'a\' and \'z\').
+-- Returns the parsed character.
+
+lower :: (Stream s m Char) => ParsecT s u m Char
+lower = satisfy isLower <?> "lowercase letter"
+
+-- | Parses a letter or digit (a character between \'0\' and \'9\').
+-- Returns the parsed character.
+
+alphaNum :: (Stream s m Char => ParsecT s u m Char)
+alphaNum = satisfy isAlphaNum <?> "letter or digit"
+
+-- | Parses a letter (an upper case or lower case character). Returns the
+-- parsed character.
+
+letter :: (Stream s m Char) => ParsecT s u m Char
+letter = satisfy isAlpha <?> "letter"
+
+-- | Parses a digit. Returns the parsed character.
+
+digit :: (Stream s m Char) => ParsecT s u m Char
+digit = satisfy isDigit <?> "digit"
+
+-- | Parses a hexadecimal digit (a digit or a letter between \'a\' and
+-- \'f\' or \'A\' and \'F\'). Returns the parsed character.
+
+hexDigit :: (Stream s m Char) => ParsecT s u m Char
+hexDigit = satisfy isHexDigit <?> "hexadecimal digit"
+
+-- | Parses an octal digit (a character between \'0\' and \'7\'). Returns
+-- the parsed character.
+
+octDigit :: (Stream s m Char) => ParsecT s u m Char
+octDigit = satisfy isOctDigit <?> "octal digit"
+
+-- | @char c@ parses a single character @c@. Returns the parsed
+-- character (i.e. @c@).
+--
+-- > semiColon = char ';'
+
+char :: (Stream s m Char) => Char -> ParsecT s u m Char
+char c = satisfy (==c) <?> show [c]
+
+-- | This parser succeeds for any character. Returns the parsed character.
+
+anyChar :: (Stream s m Char) => ParsecT s u m Char
+anyChar = satisfy (const True)
+
+-- | The parser @satisfy f@ succeeds for any character for which the
+-- supplied function @f@ returns 'True'. Returns the character that is
+-- actually parsed.
+
+-- > digit = satisfy isDigit
+-- > oneOf cs = satisfy (\c -> c `elem` cs)
+
+satisfy :: (Stream s m Char) => (Char -> Bool) -> ParsecT s u m Char
+satisfy f = tokenPrim (\c -> show [c])
+ (\pos c _cs -> updatePosChar pos c)
+ (\c -> if f c then Just c else Nothing)
+
+-- | @string s@ parses a sequence of characters given by @s@. Returns
+-- the parsed string (i.e. @s@).
+--
+-- > divOrMod = string "div"
+-- > <|> string "mod"
+
+string :: (Stream s m Char) => String -> ParsecT s u m String
+string s = tokens show updatePosString s
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Combinator
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Commonly used generic combinators
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec.Combinator
+ ( choice
+ , count
+ , between
+ , option, optionMaybe, optional
+ , skipMany1
+ , many1
+ , sepBy, sepBy1
+ , endBy, endBy1
+ , sepEndBy, sepEndBy1
+ , chainl, chainl1
+ , chainr, chainr1
+ , eof, notFollowedBy
+ -- tricky combinators
+ , manyTill, lookAhead, anyToken
+ ) where
+
+import Control.Monad
+import Text.Parsec.Prim
+
+-- | @choice ps@ tries to apply the parsers in the list @ps@ in order,
+-- until one of them succeeds. Returns the value of the succeeding
+-- parser.
+
+choice :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a
+choice ps = foldr (<|>) mzero ps
+
+-- | @option x p@ tries to apply parser @p@. If @p@ fails without
+-- consuming input, it returns the value @x@, otherwise the value
+-- returned by @p@.
+--
+-- > priority = option 0 (do{ d <- digit
+-- > ; return (digitToInt d)
+-- > })
+
+option :: (Stream s m t) => a -> ParsecT s u m a -> ParsecT s u m a
+option x p = p <|> return x
+
+-- | @option p@ tries to apply parser @p@. If @p@ fails without
+-- consuming input, it return 'Nothing', otherwise it returns
+-- 'Just' the value returned by @p@.
+
+optionMaybe :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (Maybe a)
+optionMaybe p = option Nothing (liftM Just p)
+
+-- | @optional p@ tries to apply parser @p@. It will parse @p@ or nothing.
+-- It only fails if @p@ fails after consuming input. It discards the result
+-- of @p@.
+
+optional :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
+optional p = do{ p; return ()} <|> return ()
+
+-- | @between open close p@ parses @open@, followed by @p@ and @close@.
+-- Returns the value returned by @p@.
+--
+-- > braces = between (symbol "{") (symbol "}")
+
+between :: (Stream s m t) => ParsecT s u m open -> ParsecT s u m close
+ -> ParsecT s u m a -> ParsecT s u m a
+between open close p
+ = do{ open; x <- p; close; return x }
+
+-- | @skipMany1 p@ applies the parser @p@ /one/ or more times, skipping
+-- its result.
+
+skipMany1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
+skipMany1 p = do{ p; skipMany p }
+{-
+skipMany p = scan
+ where
+ scan = do{ p; scan } <|> return ()
+-}
+
+-- | @many p@ applies the parser @p@ /one/ or more times. Returns a
+-- list of the returned values of @p@.
+--
+-- > word = many1 letter
+
+many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]
+many1 p = do{ x <- p; xs <- many p; return (x:xs) }
+{-
+many p = scan id
+ where
+ scan f = do{ x <- p
+ ; scan (\tail -> f (x:tail))
+ }
+ <|> return (f [])
+-}
+
+
+-- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated
+-- by @sep@. Returns a list of values returned by @p@.
+--
+-- > commaSep p = p `sepBy` (symbol ",")
+
+sepBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+sepBy p sep = sepBy1 p sep <|> return []
+
+-- | @sepBy1 p sep@ parses /one/ or more occurrences of @p@, separated
+-- by @sep@. Returns a list of values returned by @p@.
+
+sepBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+sepBy1 p sep = do{ x <- p
+ ; xs <- many (sep >> p)
+ ; return (x:xs)
+ }
+
+
+-- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@,
+-- separated and optionally ended by @sep@. Returns a list of values
+-- returned by @p@.
+
+sepEndBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+sepEndBy1 p sep = do{ x <- p
+ ; do{ sep
+ ; xs <- sepEndBy p sep
+ ; return (x:xs)
+ }
+ <|> return [x]
+ }
+
+-- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@,
+-- separated and optionally ended by @sep@, ie. haskell style
+-- statements. Returns a list of values returned by @p@.
+--
+-- > haskellStatements = haskellStatement `sepEndBy` semi
+
+sepEndBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+sepEndBy p sep = sepEndBy1 p sep <|> return []
+
+
+-- | @endBy1 p sep@ parses /one/ or more occurrences of @p@, seperated
+-- and ended by @sep@. Returns a list of values returned by @p@.
+
+endBy1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+endBy1 p sep = many1 (do{ x <- p; sep; return x })
+
+-- | @endBy p sep@ parses /zero/ or more occurrences of @p@, seperated
+-- and ended by @sep@. Returns a list of values returned by @p@.
+--
+-- > cStatements = cStatement `endBy` semi
+
+endBy :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
+endBy p sep = many (do{ x <- p; sep; return x })
+
+-- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or
+-- equal to zero, the parser equals to @return []@. Returns a list of
+-- @n@ values returned by @p@.
+
+count :: (Stream s m t) => Int -> ParsecT s u m a -> ParsecT s u m [a]
+count n p | n <= 0 = return []
+ | otherwise = sequence (replicate n p)
+
+-- | @chainr p op x@ parser /zero/ or more occurrences of @p@,
+-- separated by @op@ Returns a value obtained by a /right/ associative
+-- application of all functions returned by @op@ to the values returned
+-- by @p@. If there are no occurrences of @p@, the value @x@ is
+-- returned.
+
+chainr :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a
+chainr p op x = chainr1 p op <|> return x
+
+-- | @chainl p op x@ parser /zero/ or more occurrences of @p@,
+-- separated by @op@. Returns a value obtained by a /left/ associative
+-- application of all functions returned by @op@ to the values returned
+-- by @p@. If there are zero occurrences of @p@, the value @x@ is
+-- returned.
+
+chainl :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> a -> ParsecT s u m a
+chainl p op x = chainl1 p op <|> return x
+
+-- | @chainl1 p op x@ parser /one/ or more occurrences of @p@,
+-- separated by @op@ Returns a value obtained by a /left/ associative
+-- application of all functions returned by @op@ to the values returned
+-- by @p@. . This parser can for example be used to eliminate left
+-- recursion which typically occurs in expression grammars.
+--
+-- > expr = term `chainl1` mulop
+-- > term = factor `chainl1` addop
+-- > factor = parens expr <|> integer
+-- >
+-- > mulop = do{ symbol "*"; return (*) }
+-- > <|> do{ symbol "/"; return (div) }
+-- >
+-- > addop = do{ symbol "+"; return (+) }
+-- > <|> do{ symbol "-"; return (-) }
+
+chainl1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
+chainl1 p op = do{ x <- p; rest x }
+ where
+ rest x = do{ f <- op
+ ; y <- p
+ ; rest (f x y)
+ }
+ <|> return x
+
+-- | @chainr1 p op x@ parser /one/ or more occurrences of |p|,
+-- separated by @op@ Returns a value obtained by a /right/ associative
+-- application of all functions returned by @op@ to the values returned
+-- by @p@.
+
+chainr1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m (a -> a -> a) -> ParsecT s u m a
+chainr1 p op = scan
+ where
+ scan = do{ x <- p; rest x }
+
+ rest x = do{ f <- op
+ ; y <- scan
+ ; return (f x y)
+ }
+ <|> return x
+
+-----------------------------------------------------------
+-- Tricky combinators
+-----------------------------------------------------------
+-- | The parser @anyToken@ accepts any kind of token. It is for example
+-- used to implement 'eof'. Returns the accepted token.
+
+anyToken :: (Stream s m t, Show t) => ParsecT s u m t
+anyToken = tokenPrim show (\pos _tok _toks -> pos) Just
+
+-- | This parser only succeeds at the end of the input. This is not a
+-- primitive parser but it is defined using 'notFollowedBy'.
+--
+-- > eof = notFollowedBy anyToken <?> "end of input"
+
+eof :: (Stream s m t, Show t) => ParsecT s u m ()
+eof = notFollowedBy anyToken <?> "end of input"
+
+-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser
+-- does not consume any input. This parser can be used to implement the
+-- \'longest match\' rule. For example, when recognizing keywords (for
+-- example @let@), we want to make sure that a keyword is not followed
+-- by a legal identifier character, in which case the keyword is
+-- actually an identifier (for example @lets@). We can program this
+-- behaviour as follows:
+--
+-- > keywordLet = try (do{ string "let"
+-- > ; notFollowedBy alphaNum
+-- > })
+
+notFollowedBy :: (Stream s m t, Show t) => ParsecT s u m t -> ParsecT s u m ()
+notFollowedBy p = try (do{ c <- p; unexpected (show [c]) }
+ <|> return ()
+ )
+
+-- | @manyTill p end@ applies parser @p@ /zero/ or more times until
+-- parser @end@ succeeds. Returns the list of values returned by @p@.
+-- This parser can be used to scan comments:
+--
+-- > simpleComment = do{ string "<!--"
+-- > ; manyTill anyChar (try (string "-->"))
+-- > }
+--
+-- Note the overlapping parsers @anyChar@ and @string \"<!--\"@, and
+-- therefore the use of the 'try' combinator.
+
+manyTill :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
+manyTill p end = scan
+ where
+ scan = do{ end; return [] }
+ <|>
+ do{ x <- p; xs <- scan; return (x:xs) }
+
+-- | @lookAhead p@ parses @p@ without consuming any input.
+
+lookAhead :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a
+lookAhead p = do{ state <- getParserState
+ ; x <- p
+ ; setParserState state
+ ; return x
+ }
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Error
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parse errors
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec.Error
+ ( Message ( SysUnExpect, UnExpect, Expect, Message )
+ , messageString
+ , ParseError, errorPos, errorMessages, errorIsUnknown
+ , showErrorMessages
+ , newErrorMessage, newErrorUnknown
+ , addErrorMessage, setErrorPos, setErrorMessage
+ , mergeError
+ ) where
+
+import Data.List ( nub, sort )
+
+import Text.Parsec.Pos
+
+-- | This abstract data type represents parse error messages. There are
+-- four kinds of messages:
+--
+-- > data Message = SysUnExpect String
+-- > | UnExpect String
+-- > | Expect String
+-- > | Message String
+--
+-- The fine distinction between different kinds of parse errors allows
+-- the system to generate quite good error messages for the user. It
+-- also allows error messages that are formatted in different
+-- languages. Each kind of message is generated by different combinators:
+--
+-- * A 'SysUnExpect' message is automatically generated by the
+-- 'Text.Parsec.Combinator.satisfy' combinator. The argument is the
+-- unexpected input.
+--
+-- * A 'UnExpect' message is generated by the 'Text.Parsec.Prim.unexpected'
+-- combinator. The argument describes the
+-- unexpected item.
+--
+-- * A 'Expect' message is generated by the 'Text.Parsec.Prim.<?>'
+-- combinator. The argument describes the expected item.
+--
+-- * A 'Message' message is generated by the 'fail'
+-- combinator. The argument is some general parser message.
+
+data Message = SysUnExpect !String -- @ library generated unexpect
+ | UnExpect !String -- @ unexpected something
+ | Expect !String -- @ expecting something
+ | Message !String -- @ raw message
+
+instance Enum Message where
+ fromEnum (SysUnExpect _) = 0
+ fromEnum (UnExpect _) = 1
+ fromEnum (Expect _) = 2
+ fromEnum (Message _) = 3
+ toEnum _ = error "toEnum is undefined for Message"
+
+-- < Return 'True' only when 'compare' would return 'EQ'.
+
+instance Eq Message where
+
+ m1 == m2 = fromEnum m1 == fromEnum m2
+
+-- < Compares two error messages without looking at their content. Only
+-- the constructors are compared where:
+--
+-- > 'SysUnExpect' < 'UnExpect' < 'Expect' < 'Message'
+
+instance Ord Message where
+ compare msg1 msg2 = compare (fromEnum msg1) (fromEnum msg2)
+
+-- | Extract the message string from an error message
+
+messageString :: Message -> String
+messageString (SysUnExpect s) = s
+messageString (UnExpect s) = s
+messageString (Expect s) = s
+messageString (Message s) = s
+
+-- | The abstract data type @ParseError@ represents parse errors. It
+-- provides the source position ('SourcePos') of the error
+-- and a list of error messages ('Message'). A @ParseError@
+-- can be returned by the function 'Text.Parsec.Prim.parse'. @ParseError@ is an
+-- instance of the 'Show' class.
+
+data ParseError = ParseError !SourcePos [Message]
+
+-- | Extracts the source position from the parse error
+
+errorPos :: ParseError -> SourcePos
+errorPos (ParseError pos _msgs)
+ = pos
+
+-- | Extracts the list of error messages from the parse error
+
+errorMessages :: ParseError -> [Message]
+errorMessages (ParseError _pos msgs)
+ = sort msgs
+
+errorIsUnknown :: ParseError -> Bool
+errorIsUnknown (ParseError _pos msgs)
+ = null msgs
+
+-- < Create parse errors
+
+newErrorUnknown :: SourcePos -> ParseError
+newErrorUnknown pos
+ = ParseError pos []
+
+newErrorMessage :: Message -> SourcePos -> ParseError
+newErrorMessage msg pos
+ = ParseError pos [msg]
+
+addErrorMessage :: Message -> ParseError -> ParseError
+addErrorMessage msg (ParseError pos msgs)
+ = ParseError pos (msg:msgs)
+
+setErrorPos :: SourcePos -> ParseError -> ParseError
+setErrorPos pos (ParseError _ msgs)
+ = ParseError pos msgs
+
+setErrorMessage :: Message -> ParseError -> ParseError
+setErrorMessage msg (ParseError pos msgs)
+ = ParseError pos (msg : filter (msg /=) msgs)
+
+mergeError :: ParseError -> ParseError -> ParseError
+mergeError (ParseError pos msgs1) (ParseError _ msgs2)
+ = ParseError pos (msgs1 ++ msgs2)
+
+instance Show ParseError where
+ show err
+ = show (errorPos err) ++ ":" ++
+ showErrorMessages "or" "unknown parse error"
+ "expecting" "unexpected" "end of input"
+ (errorMessages err)
+
+-- Language independent show function
+
+-- TODO
+-- < The standard function for showing error messages. Formats a list of
+-- error messages in English. This function is used in the |Show|
+-- instance of |ParseError <#ParseError>|. The resulting string will be
+-- formatted like:
+--
+-- |unexpected /{The first UnExpect or a SysUnExpect message}/;
+-- expecting /{comma separated list of Expect messages}/;
+-- /{comma separated list of Message messages}/
+
+showErrorMessages ::
+ String -> String -> String -> String -> String -> [Message] -> String
+showErrorMessages msgOr msgUnknown msgExpecting msgUnExpected msgEndOfInput msgs
+ | null msgs = msgUnknown
+ | otherwise = concat $ map ("\n"++) $ clean $
+ [showSysUnExpect,showUnExpect,showExpect,showMessages]
+ where
+ (sysUnExpect,msgs1) = span ((SysUnExpect "") ==) msgs
+ (unExpect,msgs2) = span ((UnExpect "") ==) msgs1
+ (expect,messages) = span ((Expect "") ==) msgs2
+
+ showExpect = showMany msgExpecting expect
+ showUnExpect = showMany msgUnExpected unExpect
+ showSysUnExpect | not (null unExpect) ||
+ null sysUnExpect = ""
+ | null firstMsg = msgUnExpected ++ " " ++ msgEndOfInput
+ | otherwise = msgUnExpected ++ " " ++ firstMsg
+ where
+ firstMsg = messageString (head sysUnExpect)
+
+ showMessages = showMany "" messages
+
+ -- helpers
+ showMany pre msgs = case clean (map messageString msgs) of
+ [] -> ""
+ ms | null pre -> commasOr ms
+ | otherwise -> pre ++ " " ++ commasOr ms
+
+ commasOr [] = ""
+ commasOr [m] = m
+ commasOr ms = commaSep (init ms) ++ " " ++ msgOr ++ " " ++ last ms
+
+ commaSep = seperate ", " . clean
+
+ seperate _ [] = ""
+ seperate _ [m] = m
+ seperate sep (m:ms) = m ++ sep ++ seperate sep ms
+
+ clean = nub . filter (not . null)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Expr
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : non-portable
+--
+-- A helper module to parse \"expressions\".
+-- Builds a parser given a table of operators and associativities.
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec.Expr
+ ( Assoc(..), Operator(..), OperatorTable
+ , buildExpressionParser
+ ) where
+
+import Text.Parsec.Prim
+import Text.Parsec.Combinator
+
+-----------------------------------------------------------
+-- Assoc and OperatorTable
+-----------------------------------------------------------
+
+-- | This data type specifies the associativity of operators: left, right
+-- or none.
+
+data Assoc = AssocNone
+ | AssocLeft
+ | AssocRight
+
+-- | This data type specifies operators that work on values of type @a@.
+-- An operator is either binary infix or unary prefix or postfix. A
+-- binary operator has also an associated associativity.
+
+data Operator s u m a = Infix (ParsecT s u m (a -> a -> a)) Assoc
+ | Prefix (ParsecT s u m (a -> a))
+ | Postfix (ParsecT s u m (a -> a))
+
+-- | An @OperatorTable s u m a@ is a list of @Operator s u m a@
+-- lists. The list is ordered in descending
+-- precedence. All operators in one list have the same precedence (but
+-- may have a different associativity).
+
+type OperatorTable s u m a = [[Operator s u m a]]
+
+-----------------------------------------------------------
+-- Convert an OperatorTable and basic term parser into
+-- a full fledged expression parser
+-----------------------------------------------------------
+
+-- | @buildExpressionParser table term@ builds an expression parser for
+-- terms @term@ with operators from @table@, taking the associativity
+-- and precedence specified in @table@ into account. Prefix and postfix
+-- operators of the same precedence can only occur once (i.e. @--2@ is
+-- not allowed if @-@ is prefix negate). Prefix and postfix operators
+-- of the same precedence associate to the left (i.e. if @++@ is
+-- postfix increment, than @-2++@ equals @-1@, not @-3@).
+--
+-- The @buildExpressionParser@ takes care of all the complexity
+-- involved in building expression parser. Here is an example of an
+-- expression parser that handles prefix signs, postfix increment and
+-- basic arithmetic.
+--
+-- > expr = buildExpressionParser table term
+-- > <?> "expression"
+-- >
+-- > term = parens expr
+-- > <|> natural
+-- > <?> "simple expression"
+-- >
+-- > table = [ [prefix "-" negate, prefix "+" id ]
+-- > , [postfix "++" (+1)]
+-- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]
+-- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ]
+-- > ]
+-- >
+-- > binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc
+-- > prefix name fun = Prefix (do{ reservedOp name; return fun })
+-- > postfix name fun = Postfix (do{ reservedOp name; return fun })
+
+buildExpressionParser :: (Stream s m t)
+ => OperatorTable s u m a
+ -> ParsecT s u m a
+ -> ParsecT s u m a
+buildExpressionParser operators simpleExpr
+ = foldl (makeParser) simpleExpr operators
+ where
+ makeParser term ops
+ = let (rassoc,lassoc,nassoc
+ ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops
+
+ rassocOp = choice rassoc
+ lassocOp = choice lassoc
+ nassocOp = choice nassoc
+ prefixOp = choice prefix <?> ""
+ postfixOp = choice postfix <?> ""
+
+ ambigious assoc op= try $
+ do{ op; fail ("ambiguous use of a " ++ assoc
+ ++ " associative operator")
+ }
+
+ ambigiousRight = ambigious "right" rassocOp
+ ambigiousLeft = ambigious "left" lassocOp
+ ambigiousNon = ambigious "non" nassocOp
+
+ termP = do{ pre <- prefixP
+ ; x <- term
+ ; post <- postfixP
+ ; return (post (pre x))
+ }
+
+ postfixP = postfixOp <|> return id
+
+ prefixP = prefixOp <|> return id
+
+ rassocP x = do{ f <- rassocOp
+ ; y <- do{ z <- termP; rassocP1 z }
+ ; return (f x y)
+ }
+ <|> ambigiousLeft
+ <|> ambigiousNon
+ -- <|> return x
+
+ rassocP1 x = rassocP x <|> return x
+
+ lassocP x = do{ f <- lassocOp
+ ; y <- termP
+ ; lassocP1 (f x y)
+ }
+ <|> ambigiousRight
+ <|> ambigiousNon
+ -- <|> return x
+
+ lassocP1 x = lassocP x <|> return x
+
+ nassocP x = do{ f <- nassocOp
+ ; y <- termP
+ ; ambigiousRight
+ <|> ambigiousLeft
+ <|> ambigiousNon
+ <|> return (f x y)
+ }
+ -- <|> return x
+
+ in do{ x <- termP
+ ; rassocP x <|> lassocP x <|> nassocP x <|> return x
+ <?> "operator"
+ }
+
+
+ splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix)
+ = case assoc of
+ AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix)
+ AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix)
+ AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix)
+
+ splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix)
+ = (rassoc,lassoc,nassoc,op:prefix,postfix)
+
+ splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix)
+ = (rassoc,lassoc,nassoc,prefix,op:postfix)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Language
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : non-portable (uses non-portable module Text.Parsec.Token)
+--
+-- A helper module that defines some language definitions that can be used
+-- to instantiate a token parser (see "Text.Parsec.Token").
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec.Language
+ ( haskellDef, haskell
+ , mondrianDef, mondrian
+ , emptyDef
+ , haskellStyle
+ , javaStyle
+ , LanguageDef
+ , GenLanguageDef
+ ) where
+
+import Text.Parsec
+import Text.Parsec.Token
+
+-----------------------------------------------------------
+-- Styles: haskellStyle, javaStyle
+-----------------------------------------------------------
+
+-- | This is a minimal token definition for Haskell style languages. It
+-- defines the style of comments, valid identifiers and case
+-- sensitivity. It does not define any reserved words or operators.
+
+haskellStyle :: LanguageDef st
+haskellStyle = emptyDef
+ { commentStart = "{-"
+ , commentEnd = "-}"
+ , commentLine = "--"
+ , nestedComments = True
+ , identStart = letter
+ , identLetter = alphaNum <|> oneOf "_'"
+ , opStart = opLetter haskellStyle
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames= []
+ , reservedNames = []
+ , caseSensitive = True
+ }
+
+-- | This is a minimal token definition for Java style languages. It
+-- defines the style of comments, valid identifiers and case
+-- sensitivity. It does not define any reserved words or operators.
+
+javaStyle :: LanguageDef st
+javaStyle = emptyDef
+ { commentStart = "/*"
+ , commentEnd = "*/"
+ , commentLine = "//"
+ , nestedComments = True
+ , identStart = letter
+ , identLetter = alphaNum <|> oneOf "_'"
+ , reservedNames = []
+ , reservedOpNames= []
+ , caseSensitive = False
+ }
+
+-----------------------------------------------------------
+-- minimal language definition
+--------------------------------------------------------
+
+-- TODO: This seems wrong
+-- < This is the most minimal token definition. It is recommended to use
+-- this definition as the basis for other definitions. @emptyDef@ has
+-- no reserved names or operators, is case sensitive and doesn't accept
+-- comments, identifiers or operators.
+
+emptyDef :: LanguageDef st
+emptyDef = LanguageDef
+ { commentStart = ""
+ , commentEnd = ""
+ , commentLine = ""
+ , nestedComments = True
+ , identStart = letter <|> char '_'
+ , identLetter = alphaNum <|> oneOf "_'"
+ , opStart = opLetter emptyDef
+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
+ , reservedOpNames= []
+ , reservedNames = []
+ , caseSensitive = True
+ }
+
+
+
+-----------------------------------------------------------
+-- Haskell
+-----------------------------------------------------------
+
+-- | A lexer for the haskell language.
+
+haskell :: TokenParser st
+haskell = makeTokenParser haskellDef
+
+-- | The language definition for the Haskell language.
+
+haskellDef :: LanguageDef st
+haskellDef = haskell98Def
+ { identLetter = identLetter haskell98Def <|> char '#'
+ , reservedNames = reservedNames haskell98Def ++
+ ["foreign","import","export","primitive"
+ ,"_ccall_","_casm_"
+ ,"forall"
+ ]
+ }
+
+-- | The language definition for the language Haskell98.
+
+haskell98Def :: LanguageDef st
+haskell98Def = haskellStyle
+ { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"]
+ , reservedNames = ["let","in","case","of","if","then","else",
+ "data","type",
+ "class","default","deriving","do","import",
+ "infix","infixl","infixr","instance","module",
+ "newtype","where",
+ "primitive"
+ -- "as","qualified","hiding"
+ ]
+ }
+
+
+-----------------------------------------------------------
+-- Mondrian
+-----------------------------------------------------------
+
+-- | A lexer for the mondrian language.
+
+mondrian :: TokenParser st
+mondrian = makeTokenParser mondrianDef
+
+-- | The language definition for the language Mondrian.
+
+mondrianDef :: LanguageDef st
+mondrianDef = javaStyle
+ { reservedNames = [ "case", "class", "default", "extends"
+ , "import", "in", "let", "new", "of", "package"
+ ]
+ , caseSensitive = True
+ }
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Perm
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the file libraries/parsec/LICENSE)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : non-portable (uses existentially quantified data constructors)
+--
+-- This module implements permutation parsers. The algorithm used
+-- is fairly complex since we push the type system to its limits :-)
+-- The algorithm is described in:
+--
+-- /Parsing Permutation Phrases,/
+-- by Arthur Baars, Andres Loh and Doaitse Swierstra.
+-- Published as a functional pearl at the Haskell Workshop 2001.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Text.Parsec.Perm
+ ( PermParser
+ , StreamPermParser -- abstract
+
+ , permute
+ , (<||>), (<$$>)
+ , (<|?>), (<$?>)
+ ) where
+
+import Text.Parsec
+
+import Control.Monad.Identity
+
+infixl 1 <||>, <|?>
+infixl 2 <$$>, <$?>
+
+
+{---------------------------------------------------------------
+ test -- parse a permutation of
+ * an optional string of 'a's
+ * a required 'b'
+ * an optional 'c'
+---------------------------------------------------------------}
+{-
+test input
+ = parse (do{ x <- ptest; eof; return x }) "" input
+
+ptest :: Parser (String,Char,Char)
+ptest
+ = permute $
+ (,,) <$?> ("",many1 (char 'a'))
+ <||> char 'b'
+ <|?> ('_',char 'c')
+-}
+
+{---------------------------------------------------------------
+ Building a permutation parser
+---------------------------------------------------------------}
+
+-- | The expression @perm \<||> p@ adds parser @p@ to the permutation
+-- parser @perm@. The parser @p@ is not allowed to accept empty input -
+-- use the optional combinator ('<|?>') instead. Returns a
+-- new permutation parser that includes @p@.
+
+(<||>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
+(<||>) perm p = add perm p
+
+-- | The expression @f \<$$> p@ creates a fresh permutation parser
+-- consisting of parser @p@. The the final result of the permutation
+-- parser is the function @f@ applied to the return value of @p@. The
+-- parser @p@ is not allowed to accept empty input - use the optional
+-- combinator ('<$?>') instead.
+--
+-- If the function @f@ takes more than one parameter, the type variable
+-- @b@ is instantiated to a functional type which combines nicely with
+-- the adds parser @p@ to the ('<||>') combinator. This
+-- results in stylized code where a permutation parser starts with a
+-- combining function @f@ followed by the parsers. The function @f@
+-- gets its parameters in the order in which the parsers are specified,
+-- but actual input can be in any order.
+
+(<$$>) :: (Stream s Identity tok) => (a -> b) -> Parsec s st a -> StreamPermParser s st b
+(<$$>) f p = newperm f <||> p
+
+-- | The expression @perm \<||> (x,p)@ adds parser @p@ to the
+-- permutation parser @perm@. The parser @p@ is optional - if it can
+-- not be applied, the default value @x@ will be used instead. Returns
+-- a new permutation parser that includes the optional parser @p@.
+
+(<|?>) :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
+(<|?>) perm (x,p) = addopt perm x p
+
+-- | The expression @f \<$?> (x,p)@ creates a fresh permutation parser
+-- consisting of parser @p@. The the final result of the permutation
+-- parser is the function @f@ applied to the return value of @p@. The
+-- parser @p@ is optional - if it can not be applied, the default value
+-- @x@ will be used instead.
+
+(<$?>) :: (Stream s Identity tok) => (a -> b) -> (a, Parsec s st a) -> StreamPermParser s st b
+(<$?>) f (x,p) = newperm f <|?> (x,p)
+
+{---------------------------------------------------------------
+ The permutation tree
+---------------------------------------------------------------}
+
+-- | Provided for backwards compatibility. The tok type is ignored.
+
+type PermParser tok st a = StreamPermParser String st a
+
+-- | The type @StreamPermParser s st a@ denotes a permutation parser that,
+-- when converted by the 'permute' function, parses
+-- @s@ streams with user state @st@ and returns a value of
+-- type @a@ on success.
+--
+-- Normally, a permutation parser is first build with special operators
+-- like ('<||>') and than transformed into a normal parser
+-- using 'permute'.
+
+data StreamPermParser s st a = Perm (Maybe a) [StreamBranch s st a]
+
+-- type Branch st a = StreamBranch String st a
+
+data StreamBranch s st a = forall b. Branch (StreamPermParser s st (b -> a)) (Parsec s st b)
+
+-- | The parser @permute perm@ parses a permutation of parser described
+-- by @perm@. For example, suppose we want to parse a permutation of:
+-- an optional string of @a@'s, the character @b@ and an optional @c@.
+-- This can be described by:
+--
+-- > test = permute (tuple <$?> ("",many1 (char 'a'))
+-- > <||> char 'b'
+-- > <|?> ('_',char 'c'))
+-- > where
+-- > tuple a b c = (a,b,c)
+
+-- transform a permutation tree into a normal parser
+permute :: (Stream s Identity tok) => StreamPermParser s st a -> Parsec s st a
+permute (Perm def xs)
+ = choice (map branch xs ++ empty)
+ where
+ empty
+ = case def of
+ Nothing -> []
+ Just x -> [return x]
+
+ branch (Branch perm p)
+ = do{ x <- p
+ ; f <- permute perm
+ ; return (f x)
+ }
+
+-- build permutation trees
+newperm :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st (a -> b)
+newperm f
+ = Perm (Just f) []
+
+add :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> Parsec s st a -> StreamPermParser s st b
+add perm@(Perm _mf fs) p
+ = Perm Nothing (first:map insert fs)
+ where
+ first = Branch perm p
+ insert (Branch perm' p')
+ = Branch (add (mapPerms flip perm') p) p'
+
+addopt :: (Stream s Identity tok) => StreamPermParser s st (a -> b) -> a -> Parsec s st a -> StreamPermParser s st b
+addopt perm@(Perm mf fs) x p
+ = Perm (fmap ($ x) mf) (first:map insert fs)
+ where
+ first = Branch perm p
+ insert (Branch perm' p')
+ = Branch (addopt (mapPerms flip perm') x p) p'
+
+
+mapPerms :: (Stream s Identity tok) => (a -> b) -> StreamPermParser s st a -> StreamPermParser s st b
+mapPerms f (Perm x xs)
+ = Perm (fmap f x) (map mapBranch xs)
+ where
+ mapBranch (Branch perm p)
+ = Branch (mapPerms (f.) perm) p
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Pos
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Textual source positions.
+--
+-----------------------------------------------------------------------------
+
+module Text.Parsec.Pos
+ ( SourceName, Line, Column
+ , SourcePos
+ , sourceLine, sourceColumn, sourceName
+ , incSourceLine, incSourceColumn
+ , setSourceLine, setSourceColumn, setSourceName
+ , newPos, initialPos
+ , updatePosChar, updatePosString
+ ) where
+
+-- < Source positions: a file name, a line and a column
+-- upper left is (1,1)
+
+type SourceName = String
+type Line = Int
+type Column = Int
+
+-- | The abstract data type @SourcePos@ represents source positions. It
+-- contains the name of the source (i.e. file name), a line number and
+-- a column number. @SourcePos@ is an instance of the 'Show', 'Eq' and
+-- 'Ord' class.
+
+data SourcePos = SourcePos SourceName !Line !Column
+ deriving ( Eq, Ord )
+
+-- | Create a new 'SourcePos' with the given source name,
+-- line number and column number.
+
+newPos :: SourceName -> Line -> Column -> SourcePos
+newPos name line column
+ = SourcePos name line column
+
+-- | Create a new 'SourcePos' with the given source name,
+-- and line number and column number set to 1, the upper left.
+
+initialPos :: SourceName -> SourcePos
+initialPos name
+ = newPos name 1 1
+
+-- | Extracts the name of the source from a source position.
+
+sourceName :: SourcePos -> SourceName
+sourceName (SourcePos name _line _column) = name
+
+-- | Extracts the line number from a source position.
+
+sourceLine :: SourcePos -> Line
+sourceLine (SourcePos _name line _column) = line
+
+-- | Extracts the column number from a source position.
+
+sourceColumn :: SourcePos -> Column
+sourceColumn (SourcePos _name _line column) = column
+
+-- | Increments the line number of a source position.
+
+incSourceLine :: SourcePos -> Line -> SourcePos
+incSourceLine (SourcePos name line column) n = SourcePos name (line+n) column
+
+-- | Increments the column number of a source position.
+
+incSourceColumn :: SourcePos -> Column -> SourcePos
+incSourceColumn (SourcePos name line column) n = SourcePos name line (column+n)
+
+-- | Set the name of the source.
+
+setSourceName :: SourcePos -> SourceName -> SourcePos
+setSourceName (SourcePos _name line column) n = SourcePos n line column
+
+-- | Set the line number of a source position.
+
+setSourceLine :: SourcePos -> Line -> SourcePos
+setSourceLine (SourcePos name _line column) n = SourcePos name n column
+
+-- | Set the column number of a source position.
+
+setSourceColumn :: SourcePos -> Column -> SourcePos
+setSourceColumn (SourcePos name line _column) n = SourcePos name line n
+
+-- | The expression @updatePosString pos s@ updates the source position
+-- @pos@ by calling 'updatePosChar' on every character in @s@, ie.
+-- @foldl updatePosChar pos string@.
+
+updatePosString :: SourcePos -> String -> SourcePos
+updatePosString pos string
+ = foldl updatePosChar pos string
+
+-- | Update a source position given a character. If the character is a
+-- newline (\'\\n\') or carriage return (\'\\r\') the line number is
+-- incremented by 1. If the character is a tab (\'\t\') the column
+-- number is incremented to the nearest 8'th column, ie. @column + 8 -
+-- ((column-1) \`mod\` 8)@. In all other cases, the column is
+-- incremented by 1.
+
+updatePosChar :: SourcePos -> Char -> SourcePos
+updatePosChar (SourcePos name line column) c
+ = case c of
+ '\n' -> SourcePos name (line+1) 1
+ '\t' -> SourcePos name line (column + 8 - ((column-1) `mod` 8))
+ _ -> SourcePos name line (column + 1)
+
+instance Show SourcePos where
+ show (SourcePos name line column)
+ | null name = showLineColumn
+ | otherwise = "\"" ++ name ++ "\" " ++ showLineColumn
+ where
+ showLineColumn = "(line " ++ show line ++
+ ", column " ++ show column ++
+ ")"
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Prim
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- The primitive parser combinators.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts,
+ UndecidableInstances #-}
+
+module Text.Parsec.Prim where
+
+import qualified Control.Applicative as Applicative ( Applicative(..), Alternative(..) )
+import Control.Monad()
+import Control.Monad.Trans
+import Control.Monad.Identity
+
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+
+import Text.Parsec.Pos
+import Text.Parsec.Error
+
+unknownError :: State s u -> ParseError
+unknownError state = newErrorUnknown (statePos state)
+
+sysUnExpectError :: String -> SourcePos -> Reply s u a
+sysUnExpectError msg pos = Error (newErrorMessage (SysUnExpect msg) pos)
+
+-- | The parser @unexpected msg@ always fails with an unexpected error
+-- message @msg@ without consuming any input.
+--
+-- The parsers 'fail', ('<?>') and @unexpected@ are the three parsers
+-- used to generate error messages. Of these, only ('<?>') is commonly
+-- used. For an example of the use of @unexpected@, see the definition
+-- of 'Text.Parsec.Combinator.notFollowedBy'.
+
+unexpected :: (Stream s m t) => String -> ParsecT s u m a
+unexpected msg
+ = ParsecT $ \s -> return $ Empty $ return $
+ Error (newErrorMessage (UnExpect msg) (statePos s))
+
+-- | ParserT monad transformer and Parser type
+
+-- | @ParsecT s u m a@ is a parser with stream type @s@, user state type @u@,
+-- underlying monad @m@ and return type @a@
+
+data ParsecT s u m a
+ = ParsecT { runParsecT :: State s u -> m (Consumed (m (Reply s u a))) }
+
+type Parsec s u = ParsecT s u Identity
+
+data Consumed a = Consumed a
+ | Empty !a
+
+data Reply s u a = Ok !a !(State s u) ParseError
+ | Error ParseError
+
+data State s u = State {
+ stateInput :: s,
+ statePos :: !SourcePos,
+ stateUser :: !u
+ }
+
+instance Functor Consumed where
+ fmap f (Consumed x) = Consumed (f x)
+ fmap f (Empty x) = Empty (f x)
+
+instance Functor (Reply s u) where
+ fmap f (Ok x s e) = Ok (f x) s e
+ fmap _ (Error e) = Error e -- XXX
+
+instance (Monad m) => Functor (ParsecT s u m) where
+ fmap f p = parsecMap f p
+
+parsecMap :: (Monad m) => (a -> b) -> ParsecT s u m a -> ParsecT s u m b
+parsecMap f p
+ = ParsecT $ \s -> liftM (fmap (liftM (fmap f))) (runParsecT p s)
+
+instance (Monad m) => Applicative.Applicative (ParsecT s u m) where
+ pure = return
+ (<*>) = ap -- TODO: Can this be optimized?
+
+instance (Monad m) => Applicative.Alternative (ParsecT s u m) where
+ empty = mzero
+ (<|>) = mplus
+
+instance (Monad m) => Monad (ParsecT s u m) where
+ return x = parserReturn x
+ p >>= f = parserBind p f
+ fail msg = parserFail msg
+
+instance (MonadIO m) => MonadIO (ParsecT s u m) where
+ liftIO = lift . liftIO
+
+instance (MonadReader r m) => MonadReader r (ParsecT s u m) where
+ ask = lift ask
+ local f p = ParsecT $ \s -> local f (runParsecT p s)
+
+-- I'm presuming the user might want a separate, non-backtracking
+-- state aside from the Parsec user state.
+instance (MonadState s m) => MonadState s (ParsecT s' u m) where
+ get = lift get
+ put = lift . put
+
+instance (MonadCont m) => MonadCont (ParsecT s u m) where
+ callCC f = ParsecT $ \s ->
+ callCC $ \c ->
+ runParsecT (f (\a -> ParsecT $ \s' -> c (pack s' a))) s
+
+ where pack s a= Empty $ return (Ok a s (unknownError s))
+
+instance (MonadError e m) => MonadError e (ParsecT s u m) where
+ throwError = lift . throwError
+ p `catchError` h = ParsecT $ \s ->
+ runParsecT p s `catchError` \e ->
+ runParsecT (h e) s
+
+parserReturn :: (Monad m) => a -> ParsecT s u m a
+parserReturn x
+ = ParsecT $ \s -> return $ Empty $ return (Ok x s (unknownError s))
+
+parserBind :: (Monad m)
+ => ParsecT s u m a -> (a -> ParsecT s u m b) -> ParsecT s u m b
+
+parserBind p f
+ = ParsecT $ \s -> do -- TODO: This was \s@(State _ u _) ???
+ res1 <- runParsecT p s
+ case res1 of
+
+ Empty mReply1
+ -> do reply1 <- mReply1
+ case reply1 of
+ Ok x s' err1 -> do
+ res2 <- runParsecT (f x) s'
+ case res2 of
+ Empty mReply2
+ -> do reply2 <- mReply2
+ return $ Empty $
+ return $ mergeErrorReply err1 reply2
+ other
+ -> do return $ other
+ Error err1 -> return $ Empty $ return $ Error err1
+
+ Consumed mReply1
+ -> do reply1 <- mReply1
+ return $ Consumed $ -- `early' returning
+ case reply1 of
+ Ok x s' err1 -> do
+ res2 <- runParsecT (f x) s'
+ case res2 of
+ Empty mReply2
+ -> do reply2 <- mReply2
+ return $ mergeErrorReply err1 reply2
+ Consumed reply2 -> reply2
+ Error err1 -> return $ Error err1
+
+
+mergeErrorReply :: ParseError -> Reply s u a -> Reply s u a
+mergeErrorReply err1 reply -- XXX where to put it?
+ = case reply of
+ Ok x state err2 -> Ok x state (mergeError err1 err2)
+ Error err2 -> Error (mergeError err1 err2)
+
+parserFail :: (Monad m) => String -> ParsecT s u m a
+parserFail msg
+ = ParsecT $ \s -> return $ Empty $ return $
+ Error (newErrorMessage (Message msg) (statePos s))
+
+instance (Monad m) => MonadPlus (ParsecT s u m) where
+ mzero = parserZero
+ mplus p1 p2 = parserPlus p1 p2
+
+-- | @parserZero@ always fails without consuming any input. @parserZero@ is defined
+-- equal to the 'mzero' member of the 'MonadPlus' class and to the 'Control.Applicative.empty' member
+-- of the 'Control.Applicative.Applicative' class.
+
+parserZero :: (Monad m) => ParsecT s u m a
+parserZero
+ = ParsecT $ \s -> return $ Empty $ return $ Error (unknownError s)
+
+parserPlus :: (Monad m)
+ => ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
+parserPlus (ParsecT p1) (ParsecT p2)
+ = ParsecT $ \s -> do
+ c1 <- p1 s
+ case c1 of
+ Empty mReply1
+ -> do r1 <- mReply1
+ case r1 of
+ Error err -> do
+ c2 <- p2 s
+ case c2 of
+ Empty mReply2
+ -> do reply2 <- mReply2
+ return $ Empty $ return (mergeErrorReply err reply2)
+ consumed
+ -> return $ consumed
+ other -> return $ Empty $ return $ other
+ other -> return $ other
+
+instance MonadTrans (ParsecT s u) where
+ lift amb = ParsecT $ \s -> do
+ a <- amb
+ return $ Empty $ return $ Ok a s (unknownError s)
+
+infix 0 <?>
+infixr 1 <|>
+
+-- | The parser @p <?> msg@ behaves as parser @p@, but whenever the
+-- parser @p@ fails /without consuming any input/, it replaces expect
+-- error messages with the expect error message @msg@.
+--
+-- This is normally used at the end of a set alternatives where we want
+-- to return an error message in terms of a higher level construct
+-- rather than returning all possible characters. For example, if the
+-- @expr@ parser from the 'try' example would fail, the error
+-- message is: '...: expecting expression'. Without the @(\<?>)@
+-- combinator, the message would be like '...: expecting \"let\" or
+-- letter', which is less friendly.
+
+(<?>) :: (Monad m)
+ => (ParsecT s u m a) -> String -> (ParsecT s u m a)
+p <?> msg = label p msg
+
+-- | This combinator implements choice. The parser @p \<|> q@ first
+-- applies @p@. If it succeeds, the value of @p@ is returned. If @p@
+-- fails /without consuming any input/, parser @q@ is tried. This
+-- combinator is defined equal to the 'mplus' member of the 'MonadPlus'
+-- class and the ('Control.Applicative.<|>') member of 'Control.Applicative.Alternative'.
+--
+-- The parser is called /predictive/ since @q@ is only tried when
+-- parser @p@ didn't consume any input (i.e.. the look ahead is 1).
+-- This non-backtracking behaviour allows for both an efficient
+-- implementation of the parser combinators and the generation of good
+-- error messages.
+
+(<|>) :: (Monad m)
+ => (ParsecT s u m a) -> (ParsecT s u m a) -> (ParsecT s u m a)
+p1 <|> p2 = mplus p1 p2
+
+label :: (Monad m) => ParsecT s u m a -> String -> ParsecT s u m a
+label p msg
+ = labels p [msg]
+
+labels :: (Monad m) => ParsecT s u m a -> [String] -> ParsecT s u m a
+labels p msgs
+ = ParsecT $ \s -> do
+ r <- runParsecT p s
+ case r of
+ Empty mReply -> do
+ reply <- mReply
+ return $ Empty $ case reply of
+ Error err
+ -> return $ Error (setExpectErrors err msgs)
+ Ok x s' err
+ | errorIsUnknown err -> return $ reply
+ | otherwise -> return (Ok x s' (setExpectErrors err msgs))
+ other -> return $ other
+ where
+ setExpectErrors err [] = setErrorMessage (Expect "") err
+ setExpectErrors err [msg] = setErrorMessage (Expect msg) err
+ setExpectErrors err (msg:msgs)
+ = foldr (\msg' err' -> addErrorMessage (Expect msg') err')
+ (setErrorMessage (Expect msg) err) msgs
+
+-- TODO: There should be a stronger statement that can be made about this
+
+-- | An instance of @Stream@ has stream type @s@, underlying monad @m@ and token type @t@ determined by the stream
+--
+-- Some rough guidelines for a \"correct\" instance of Stream:
+--
+-- * unfoldM uncons gives the [t] corresponding to the stream
+--
+-- * A @Stream@ instance is responsible for maintaining the \"position within the stream\" in the stream state @s@. This is trivial unless you are using the monad in a non-trivial way.
+
+class (Monad m) => Stream s m t | s -> t where
+ uncons :: s -> m (Maybe (t,s))
+
+tokens :: (Stream s m t, Eq t)
+ => ([t] -> String) -- Pretty print a list of tokens
+ -> (SourcePos -> [t] -> SourcePos)
+ -> [t] -- List of tokens to parse
+ -> ParsecT s u m [t]
+tokens _ _ []
+ = ParsecT $ \s -> return $ Empty $ return $ Ok [] s (unknownError s)
+tokens showTokens nextposs tts@(tok:toks)
+ = ParsecT $ \(State input pos u) ->
+ let
+ errEof = return $ Error (setErrorMessage (Expect (showTokens tts))
+ (newErrorMessage (SysUnExpect "") pos))
+ errExpect x = return $ Error (setErrorMessage (Expect (showTokens tts))
+ (newErrorMessage (SysUnExpect (showTokens [x])) pos))
+ walk [] rs = return (ok rs)
+ walk (t:ts) rs = do
+ sr <- uncons rs
+ case sr of
+ Nothing -> errEof
+ Just (x,xs) | t == x -> walk ts xs
+ | otherwise -> errExpect x
+ ok rs = let pos' = nextposs pos tts
+ s' = State rs pos' u
+ in Ok tts s' (newErrorUnknown pos')
+ in do
+ sr <- uncons input
+ return $ case sr of
+ Nothing -> Empty $ errEof
+ Just (x,xs)
+ | tok == x -> Consumed $ walk toks xs
+ | otherwise -> Empty $ errExpect x
+
+-- | The parser @try p@ behaves like parser @p@, except that it
+-- pretends that it hasn't consumed any input when an error occurs.
+--
+-- This combinator is used whenever arbitrary look ahead is needed.
+-- Since it pretends that it hasn't consumed any input when @p@ fails,
+-- the ('<|>') combinator will try its second alternative even when the
+-- first parser failed while consuming input.
+--
+-- The @try@ combinator can for example be used to distinguish
+-- identifiers and reserved words. Both reserved words and identifiers
+-- are a sequence of letters. Whenever we expect a certain reserved
+-- word where we can also expect an identifier we have to use the @try@
+-- combinator. Suppose we write:
+--
+-- > expr = letExpr <|> identifier <?> "expression"
+-- >
+-- > letExpr = do{ string "let"; ... }
+-- > identifier = many1 letter
+--
+-- If the user writes \"lexical\", the parser fails with: @unexpected
+-- \'x\', expecting \'t\' in \"let\"@. Indeed, since the ('<|>') combinator
+-- only tries alternatives when the first alternative hasn't consumed
+-- input, the @identifier@ parser is never tried (because the prefix
+-- \"le\" of the @string \"let\"@ parser is already consumed). The
+-- right behaviour can be obtained by adding the @try@ combinator:
+--
+-- > expr = letExpr <|> identifier <?> "expression"
+-- >
+-- > letExpr = do{ try (string "let"); ... }
+-- > identifier = many1 letter
+
+try :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m a
+try (ParsecT p)
+ = ParsecT $ \s@(State _ pos _) -> do
+ res <- p s
+ case res of
+ Consumed rep -> do r <- rep
+ case r of
+ Error err -> return $ Empty $ return $ Error
+ (setErrorPos pos err)
+ ok -> return $ Consumed $ return $ ok
+ empty -> return $ empty
+
+-- | The parser @token showTok posFromTok testTok@ accepts a token @t@
+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The
+-- source position of the @t@ should be returned by @posFromTok t@ and
+-- the token can be shown using @showTok t@.
+--
+-- This combinator is expressed in terms of 'tokenPrim'.
+-- It is used to accept user defined token streams. For example,
+-- suppose that we have a stream of basic tokens tupled with source
+-- positions. We can than define a parser that accepts single tokens as:
+--
+-- > mytoken x
+-- > = token showTok posFromTok testTok
+-- > where
+-- > showTok (pos,t) = show t
+-- > posFromTok (pos,t) = pos
+-- > testTok (pos,t) = if x == t then Just t else Nothing
+
+token :: (Stream s Identity t)
+ => (t -> String) -- ^ Token pretty-printing function.
+ -> (t -> SourcePos) -- ^ Computes the position of a token.
+ -> (t -> Maybe a) -- ^ Matching function for the token to parse.
+ -> Parsec s u a
+token showToken tokpos test = tokenPrim showToken nextpos test
+ where
+ nextpos _ tok ts = case runIdentity (uncons ts) of
+ Nothing -> tokpos tok
+ Just (tok',_) -> tokpos tok'
+
+-- | The parser @token showTok nextPos testTok@ accepts a token @t@
+-- with result @x@ when the function @testTok t@ returns @'Just' x@. The
+-- token can be shown using @showTok t@. The position of the /next/
+-- token should be returned when @nextPos@ is called with the current
+-- source position @pos@, the current token @t@ and the rest of the
+-- tokens @toks@, @nextPos pos t toks@.
+--
+-- This is the most primitive combinator for accepting tokens. For
+-- example, the 'Text.Parsec.Char.char' parser could be implemented as:
+--
+-- > char c
+-- > = tokenPrim showChar nextPos testChar
+-- > where
+-- > showChar x = "'" ++ x ++ "'"
+-- > testChar x = if x == c then Just x else Nothing
+-- > nextPos pos x xs = updatePosChar pos x
+
+tokenPrim :: (Stream s m t)
+ => (t -> String) -- ^ Token pretty-printing function.
+ -> (SourcePos -> t -> s -> SourcePos) -- ^ Next position calculating function.
+ -> (t -> Maybe a) -- ^ Matching function for the token to parse.
+ -> ParsecT s u m a
+tokenPrim showToken nextpos test = tokenPrimEx showToken nextpos Nothing test
+
+tokenPrimEx :: (Stream s m t)
+ => (t -> String)
+ -> (SourcePos -> t -> s -> SourcePos)
+ -> Maybe (SourcePos -> t -> s -> u -> u)
+ -> (t -> Maybe a)
+ -> ParsecT s u m a
+tokenPrimEx showToken nextpos mbNextState test
+ = case mbNextState of
+ Nothing
+ -> ParsecT $ \(State input pos user) -> do
+ r <- uncons input
+ case r of
+ Nothing -> return $ Empty $ return (sysUnExpectError "" pos)
+ Just (c,cs)
+ -> case test c of
+ Just x -> let newpos = nextpos pos c cs
+ newstate = State cs newpos user
+ in seq newpos $ seq newstate $
+ return $ Consumed $ return $
+ (Ok x newstate (newErrorUnknown newpos))
+ Nothing -> return $ Empty $ return $
+ (sysUnExpectError (showToken c) pos)
+ Just nextState
+ -> ParsecT $ \(State input pos user) -> do
+ r <- uncons input
+ case r of
+ Nothing -> return $ Empty $ return (sysUnExpectError "" pos)
+ Just (c,cs)
+ -> case test c of
+ Just x -> let newpos = nextpos pos c cs
+ newuser = nextState pos c cs user
+ newstate = State cs newpos newuser
+ in seq newpos $ seq newstate $
+ return $ Consumed $ return $
+ (Ok x newstate (newErrorUnknown newpos))
+ Nothing -> return $ Empty $ return $
+ (sysUnExpectError (showToken c) pos)
+
+-- | @many p@ applies the parser @p@ /zero/ or more times. Returns a
+-- list of the returned values of @p@.
+--
+-- > identifier = do{ c <- letter
+-- > ; cs <- many (alphaNum <|> char '_')
+-- > ; return (c:cs)
+-- > }
+
+many :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]
+many p
+ = do xs <- manyAccum (:) p
+ return (reverse xs)
+
+-- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping
+-- its result.
+--
+-- > spaces = skipMany space
+
+skipMany :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m ()
+skipMany p
+ = do manyAccum (\_ _ -> []) p
+ return ()
+
+manyAccum :: (Stream s m t)
+ => (a -> [a] -> [a])
+ -> ParsecT s u m a
+ -> ParsecT s u m [a]
+manyAccum accum p
+ = ParsecT $ \s ->
+ let walk xs state mr
+ = do r <- mr
+ case r of
+ Empty mReply
+ -> do reply <- mReply
+ case reply of
+ Error err -> return $ Ok xs state err
+ _ -> error "Text.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
+ Consumed mReply
+ -> do reply <- mReply
+ case reply of
+ Error err
+ -> return $ Error err
+ Ok x s' _err
+ -> let ys = accum x xs
+ in seq ys (walk ys s' (runParsecT p s'))
+ in do r <- runParsecT p s
+ case r of
+ Empty mReply
+ -> do reply <- mReply
+ case reply of
+ Ok _ _ _
+ -> error "Text.ParserCombinators.Parsec.Prim.many: combinator 'many' is applied to a parser that accepts an empty string."
+ Error err
+ -> return $ Empty $ return (Ok [] s err)
+ consumed
+ -> return $ Consumed $ walk [] s (return consumed)
+
+
+-- < Running a parser: monadic (runPT) and pure (runP)
+
+runPT :: (Stream s m t)
+ => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
+runPT p u name s
+ = do res <- runParsecT p (State s (initialPos name) u)
+ r <- parserReply res
+ case r of
+ Ok x _ _ -> return (Right x)
+ Error err -> return (Left err)
+ where
+ parserReply res
+ = case res of
+ Consumed r -> r
+ Empty r -> r
+
+runP :: (Stream s Identity t)
+ => Parsec s u a -> u -> SourceName -> s -> Either ParseError a
+runP p u name s = runIdentity $ runPT p u name s
+
+-- | The most general way to run a parser. @runParserT p state filePath
+-- input@ runs parser @p@ on the input list of tokens @input@,
+-- obtained from source @filePath@ with the initial user state @st@.
+-- The @filePath@ is only used in error messages and may be the empty
+-- string. Returns a computation in the underlying monad @m@ that return either a 'ParseError' ('Left') or a
+-- value of type @a@ ('Right').
+
+runParserT :: (Stream s m t)
+ => ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
+runParserT = runPT
+
+-- | The most general way to run a parser over the Identity monad. @runParser p state filePath
+-- input@ runs parser @p@ on the input list of tokens @input@,
+-- obtained from source @filePath@ with the initial user state @st@.
+-- The @filePath@ is only used in error messages and may be the empty
+-- string. Returns either a 'ParseError' ('Left') or a
+-- value of type @a@ ('Right').
+--
+-- > parseFromFile p fname
+-- > = do{ input <- readFile fname
+-- > ; return (runParser p () fname input)
+-- > }
+
+runParser :: (Stream s Identity t)
+ => Parsec s u a -> u -> SourceName -> s -> Either ParseError a
+runParser = runP
+
+-- | @parse p filePath input@ runs a parser @p@ over Identity without user
+-- state. The @filePath@ is only used in error messages and may be the
+-- empty string. Returns either a 'ParseError' ('Left')
+-- or a value of type @a@ ('Right').
+--
+-- > main = case (parse numbers "" "11, 2, 43") of
+-- > Left err -> print err
+-- > Right xs -> print (sum xs)
+-- >
+-- > numbers = commaSep integer
+
+parse :: (Stream s Identity t)
+ => Parsec s () a -> SourceName -> s -> Either ParseError a
+parse p = runP p ()
+
+-- | The expression @parseTest p input@ applies a parser @p@ against
+-- input @input@ and prints the result to stdout. Used for testing
+-- parsers.
+
+parseTest :: (Stream s Identity t, Show a)
+ => Parsec s () a -> s -> IO ()
+parseTest p input
+ = case parse p "" input of
+ Left err -> do putStr "parse error at "
+ print err
+ Right x -> print x
+
+-- < Parser state combinators
+
+-- | Returns the current source position. See also 'SourcePos'.
+
+getPosition :: (Monad m) => ParsecT s u m SourcePos
+getPosition = do state <- getParserState
+ return (statePos state)
+
+-- | Returns the current input
+
+getInput :: (Monad m) => ParsecT s u m s
+getInput = do state <- getParserState
+ return (stateInput state)
+
+-- | @setPosition pos@ sets the current source position to @pos@.
+
+setPosition :: (Monad m) => SourcePos -> ParsecT s u m ()
+setPosition pos
+ = do updateParserState (\(State input _ user) -> State input pos user)
+ return ()
+
+-- | @setInput input@ continues parsing with @input@. The 'getInput' and
+-- @setInput@ functions can for example be used to deal with #include
+-- files.
+
+setInput :: (Monad m) => s -> ParsecT s u m ()
+setInput input
+ = do updateParserState (\(State _ pos user) -> State input pos user)
+ return ()
+
+-- | Returns the full parser state as a 'State' record.
+
+getParserState :: (Monad m) => ParsecT s u m (State s u)
+getParserState = updateParserState id
+
+-- | @setParserState st@ set the full parser state to @st@.
+
+setParserState :: (Monad m) => State s u -> ParsecT s u m (State s u)
+setParserState st = updateParserState (const st)
+
+-- | @updateParserState f@ applies function @f@ to the parser state.
+
+updateParserState :: (Monad m)
+ => (State s u -> State s u) -> ParsecT s u m (State s u)
+updateParserState f
+ = ParsecT $ \s -> let s' = f s
+ in return $ Empty $ return (Ok s' s' (unknownError s'))
+
+-- < User state combinators
+
+-- | Returns the current user state.
+
+getState :: (Monad m) => ParsecT s u m u
+getState = stateUser `liftM` getParserState
+
+-- | @putState st@ set the user state to @st@.
+
+putState :: (Monad m) => u -> ParsecT s u m ()
+putState u = do updateParserState $ \s -> s { stateUser = u }
+ return ()
+
+-- | @updateState f@ applies function @f@ to the user state. Suppose
+-- that we want to count identifiers in a source, we could use the user
+-- state as:
+--
+-- > expr = do{ x <- identifier
+-- > ; updateState (+1)
+-- > ; return (Id x)
+-- > }
+
+modifyState :: (Monad m) => (u -> u) -> ParsecT s u m ()
+modifyState f = do updateParserState $ \s -> s { stateUser = f (stateUser s) }
+ return ()
+
+-- XXX Compat
+
+-- | An alias for putState for backwards compatibility.
+
+setState :: (Monad m) => u -> ParsecT s u m ()
+setState = putState
+
+-- | An alias for modifyState for backwards compatibility.
+
+updateState :: (Monad m) => (u -> u) -> ParsecT s u m ()
+updateState = modifyState
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.String
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the file libraries/parsec/LICENSE)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Make Strings an instance of 'Stream' with 'Char' token type.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Parsec.String
+ ( Parser, GenParser, parseFromFile
+ ) where
+
+import Text.Parsec.Error
+import Text.Parsec.Prim
+
+instance (Monad m) => Stream [tok] m tok where
+ uncons [] = return $ Nothing
+ uncons (t:ts) = return $ Just (t,ts)
+
+type Parser = Parsec String ()
+type GenParser tok st = Parsec [tok] st
+
+-- | @parseFromFile p filePath@ runs a string parser @p@ on the
+-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError'
+-- ('Left') or a value of type @a@ ('Right').
+--
+-- > main = do{ result <- parseFromFile numbers "digits.txt"
+-- > ; case result of
+-- > Left err -> print err
+-- > Right xs -> print (sum xs)
+-- > }
+parseFromFile :: Parser a -> String -> IO (Either ParseError a)
+parseFromFile p fname
+ = do input <- readFile fname
+ return (runP p () fname input)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.Parsec.Token
+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : non-portable (uses local universal quantification: PolymorphicComponents)
+--
+-- A helper module to parse lexical elements (tokens). See 'makeTokenParser'
+-- for a description of how to use it.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE PolymorphicComponents #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Text.Parsec.Token
+ ( LanguageDef
+ , GenLanguageDef (..)
+ , TokenParser
+ , GenTokenParser (..)
+ , makeTokenParser
+ ) where
+
+import Data.Char ( isAlpha, toLower, toUpper, isSpace, digitToInt )
+import Data.List ( nub, sort )
+import Control.Monad.Identity
+import Text.Parsec.Prim
+import Text.Parsec.Char
+import Text.Parsec.Combinator
+
+-----------------------------------------------------------
+-- Language Definition
+-----------------------------------------------------------
+
+type LanguageDef st = GenLanguageDef String st Identity
+
+-- | The @GenLanguageDef@ type is a record that contains all parameterizable
+-- features of the 'Text.Parsec.Token' module. The module 'Text.Parsec.Language'
+-- contains some default definitions.
+
+data GenLanguageDef s u m
+ = LanguageDef {
+
+ -- | Describes the start of a block comment. Use the empty string if the
+ -- language doesn't support block comments. For example \"\/*\".
+
+ commentStart :: String,
+
+ -- | Describes the end of a block comment. Use the empty string if the
+ -- language doesn't support block comments. For example \"*\/\".
+
+ commentEnd :: String,
+
+ -- | Describes the start of a line comment. Use the empty string if the
+ -- language doesn't support line comments. For example \"\/\/\".
+
+ commentLine :: String,
+
+ -- | Set to 'True' if the language supports nested block comments.
+
+ nestedComments :: Bool,
+
+ -- | This parser should accept any start characters of identifiers. For
+ -- example @letter \<|> char \"_\"@.
+
+ identStart :: ParsecT s u m Char,
+
+ -- | This parser should accept any legal tail characters of identifiers.
+ -- For example @alphaNum \<|> char \"_\"@.
+
+ identLetter :: ParsecT s u m Char,
+
+ -- | This parser should accept any start characters of operators. For
+ -- example @oneOf \":!#$%&*+.\/\<=>?\@\\\\^|-~\"@
+
+ opStart :: ParsecT s u m Char,
+
+ -- | This parser should accept any legal tail characters of operators.
+ -- Note that this parser should even be defined if the language doesn't
+ -- support user-defined operators, or otherwise the 'reservedOp'
+ -- parser won't work correctly.
+
+ opLetter :: ParsecT s u m Char,
+
+ -- | The list of reserved identifiers.
+
+ reservedNames :: [String],
+
+ -- | The list of reserved operators.
+
+ reservedOpNames:: [String],
+
+ -- | Set to 'True' if the language is case sensitive.
+
+ caseSensitive :: Bool
+
+ }
+
+-----------------------------------------------------------
+-- A first class module: TokenParser
+-----------------------------------------------------------
+
+type TokenParser st = GenTokenParser String st Identity
+
+-- | The type of the record that holds lexical parsers that work on
+-- @s@ streams with state @u@ over a monad @m@.
+
+data GenTokenParser s u m
+ = TokenParser {
+
+ -- | This lexeme parser parses a legal identifier. Returns the identifier
+ -- string. This parser will fail on identifiers that are reserved
+ -- words. Legal identifier (start) characters and reserved words are
+ -- defined in the 'LanguageDef' that is passed to
+ -- 'makeTokenParser'. An @identifier@ is treated as
+ -- a single token using 'try'.
+
+ identifier :: ParsecT s u m String,
+
+ -- | The lexeme parser @reserved name@ parses @symbol
+ -- name@, but it also checks that the @name@ is not a prefix of a
+ -- valid identifier. A @reserved@ word is treated as a single token
+ -- using 'try'.
+
+ reserved :: String -> ParsecT s u m (),
+
+ -- | This lexeme parser parses a legal operator. Returns the name of the
+ -- operator. This parser will fail on any operators that are reserved
+ -- operators. Legal operator (start) characters and reserved operators
+ -- are defined in the 'LanguageDef' that is passed to
+ -- 'makeTokenParser'. An @operator@ is treated as a
+ -- single token using 'try'.
+
+ operator :: ParsecT s u m String,
+
+ -- |The lexeme parser @reservedOp name@ parses @symbol
+ -- name@, but it also checks that the @name@ is not a prefix of a
+ -- valid operator. A @reservedOp@ is treated as a single token using
+ -- 'try'.
+
+ reservedOp :: String -> ParsecT s u m (),
+
+
+ -- | This lexeme parser parses a single literal character. Returns the
+ -- literal character value. This parsers deals correctly with escape
+ -- sequences. The literal character is parsed according to the grammar
+ -- rules defined in the Haskell report (which matches most programming
+ -- languages quite closely).
+
+ charLiteral :: ParsecT s u m Char,
+
+ -- | This lexeme parser parses a literal string. Returns the literal
+ -- string value. This parsers deals correctly with escape sequences and
+ -- gaps. The literal string is parsed according to the grammar rules
+ -- defined in the Haskell report (which matches most programming
+ -- languages quite closely).
+
+ stringLiteral :: ParsecT s u m String,
+
+ -- | This lexeme parser parses a natural number (a positive whole
+ -- number). Returns the value of the number. The number can be
+ -- specified in 'decimal', 'hexadecimal' or
+ -- 'octal'. The number is parsed according to the grammar
+ -- rules in the Haskell report.
+
+ natural :: ParsecT s u m Integer,
+
+ -- | This lexeme parser parses an integer (a whole number). This parser
+ -- is like 'natural' except that it can be prefixed with
+ -- sign (i.e. \'-\' or \'+\'). Returns the value of the number. The
+ -- number can be specified in 'decimal', 'hexadecimal'
+ -- or 'octal'. The number is parsed according
+ -- to the grammar rules in the Haskell report.
+
+ integer :: ParsecT s u m Integer,
+
+ -- | This lexeme parser parses a floating point value. Returns the value
+ -- of the number. The number is parsed according to the grammar rules
+ -- defined in the Haskell report.
+
+ float :: ParsecT s u m Double,
+
+ -- | This lexeme parser parses either 'natural' or a 'float'.
+ -- Returns the value of the number. This parsers deals with
+ -- any overlap in the grammar rules for naturals and floats. The number
+ -- is parsed according to the grammar rules defined in the Haskell report.
+
+ naturalOrFloat :: ParsecT s u m (Either Integer Double),
+
+ -- | Parses a positive whole number in the decimal system. Returns the
+ -- value of the number.
+
+ decimal :: ParsecT s u m Integer,
+
+ -- | Parses a positive whole number in the hexadecimal system. The number
+ -- should be prefixed with \"0x\" or \"0X\". Returns the value of the
+ -- number.
+
+ hexadecimal :: ParsecT s u m Integer,
+
+ -- | Parses a positive whole number in the octal system. The number
+ -- should be prefixed with \"0o\" or \"0O\". Returns the value of the
+ -- number.
+
+ octal :: ParsecT s u m Integer,
+
+ -- | Lexeme parser @symbol s@ parses 'string' @s@ and skips
+ -- trailing white space.
+
+ symbol :: String -> ParsecT s u m String,
+
+ -- | @lexeme p@ first applies parser @p@ and than the 'whiteSpace'
+ -- parser, returning the value of @p@. Every lexical
+ -- token (lexeme) is defined using @lexeme@, this way every parse
+ -- starts at a point without white space. Parsers that use @lexeme@ are
+ -- called /lexeme/ parsers in this document.
+ --
+ -- The only point where the 'whiteSpace' parser should be
+ -- called explicitly is the start of the main parser in order to skip
+ -- any leading white space.
+ --
+ -- > mainParser = do{ whiteSpace
+ -- > ; ds <- many (lexeme digit)
+ -- > ; eof
+ -- > ; return (sum ds)
+ -- > }
+
+ lexeme :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | Parses any white space. White space consists of /zero/ or more
+ -- occurrences of a 'space', a line comment or a block (multi
+ -- line) comment. Block comments may be nested. How comments are
+ -- started and ended is defined in the 'LanguageDef'
+ -- that is passed to 'makeTokenParser'.
+
+ whiteSpace :: ParsecT s u m (),
+
+ -- | Lexeme parser @parens p@ parses @p@ enclosed in parenthesis,
+ -- returning the value of @p@.
+
+ parens :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | Lexeme parser @braces p@ parses @p@ enclosed in braces (\'{\' and
+ -- \'}\'), returning the value of @p@.
+
+ braces :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | Lexeme parser @angles p@ parses @p@ enclosed in angle brackets (\'\<\'
+ -- and \'>\'), returning the value of @p@.
+
+ angles :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | Lexeme parser @brackets p@ parses @p@ enclosed in brackets (\'[\'
+ -- and \']\'), returning the value of @p@.
+
+ brackets :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | DEPRECATED: Use 'brackets'.
+
+ squares :: forall a. ParsecT s u m a -> ParsecT s u m a,
+
+ -- | Lexeme parser |semi| parses the character \';\' and skips any
+ -- trailing white space. Returns the string \";\".
+
+ semi :: ParsecT s u m String,
+
+ -- | Lexeme parser @comma@ parses the character \',\' and skips any
+ -- trailing white space. Returns the string \",\".
+
+ comma :: ParsecT s u m String,
+
+ -- | Lexeme parser @colon@ parses the character \':\' and skips any
+ -- trailing white space. Returns the string \":\".
+
+ colon :: ParsecT s u m String,
+
+ -- | Lexeme parser @dot@ parses the character \'.\' and skips any
+ -- trailing white space. Returns the string \".\".
+
+ dot :: ParsecT s u m String,
+
+ -- | Lexeme parser @semiSep p@ parses /zero/ or more occurrences of @p@
+ -- separated by 'semi'. Returns a list of values returned by
+ -- @p@.
+
+ semiSep :: forall a . ParsecT s u m a -> ParsecT s u m [a],
+
+ -- | Lexeme parser @semiSep1 p@ parses /one/ or more occurrences of @p@
+ -- separated by 'semi'. Returns a list of values returned by @p@.
+
+ semiSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a],
+
+ -- | Lexeme parser @commaSep p@ parses /zero/ or more occurrences of
+ -- @p@ separated by 'comma'. Returns a list of values returned
+ -- by @p@.
+
+ commaSep :: forall a . ParsecT s u m a -> ParsecT s u m [a],
+
+ -- | Lexeme parser @commaSep1 p@ parses /one/ or more occurrences of
+ -- @p@ separated by 'comma'. Returns a list of values returned
+ -- by @p@.
+
+ commaSep1 :: forall a . ParsecT s u m a -> ParsecT s u m [a]
+ }
+
+-----------------------------------------------------------
+-- Given a LanguageDef, create a token parser.
+-----------------------------------------------------------
+
+-- | The expression @makeTokenParser language@ creates a 'GenTokenParser'
+-- record that contains lexical parsers that are
+-- defined using the definitions in the @language@ record.
+--
+-- The use of this function is quite stylized - one imports the
+-- appropiate language definition and selects the lexical parsers that
+-- are needed from the resulting 'GenTokenParser'.
+--
+-- > module Main where
+-- >
+-- > import Text.Parsec
+-- > import qualified Text.Parsec.Token as P
+-- > import Text.Parsec.Language (haskellDef)
+-- >
+-- > -- The parser
+-- > ...
+-- >
+-- > expr = parens expr
+-- > <|> identifier
+-- > <|> ...
+-- >
+-- >
+-- > -- The lexer
+-- > lexer = P.makeTokenParser haskellDef
+-- >
+-- > parens = P.parens lexer
+-- > braces = P.braces lexer
+-- > identifier = P.identifier lexer
+-- > reserved = P.reserved lexer
+-- > ...
+
+makeTokenParser :: (Stream s m Char)
+ => GenLanguageDef s u m -> GenTokenParser s u m
+makeTokenParser languageDef
+ = TokenParser{ identifier = identifier
+ , reserved = reserved
+ , operator = operator
+ , reservedOp = reservedOp
+
+ , charLiteral = charLiteral
+ , stringLiteral = stringLiteral
+ , natural = natural
+ , integer = integer
+ , float = float
+ , naturalOrFloat = naturalOrFloat
+ , decimal = decimal
+ , hexadecimal = hexadecimal
+ , octal = octal
+
+ , symbol = symbol
+ , lexeme = lexeme
+ , whiteSpace = whiteSpace
+
+ , parens = parens
+ , braces = braces
+ , angles = angles
+ , brackets = brackets
+ , squares = brackets
+ , semi = semi
+ , comma = comma
+ , colon = colon
+ , dot = dot
+ , semiSep = semiSep
+ , semiSep1 = semiSep1
+ , commaSep = commaSep
+ , commaSep1 = commaSep1
+ }
+ where
+
+ -----------------------------------------------------------
+ -- Bracketing
+ -----------------------------------------------------------
+ parens p = between (symbol "(") (symbol ")") p
+ braces p = between (symbol "{") (symbol "}") p
+ angles p = between (symbol "<") (symbol ">") p
+ brackets p = between (symbol "[") (symbol "]") p
+
+ semi = symbol ";"
+ comma = symbol ","
+ dot = symbol "."
+ colon = symbol ":"
+
+ commaSep p = sepBy p comma
+ semiSep p = sepBy p semi
+
+ commaSep1 p = sepBy1 p comma
+ semiSep1 p = sepBy1 p semi
+
+
+ -----------------------------------------------------------
+ -- Chars & Strings
+ -----------------------------------------------------------
+ charLiteral = lexeme (between (char '\'')
+ (char '\'' <?> "end of character")
+ characterChar )
+ <?> "character"
+
+ characterChar = charLetter <|> charEscape
+ <?> "literal character"
+
+ charEscape = do{ char '\\'; escapeCode }
+ charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
+
+
+
+ stringLiteral = lexeme (
+ do{ str <- between (char '"')
+ (char '"' <?> "end of string")
+ (many stringChar)
+ ; return (foldr (maybe id (:)) "" str)
+ }
+ <?> "literal string")
+
+ stringChar = do{ c <- stringLetter; return (Just c) }
+ <|> stringEscape
+ <?> "string character"
+
+ stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
+
+ stringEscape = do{ char '\\'
+ ; do{ escapeGap ; return Nothing }
+ <|> do{ escapeEmpty; return Nothing }
+ <|> do{ esc <- escapeCode; return (Just esc) }
+ }
+
+ escapeEmpty = char '&'
+ escapeGap = do{ many1 space
+ ; char '\\' <?> "end of string gap"
+ }
+
+
+
+ -- escape codes
+ escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
+ <?> "escape code"
+
+ charControl = do{ char '^'
+ ; code <- upper
+ ; return (toEnum (fromEnum code - fromEnum 'A'))
+ }
+
+ charNum = do{ code <- decimal
+ <|> do{ char 'o'; number 8 octDigit }
+ <|> do{ char 'x'; number 16 hexDigit }
+ ; return (toEnum (fromInteger code))
+ }
+
+ charEsc = choice (map parseEsc escMap)
+ where
+ parseEsc (c,code) = do{ char c; return code }
+
+ charAscii = choice (map parseAscii asciiMap)
+ where
+ parseAscii (asc,code) = try (do{ string asc; return code })
+
+
+ -- escape code tables
+ escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+
+ ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
+ "FS","GS","RS","US","SP"]
+ ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
+ "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
+ "CAN","SUB","ESC","DEL"]
+
+ ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',
+ '\EM','\FS','\GS','\RS','\US','\SP']
+ ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',
+ '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',
+ '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
+
+
+ -----------------------------------------------------------
+ -- Numbers
+ -----------------------------------------------------------
+ naturalOrFloat = lexeme (natFloat) <?> "number"
+
+ float = lexeme floating <?> "float"
+ integer = lexeme int <?> "integer"
+ natural = lexeme nat <?> "natural"
+
+
+ -- floats
+ floating = do{ n <- decimal
+ ; fractExponent n
+ }
+
+
+ natFloat = do{ char '0'
+ ; zeroNumFloat
+ }
+ <|> decimalFloat
+
+ zeroNumFloat = do{ n <- hexadecimal <|> octal
+ ; return (Left n)
+ }
+ <|> decimalFloat
+ <|> fractFloat 0
+ <|> return (Left 0)
+
+ decimalFloat = do{ n <- decimal
+ ; option (Left n)
+ (fractFloat n)
+ }
+
+ fractFloat n = do{ f <- fractExponent n
+ ; return (Right f)
+ }
+
+ fractExponent n = do{ fract <- fraction
+ ; expo <- option 1.0 exponent'
+ ; return ((fromInteger n + fract)*expo)
+ }
+ <|>
+ do{ expo <- exponent'
+ ; return ((fromInteger n)*expo)
+ }
+
+ fraction = do{ char '.'
+ ; digits <- many1 digit <?> "fraction"
+ ; return (foldr op 0.0 digits)
+ }
+ <?> "fraction"
+ where
+ op d f = (f + fromIntegral (digitToInt d))/10.0
+
+ exponent' = do{ oneOf "eE"
+ ; f <- sign
+ ; e <- decimal <?> "exponent"
+ ; return (power (f e))
+ }
+ <?> "exponent"
+ where
+ power e | e < 0 = 1.0/power(-e)
+ | otherwise = fromInteger (10^e)
+
+
+ -- integers and naturals
+ int = do{ f <- lexeme sign
+ ; n <- nat
+ ; return (f n)
+ }
+
+ sign = (char '-' >> return negate)
+ <|> (char '+' >> return id)
+ <|> return id
+
+ nat = zeroNumber <|> decimal
+
+ zeroNumber = do{ char '0'
+ ; hexadecimal <|> octal <|> decimal <|> return 0
+ }
+ <?> ""
+
+ decimal = number 10 digit
+ hexadecimal = do{ oneOf "xX"; number 16 hexDigit }
+ octal = do{ oneOf "oO"; number 8 octDigit }
+
+ number base baseDigit
+ = do{ digits <- many1 baseDigit
+ ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
+ ; seq n (return n)
+ }
+
+ -----------------------------------------------------------
+ -- Operators & reserved ops
+ -----------------------------------------------------------
+ reservedOp name =
+ lexeme $ try $
+ do{ string name
+ ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)
+ }
+
+ operator =
+ lexeme $ try $
+ do{ name <- oper
+ ; if (isReservedOp name)
+ then unexpected ("reserved operator " ++ show name)
+ else return name
+ }
+
+ oper =
+ do{ c <- (opStart languageDef)
+ ; cs <- many (opLetter languageDef)
+ ; return (c:cs)
+ }
+ <?> "operator"
+
+ isReservedOp name =
+ isReserved (sort (reservedOpNames languageDef)) name
+
+
+ -----------------------------------------------------------
+ -- Identifiers & Reserved words
+ -----------------------------------------------------------
+ reserved name =
+ lexeme $ try $
+ do{ caseString name
+ ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)
+ }
+
+ caseString name
+ | caseSensitive languageDef = string name
+ | otherwise = do{ walk name; return name }
+ where
+ walk [] = return ()
+ walk (c:cs) = do{ caseChar c <?> msg; walk cs }
+
+ caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c)
+ | otherwise = char c
+
+ msg = show name
+
+
+ identifier =
+ lexeme $ try $
+ do{ name <- ident
+ ; if (isReservedName name)
+ then unexpected ("reserved word " ++ show name)
+ else return name
+ }
+
+
+ ident
+ = do{ c <- identStart languageDef
+ ; cs <- many (identLetter languageDef)
+ ; return (c:cs)
+ }
+ <?> "identifier"
+
+ isReservedName name
+ = isReserved theReservedNames caseName
+ where
+ caseName | caseSensitive languageDef = name
+ | otherwise = map toLower name
+
+
+ isReserved names name
+ = scan names
+ where
+ scan [] = False
+ scan (r:rs) = case (compare r name) of
+ LT -> scan rs
+ EQ -> True
+ GT -> False
+
+ theReservedNames
+ | caseSensitive languageDef = sortedNames
+ | otherwise = map (map toLower) sortedNames
+ where
+ sortedNames = sort (reservedNames languageDef)
+
+
+
+ -----------------------------------------------------------
+ -- White space & symbols
+ -----------------------------------------------------------
+ symbol name
+ = lexeme (string name)
+
+ lexeme p
+ = do{ x <- p; whiteSpace; return x }
+
+
+ --whiteSpace
+ whiteSpace
+ | noLine && noMulti = skipMany (simpleSpace <?> "")
+ | noLine = skipMany (simpleSpace <|> multiLineComment <?> "")
+ | noMulti = skipMany (simpleSpace <|> oneLineComment <?> "")
+ | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
+ where
+ noLine = null (commentLine languageDef)
+ noMulti = null (commentStart languageDef)
+
+
+ simpleSpace =
+ skipMany1 (satisfy isSpace)
+
+ oneLineComment =
+ do{ try (string (commentLine languageDef))
+ ; skipMany (satisfy (/= '\n'))
+ ; return ()
+ }
+
+ multiLineComment =
+ do { try (string (commentStart languageDef))
+ ; inComment
+ }
+
+ inComment
+ | nestedComments languageDef = inCommentMulti
+ | otherwise = inCommentSingle
+
+ inCommentMulti
+ = do{ try (string (commentEnd languageDef)) ; return () }
+ <|> do{ multiLineComment ; inCommentMulti }
+ <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti }
+ <|> do{ oneOf startEnd ; inCommentMulti }
+ <?> "end of comment"
+ where
+ startEnd = nub (commentEnd languageDef ++ commentStart languageDef)
+
+ inCommentSingle
+ = do{ try (string (commentEnd languageDef)); return () }
+ <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle }
+ <|> do{ oneOf startEnd ; inCommentSingle }
+ <?> "end of comment"
+ where
+ startEnd = nub (commentEnd languageDef ++ commentStart languageDef)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec
+ ( -- complete modules
+ module Text.ParserCombinators.Parsec.Prim
+ , module Text.ParserCombinators.Parsec.Combinator
+ , module Text.ParserCombinators.Parsec.Char
+
+ -- module Text.ParserCombinators.Parsec.Error
+ , ParseError
+ , errorPos
+
+ -- module Text.ParserCombinators.Parsec.Pos
+ , SourcePos
+ , SourceName, Line, Column
+ , sourceName, sourceLine, sourceColumn
+ , incSourceLine, incSourceColumn
+ , setSourceLine, setSourceColumn, setSourceName
+
+ ) where
+
+import Text.Parsec.String()
+
+import Text.ParserCombinators.Parsec.Prim
+import Text.ParserCombinators.Parsec.Combinator
+import Text.ParserCombinators.Parsec.Char
+
+import Text.ParserCombinators.Parsec.Error
+import Text.ParserCombinators.Parsec.Pos
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Char
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Char
+ ( CharParser,
+ spaces,
+ space,
+ newline,
+ tab,
+ upper,
+ lower,
+ alphaNum,
+ letter,
+ digit,
+ hexDigit,
+ octDigit,
+ char,
+ string,
+ anyChar,
+ oneOf,
+ noneOf,
+ satisfy
+ ) where
+
+
+import Text.Parsec.Char
+import Text.Parsec.String
+
+type CharParser st = GenParser Char st
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Combinator
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Combinator
+ ( choice,
+ count,
+ between,
+ option,
+ optionMaybe,
+ optional,
+ skipMany1,
+ many1,
+ sepBy,
+ sepBy1,
+ endBy,
+ endBy1,
+ sepEndBy,
+ sepEndBy1,
+ chainl,
+ chainl1,
+ chainr,
+ chainr1,
+ eof,
+ notFollowedBy,
+ manyTill,
+ lookAhead,
+ anyToken
+ ) where
+
+
+import Text.Parsec.Combinator
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Error
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Error
+ ( Message (SysUnExpect,UnExpect,Expect,Message),
+ messageString,
+ messageCompare,
+ messageEq,
+ ParseError,
+ errorPos,
+ errorMessages,
+ errorIsUnknown,
+ showErrorMessages,
+ newErrorMessage,
+ newErrorUnknown,
+ addErrorMessage,
+ setErrorPos,
+ setErrorMessage,
+ mergeError
+ ) where
+
+import Text.Parsec.Error
+
+
+messageCompare :: Message -> Message -> Ordering
+messageCompare = compare
+
+messageEq :: Message -> Message -> Bool
+messageEq = (==)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Expr
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Expr
+ ( Assoc (AssocNone,AssocLeft,AssocRight),
+ Operator(..),
+ OperatorTable,
+ buildExpressionParser
+ ) where
+
+import Text.Parsec.Expr(Assoc(..))
+import qualified Text.Parsec.Expr as N
+import Text.ParserCombinators.Parsec(GenParser)
+
+import Control.Monad.Identity
+
+data Operator tok st a = Infix (GenParser tok st (a -> a -> a)) Assoc
+ | Prefix (GenParser tok st (a -> a))
+
+type OperatorTable tok st a = [[Operator tok st a]]
+
+convert :: Operator tok st a -> N.Operator [tok] st Identity a
+convert (Infix p a) = N.Infix p a
+convert (Prefix p) = N.Prefix p
+
+buildExpressionParser :: OperatorTable tok st a
+ -> GenParser tok st a
+ -> GenParser tok st a
+buildExpressionParser = N.buildExpressionParser . map (map convert)
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Language
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Language
+ ( haskellDef,
+ haskell,
+ mondrianDef,
+ mondrian,
+ emptyDef,
+ haskellStyle,
+ javaStyle,
+ LanguageDef,
+ GenLanguageDef(..),
+ ) where
+
+import Text.Parsec.Token
+import Text.Parsec.Language
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Perm
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Perm
+ ( PermParser,
+ permute,
+ (<||>),
+ (<$$>),
+ (<|?>),
+ (<$?>)
+ ) where
+
+import Text.Parsec.Perm
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Pos
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Pos
+ ( SourceName,
+ Line,
+ Column,
+ SourcePos,
+ sourceLine,
+ sourceColumn,
+ sourceName,
+ incSourceLine,
+ incSourceColumn,
+ setSourceLine,
+ setSourceColumn,
+ setSourceName,
+ newPos,
+ initialPos,
+ updatePosChar,
+ updatePosString
+ ) where
+
+
+import Text.Parsec.Pos
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Prim
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Prim
+ ( (<?>),
+ (<|>),
+ Parser,
+ GenParser,
+ runParser,
+ parse,
+ parseFromFile,
+ parseTest,
+ token,
+ tokens,
+ tokenPrim,
+ tokenPrimEx,
+ try,
+ label,
+ labels,
+ unexpected,
+ pzero,
+ many,
+ skipMany,
+ getState,
+ setState,
+ updateState,
+ getPosition,
+ setPosition,
+ getInput,
+ setInput,
+ State(..),
+ getParserState,
+ setParserState
+ ) where
+
+import Text.Parsec.Prim hiding (runParser, try)
+import qualified Text.Parsec.Prim as N -- 'N' for 'New'
+import Text.Parsec.String
+
+import Text.Parsec.Error
+import Text.Parsec.Pos
+
+pzero :: GenParser tok st a
+pzero = parserZero
+
+runParser :: GenParser tok st a
+ -> st
+ -> SourceName
+ -> [tok]
+ -> Either ParseError a
+runParser = N.runParser
+
+try :: GenParser tok st a -> GenParser tok st a
+try = N.try
--- /dev/null
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.ParserCombinators.Parsec.Token
+-- Copyright : (c) Paolo Martini 2007
+-- License : BSD-style (see the LICENSE file)
+--
+-- Maintainer : derek.a.elkins@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Parsec compatibility module
+--
+-----------------------------------------------------------------------------
+
+module Text.ParserCombinators.Parsec.Token
+ ( LanguageDef,
+ GenLanguageDef(..),
+ TokenParser,
+ GenTokenParser(..),
+ makeTokenParser
+ ) where
+
+import Text.Parsec.Token
projects / calu.git / commitdiff