Text/ParserCombinators/MTLParse/MTLParseCore.hs

   1 --
   2 -- MTLParseCore.hs
   3 --
   4 -- Author: Yoshikuni Jujo <PAF01143@nifty.ne.jp>
   5 --
   6 -- This file is part of mtlparse library
   7 --
   8 -- mtlparse is free software: you can redistribute it and/or modify
   9 -- it under the terms of the GNU Lesser General Public License as
  10 -- published by the Free Software Foundation, either version 3 of the
  11 -- License, or any later version.
  12 --
  13 -- mtlparse is distributed in the hope that it will be useful,
  14 -- but WITHOUT ANY WARRANGY; without even the implied warranty of
  15 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 -- GNU Lesser General Public License for more details.
  17 --
  18 -- You should have received a copy of the GNU Lesser General Public
  19 -- License along with this program. If not, see
  20 -- <http://www.gnu.org/licenses/>.
  21
  22 {-# LANGUAGE MultiParamTypeClasses  #-}
  23 {-# LANGUAGE FunctionalDependencies #-}
  24 {-# LANGUAGE FlexibleInstances      #-}
  25 {-# LANGUAGE UndecidableInstances   #-}
  26
  27 module Text.ParserCombinators.MTLParse.MTLParseCore (
  28
  29   -- * MonadParse class
  30   MonadParse( spot, spotBack, still, parseNot, getHere, putHere,
  31               noBacktrack )
  32
  33 , token
  34 , tokenBack
  35
  36 , getsHere
  37 , modifyHere
  38
  39 , getForward
  40 , getsForward
  41 , putForward
  42 , modifyForward
  43
  44 , getBack
  45 , getsBack
  46 , putBack
  47 , modifyBack
  48
  49   -- * The Parse Monad
  50 , Parse(..)
  51 , evalParse
  52 , execParse
  53 , mapParse
  54 , withParse
  55
  56   -- * The ParseT Monad
  57 , ParseT(..)
  58 , evalParseT
  59 , execParseT
  60 , mapParseT
  61 , withParseT
  62
  63 , module Control.Monad
  64 , module Control.Monad.Trans
  65
  66 ) where
  67
  68 import Control.Applicative  ( Applicative(..), Alternative(..)   )
  69 import Control.Monad        ( MonadPlus, mplus, mzero, liftM, ap )
  70 import Control.Monad.Trans  ( MonadTrans( lift ),
  71                               MonadIO, liftIO                    )
  72 import Control.Monad.Reader ( MonadReader( ask, local ),
  73                               ReaderT( ReaderT, runReaderT ),
  74                               mapReaderT                         )
  75 import Control.Monad.Writer ( MonadWriter( tell, listen, pass ),
  76                               WriterT( WriterT, runWriterT ),
  77                               mapWriterT                         )
  78 import Control.Monad.State  ( MonadState( get, put ),
  79                               StateT( StateT, runStateT ),
  80                               mapStateT                          )
  81 import Control.Arrow        ( first, second                      )
  82 import Data.Monoid          ( Monoid( mempty )                   )
  83
  84 class Monad m => MonadParse a m | m -> a where
  85   spot        :: ( a -> Bool ) -> m a
  86   spotBack    :: ( a -> Bool ) -> m a
  87   still       :: m b -> m b
  88   parseNot    :: c -> m b -> m c
  89   getHere     :: m ( [a], [a] )
  90   putHere     :: ( [a], [a] ) -> m ()
  91   noBacktrack :: m b -> m b
  92
  93 token, tokenBack :: ( Eq a, MonadParse a m ) => a -> m a
  94 token     x = spot     (==x)
  95 tokenBack x = spotBack (==x)
  96
  97 getsHere   :: MonadParse a m => ( ([a], [a]) -> b ) -> m b
  98 modifyHere :: MonadParse a m => ( ([a], [a]) -> ([a], [a]) ) -> m ()
  99 getsHere   f = liftM f getHere
 100 modifyHere f = getHere >>= putHere . f
 101
 102 getBack, getForward   :: MonadParse a m => m [ a ]
 103 getsBack, getsForward :: MonadParse a m => ( [a] -> [a] ) -> m [ a ]
 104 getBack       = getsHere fst
 105 getForward    = getsHere snd
 106 getsBack    f = getsHere ( f.fst )
 107 getsForward f = getsHere ( f.snd )
 108
 109 putBack, putForward       :: MonadParse a m => [ a ] -> m ()
 110 modifyBack, modifyForward :: MonadParse a m => ( [a] -> [a] ) -> m ()
 111 putBack    b  = getsHere snd >>= putHere . (,) b
 112 putForward f  = getsHere fst >>= putHere . flip (,) f
 113 modifyBack    = modifyHere . first
 114 modifyForward = modifyHere . second
 115
 116 -- | A parse monad where /a/ is the type of the token to parse
 117 -- and /b/ is the type of the /return value/.
 118
 119 newtype Parse a b
 120   = Parse { runParse :: ( [a], [a] ) -> [ ( b, ([a], [a]) ) ] }
 121
 122 -- Parse is instance of Functor Monad MonadPlus MonadReader MonadParse
 123
 124 instance Functor ( Parse p ) where
 125   fmap f m = Parse $ liftM ( first f ) . runParse m
 126
 127 instance Applicative ( Parse p ) where
 128   pure = return; (<*>) = ap
 129
 130 instance Alternative (Parse p ) where
 131   empty = mzero
 132   (<|>) = mplus
 133
 134 instance Monad ( Parse a ) where
 135   return = Parse . \val inp -> [ (val, inp) ]
 136   Parse pr >>= f
 137          = Parse ( \st -> concat
 138              [ runParse ( f a ) rest | ( a, rest ) <- pr st ] )
 139
 140 instance MonadPlus ( Parse a ) where
 141   mzero                     = Parse $ const []
 142   Parse p1 `mplus` Parse p2 = Parse $ \inp -> p1 inp ++ p2 inp
 143
 144 instance MonadReader ( [a], [a] ) ( Parse a ) where
 145   ask       = Parse $ \inp -> [ (inp, inp) ]
 146   local f m = Parse $ runParse m . f
 147
 148 instance MonadState ( [a], [a] ) ( Parse a ) where
 149   get     = Parse $ \inp -> [ (inp, inp) ]
 150   put inp = Parse $ const [ ((), inp) ]
 151
 152 instance MonadParse a ( Parse a ) where
 153   spot = Parse . spt
 154     where
 155     spt p ( pre, x:xs )
 156       | p x         = [ ( x, (x:pre, xs) ) ]
 157       | otherwise   = []
 158     spt _ ( _, [] ) = []
 159   spotBack = Parse . sptbck
 160     where
 161     sptbck p ( x:xs, post )
 162       | p x            = [ ( x, (xs, x:post) ) ]
 163       | otherwise      = []
 164     sptbck _ ( [], _ ) = []
 165   still p = Parse $ \inp -> do ( ret, _ ) <- runParse p inp
 166                                return ( ret, inp )
 167   parseNot x ( Parse p ) = Parse $ \inp -> case p inp of
 168                                                 [] -> [ (x, inp) ]
 169                                                 _  -> []
 170   getHere = get
 171   putHere = put
 172   noBacktrack p = Parse $ (:[]) . head . runParse p
 173
 174 evalParse :: Parse a b -> ( [a], [a] ) -> [ b ]
 175 evalParse m = map fst . runParse m
 176
 177 execParse :: Parse a b -> ( [a], [a] ) -> [ ([a], [a]) ]
 178 execParse m = map snd . runParse m
 179
 180 mapParse :: ( ( b, ([a], [a]) ) -> ( c, ([a], [a]) ) ) -> Parse a b
 181                                                        -> Parse a c
 182 mapParse f m = Parse $ map f . runParse m
 183
 184 withParse :: ( ([a], [a]) -> ([a], [a]) ) -> Parse a b -> Parse a b
 185 withParse f m = Parse $ runParse m . f
 186
 187 -- | A parse monad for encaplulating an inner monad.
 188
 189 newtype ParseT a m b
 190   = ParseT { runParseT :: ( [a], [a] ) -> m [ ( b, ([a], [a]) ) ] }
 191
 192 instance Monad m => Functor ( ParseT a m ) where
 193   fmap f m = ParseT $ \a -> do
 194                rets <- runParseT m a
 195                return [ ( f a', rst ) | ( a', rst ) <- rets ]
 196
 197 instance Monad m => Applicative ( ParseT a m ) where
 198   pure = return; (<*>) = ap
 199
 200 instance Monad m => Alternative (ParseT a m ) where
 201   empty = mzero
 202   (<|>) = mplus
 203
 204 instance Monad m => Monad ( ParseT a m ) where
 205   return b = ParseT $ \a -> return [ (b, a) ]
 206   ParseT pr >>= f
 207     = ParseT $ \a ->
 208         pr a >>=
 209           liftM concat . mapM ( \(a', rest) -> runParseT (f a') rest )
 210
 211 instance Monad m => MonadPlus ( ParseT a m ) where
 212   mzero                       = ParseT $ const $ return []
 213   ParseT p1 `mplus` ParseT p2 = ParseT $ \inp -> do ret1 <- p1 inp
 214                                                     ret2 <- p2 inp
 215                                                     return $ ret1 ++ ret2
 216
 217 instance Monad m => MonadParse a ( ParseT a m ) where
 218   spot = ParseT . spt
 219     where
 220     spt p ( pre, x:xs )
 221       | p x         = return [ ( x, (x:pre, xs) ) ]
 222       | otherwise   = return []
 223     spt _ ( _, [] ) = return []
 224   spotBack = ParseT . sptbck
 225     where
 226     sptbck p ( x:xs, post )
 227       | p x            = return [ ( x, (xs, x:post) ) ]
 228       | otherwise      = return []
 229     sptbck _ ( [], _ ) = return []
 230   still p = ParseT $ \inp -> do
 231     rets <- runParseT p inp
 232     return [ ( ret, inp ) | ( ret, _ ) <- rets ]
 233   parseNot x ( ParseT p ) = ParseT $ \inp -> do
 234     rets <- p inp
 235     case rets of
 236       [] -> return [ (x, inp) ]
 237       _  -> return []
 238   getHere = get
 239   putHere = put
 240   noBacktrack p = ParseT $ \inp -> do ret <- runParseT p inp
 241                                       return [ head ret ]
 242
 243 instance Monad m => MonadReader ( [a], [a] ) ( ParseT a m ) where
 244   ask       = ParseT $ \inp -> return [ (inp, inp) ]
 245   local f m = ParseT $ runParseT m . f
 246
 247 instance Monad m => MonadState ( [a], [a] ) ( ParseT a m ) where
 248   get     = ParseT $ \inp -> return [ (inp, inp) ]
 249   put inp = ParseT $ \_   -> return [ ((), inp) ]
 250
 251 instance MonadTrans ( ParseT a ) where
 252   lift m = ParseT $ \a -> do
 253              ret <- m
 254              return [ (ret, a) ]
 255
 256 instance MonadIO m => MonadIO ( ParseT a m ) where
 257   liftIO = lift . liftIO
 258
 259 instance MonadWriter w m => MonadWriter w ( ParseT a m ) where
 260   tell     = lift . tell
 261   listen m = ParseT $ \inp -> do
 262     ( al, w ) <- listen ( runParseT m inp )
 263     return [ ( (ret, w), inp' ) | ( ret, inp' ) <- al ]
 264   pass m   = ParseT $ \inp -> pass $ do
 265     al <- runParseT m inp
 266     return
 267       ( [ ( ret, inp' ) | ( (ret, _), inp' ) <- al ] ,
 268         snd . fst $ head al )
 269
 270 evalParseT :: ( Monad m ) => ParseT a m b -> ( [a], [a] ) -> m [ b ]
 271 evalParseT m inp = do
 272   al <- runParseT m inp
 273   return $ map fst al
 274
 275 execParseT
 276   :: ( Monad m ) => ParseT a m b -> ( [a], [a] ) -> m [ ([a], [a]) ]
 277 execParseT m inp = do
 278   al <- runParseT m inp
 279   return $ map snd al
 280
 281 mapParseT
 282   :: ( m [ ( b, ([a], [a]) ) ] -> n [ (c, ( [a], [a]) ) ] )
 283        -> ParseT a m b -> ParseT a n c
 284 mapParseT f m = ParseT $ f . runParseT m
 285
 286 withParseT :: ( ([a], [a]) -> ([a], [a]) ) -> ParseT a m b
 287                                            -> ParseT a m b
 288 withParseT f m = ParseT $ runParseT m . f
 289
 290 -- MonadParse instance for other monad transformers
 291
 292 instance ( MonadParse a m ) => MonadParse a ( ReaderT s m ) where
 293   spot         = lift . spot
 294   spotBack     = lift . spotBack
 295   still        = mapReaderT still
 296   parseNot x p = ReaderT $ \r -> parseNot x ( runReaderT p r )
 297   getHere      = lift getHere
 298   putHere      = lift . putHere
 299   noBacktrack  = mapReaderT noBacktrack
 300
 301 instance ( MonadParse a m, Monoid w ) => MonadParse a ( WriterT w m )
 302   where
 303   spot        = lift . spot
 304   spotBack    = lift . spotBack
 305   still       = mapWriterT still
 306   parseNot x  = WriterT . parseNot (x, mempty) . runWriterT
 307   getHere     = lift getHere
 308   putHere     = lift . putHere
 309   noBacktrack = mapWriterT noBacktrack
 310
 311 instance ( MonadParse a m ) => MonadParse a ( StateT r m ) where
 312   spot         = lift . spot
 313   spotBack     = lift . spotBack
 314   still        = mapStateT still
 315   parseNot x p = StateT $ \s -> parseNot ( x, s ) ( runStateT p s )
 316   getHere      = lift getHere
 317   putHere      = lift . putHere
 318   noBacktrack  = mapStateT noBacktrack