{-# LANGUAGE  RankNTypes, 
              GADTs,
              MultiParamTypeClasses,
              FunctionalDependencies, 
              FlexibleInstances, 
              FlexibleContexts, 
              UndecidableInstances,
              NoMonomorphismRestriction,
              TypeSynonymInstances,
              ScopedTypeVariables #-}

-- | This module caontains basic instances for the class interface described in the "Text.ParserCombinators.UU.Core" module.
--   It demonstates how to use construct and maintain a state during parsing. In the state we store error messages, 
--   positional information and the actual input that is being parsed.
--   Unless you have very specific wishes the module can be used as such. 
--   Since we make use of the "Data.ListLike" interface a wide variety of input structures can be handled.
--
--   The main part of this module is made up from the various instances for the class `Provides`

module Text.ParserCombinators.UU.BasicInstances(
-- * Data Types
   Error      (..),
   Str        (..),
   Insertion  (..),
   LineCol    (..),
   LineColPos (..),
-- * Types
   Parser,
   ParserTrafo,
-- * Classes
   IsLocationUpdatedBy,
-- * Functions
   createStr,
   show_expecting,
   pSatisfy,
   pRangeInsert,
   pRange,
   pSymInsert,
   pSym,
   pToken,
   pTokenCost,
   pMunch
) where
import Text.ParserCombinators.UU.Core
import Data.Maybe
import Data.Word
import Debug.Trace
import qualified Data.ListLike as LL

-- *  `Error`
-- |The data type `Error` describes the various kinds of errors which can be generated by the instances in this module
data Error  pos =    Inserted String pos        Strings  
                     -- ^  @String@ was inserted at @pos@-ition, where we expected  @Strings@
                   | Deleted  String pos        Strings
                     -- ^  @String@ was deleted at @pos@-ition, where we expected  @Strings@
                   | Replaced String String pos Strings
                     -- ^ for future use
                   | DeletedAtEnd String
                     -- ^ the unconsumed part of the input was deleted

instance (Show pos) => Show (Error  pos) where 
 show (Inserted s pos expecting)       = "--    Inserted  " ++  s ++  show_expecting  pos expecting 
 show (Deleted  t pos expecting)       = "--    Deleted   " ++  t ++  show_expecting  pos expecting
 show (Replaced old new pos expecting) = "--    Replaced  " ++ old ++ " by "++ new ++  show_expecting  pos expecting
 show (DeletedAtEnd t)                 = "--    The token " ++ t ++ " was not consumed by the parsing process."



show_expecting :: Show pos => pos -> [String] -> String
show_expecting pos [a]    = " at position " ++ show pos ++ " expecting " ++ a
show_expecting pos (a:as) = " at position " ++ show pos ++ 
                            " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"
show_expecting pos []     = " expecting nothing"

-- * The Stream data type
-- | The data type `Str` holds the input data to be parsed, the current location, the error messages generated 
--   and whether it is ok to delet elements from the input. Since an insert/delete action is 
--   the same as a delete/insert action we try to avoid the first one. 
--   So: no deletes after an insert.

data Str a s loc = Str { -- | the unconsumed part of the input
                         input    :: s,             
                         -- | the accumulated error messages
                         msgs     :: [Error loc],
                         -- | the current input position  
                         pos      :: loc,           
                         -- | we want to avoid deletions after insertions
                         deleteOk :: !Bool         
                       }

-- | A`Parser` is a parser that is prepared to accept "Data.Listlike" input; hence we can deal with @String@'s, @ByteString@'s, etc.
type Parser      a    = (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a

-- | A @`ParserTrafo` a b@ maps a @`Parser` a@ onto a @`Parser` b@.
type ParserTrafo a  b = (IsLocationUpdatedBy loc Char, LL.ListLike state Char) => P (Str Char state loc) a ->  P (Str Char state loc) b

-- |  `createStr` initialises the input stream with the input data and the initial position. There are no error messages yet.
createStr :: LL.ListLike s a => loc -> s -> Str a s loc
createStr beginpos ls = Str ls [] beginpos True


-- | The first parameter is the current position, and the second parameter the part which has been removed from the input.
instance IsLocationUpdatedBy Int Char where
   advance pos _ = pos + 1
   
instance IsLocationUpdatedBy Int Word8 where
   advance pos _ = pos + 1
   
data LineCol = LineCol !Int !Int deriving Show
instance IsLocationUpdatedBy LineCol Char where
   advance (LineCol line pos) c = case c of
                                 '\n' ->  LineCol (line+1) 0
                                 '\t' ->  LineCol line    ( pos + 8 - (pos-1) `mod` 8)
                                 _    ->  LineCol line    (pos + 1)

data LineColPos = LineColPos !Int !Int !Int  deriving Show
instance IsLocationUpdatedBy LineColPos Char where
   advance (LineColPos line pos abs) c = case c of
                               '\n' ->  LineColPos (line+1) 0                           (abs + 1) 
                               '\t' ->  LineColPos line     (pos + 8 - (pos-1) `mod` 8) (abs + 1)
                               _    ->  LineColPos line     (pos + 1)                   (abs + 1)

instance IsLocationUpdatedBy loc a => IsLocationUpdatedBy loc [a] where
   advance  = foldl advance 

instance (Show a, LL.ListLike s a) => Eof (Str a s loc) where
       eof (Str  i        _    _    _    )              = LL.null i
       deleteAtEnd (Str s msgs pos ok )     | LL.null s = Nothing
                                            | otherwise = Just (5, Str (LL.tail s) (msgs ++ [DeletedAtEnd (show (LL.head s))]) pos ok)


instance  StoresErrors (Str a s loc) (Error loc) where
       getErrors   (Str  inp      msgs pos ok    )     = (msgs, Str inp [] pos ok)

instance  HasPosition (Str a s loc) loc where
       getPos   (Str  inp      msgs pos ok    )        = pos

data Insertion a = Insertion  String a Cost
pSatisfy :: forall loc state a .((Show a,  loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> (Insertion a) -> P (Str  a state loc) a)
pSatisfy p  (Insertion msg  a cost) = pSymExt splitState (Succ (Zero Infinite)) Nothing
  where  splitState :: forall r. ((a ->  (Str  a state loc)  -> Steps r) ->  (Str  a state loc) -> Steps r)
         splitState  k (Str  tts   msgs pos  del_ok) 
          = show_attempt ("Try Predicate: " ++ msg ++ "\n") (
             let ins exp = (cost, k a (Str tts (msgs ++ [Inserted (show a)  pos  exp]) pos  False))
             in if   LL.null tts 
                then Fail [msg] [ins]
                else let t       = LL.head tts
                         ts      = LL.tail tts
                         del exp = (5, splitState k (Str ts (msgs ++ [Deleted  (show t)  pos  exp]) (advance pos t) True ))
                     in if p t
                        then  show_symbol ("Accepting symbol: " ++ show t ++ " at position: " ++ show pos ++"\n") 
                              (Step 1 (k t (Str ts msgs (advance pos t) True)))
                        else  Fail [msg] (ins: if del_ok then [del] else [])
            )
pRangeInsert :: (Ord a, Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => (a, a) -> Insertion a -> P (Str a state loc) a
pRangeInsert (low, high)  = pSatisfy (\ t -> low <= t && t <= high)  

pRange lh@(low, high) = pRangeInsert lh (Insertion (show low ++ ".." ++ show high) low 5)


pSymInsert  :: (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a -> Insertion a -> P (Str a state loc) a
pSymInsert  t  = pSatisfy (==t) 

pSym ::   (Eq a,Show a, IsLocationUpdatedBy loc a, LL.ListLike state a) => a ->  P (Str a state loc) a    
pSym  t = pSymInsert t (Insertion (show t) t 5)

pMunchL :: forall loc state a .((Show a,  loc `IsLocationUpdatedBy` a, LL.ListLike state a) => (a -> Bool) -> String -> P (Str  a state loc) [a])
pMunchL p msg = pSymExt splitState (Succ (Zero Infinite)) Nothing
  where  splitState :: forall r. (([a] ->  (Str  a state loc)  -> Steps r) ->  (Str  a state loc) -> Steps r)
         splitState k inp@(Str tts msgs pos del_ok)
          =    show_attempt ("Try Munch: " ++ msg ++ "\n") (
               let (fmunch, rest)  = LL.span p tts
                   munched         = LL.toList fmunch
                   l               = length munched
               in if l > 0 then show_munch ("Accepting munch: " ++ msg ++ " " ++ show munched ++  show pos ++ "\n") 
                                (Step l (k munched (Str rest msgs (advance pos munched)  (l>0 || del_ok))))
                           else show_munch ("Accepting munch: " ++ msg ++ " as emtty munch " ++ show pos ++ "\n") (k [] inp)
               )

pMunch  p   = pMunchL p ""

pTokenCost :: forall loc state a .((Show a, Eq a,  loc `IsLocationUpdatedBy` a, LL.ListLike state a) => [a] -> Int -> P (Str  a state loc) [a])
pTokenCost as cost = 
  if null as then error "Module: BasicInstances, function: pTokenCost; call  with empty token"
             else pSymExt splitState (nat_length as) Nothing
  where   tas :: state 
          tas = LL.fromList as
          nat_length [] = Zero Infinite
          nat_length (_:as) = Succ (nat_length as)
          l = length as
          msg = show as 
          splitState :: forall r. (([a] ->  (Str  a state loc)  -> Steps r) ->  (Str  a state loc) -> Steps r)
          splitState k inp@(Str tts msgs pos del_ok)
             = show_attempt ("Try Token: " ++ show as ++ "\n") (
                      if LL.isPrefixOf tas tts
                      then  show_tokens ("Accepting token: " ++ show as ++"\n") 
                                      (Step l (k as (Str (LL.drop l tts)  msgs (advance pos as) True)))
                      else  let ins exp =  (cost, k as (Str tts (msgs ++ [Inserted msg pos exp]) pos False))
                            in if LL.null tts 
                               then  Fail [msg] [ins]
                               else  let t       = LL.head tts
                                         ts      = LL.tail tts
                                         del exp =  (5, splitState  k 
                                                            (Str ts (msgs ++ [Deleted  (show t) pos exp]) 
                                                            (advance pos t) True))
                                     in  Fail [msg] (ins: if del_ok then [del] else [])
                      
                     )
pToken     as   =   pTokenCost as 5

{-# INLINE show_tokens #-}

show_tokens :: String -> b -> b
show_tokens m v =   {- trace m -}  v

{-# INLINE show_munch #-}
show_munch :: String -> b -> b
show_munch  m v =   {- trace m -}  v

{-# INLINE show_symbol #-}
show_symbol :: String -> b -> b
show_symbol m v =  {-  trace m -}  v

{-# INLINE show_attempt #-}
show_attempt m v = {- trace m -} v