{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
module Documentation.Haddock.Parser.Identifier (
Identifier(..),
parseValid,
) where
import Documentation.Haddock.Types ( Namespace(..) )
import Documentation.Haddock.Parser.Monad
import qualified Text.Parsec as Parsec
import Text.Parsec.Pos ( updatePosChar )
import Text.Parsec ( State(..)
, getParserState, setParserState )
import Data.Text (Text)
import qualified Data.Text as T
import Data.Char (isAlpha, isAlphaNum)
import Control.Monad (guard)
import Data.Maybe
import CompatPrelude
data Identifier = Identifier !Namespace !Char String !Char
deriving (Int -> Identifier -> ShowS
[Identifier] -> ShowS
Identifier -> String
(Int -> Identifier -> ShowS)
-> (Identifier -> String)
-> ([Identifier] -> ShowS)
-> Show Identifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Identifier] -> ShowS
$cshowList :: [Identifier] -> ShowS
show :: Identifier -> String
$cshow :: Identifier -> String
showsPrec :: Int -> Identifier -> ShowS
$cshowsPrec :: Int -> Identifier -> ShowS
Show, Identifier -> Identifier -> Bool
(Identifier -> Identifier -> Bool)
-> (Identifier -> Identifier -> Bool) -> Eq Identifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Identifier -> Identifier -> Bool
$c/= :: Identifier -> Identifier -> Bool
== :: Identifier -> Identifier -> Bool
$c== :: Identifier -> Identifier -> Bool
Eq)
parseValid :: Parser Identifier
parseValid :: Parser Identifier
parseValid = 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 } <- ParsecT Text ParserState Identity (State Text ParserState)
forall (m :: * -> *) s u. Monad m => ParsecT s u m (State s u)
getParserState
case Text -> Maybe (Namespace, Char, Text, Char, Text)
takeIdentifier Text
inp of
Nothing -> String -> Parser Identifier
forall s u (m :: * -> *) a. String -> ParsecT s u m a
Parsec.parserFail "parseValid: Failed to match a valid identifier"
Just (ns :: Namespace
ns, op :: Char
op, ident :: Text
ident, cl :: Char
cl, inp' :: Text
inp') ->
let posOp :: SourcePos
posOp = SourcePos -> Char -> SourcePos
updatePosChar SourcePos
pos Char
op
posIdent :: SourcePos
posIdent = (SourcePos -> Char -> SourcePos) -> SourcePos -> Text -> SourcePos
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl SourcePos -> Char -> SourcePos
updatePosChar SourcePos
posOp Text
ident
posCl :: SourcePos
posCl = SourcePos -> Char -> SourcePos
updatePosChar SourcePos
posIdent Char
cl
s' :: State Text ParserState
s' = State Text ParserState
s{ stateInput :: Text
stateInput = Text
inp', statePos :: SourcePos
statePos = SourcePos
posCl }
in State Text ParserState
-> ParsecT Text ParserState Identity (State Text ParserState)
forall (m :: * -> *) s u.
Monad m =>
State s u -> ParsecT s u m (State s u)
setParserState State Text ParserState
s' ParsecT Text ParserState Identity (State Text ParserState)
-> Identifier -> Parser Identifier
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Namespace -> Char -> String -> Char -> Identifier
Identifier Namespace
ns Char
op (Text -> String
T.unpack Text
ident) Char
cl
takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text)
takeIdentifier :: Text -> Maybe (Namespace, Char, Text, Char, Text)
takeIdentifier input :: Text
input = [(Namespace, Char, Text, Char, Text)]
-> Maybe (Namespace, Char, Text, Char, Text)
forall a. [a] -> Maybe a
listToMaybe ([(Namespace, Char, Text, Char, Text)]
-> Maybe (Namespace, Char, Text, Char, Text))
-> [(Namespace, Char, Text, Char, Text)]
-> Maybe (Namespace, Char, Text, Char, Text)
forall a b. (a -> b) -> a -> b
$ do
let (ns :: Namespace
ns, input' :: Text
input') = case Text -> Maybe (Char, Text)
T.uncons Text
input of
Just ('v', i :: Text
i) -> (Namespace
Value, Text
i)
Just ('t', i :: Text
i) -> (Namespace
Type, Text
i)
_ -> (Namespace
None, Text
input)
(op :: Char
op, input'' :: Text
input'') <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
input')
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
op Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
op Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '`')
(ident :: Text
ident, input''' :: Text
input''') <- Text -> [(Text, Text)]
wrapped Text
input''
(cl :: Char
cl, input'''' :: Text
input'''') <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
input''')
Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Char
cl Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' Bool -> Bool -> Bool
|| Char
cl Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '`')
(Namespace, Char, Text, Char, Text)
-> [(Namespace, Char, Text, Char, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Namespace
ns, Char
op, Text
ident, Char
cl, Text
input'''')
where
wrapped :: Text -> [(Text, Text)]
wrapped t :: Text
t = do
(c :: Char
c, t' :: Text
t' ) <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
t)
case Char
c of
'(' | Just (c' :: Char
c', _) <- Text -> Maybe (Char, Text)
T.uncons Text
t'
, Char
c' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',' Bool -> Bool -> Bool
|| Char
c' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')'
-> do let (commas :: Text
commas, t'' :: Text
t'') = (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ',') Text
t'
(')', t''' :: Text
t''') <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
t'')
(Text, Text) -> [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Text -> Text
T.take (Text -> Int
T.length Text
commas Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Text
t, Text
t''')
'(' -> do (n :: Int
n, t'' :: Text
t'' ) <- Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general Bool
False 0 [] Text
t'
(')', t''' :: Text
t''') <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
t'')
(Text, Text) -> [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Text
t, Text
t''')
'`' -> do (n :: Int
n, t'' :: Text
t'' ) <- Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general Bool
False 0 [] Text
t'
('`', t''' :: Text
t''') <- Maybe (Char, Text) -> [(Char, Text)]
forall a. Maybe a -> [a]
maybeToList (Text -> Maybe (Char, Text)
T.uncons Text
t'')
(Text, Text) -> [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Text
t, Text
t''')
_ -> do (n :: Int
n, t'' :: Text
t'' ) <- Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general Bool
False 0 [] Text
t
(Text, Text) -> [(Text, Text)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Text -> Text
T.take Int
n Text
t, Text
t'')
general :: Bool
-> Int
-> [(Int, Text)]
-> Text
-> [(Int, Text)]
general :: Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general !Bool
identOnly !Int
i acc :: [(Int, Text)]
acc t :: Text
t
| Just (n :: Int
n, rest :: Text
rest) <- Text -> Maybe (Int, Text)
identLike Text
t
= if Text -> Bool
T.null Text
rest
then [(Int, Text)]
acc
else case Text -> Char
T.head Text
rest of
'`' -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, Text
rest) (Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
: [(Int, Text)]
acc
')' -> (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, Text
rest) (Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
: [(Int, Text)]
acc
'.' -> Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general Bool
False (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [(Int, Text)]
acc (Text -> Text
T.tail Text
rest)
'\'' -> let (m :: Int
m, rest' :: Text
rest') = Text -> (Int, Text)
quotes Text
rest
in Bool -> Int -> [(Int, Text)] -> Text -> [(Int, Text)]
general Bool
True (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, Text
rest') (Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
: [(Int, Text)]
acc) (Text -> Text
T.tail Text
rest')
_ -> [(Int, Text)]
acc
| Just (n :: Int
n, rest :: Text
rest) <- Text -> Maybe (Int, Text)
optr Text
t
, Bool -> Bool
not Bool
identOnly
= (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i, Text
rest) (Int, Text) -> [(Int, Text)] -> [(Int, Text)]
forall a. a -> [a] -> [a]
: [(Int, Text)]
acc
| Bool
otherwise
= [(Int, Text)]
acc
identLike :: Text -> Maybe (Int, Text)
identLike t :: Text
t
| Text -> Bool
T.null Text
t = Maybe (Int, Text)
forall a. Maybe a
Nothing
| Char -> Bool
isAlpha (Text -> Char
T.head Text
t) Bool -> Bool -> Bool
|| '_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Char
T.head Text
t
= let !(idt :: Text
idt, rest :: Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\c :: Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_') Text
t
!(octos :: Text
octos, rest' :: Text
rest') = (Char -> Bool) -> Text -> (Text, Text)
T.span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#') Text
rest
in (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
Just (Text -> Int
T.length Text
idt Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
octos, Text
rest')
| Bool
otherwise = Maybe (Int, Text)
forall a. Maybe a
Nothing
quotes :: Text -> (Int, Text)
quotes :: Text -> (Int, Text)
quotes t :: Text
t = let !n :: Int
n = Text -> Int
T.length ((Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'') Text
t) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
in (Int
n, Int -> Text -> Text
T.drop Int
n Text
t)
optr :: Text -> Maybe (Int, Text)
optr t :: Text
t = let !(op :: Text
op, rest :: Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isSymbolChar Text
t
in if Text -> Bool
T.null Text
op then Maybe (Int, Text)
forall a. Maybe a
Nothing else (Int, Text) -> Maybe (Int, Text)
forall a. a -> Maybe a
Just (Text -> Int
T.length Text
op, Text
rest)