{-# LANGUAGE RankNTypes #-}
module Text.MMark.Parser.Internal
(
BParser,
runBParser,
isNakedAllowed,
refLevel,
subEnv,
registerReference,
IParser,
runIParser,
disallowEmpty,
isEmptyAllowed,
disallowLinks,
isLinksAllowed,
disallowImages,
isImagesAllowed,
getLastChar,
lastChar,
lookupReference,
Isp (..),
CharType (..),
Defs,
MMarkErr (..),
)
where
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.Function ((&))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import qualified Data.List.NonEmpty as NE
import Data.Ratio ((%))
import Data.Text (Text)
import Data.Text.Metrics (damerauLevenshteinNorm)
import Lens.Micro (Lens', over, set, (.~), (^.))
import Lens.Micro.Extras (view)
import Text.MMark.Parser.Internal.Type
import Text.Megaparsec hiding (State)
import qualified Text.Megaparsec as M
import Text.URI (URI)
type BParser a = ParsecT MMarkErr Text (State BlockState) a
runBParser ::
BParser a ->
FilePath ->
Text ->
Either (ParseErrorBundle Text MMarkErr) (a, Defs)
runBParser :: BParser a
-> FilePath
-> Text
-> Either (ParseErrorBundle Text MMarkErr) (a, Defs)
runBParser BParser a
p FilePath
file Text
input =
case State BlockState (Either (ParseErrorBundle Text MMarkErr) a)
-> BlockState
-> (Either (ParseErrorBundle Text MMarkErr) a, BlockState)
forall s a. State s a -> s -> (a, s)
runState ((State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
-> Either (ParseErrorBundle Text MMarkErr) a
forall a b. (a, b) -> b
snd ((State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
-> Either (ParseErrorBundle Text MMarkErr) a)
-> State
BlockState
(State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
-> State BlockState (Either (ParseErrorBundle Text MMarkErr) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BParser a
-> State Text MMarkErr
-> State
BlockState
(State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> State s e -> m (State s e, Either (ParseErrorBundle s e) a)
runParserT' BParser a
p State Text MMarkErr
forall e. State Text e
st) BlockState
initialBlockState of
(Left ParseErrorBundle Text MMarkErr
bundle, BlockState
_) -> ParseErrorBundle Text MMarkErr
-> Either (ParseErrorBundle Text MMarkErr) (a, Defs)
forall a b. a -> Either a b
Left ParseErrorBundle Text MMarkErr
bundle
(Right a
x, BlockState
st') -> (a, Defs) -> Either (ParseErrorBundle Text MMarkErr) (a, Defs)
forall a b. b -> Either a b
Right (a
x, BlockState
st' BlockState -> Getting Defs BlockState Defs -> Defs
forall s a. s -> Getting a s a -> a
^. Getting Defs BlockState Defs
Lens' BlockState Defs
bstDefs)
where
st :: State Text e
st = FilePath -> Text -> Int -> State Text e
forall e. FilePath -> Text -> Int -> State Text e
mkInitialState FilePath
file Text
input Int
0
isNakedAllowed :: BParser Bool
isNakedAllowed :: BParser Bool
isNakedAllowed = (BlockState -> Bool) -> BParser Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlockState -> Getting Bool BlockState Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool BlockState Bool
Lens' BlockState Bool
bstAllowNaked)
refLevel :: BParser Pos
refLevel :: BParser Pos
refLevel = (BlockState -> Pos) -> BParser Pos
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlockState -> Getting Pos BlockState Pos -> Pos
forall s a. s -> Getting a s a -> a
^. Getting Pos BlockState Pos
Lens' BlockState Pos
bstRefLevel)
subEnv ::
Bool ->
Pos ->
BParser a ->
BParser a
subEnv :: Bool -> Pos -> BParser a -> BParser a
subEnv Bool
allowNaked Pos
rlevel =
Lens' BlockState Bool -> Bool -> BParser a -> BParser a
forall s (m :: * -> *) a b.
MonadState s m =>
Lens' s a -> a -> m b -> m b
locally Lens' BlockState Bool
bstAllowNaked Bool
allowNaked
(BParser a -> BParser a)
-> (BParser a -> BParser a) -> BParser a -> BParser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' BlockState Pos -> Pos -> BParser a -> BParser a
forall s (m :: * -> *) a b.
MonadState s m =>
Lens' s a -> a -> m b -> m b
locally Lens' BlockState Pos
bstRefLevel Pos
rlevel
registerReference ::
Text ->
(URI, Maybe Text) ->
BParser Bool
registerReference :: Text -> (URI, Maybe Text) -> BParser Bool
registerReference = Lens' Defs (HashMap DefLabel (URI, Maybe Text))
-> Text -> (URI, Maybe Text) -> BParser Bool
forall a.
Lens' Defs (HashMap DefLabel a) -> Text -> a -> BParser Bool
registerGeneric Lens' Defs (HashMap DefLabel (URI, Maybe Text))
referenceDefs
registerGeneric ::
Lens' Defs (HashMap DefLabel a) ->
Text ->
a ->
BParser Bool
registerGeneric :: Lens' Defs (HashMap DefLabel a) -> Text -> a -> BParser Bool
registerGeneric Lens' Defs (HashMap DefLabel a)
l Text
name a
a = do
let dlabel :: DefLabel
dlabel = Text -> DefLabel
mkDefLabel Text
name
HashMap DefLabel a
defs <- (BlockState -> HashMap DefLabel a)
-> ParsecT MMarkErr Text (State BlockState) (HashMap DefLabel a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (BlockState
-> Getting (HashMap DefLabel a) BlockState (HashMap DefLabel a)
-> HashMap DefLabel a
forall s a. s -> Getting a s a -> a
^. (Defs -> Const (HashMap DefLabel a) Defs)
-> BlockState -> Const (HashMap DefLabel a) BlockState
Lens' BlockState Defs
bstDefs ((Defs -> Const (HashMap DefLabel a) Defs)
-> BlockState -> Const (HashMap DefLabel a) BlockState)
-> ((HashMap DefLabel a
-> Const (HashMap DefLabel a) (HashMap DefLabel a))
-> Defs -> Const (HashMap DefLabel a) Defs)
-> Getting (HashMap DefLabel a) BlockState (HashMap DefLabel a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap DefLabel a
-> Const (HashMap DefLabel a) (HashMap DefLabel a))
-> Defs -> Const (HashMap DefLabel a) Defs
Lens' Defs (HashMap DefLabel a)
l)
if DefLabel -> HashMap DefLabel a -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HM.member DefLabel
dlabel HashMap DefLabel a
defs
then Bool -> BParser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
(BlockState -> BlockState)
-> ParsecT MMarkErr Text (State BlockState) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((BlockState -> BlockState)
-> ParsecT MMarkErr Text (State BlockState) ())
-> (BlockState -> BlockState)
-> ParsecT MMarkErr Text (State BlockState) ()
forall a b. (a -> b) -> a -> b
$ ASetter
BlockState BlockState (HashMap DefLabel a) (HashMap DefLabel a)
-> (HashMap DefLabel a -> HashMap DefLabel a)
-> BlockState
-> BlockState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Defs -> Identity Defs) -> BlockState -> Identity BlockState
Lens' BlockState Defs
bstDefs ((Defs -> Identity Defs) -> BlockState -> Identity BlockState)
-> ((HashMap DefLabel a -> Identity (HashMap DefLabel a))
-> Defs -> Identity Defs)
-> ASetter
BlockState BlockState (HashMap DefLabel a) (HashMap DefLabel a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap DefLabel a -> Identity (HashMap DefLabel a))
-> Defs -> Identity Defs
Lens' Defs (HashMap DefLabel a)
l) (DefLabel -> a -> HashMap DefLabel a -> HashMap DefLabel a
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert DefLabel
dlabel a
a)
Bool -> BParser Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
type IParser a = StateT InlineState (Parsec MMarkErr Text) a
runIParser ::
Defs ->
IParser a ->
Isp ->
Either (ParseError Text MMarkErr) a
runIParser :: Defs -> IParser a -> Isp -> Either (ParseError Text MMarkErr) a
runIParser Defs
_ IParser a
_ (IspError ParseError Text MMarkErr
err) = ParseError Text MMarkErr -> Either (ParseError Text MMarkErr) a
forall a b. a -> Either a b
Left ParseError Text MMarkErr
err
runIParser Defs
defs IParser a
p (IspSpan Int
offset Text
input) =
(ParseErrorBundle Text MMarkErr -> ParseError Text MMarkErr)
-> Either (ParseErrorBundle Text MMarkErr) a
-> Either (ParseError Text MMarkErr) a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (NonEmpty (ParseError Text MMarkErr) -> ParseError Text MMarkErr
forall a. NonEmpty a -> a
NE.head (NonEmpty (ParseError Text MMarkErr) -> ParseError Text MMarkErr)
-> (ParseErrorBundle Text MMarkErr
-> NonEmpty (ParseError Text MMarkErr))
-> ParseErrorBundle Text MMarkErr
-> ParseError Text MMarkErr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text MMarkErr
-> NonEmpty (ParseError Text MMarkErr)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors) ((State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
-> Either (ParseErrorBundle Text MMarkErr) a
forall a b. (a, b) -> b
snd (Parsec MMarkErr Text a
-> State Text MMarkErr
-> (State Text MMarkErr, Either (ParseErrorBundle Text MMarkErr) a)
forall e s a.
Parsec e s a
-> State s e -> (State s e, Either (ParseErrorBundle s e) a)
runParser' (IParser a -> InlineState -> Parsec MMarkErr Text a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT IParser a
p InlineState
ist) State Text MMarkErr
forall e. State Text e
pst))
where
ist :: InlineState
ist = InlineState
initialInlineState InlineState -> (InlineState -> InlineState) -> InlineState
forall a b. a -> (a -> b) -> b
& (Defs -> Identity Defs) -> InlineState -> Identity InlineState
Lens' InlineState Defs
istDefs ((Defs -> Identity Defs) -> InlineState -> Identity InlineState)
-> Defs -> InlineState -> InlineState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Defs
defs
pst :: State Text e
pst = FilePath -> Text -> Int -> State Text e
forall e. FilePath -> Text -> Int -> State Text e
mkInitialState FilePath
"" Text
input Int
offset
disallowEmpty :: IParser a -> IParser a
disallowEmpty :: IParser a -> IParser a
disallowEmpty = Lens' InlineState Bool -> Bool -> IParser a -> IParser a
forall s (m :: * -> *) a b.
MonadState s m =>
Lens' s a -> a -> m b -> m b
locally Lens' InlineState Bool
istAllowEmpty Bool
False
isEmptyAllowed :: IParser Bool
isEmptyAllowed :: IParser Bool
isEmptyAllowed = (InlineState -> Bool) -> IParser Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting Bool InlineState Bool -> InlineState -> Bool
forall a s. Getting a s a -> s -> a
view Getting Bool InlineState Bool
Lens' InlineState Bool
istAllowEmpty)
disallowLinks :: IParser a -> IParser a
disallowLinks :: IParser a -> IParser a
disallowLinks = Lens' InlineState Bool -> Bool -> IParser a -> IParser a
forall s (m :: * -> *) a b.
MonadState s m =>
Lens' s a -> a -> m b -> m b
locally Lens' InlineState Bool
istAllowLinks Bool
False
isLinksAllowed :: IParser Bool
isLinksAllowed :: IParser Bool
isLinksAllowed = (InlineState -> Bool) -> IParser Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting Bool InlineState Bool -> InlineState -> Bool
forall a s. Getting a s a -> s -> a
view Getting Bool InlineState Bool
Lens' InlineState Bool
istAllowLinks)
disallowImages :: IParser a -> IParser a
disallowImages :: IParser a -> IParser a
disallowImages = Lens' InlineState Bool -> Bool -> IParser a -> IParser a
forall s (m :: * -> *) a b.
MonadState s m =>
Lens' s a -> a -> m b -> m b
locally Lens' InlineState Bool
istAllowImages Bool
False
isImagesAllowed :: IParser Bool
isImagesAllowed :: IParser Bool
isImagesAllowed = (InlineState -> Bool) -> IParser Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting Bool InlineState Bool -> InlineState -> Bool
forall a s. Getting a s a -> s -> a
view Getting Bool InlineState Bool
Lens' InlineState Bool
istAllowImages)
getLastChar :: IParser CharType
getLastChar :: IParser CharType
getLastChar = (InlineState -> CharType) -> IParser CharType
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting CharType InlineState CharType -> InlineState -> CharType
forall a s. Getting a s a -> s -> a
view Getting CharType InlineState CharType
Lens' InlineState CharType
istLastChar)
lastChar :: CharType -> IParser ()
lastChar :: CharType -> IParser ()
lastChar = (InlineState -> InlineState) -> IParser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((InlineState -> InlineState) -> IParser ())
-> (CharType -> InlineState -> InlineState)
-> CharType
-> IParser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter InlineState InlineState CharType CharType
-> CharType -> InlineState -> InlineState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter InlineState InlineState CharType CharType
Lens' InlineState CharType
istLastChar
{-# INLINE lastChar #-}
lookupReference ::
Text ->
IParser (Either [Text] (URI, Maybe Text))
lookupReference :: Text -> IParser (Either [Text] (URI, Maybe Text))
lookupReference = Lens' Defs (HashMap DefLabel (URI, Maybe Text))
-> Text -> IParser (Either [Text] (URI, Maybe Text))
forall a.
Lens' Defs (HashMap DefLabel a)
-> Text -> IParser (Either [Text] a)
lookupGeneric Lens' Defs (HashMap DefLabel (URI, Maybe Text))
referenceDefs
lookupGeneric ::
Lens' Defs (HashMap DefLabel a) ->
Text ->
IParser (Either [Text] a)
lookupGeneric :: Lens' Defs (HashMap DefLabel a)
-> Text -> IParser (Either [Text] a)
lookupGeneric Lens' Defs (HashMap DefLabel a)
l Text
name = do
let dlabel :: DefLabel
dlabel = Text -> DefLabel
mkDefLabel Text
name
HashMap DefLabel a
defs <- (InlineState -> HashMap DefLabel a)
-> StateT InlineState (Parsec MMarkErr Text) (HashMap DefLabel a)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Getting (HashMap DefLabel a) InlineState (HashMap DefLabel a)
-> InlineState -> HashMap DefLabel a
forall a s. Getting a s a -> s -> a
view ((Defs -> Const (HashMap DefLabel a) Defs)
-> InlineState -> Const (HashMap DefLabel a) InlineState
Lens' InlineState Defs
istDefs ((Defs -> Const (HashMap DefLabel a) Defs)
-> InlineState -> Const (HashMap DefLabel a) InlineState)
-> ((HashMap DefLabel a
-> Const (HashMap DefLabel a) (HashMap DefLabel a))
-> Defs -> Const (HashMap DefLabel a) Defs)
-> Getting (HashMap DefLabel a) InlineState (HashMap DefLabel a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap DefLabel a
-> Const (HashMap DefLabel a) (HashMap DefLabel a))
-> Defs -> Const (HashMap DefLabel a) Defs
Lens' Defs (HashMap DefLabel a)
l))
case DefLabel -> HashMap DefLabel a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup DefLabel
dlabel HashMap DefLabel a
defs of
Maybe a
Nothing -> Either [Text] a -> IParser (Either [Text] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Text] a -> IParser (Either [Text] a))
-> ([Text] -> Either [Text] a)
-> [Text]
-> IParser (Either [Text] a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Either [Text] a
forall a b. a -> Either a b
Left ([Text] -> IParser (Either [Text] a))
-> [Text] -> IParser (Either [Text] a)
forall a b. (a -> b) -> a -> b
$ DefLabel -> [DefLabel] -> [Text]
closeNames DefLabel
dlabel (HashMap DefLabel a -> [DefLabel]
forall k v. HashMap k v -> [k]
HM.keys HashMap DefLabel a
defs)
Just a
x -> Either [Text] a -> IParser (Either [Text] a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either [Text] a
forall a b. b -> Either a b
Right a
x)
closeNames :: DefLabel -> [DefLabel] -> [Text]
closeNames :: DefLabel -> [DefLabel] -> [Text]
closeNames DefLabel
r' =
(Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
x -> Text -> Text -> Ratio Int
damerauLevenshteinNorm Text
r Text
x Ratio Int -> Ratio Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
2 Int -> Int -> Ratio Int
forall a. Integral a => a -> a -> Ratio a
% Int
3))
([Text] -> [Text])
-> ([DefLabel] -> [Text]) -> [DefLabel] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DefLabel -> Text) -> [DefLabel] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map DefLabel -> Text
unDefLabel
where
r :: Text
r = DefLabel -> Text
unDefLabel DefLabel
r'
mkInitialState ::
FilePath ->
Text ->
Int ->
M.State Text e
mkInitialState :: FilePath -> Text -> Int -> State Text e
mkInitialState FilePath
file Text
input Int
offset =
State :: forall s e. s -> Int -> PosState s -> [ParseError s e] -> State s e
M.State
{ stateInput :: Text
stateInput = Text
input,
stateOffset :: Int
stateOffset = Int
offset,
statePosState :: PosState Text
statePosState =
PosState :: forall s. s -> Int -> SourcePos -> Pos -> FilePath -> PosState s
PosState
{ pstateInput :: Text
pstateInput = Text
input,
pstateOffset :: Int
pstateOffset = Int
offset,
pstateSourcePos :: SourcePos
pstateSourcePos = FilePath -> SourcePos
initialPos FilePath
file,
pstateTabWidth :: Pos
pstateTabWidth = Int -> Pos
mkPos Int
4,
pstateLinePrefix :: FilePath
pstateLinePrefix = FilePath
""
},
stateParseErrors :: [ParseError Text e]
stateParseErrors = []
}
locally :: MonadState s m => Lens' s a -> a -> m b -> m b
locally :: Lens' s a -> a -> m b -> m b
locally Lens' s a
l a
x m b
m = do
a
y <- (s -> a) -> m a
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (s -> Getting a s a -> a
forall s a. s -> Getting a s a -> a
^. Getting a s a
Lens' s a
l)
(s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (ASetter s s a a -> a -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s a a
Lens' s a
l a
x)
b
r <- m b
m
(s -> s) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (ASetter s s a a -> a -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s a a
Lens' s a
l a
y)
b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
r