{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}
module Documentation.Haddock.Parser.Monad where
import qualified Text.Parsec.Char as Parsec
import qualified Text.Parsec as Parsec
import Text.Parsec.Pos ( updatePosChar )
import Text.Parsec ( State(..)
, getParserState, setParserState )
import qualified Data.Text as T
import Data.Text ( Text )
import Control.Monad ( mfilter )
import Data.String ( IsString(..) )
import Data.Bits ( Bits(..) )
import Data.Char ( ord )
import Data.List ( foldl' )
import Control.Applicative as App
import Documentation.Haddock.Types ( Version )
import Prelude hiding (takeWhile)
import CompatPrelude
newtype ParserState = ParserState {
ParserState -> Maybe Version
parserStateSince :: Maybe Version
} deriving (ParserState -> ParserState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParserState -> ParserState -> Bool
$c/= :: ParserState -> ParserState -> Bool
== :: ParserState -> ParserState -> Bool
$c== :: ParserState -> ParserState -> Bool
Eq, Int -> ParserState -> ShowS
[ParserState] -> ShowS
ParserState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParserState] -> ShowS
$cshowList :: [ParserState] -> ShowS
show :: ParserState -> String
$cshow :: ParserState -> String
showsPrec :: Int -> ParserState -> ShowS
$cshowsPrec :: Int -> ParserState -> ShowS
Show)
initialParserState :: ParserState
initialParserState :: ParserState
initialParserState = Maybe Version -> ParserState
ParserState forall a. Maybe a
Nothing
setSince :: Version -> Parser ()
setSince :: Version -> Parser ()
setSince Version
since = forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
Parsec.modifyState (\ParserState
st -> ParserState
st{ parserStateSince :: Maybe Version
parserStateSince = forall a. a -> Maybe a
Just Version
since })
type Parser = Parsec.Parsec Text ParserState
instance (a ~ Text) => IsString (Parser a) where
fromString :: String -> Parser a
fromString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
Parsec.string
parseOnly :: Parser a -> Text -> Either String (ParserState, a)
parseOnly :: forall a. Parser a -> Text -> Either String (ParserState, a)
parseOnly Parser a
p Text
t = case forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
Parsec.runParser ParsecT Text ParserState Identity (a, ParserState)
p' ParserState
initialParserState String
"<haddock>" Text
t of
Left ParseError
e -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show ParseError
e)
Right (a
x,ParserState
s) -> forall a b. b -> Either a b
Right (ParserState
s,a
x)
where p' :: ParsecT Text ParserState Identity (a, ParserState)
p' = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
Parsec.getState
peekChar :: Parser (Maybe Char)
peekChar :: Parser (Maybe Char)
peekChar = Text -> Maybe Char
headOpt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s u. State s u -> s
stateInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
where headOpt :: Text -> Maybe Char
headOpt Text
t | Text -> Bool
T.null Text
t = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just (Text -> Char
T.head Text
t)
{-# INLINE peekChar #-}
peekChar' :: Parser Char
peekChar' :: Parser Char
peekChar' = forall {s} {u} {m :: * -> *}. Text -> ParsecT s u m Char
headFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s u. State s u -> s
stateInput forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
where headFail :: Text -> ParsecT s u m Char
headFail Text
t | Text -> Bool
T.null Text
t = forall s u (m :: * -> *) a. String -> ParsecT s u m a
Parsec.parserFail String
"peekChar': reached EOF"
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
App.pure (Text -> Char
T.head Text
t)
{-# INLINE peekChar' #-}
string :: Text -> Parser Text
string :: Text -> Parser Text
string Text
t = do
s :: State Text ParserState
s@State{ stateInput :: forall s u. State s u -> s
stateInput = Text
inp, statePos :: forall s u. State s u -> SourcePos
statePos = SourcePos
pos } <- forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
case Text -> Text -> Maybe Text
T.stripPrefix Text
t Text
inp of
Maybe Text
Nothing -> forall s u (m :: * -> *) a. String -> ParsecT s u m a
Parsec.parserFail String
"string: Failed to match the input string"
Just Text
inp' ->
let pos' :: SourcePos
pos' = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl SourcePos -> Char -> SourcePos
updatePosChar SourcePos
pos Text
t
s' :: State Text ParserState
s' = State Text ParserState
s{ stateInput :: Text
stateInput = Text
inp', statePos :: SourcePos
statePos = SourcePos
pos' }
in forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State Text ParserState
s' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
t
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile :: (Char -> Bool) -> Parser Text
takeWhile Char -> Bool
f = do
s :: State Text ParserState
s@State{ stateInput :: forall s u. State s u -> s
stateInput = Text
inp, statePos :: forall s u. State s u -> SourcePos
statePos = SourcePos
pos } <- forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
let (Text
t, Text
inp') = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
f Text
inp
pos' :: SourcePos
pos' = forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl SourcePos -> Char -> SourcePos
updatePosChar SourcePos
pos Text
t
s' :: State Text ParserState
s' = State Text ParserState
s{ stateInput :: Text
stateInput = Text
inp', statePos :: SourcePos
statePos = SourcePos
pos' }
forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State Text ParserState
s' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
t
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 :: (Char -> Bool) -> Parser Text
takeWhile1 = forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Parser Text
takeWhile
scan :: (s -> Char -> Maybe s)
-> s
-> Parser Text
scan :: forall s. (s -> Char -> Maybe s) -> s -> Parser Text
scan s -> Char -> Maybe s
f s
st = do
s :: State Text ParserState
s@State{ stateInput :: forall s u. State s u -> s
stateInput = Text
inp, statePos :: forall s u. State s u -> SourcePos
statePos = SourcePos
pos } <- forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
Text
-> s
-> SourcePos
-> Int
-> (Text -> SourcePos -> Int -> Parser Text)
-> Parser Text
go Text
inp s
st SourcePos
pos Int
0 forall a b. (a -> b) -> a -> b
$ \Text
inp' SourcePos
pos' Int
n ->
let s' :: State Text ParserState
s' = State Text ParserState
s{ stateInput :: Text
Parsec.stateInput = Text
inp', statePos :: SourcePos
Parsec.statePos = SourcePos
pos' }
in forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State Text ParserState
s' forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int -> Text -> Text
T.take Int
n Text
inp
where
go :: Text
-> s
-> SourcePos
-> Int
-> (Text -> SourcePos -> Int -> Parser Text)
-> Parser Text
go Text
inp s
s !SourcePos
pos !Int
n Text -> SourcePos -> Int -> Parser Text
cont
= case Text -> Maybe (Char, Text)
T.uncons Text
inp of
Maybe (Char, Text)
Nothing -> Text -> SourcePos -> Int -> Parser Text
cont Text
inp SourcePos
pos Int
n
Just (Char
c, Text
inp') ->
case s -> Char -> Maybe s
f s
s Char
c of
Maybe s
Nothing -> Text -> SourcePos -> Int -> Parser Text
cont Text
inp SourcePos
pos Int
n
Just s
s' -> Text
-> s
-> SourcePos
-> Int
-> (Text -> SourcePos -> Int -> Parser Text)
-> Parser Text
go Text
inp' s
s' (SourcePos -> Char -> SourcePos
updatePosChar SourcePos
pos Char
c) (Int
nforall a. Num a => a -> a -> a
+Int
1) Text -> SourcePos -> Int -> Parser Text
cont
decimal :: Integral a => Parser a
decimal :: forall a. Integral a => Parser a
decimal = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. Num a => a -> Char -> a
step a
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
Parsec.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.digit
where step :: a -> Char -> a
step a
a Char
c = a
a forall a. Num a => a -> a -> a
* a
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c forall a. Num a => a -> a -> a
- Int
48)
hexadecimal :: (Integral a, Bits a) => Parser a
hexadecimal :: forall a. (Integral a, Bits a) => Parser a
hexadecimal = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. (Bits a, Num a) => a -> Char -> a
step a
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
Parsec.many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
Parsec.hexDigit
where
step :: a -> Char -> a
step a
a Char
c | Int
w forall a. Ord a => a -> a -> Bool
>= Int
48 Bool -> Bool -> Bool
&& Int
w forall a. Ord a => a -> a -> Bool
<= Int
57 = (a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w forall a. Num a => a -> a -> a
- Int
48)
| Int
w forall a. Ord a => a -> a -> Bool
>= Int
97 = (a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w forall a. Num a => a -> a -> a
- Int
87)
| Bool
otherwise = (a
a forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
w forall a. Num a => a -> a -> a
- Int
55)
where w :: Int
w = Char -> Int
ord Char
c