Interface.hs

{-# LANGUAGE  MagicHash,
              UnboxedTuples,
              ScopedTypeVariables #-}

module UU.Parsing.Interface 
       ( AnaParser, pWrap, pMap
       , module UU.Parsing.MachineInterface
       , module UU.Parsing.Interface
       , (<*>), (<*), (*>), (<$>), (<$), (<|>)
       ) where

import GHC.Prim
import UU.Parsing.Machine
import UU.Parsing.MachineInterface
--import IOExts
import System.IO.Unsafe
import System.IO
import Control.Applicative

-- ==================================================================================
-- ===== PRIORITIES ======================================================================
-- =======================================================================================

{- 20150402 AD: use of Applicative, Functor, Alternative
infixl 3 <|>:
infixl 4 <*>:, <$>: 
infixl 4 <$:
infixl 4 <*:, *>:
-}

-- =======================================================================================
-- ===== ANAPARSER INSTANCES =============================================================
-- =======================================================================================
type Parser s = AnaParser [s] Pair s (Maybe s)
-- =======================================================================================
-- ===== PARSER CLASSES ==================================================================
-- =======================================================================================

-- | The 'IsParser' class contains the base combinators with which
-- to write parsers. A minimal complete instance definition consists of
-- definitions for '(<*>)', '(<|>)', 'pSucceed', 'pLow', 'pFail', 
-- 'pCostRange', 'pCostSym', 'getfirsts', 'setfirsts', and 'getzerop'.
-- All operators available through 'Applicative', 'Functor", and 'Alternative' have the same names suffixed with ':'.
class (Applicative p, Alternative p, Functor p) => IsParser p s | p -> s where
  {- 20150402 AD: use of Applicative, Functor, Alternative
  -- | Sequential composition. Often used in combination with <$>.
  -- The function returned by parsing the left-hand side is applied 
  -- to the value returned by parsing the right-hand side.
  -- Note: Implementations of this combinator should lazily match on
  -- and evaluate the right-hand side parser. The derived combinators 
  -- for list parsing will explode if they do not.
  (<*>:) :: p (a->b) -> p a -> p b
  -- | Value ignoring versions of sequential composition. These ignore
  -- either the value returned by the parser on the right-hand side or 
  -- the left-hand side, depending on the visual direction of the
  -- combinator.
  (<*: ) :: p a      -> p b -> p a
  ( *>:) :: p a      -> p b -> p b
  -- | Applies the function f to the result of p after parsing p.
  (<$>:) :: (a->b)   -> p a -> p b
  (<$: ) :: b        -> p a -> p b
  -}
  {- 20150402 AD: use of Applicative, Functor, Alternative
  f <$>: p = pSucceed f <*>: p
  f <$:  q = pSucceed f <*  q
  p <*:  q = pSucceed       const  <*>: p <*>: q
  p  *>: q = pSucceed (flip const) <*>: p <*>: q
  -}
  {- 20150402 AD: use of Applicative, Functor, Alternative
  -- | Alternative combinator. Succeeds if either of the two arguments
  -- succeed, and returns the result of the best success parse.
  (<|>:) :: p a -> p a -> p a
  -}
  -- | Two variants of the parser for empty strings. 'pSucceed' parses the
  -- empty string, and fully counts as an alternative parse. It returns the
  -- value passed to it.
  pSucceed :: a -> p a
  -- | 'pLow' parses the empty string, but alternatives to pLow are always
  -- preferred over 'pLow' parsing the empty string.
  pLow     :: a -> p a
  pSucceed = pure
  -- | This parser always fails, and never returns any value at all.
  pFail :: p a
  -- | Parses a range of symbols with an associated cost and the symbol to
  -- insert if no symbol in the range is present. Returns the actual symbol
  -- parsed.
  pCostRange   :: Int# -> s -> SymbolR s -> p s
  -- | Parses a symbol with an associated cost and the symbol to insert if
  -- the symbol to parse isn't present. Returns either the symbol parsed or
  -- the symbol inserted.
  pCostSym     :: Int# -> s -> s         -> p s
  -- | Parses a symbol. Returns the symbol parsed.
  pSym         ::                   s         -> p s
  pRange       ::              s -> SymbolR s -> p s
  -- | Get the firsts set from the parser, i.e. the symbols it expects.
  getfirsts    :: p v -> Expecting s
  -- | Set the firsts set in the parser.
  setfirsts    :: Expecting s -> p v ->  p v
  pFail        =  empty
  pSym a       =  pCostSym   5# a a
  pRange       =  pCostRange 5#
  -- | 'getzerop' returns @Nothing@ if the parser can not parse the empty
  -- string, and returns @Just p@ with @p@ a parser that parses the empty 
  -- string and returns the appropriate value.
  getzerop     ::              p v -> Maybe (p v)
  -- | 'getonep' returns @Nothing@ if the parser can only parse the empty
  -- string, and returns @Just p@ with @p@ a parser that does not parse any
  -- empty string.
  getonep      :: p v -> Maybe (p v)


-- =======================================================================================
-- ===== AnaParser =======================================================================
-- =======================================================================================

-- | The fast 'AnaParser' instance of the 'IsParser' class. Note that this
-- requires a functioning 'Ord' for the symbol type s, as tokens are
-- often compared using the 'compare' function in 'Ord' rather than always
-- using '==' rom 'Eq'. The two do need to be consistent though, that is
-- for any two @x1@, @x2@ such that @x1 == x2@ you must have 
-- @compare x1 x2 == EQ@.
instance (Ord s, Symbol s, InputState state s p, OutputState result) => IsParser (AnaParser state result s p) s where
  {- 20150402 AD: use of Applicative, Functor, Alternative
  (<*>:) p q = anaSeq libDollar  libSeq  ($) p q
  (<*: ) p q = anaSeq libDollarL libSeqL const p q
  ( *>:) p q = anaSeq libDollarR libSeqR (flip const) p q
  pSucceed =  anaSucceed
  (<|>:) =  anaOr
  pFail = anaFail
  -}
  pLow     =  anaLow
  pCostRange   = anaCostRange
  pCostSym i ins sym = anaCostRange i ins (mk_range sym sym)
  getfirsts    = anaGetFirsts
  setfirsts    = anaSetFirsts
  getzerop  p  = case zerop p of
                 Nothing     -> Nothing
                 Just (b,e)  -> Just p { pars = libSucceed `either` id $ e
                                       , leng = Zero
                                       , onep = noOneParser
                                       }
  getonep   p = let tab = table (onep p)
                in if null tab then Nothing else Just (mkParser (leng p) Nothing (onep p))

instance (Ord s, Symbol s, InputState state s p, OutputState result) => Applicative (AnaParser state result s p) where
  (<*>) p q = anaSeq libDollar  libSeq  ($) p q
  {-# INLINE (<*>) #-}
  (<* ) p q = anaSeq libDollarL libSeqL const p q
  {-# INLINE (<*) #-}
  ( *>) p q = anaSeq libDollarR libSeqR (flip const) p q
  {-# INLINE (*>) #-}
  pure      = anaSucceed
  {-# INLINE pure #-}

instance (Ord s, Symbol s, InputState state s p, OutputState result) => Alternative (AnaParser state result s p) where
  (<|>) = anaOr
  {-# INLINE (<|>) #-}
  empty = anaFail
  {-# INLINE empty #-}

instance (Ord s, Symbol s, InputState state s p, OutputState result, Applicative (AnaParser state result s p)) => Functor (AnaParser state result s p) where
  fmap f p = pure f <*> p
  {-# INLINE fmap #-}

instance InputState [s] s (Maybe s) where
 splitStateE []     = Right' []
 splitStateE (s:ss) = Left'  s ss
 splitState  (s:ss) = (# s, ss #)
 getPosition []     = Nothing
 getPosition (s:ss) = Just s


instance OutputState Pair  where
  acceptR            = Pair
  nextR       acc    = \ f   ~(Pair a r) -> acc  (f a) r  
  
pCost :: (OutputState out, InputState inp sym pos, Symbol sym, Ord sym) 
      => Int# -> AnaParser inp out sym pos ()
pCost x = pMap f f' (pSucceed ())
  where f  acc inp steps = (inp, Cost x (val (uncurry acc) steps))
        f'     inp steps = (inp, Cost x steps)

getInputState :: (InputState a c d, Symbol c, Ord c, OutputState b)=>AnaParser a b c d a
getInputState = pMap f g (pSucceed id)
  where f acc inp steps = (inp, val (acc inp . snd) steps)
        g = (,)

handleEof input = case splitStateE input
                   of Left'  s  ss  ->  StRepair (deleteCost s)  
                                                 (Msg (EStr "end of file") (getPosition input) 
                                                                   (Delete s)
                                                 ) 
                                                 (handleEof ss)
                      Right' ss      ->  NoMoreSteps (Pair ss ())

parse :: (Symbol s, InputState inp s pos) 
      => AnaParser inp Pair s pos a 
      -> inp 
      -> Steps (Pair a (Pair inp ())) s pos
parse = parsebasic handleEof


parseIOMessage :: ( Symbol s, InputState inp s p) 
               => (Message s p -> String) 
               -> AnaParser inp Pair s p a 
               -> inp 
               -> IO a
parseIOMessage showMessage p inp
 = do  (Pair v final) <- evalStepsIO showMessage (parse p inp) 
       final `seq` return v -- in order to force the trailing error messages to be printed
       
parseIOMessageN :: ( Symbol s, InputState inp s p) 
               => (Message s p -> String) 
               -> Int
               -> AnaParser inp Pair s p a 
               -> inp 
               -> IO a
parseIOMessageN showMessage n p inp
 = do  (Pair v final) <- evalStepsIO' showMessage n (parse p inp) 
       final `seq` return v -- in order to force the trailing error messages to be printed

data Pair a r = Pair a r

evalStepsIO :: (Message s p -> String) 
            ->  Steps b s p 
            -> IO b
evalStepsIO showMessage = evalStepsIO' showMessage (-1)      
       
evalStepsIO' :: (Message s p -> String) 
            -> Int
            ->  Steps b s p 
            -> IO b
evalStepsIO' showMessage n (steps :: Steps b s p) = eval n steps
  where eval                      :: Int -> Steps a s p -> IO a
        eval 0 steps               = return (evalSteps steps)
        eval n steps = case steps of
          OkVal v        rest -> do arg <- unsafeInterleaveIO (eval n rest)
                                    return (v arg)
          Ok             rest -> eval n rest
          Cost  _        rest -> eval n rest
          StRepair _ msg rest -> do hPutStr stderr (showMessage msg)
                                    eval (n-1) rest
          Best _   rest   _   -> eval n rest
          NoMoreSteps v       -> return v