{-# LANGUAGE RankNTypes, GADTs, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances, NoMonomorphismRestriction, TypeSynonymInstances #-} -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%% Some Instances %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% module Text.ParserCombinators.UU.BasicInstances where import Text.ParserCombinators.UU.Core import Data.List import Debug.Trace 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 :: (Show a) => [a] -> IO () show_errors = sequence_ . (map (putStrLn . show)) show_expecting :: [String] -> String show_expecting [a] = " expecting " ++ a show_expecting (a:as) = " expecting one of [" ++ a ++ concat (map (", " ++) as) ++ "]" show_expecting [] = " expecting nothing" data Str t loc = Str { input :: [t] , msgs :: [Error loc ] , pos :: loc , deleteOk :: !Bool} listToStr :: [t] -> loc -> Str t loc listToStr ls initloc = Str ls [] initloc True type Parser a = P (Str Char (Int,Int)) a instance IsLocationUpdatedBy (Int,Int) Char where advance (line,pos) c = case c of '\n' -> (line+1, 0) '\t' -> (line , pos + 8 - (pos-1) `mod` 8) _ -> (line , pos + 1) instance IsLocationUpdatedBy (Int,Int) String where advance = foldl advance instance (Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) (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]) (advance pos (head tts)) True )) in case tts of (t:ts) -> 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 []) [] -> Fail [msg] [ins] instance (Ord a, Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) (a,a) a where splitState a@(low, high) = splitState (\ t -> low <= t && t <= high, show low ++ ".." ++ show high, low) instance (Eq a, Show a, loc `IsLocationUpdatedBy` a) => Provides (Str a loc) a a where splitState a = splitState ((==a), show a, a) instance Show a => Eof (Str a loc) 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 loc) (Error loc) where getErrors (Str inp msgs pos ok ) = (msgs, Str inp [] pos ok) instance HasPosition (Str a loc) loc where getPos (Str inp msgs pos ok ) = pos -- pMunch data Munch a = Munch (a -> Bool) String instance (Show a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (Munch a) [a] where splitState (Munch p x) k inp@(Str tts msgs pos del_ok) = let (munched, rest) = span p tts l = length munched in if l > 0 then show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") (Step l (k munched (Str rest msgs (advance pos munched) (l>0 || del_ok)))) else show_munch ("Accepting munch: " ++ x ++ " " ++ show munched ++ show pos ++ "\n") (k [] inp) pMunch :: (Provides st (Munch a) [a]) => (a -> Bool) -> P st [a] pMunch p = pSymExt Zero Nothing (Munch p "") -- the empty case is handled above pMunchL p l = pSymExt Zero Nothing (Munch p l) -- the empty case is handled above data Token a = Token [a] Int -- the Int value represents the cost for inserting such a token instance (Show a, Eq a, loc `IsLocationUpdatedBy` [a]) => Provides (Str a loc) (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]) (advance pos [(head tts)]) True )) in if null tts then Fail [msg] [ins] else Fail [msg] (ins: if del_ok then [del] else []) Just rest -> show_tokens ("Accepting token: " ++ show as ++"\n") (Step l (k as (Str rest msgs (advance pos as) True))) pToken :: (Provides state (Token a) token) => [a] -> P state token 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) show_tokens :: a -> b -> b show_tokens m v = {- trace m -} v show_munch :: a -> b -> b show_munch m v = {- trace m -} v show_symbol :: a -> b -> b show_symbol m v = {- trace m -} v