{-# LANGUAGE  MagicHash,
              UnboxedTuples #-}

module UU.Parsing.MachineInterface where
import GHC.Prim

-- | The 'InputState' class contains the interface that the AnaParser
-- parsers expect for the input. A minimal complete instance definition
-- consists of 'splitStateE', 'splitState' and 'getPosition'.
class InputState state s pos | state -> s, state -> pos where
 -- | Splits the state in a strict variant of 'Either', with 'Left'' if a symbol
 --   can be split off and 'Right'' if none can
 splitStateE :: state             -> Either' state s
 -- | Splits the state in the first symbol and the remaining state
 splitState  :: state             -> (# s, state #)
 -- | Gets the current position in the input
 getPosition :: state             -> pos
 -- | Reports an error
 reportError :: Message s pos     -> state -> state
 reportError Message s pos
_ = state -> state
forall a. a -> a
id
 -- | Modify the state as the result of inserting a symbol 's' in the input.
 -- The symbol that has already been considered as having been inserted 
 -- is passed. It should normally not be added to the state.
 insertSymbol :: s                -> state -> state
 insertSymbol s
_ = state -> state
forall a. a -> a
id
 -- | Modify the state as the result of deleting a symbol 's' from the input.
 -- The symbol that has already been deleted from the input state is passed.
 -- It should normally not be deleted from the state.
 deleteSymbol :: s                -> state -> state
 deleteSymbol s
_ = state -> state
forall a. a -> a
id
 {-
{-# INLINE splitStateE #-}
 {-# INLINE splitState  #-}
 {-# INLINE insertSymbol  #-}
 {-# INLINE deleteSymbol  #-}
-}

class OutputState r  where
  acceptR      ::                     v                   -> rest        -> r v rest
  nextR        ::  (a -> rest  -> rest') -> (b -> a)      -> (r b rest)  -> rest'
{-
{-# INLINE acceptR #-}
  {-# INLINE nextR   #-}
-}
class Symbol s where
 deleteCost :: s -> Int#
 symBefore  :: s -> s
 symAfter   :: s -> s
 deleteCost s
b = Int#
5#
 symBefore  = [Char] -> s -> s
forall a. HasCallStack => [Char] -> a
error [Char]
"You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
 symAfter   = [Char] -> s -> s
forall a. HasCallStack => [Char] -> a
error [Char]
"You should have made your token type an instance of the Class Symbol. eg by defining symAfter  = succ"

data Either' state s = Left' !s (state )
                     | Right' (state )

-- =======================================================================================
-- ===== STEPS ===========================================================================
-- =======================================================================================
data Steps val s p 
             = forall a . OkVal           (a -> val)                                (Steps a   s p)
             |            Ok         {                                       forall val s p. Steps val s p -> Steps val s p
rest :: Steps val s p}
             |            Cost       {forall val s p. Steps val s p -> Int#
costing::Int#                        , rest :: Steps val s p}
             |            StRepair   {costing::Int#  , forall val s p. Steps val s p -> Message s p
m :: !(Message s p) , rest :: Steps val s p}
             |            Best       (Steps val s p) (Steps val s p) ( Steps val s p)
             |            NoMoreSteps val
data Action s  =  Insert s
               |  Delete s 
               |  Other  String

val :: (a -> b) -> Steps a s p -> Steps b s p

val :: forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f (OkVal a -> a
a Steps a s p
rest) = (a -> b) -> Steps a s p -> Steps b s p
forall val s p a. (a -> val) -> Steps a s p -> Steps val s p
OkVal (a -> b
f(a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> a
a) Steps a s p
rest
val a -> b
f (Ok      Steps a s p
rest) = (a -> b) -> Steps a s p -> Steps b s p
forall val s p a. (a -> val) -> Steps a s p -> Steps val s p
OkVal  a -> b
f Steps a s p
rest
val a -> b
f (Cost Int#
i  Steps a s p
rest) = Int# -> Steps b s p -> Steps b s p
forall val s p. Int# -> Steps val s p -> Steps val s p
Cost Int#
i ((a -> b) -> Steps a s p -> Steps b s p
forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f Steps a s p
rest)
val a -> b
f (StRepair Int#
c Message s p
m Steps a s p
r) = Int# -> Message s p -> Steps b s p -> Steps b s p
forall val s p.
Int# -> Message s p -> Steps val s p -> Steps val s p
StRepair Int#
c Message s p
m ((a -> b) -> Steps a s p -> Steps b s p
forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f Steps a s p
r)
val a -> b
f (Best Steps a s p
l Steps a s p
s     Steps a s p
r) = Steps b s p -> Steps b s p -> Steps b s p -> Steps b s p
forall val s p.
Steps val s p -> Steps val s p -> Steps val s p -> Steps val s p
Best ((a -> b) -> Steps a s p -> Steps b s p
forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f Steps a s p
l) ((a -> b) -> Steps a s p -> Steps b s p
forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f Steps a s p
s) ((a -> b) -> Steps a s p -> Steps b s p
forall a b s p. (a -> b) -> Steps a s p -> Steps b s p
val a -> b
f Steps a s p
r)
val a -> b
f (NoMoreSteps a
v)  = b -> Steps b s p
forall val s p. val -> Steps val s p
NoMoreSteps (a -> b
f a
v)

evalSteps :: Steps a s p -> a
evalSteps :: forall a s p. Steps a s p -> a
evalSteps (OkVal a -> a
v  Steps a s p
rest    ) = a -> a
v (Steps a s p -> a
forall a s p. Steps a s p -> a
evalSteps Steps a s p
rest)
evalSteps (Ok       Steps a s p
rest    ) =    Steps a s p -> a
forall a s p. Steps a s p -> a
evalSteps Steps a s p
rest
evalSteps (Cost  Int#
_  Steps a s p
rest    ) =    Steps a s p -> a
forall a s p. Steps a s p -> a
evalSteps Steps a s p
rest
evalSteps (StRepair Int#
_ Message s p
msg Steps a s p
rest    ) =    Steps a s p -> a
forall a s p. Steps a s p -> a
evalSteps Steps a s p
rest
evalSteps (Best Steps a s p
_   Steps a s p
rest  Steps a s p
_) =  Steps a s p -> a
forall a s p. Steps a s p -> a
evalSteps Steps a s p
rest
evalSteps (NoMoreSteps a
v    ) =  a
v


getMsgs :: Steps a s p -> [Message s p]
getMsgs :: forall a s p. Steps a s p -> [Message s p]
getMsgs (OkVal a -> a
_        Steps a s p
rest) = Steps a s p -> [Message s p]
forall a s p. Steps a s p -> [Message s p]
getMsgs Steps a s p
rest
getMsgs (Ok             Steps a s p
rest) = Steps a s p -> [Message s p]
forall a s p. Steps a s p -> [Message s p]
getMsgs Steps a s p
rest
getMsgs (Cost Int#
_         Steps a s p
rest) = Steps a s p -> [Message s p]
forall a s p. Steps a s p -> [Message s p]
getMsgs Steps a s p
rest
getMsgs (StRepair Int#
_ Message s p
m   Steps a s p
rest) = Message s p
mMessage s p -> [Message s p] -> [Message s p]
forall a. a -> [a] -> [a]
:Steps a s p -> [Message s p]
forall a s p. Steps a s p -> [Message s p]
getMsgs Steps a s p
rest
getMsgs (Best Steps a s p
_ Steps a s p
m   Steps a s p
_)        = Steps a s p -> [Message s p]
forall a s p. Steps a s p -> [Message s p]
getMsgs Steps a s p
m
getMsgs (NoMoreSteps a
_      ) = []

data Message sym pos = Msg (Expecting sym) !pos (Action sym) 
-- Msg (String, String, Expecting s) -- action, position, expecting 
instance (Eq s, Show s) => Show (Expecting s) where
 show :: Expecting s -> [Char]
show (ESym     SymbolR s
s)   = SymbolR s -> [Char]
forall a. Show a => a -> [Char]
show SymbolR s
s
 show (EStr   [Char]
str)   = [Char]
str
 show (EOr     [])   = [Char]
"Nothing expected "
 show (EOr    [Expecting s
e])   = Expecting s -> [Char]
forall a. Show a => a -> [Char]
show Expecting s
e
 show (EOr  (Expecting s
e:[Expecting s]
ee))  = Expecting s -> [Char]
forall a. Show a => a -> [Char]
show Expecting s
e [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" or " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Expecting s -> [Char]
forall a. Show a => a -> [Char]
show ([Expecting s] -> Expecting s
forall s. [Expecting s] -> Expecting s
EOr [Expecting s]
ee)
 show (ESeq  [Expecting s]
seq)    = [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Expecting s -> [Char]) -> [Expecting s] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Expecting s -> [Char]
forall a. Show a => a -> [Char]
show [Expecting s]
seq)

instance (Eq s, Show s, Show p) => Show (Message s p) where
 show :: Message s p -> [Char]
show (Msg Expecting s
expecting p
position Action s
action)  
   =  [Char]
"\n?? Error      : " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ p -> [Char]
forall a. Show a => a -> [Char]
show p
position [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      [Char]
"\n?? Expecting  : " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Expecting s -> [Char]
forall a. Show a => a -> [Char]
show Expecting s
expecting [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
      [Char]
"\n?? Repaired by: "  [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Action s -> [Char]
forall a. Show a => a -> [Char]
show Action s
action [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
"\n"

instance Show s => Show (Action s) where
  show :: Action s -> [Char]
show (Insert s
s) = [Char]
"inserting: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ s -> [Char]
forall a. Show a => a -> [Char]
show s
s 
  show (Delete s
s) = [Char]
"deleting: "  [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ s -> [Char]
forall a. Show a => a -> [Char]
show s
s 
  show (Other [Char]
s)  = [Char]
s 
data Expecting s = ESym (SymbolR s)
                 | EStr String
                 | EOr  [Expecting s]
                 | ESeq [Expecting s]
                 deriving (Eq (Expecting s)
Eq (Expecting s)
-> (Expecting s -> Expecting s -> Ordering)
-> (Expecting s -> Expecting s -> Bool)
-> (Expecting s -> Expecting s -> Bool)
-> (Expecting s -> Expecting s -> Bool)
-> (Expecting s -> Expecting s -> Bool)
-> (Expecting s -> Expecting s -> Expecting s)
-> (Expecting s -> Expecting s -> Expecting s)
-> Ord (Expecting s)
Expecting s -> Expecting s -> Bool
Expecting s -> Expecting s -> Ordering
Expecting s -> Expecting s -> Expecting s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s}. Ord s => Eq (Expecting s)
forall s. Ord s => Expecting s -> Expecting s -> Bool
forall s. Ord s => Expecting s -> Expecting s -> Ordering
forall s. Ord s => Expecting s -> Expecting s -> Expecting s
$ccompare :: forall s. Ord s => Expecting s -> Expecting s -> Ordering
compare :: Expecting s -> Expecting s -> Ordering
$c< :: forall s. Ord s => Expecting s -> Expecting s -> Bool
< :: Expecting s -> Expecting s -> Bool
$c<= :: forall s. Ord s => Expecting s -> Expecting s -> Bool
<= :: Expecting s -> Expecting s -> Bool
$c> :: forall s. Ord s => Expecting s -> Expecting s -> Bool
> :: Expecting s -> Expecting s -> Bool
$c>= :: forall s. Ord s => Expecting s -> Expecting s -> Bool
>= :: Expecting s -> Expecting s -> Bool
$cmax :: forall s. Ord s => Expecting s -> Expecting s -> Expecting s
max :: Expecting s -> Expecting s -> Expecting s
$cmin :: forall s. Ord s => Expecting s -> Expecting s -> Expecting s
min :: Expecting s -> Expecting s -> Expecting s
Ord, Expecting s -> Expecting s -> Bool
(Expecting s -> Expecting s -> Bool)
-> (Expecting s -> Expecting s -> Bool) -> Eq (Expecting s)
forall s. Eq s => Expecting s -> Expecting s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall s. Eq s => Expecting s -> Expecting s -> Bool
== :: Expecting s -> Expecting s -> Bool
$c/= :: forall s. Eq s => Expecting s -> Expecting s -> Bool
/= :: Expecting s -> Expecting s -> Bool
Eq)
-- =======================================================================================
-- ===== SYMBOLS and RANGES ==============================================================
-- =======================================================================================

data  SymbolR s  =  Range !s !s | EmptyR deriving (SymbolR s -> SymbolR s -> Bool
(SymbolR s -> SymbolR s -> Bool)
-> (SymbolR s -> SymbolR s -> Bool) -> Eq (SymbolR s)
forall s. Eq s => SymbolR s -> SymbolR s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall s. Eq s => SymbolR s -> SymbolR s -> Bool
== :: SymbolR s -> SymbolR s -> Bool
$c/= :: forall s. Eq s => SymbolR s -> SymbolR s -> Bool
/= :: SymbolR s -> SymbolR s -> Bool
Eq,Eq (SymbolR s)
Eq (SymbolR s)
-> (SymbolR s -> SymbolR s -> Ordering)
-> (SymbolR s -> SymbolR s -> Bool)
-> (SymbolR s -> SymbolR s -> Bool)
-> (SymbolR s -> SymbolR s -> Bool)
-> (SymbolR s -> SymbolR s -> Bool)
-> (SymbolR s -> SymbolR s -> SymbolR s)
-> (SymbolR s -> SymbolR s -> SymbolR s)
-> Ord (SymbolR s)
SymbolR s -> SymbolR s -> Bool
SymbolR s -> SymbolR s -> Ordering
SymbolR s -> SymbolR s -> SymbolR s
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s}. Ord s => Eq (SymbolR s)
forall s. Ord s => SymbolR s -> SymbolR s -> Bool
forall s. Ord s => SymbolR s -> SymbolR s -> Ordering
forall s. Ord s => SymbolR s -> SymbolR s -> SymbolR s
$ccompare :: forall s. Ord s => SymbolR s -> SymbolR s -> Ordering
compare :: SymbolR s -> SymbolR s -> Ordering
$c< :: forall s. Ord s => SymbolR s -> SymbolR s -> Bool
< :: SymbolR s -> SymbolR s -> Bool
$c<= :: forall s. Ord s => SymbolR s -> SymbolR s -> Bool
<= :: SymbolR s -> SymbolR s -> Bool
$c> :: forall s. Ord s => SymbolR s -> SymbolR s -> Bool
> :: SymbolR s -> SymbolR s -> Bool
$c>= :: forall s. Ord s => SymbolR s -> SymbolR s -> Bool
>= :: SymbolR s -> SymbolR s -> Bool
$cmax :: forall s. Ord s => SymbolR s -> SymbolR s -> SymbolR s
max :: SymbolR s -> SymbolR s -> SymbolR s
$cmin :: forall s. Ord s => SymbolR s -> SymbolR s -> SymbolR s
min :: SymbolR s -> SymbolR s -> SymbolR s
Ord)

instance (Eq s,Show s) => Show (SymbolR s) where
 show :: SymbolR s -> [Char]
show SymbolR s
EmptyR      = [Char]
"the empty range"
 show (Range s
a s
b) = if s
a s -> s -> Bool
forall a. Eq a => a -> a -> Bool
== s
b then s -> [Char]
forall a. Show a => a -> [Char]
show s
a else s -> [Char]
forall a. Show a => a -> [Char]
show s
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
".." [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ s -> [Char]
forall a. Show a => a -> [Char]
show s
b


mk_range :: s -> s -> SymbolR s
mk_range             s
l    s
r =  if s
l s -> s -> Bool
forall a. Ord a => a -> a -> Bool
> s
r then SymbolR s
forall s. SymbolR s
EmptyR else s -> s -> SymbolR s
forall s. s -> s -> SymbolR s
Range s
l s
r

symInRange :: SymbolR a -> a -> Bool
symInRange (Range a
l a
r) = if a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r then (a
la -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)
                                   else (\ a
s ->  a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
l Bool -> Bool -> Bool
&& a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
r)

symRS :: SymbolR a -> a -> Ordering
symRS (Range a
l a
r)
  = if a
l a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
r then (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
l)
    else (\ a
s -> if      a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
l then Ordering
GT
                 else if a
s a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
r then Ordering
LT
                 else               Ordering
EQ)

SymbolR a
range except :: SymbolR a -> t a -> [SymbolR a]
`except` t a
elems
 = (a -> [SymbolR a] -> [SymbolR a])
-> [SymbolR a] -> t a -> [SymbolR a]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> [SymbolR a] -> [SymbolR a]
forall {s}. (Ord s, Symbol s) => s -> [SymbolR s] -> [SymbolR s]
removeelem [SymbolR a
range] t a
elems
   where removeelem :: s -> [SymbolR s] -> [SymbolR s]
removeelem s
elem [SymbolR s]
ranges = [SymbolR s
r | SymbolR s
ran <- [SymbolR s]
ranges, SymbolR s
r <- SymbolR s
ran SymbolR s -> s -> [SymbolR s]
forall {s}. (Ord s, Symbol s) => SymbolR s -> s -> [SymbolR s]
`minus` s
elem]
         SymbolR s
EmptyR          minus :: SymbolR s -> s -> [SymbolR s]
`minus` s
_    = []
         ran :: SymbolR s
ran@(Range s
l s
r) `minus` s
elem = if SymbolR s -> s -> Bool
forall {a}. Ord a => SymbolR a -> a -> Bool
symInRange SymbolR s
ran s
elem
                                        then [s -> s -> SymbolR s
forall {s}. Ord s => s -> s -> SymbolR s
mk_range s
l (s -> s
forall s. Symbol s => s -> s
symBefore s
elem), s -> s -> SymbolR s
forall {s}. Ord s => s -> s -> SymbolR s
mk_range (s -> s
forall s. Symbol s => s -> s
symAfter s
elem) s
r]
                                        else [SymbolR s
ran]
-- =======================================================================================
-- ===== TRACING  and ERRORS  and MISC ===================================================
-- =======================================================================================
usererror :: [Char] -> a
usererror   [Char]
m = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"Your grammar contains a problem:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
m)
systemerror :: [Char] -> [Char] -> a
systemerror [Char]
modname [Char]
m
  = [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char]
"I apologise: I made a mistake in my design. This should not have happened.\n"
                       [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
           [Char]
" Please report: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
modname [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++[Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" to doaitse@cs.uu.nl\n")