module Text.ParserCombinators.UU.BasicInstances where
import Text.ParserCombinators.UU.Core
import Data.List
data Error pos = Inserted String pos Strings
| Deleted String pos Strings
| DeletedAtEnd String
instance (Show pos) => Show (Error pos) where
show (Inserted s pos expecting) = "-- > Inserted " ++ s ++ " at position " ++ show pos ++ show_expecting expecting
show (Deleted t pos expecting) = "-- > Deleted " ++ t ++ " at position " ++ show pos ++ show_expecting expecting
show (DeletedAtEnd t) = "-- > The token " ++ t ++ " was not consumed by the parsing process."
show_errors = sequence_ . (map (putStrLn . show))
show_expecting [a] = " expecting " ++ a
show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]"
show_expecting [] = " expecting nothing"
data Str t = Str { input :: [t]
, msgs :: [Error Int ]
, pos :: !Int
, deleteOk :: !Bool}
listToStr ls = Str ls [] 0 True
instance (Show a) => Provides (Str a) (a -> Bool, String, a) a where
splitState (p, msg, a) k (Str tts msgs pos del_ok)
= let ins exp = (5, k a (Str tts (msgs ++ [Inserted (show a) pos exp]) pos False))
del exp = (5, splitState (p,msg, a)
k
(Str (tail tts) (msgs ++ [Deleted (show(head tts)) pos exp]) (pos+1) True ))
in case tts of
(t:ts) -> if p t
then Step 1 (k t (Str ts msgs (pos + 1) True))
else Fail [msg] (ins: if del_ok then [del] else [])
[] -> Fail [msg] [ins]
instance (Ord a, Show a) => Provides (Str a) (a,a) a where
splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low)
instance (Eq a, Show a) => Provides (Str a) a a where
splitState a = splitState ((==a), show a, a)
instance Show a => Eof (Str a) where
eof (Str i _ _ _ ) = null i
deleteAtEnd (Str (i:ii) msgs pos ok ) = Just (5, Str ii (msgs ++ [DeletedAtEnd (show i)]) pos ok)
deleteAtEnd _ = Nothing
instance Stores (Str a) (Error Int) where
getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok)
data Munch a = Munch (a -> Bool)
instance (Show a) => Provides (Str a) (Munch a) [a] where
splitState (Munch p) k (Str tts msgs pos del_ok)
= let (munched, rest) = span p tts
l = length munched
in Step l (k munched (Str rest msgs (pos+l) (l>0 || del_ok)))
pMunch :: (Text.ParserCombinators.UU.Core.Symbol p (Munch a) [a]) => (a -> Bool) -> p [a]
pMunch p = pSymExt Zero (Just []) (Munch p)
data Token a = Token [a] Int
instance (Show a, Eq a) => Provides (Str a) (Token a) [a] where
splitState tok@(Token as cost) k (Str tts msgs pos del_ok)
= let l = length as
msg = show as
in case stripPrefix as tts of
Nothing -> let ins exp = (cost, k as (Str tts (msgs ++ [Inserted msg pos exp]) pos False))
del exp = (5, splitState tok k (Str (tail tts) (msgs ++ [Deleted (show(head tts)) pos exp]) (pos+1) True ))
in if null tts then Fail [msg] [ins]
else Fail [msg] (ins: if del_ok then [del] else [])
Just rest -> Step l (k as (Str rest msgs (pos+l) True))
pToken as = pTokenCost as 5
pTokenCost as c = if null as then error "call to pToken with empty token"
else pSymExt (length as) Nothing (Token as c)
where length [] = Zero
length (_:as) = Succ (length as)