import Text.ParserCombinators.Parsec
import Text.Parsec.Prim
import Text.ParserCombinators.Parsec.Error

segment :: String -> GenParser String () String
segment x = pToken (const x) (\y -> if x == y then Just x else Nothing)


anySegment :: GenParser String () String
anySegment = pToken (const "any string") Just

pToken msg f = do pos <- getPosition
                  token id (const $ incSourceLine pos 1) f
                  
p2u :: GenParser Char () a -> GenParser String () a
p2u p = 
  mkPT $ \state@(State sInput sPos sUser) -> 
  case sInput of
    (s:ss) ->
       do r <- runParsecT p (State s sPos sUser)
          return (fmap (fmap (fixReply ss)) r)

    where
      fixReply :: [String] -> (Reply String u a) -> (Reply [String] u a)
      fixReply _ (Error err) = (Error err)
      fixReply ss (Ok a (State "" sPos sUser) e) = (Ok a (State ss sPos sUser) e) 
      fixReply ss (Ok a (State s sPos sUser) e) = (Ok a (State (s:ss) sPos sUser) e)  
     
test :: IO ()
test = 
  let segments = ["foo", "hi", "there", "world"] in
  case parse testp (show segments) segments of
    (Left e) -> putStrLn $ showParseError e
    (Right r) -> print r
  
testp :: GenParser String () (Char, String, String)
testp =  
  do segment "foo"
     st <- p2u (char 'h' >> char 'o')
     sg <- anySegment
     sg' <- anySegment
     return (st,sg, sg')


showParseError :: ParseError -> String
showParseError pErr =
  let pos    = errorPos pErr
      posMsg = sourceName pos ++ " (segment " ++ show (sourceLine pos) ++ " character " ++ show (sourceColumn pos) ++ "): "
      msgs   = errorMessages pErr
  in posMsg ++ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" msgs