{-# 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 _ = 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 _ = 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 _ = 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 b = 5#
 symBefore  = error "You should have made your token type an instance of the Class Symbol. eg by defining symBefore = pred"
 symAfter   = error "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         {                                       rest :: Steps val s p}
             |            Cost       {costing::Int#                        , rest :: Steps val s p}
             |            StRepair   {costing::Int#  , 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 f (OkVal a rest) = OkVal (f.a) rest
val f (Ok      rest) = OkVal  f rest
val f (Cost i  rest) = Cost i (val f rest)
val f (StRepair c m r) = StRepair c m (val f r)
val f (Best l s     r) = Best (val f l) (val f s) (val f r)
val f (NoMoreSteps v)  = NoMoreSteps (f v)

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


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

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 (ESym     s)   = show s
 show (EStr   str)   = str
 show (EOr     [])   = "Nothing expected "
 show (EOr    [e])   = show e
 show (EOr  (e:ee))  = show e ++ " or " ++ show (EOr ee)
 show (ESeq  seq)    = concat (map show seq)

instance (Eq s, Show s, Show p) => Show (Message s p) where
 show (Msg expecting position action)
   =  "\n?? Error      : " ++ show position ++
      "\n?? Expecting  : " ++ show expecting ++
      "\n?? Repaired by: "  ++ show action ++"\n"

instance Show s => Show (Action s) where
  show (Insert s) = "inserting: " ++ show s
  show (Delete s) = "deleting: "  ++ show s
  show (Other s)  = s
data Expecting s = ESym (SymbolR s)
                 | EStr String
                 | EOr  [Expecting s]
                 | ESeq [Expecting s]
                 deriving (Ord, Eq)
-- =======================================================================================
-- ===== SYMBOLS and RANGES ==============================================================
-- =======================================================================================

data  SymbolR s  =  Range !s !s | EmptyR deriving (Eq,Ord)

instance (Eq s,Show s) => Show (SymbolR s) where
 show EmptyR      = "the empty range"
 show (Range a b) = if a == b then show a else show a ++ ".." ++ show b


mk_range             l    r =  if l > r then EmptyR else Range l r

symInRange (Range l r) = if l == r then (l==)
                                   else (\ s ->  s >= l && s <= r)

symRS (Range l r)
  = if l == r then (compare l)
    else (\ s -> if      s < l then GT
                 else if s > r then LT
                 else               EQ)

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