{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE UndecidableInstances #-}
module Commonmark.Extensions.Smart
  ( HasQuoted(..)
  , smartPunctuationSpec )
where

import Commonmark.Types
import Commonmark.Syntax
import Commonmark.Inlines
import Commonmark.Html
import Commonmark.SourceMap
import Commonmark.TokParsers (symbol)
import Text.Parsec
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid (Monoid)
import Data.Semigroup (Semigroup, (<>))
#endif

class IsInline il => HasQuoted il where
  singleQuoted :: il -> il
  doubleQuoted :: il -> il

instance Rangeable (Html a) => HasQuoted (Html a) where
  singleQuoted :: Html a -> Html a
singleQuoted Html a
x = Text -> Html a
forall a. Text -> Html a
htmlText Text
"‘" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlText Text
"’"
  doubleQuoted :: Html a -> Html a
doubleQuoted Html a
x = Text -> Html a
forall a. Text -> Html a
htmlText Text
"“" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Text -> Html a
forall a. Text -> Html a
htmlText Text
"”"

instance (HasQuoted i, Monoid i, Semigroup i)
        => HasQuoted (WithSourceMap i) where
  singleQuoted :: WithSourceMap i -> WithSourceMap i
singleQuoted WithSourceMap i
x = (i -> i
forall il. HasQuoted il => il -> il
singleQuoted (i -> i) -> WithSourceMap i -> WithSourceMap i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap i
x) WithSourceMap i -> WithSourceMap () -> WithSourceMap i
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"singleQuoted"
  doubleQuoted :: WithSourceMap i -> WithSourceMap i
doubleQuoted WithSourceMap i
x = (i -> i
forall il. HasQuoted il => il -> il
doubleQuoted (i -> i) -> WithSourceMap i -> WithSourceMap i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap i
x) WithSourceMap i -> WithSourceMap () -> WithSourceMap i
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"doubleQuoted"

smartPunctuationSpec :: (Monad m, IsBlock il bl, IsInline il, HasQuoted il)
                     => SyntaxSpec m il bl
smartPunctuationSpec :: SyntaxSpec m il bl
smartPunctuationSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxFormattingSpecs :: [FormattingSpec il]
syntaxFormattingSpecs = [FormattingSpec il
forall il. (IsInline il, HasQuoted il) => FormattingSpec il
singleQuotedSpec, FormattingSpec il
forall il. (IsInline il, HasQuoted il) => FormattingSpec il
doubleQuotedSpec]
  , syntaxInlineParsers :: [InlineParser m il]
syntaxInlineParsers = [InlineParser m il
forall (m :: * -> *) a. (Monad m, IsInline a) => InlineParser m a
pEllipses, InlineParser m il
forall (m :: * -> *) a. (Monad m, IsInline a) => InlineParser m a
pDash]
  }

singleQuotedSpec :: (IsInline il, HasQuoted il) => FormattingSpec il
singleQuotedSpec :: FormattingSpec il
singleQuotedSpec = Char
-> Bool
-> Bool
-> Maybe (il -> il)
-> Maybe (il -> il)
-> Char
-> FormattingSpec il
forall il.
Char
-> Bool
-> Bool
-> Maybe (il -> il)
-> Maybe (il -> il)
-> Char
-> FormattingSpec il
FormattingSpec Char
'\'' Bool
False Bool
False ((il -> il) -> Maybe (il -> il)
forall a. a -> Maybe a
Just il -> il
forall il. HasQuoted il => il -> il
singleQuoted) Maybe (il -> il)
forall a. Maybe a
Nothing Char
'’'

doubleQuotedSpec :: (IsInline il, HasQuoted il) => FormattingSpec il
doubleQuotedSpec :: FormattingSpec il
doubleQuotedSpec = Char
-> Bool
-> Bool
-> Maybe (il -> il)
-> Maybe (il -> il)
-> Char
-> FormattingSpec il
forall il.
Char
-> Bool
-> Bool
-> Maybe (il -> il)
-> Maybe (il -> il)
-> Char
-> FormattingSpec il
FormattingSpec Char
'"' Bool
False Bool
False ((il -> il) -> Maybe (il -> il)
forall a. a -> Maybe a
Just il -> il
forall il. HasQuoted il => il -> il
doubleQuoted) Maybe (il -> il)
forall a. Maybe a
Nothing Char
'“'

pEllipses :: (Monad m, IsInline a) => InlineParser m a
pEllipses :: InlineParser m a
pEllipses = InlineParser m a -> InlineParser m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m a -> InlineParser m a)
-> InlineParser m a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$ do
  Int
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
Int -> ParsecT s u m a -> ParsecT s u m [a]
count Int
3 (Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'.')
  a -> InlineParser m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> InlineParser m a) -> a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$! Text -> a
forall a. IsInline a => Text -> a
str Text
"…"

pDash :: (Monad m, IsInline a) => InlineParser m a
pDash :: InlineParser m a
pDash = InlineParser m a -> InlineParser m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m a -> InlineParser m a)
-> InlineParser m a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$ do
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'-'
  Int
numhyphens <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int -> Int) -> ([Tok] -> Int) -> [Tok] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tok] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Tok] -> Int)
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
-> ParsecT [Tok] (IPState m) (StateT Enders m) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'-')
  let (Int
emcount, Int
encount) =
        case Int
numhyphens of
             Int
n | Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> (Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3, Int
0)
               | Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> (Int
0, Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
               | Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3, Int
1)
               | Bool
otherwise      -> ((Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3, Int
2)
  a -> InlineParser m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> InlineParser m a) -> a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$! [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$
    Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
emcount (Text -> a
forall a. IsInline a => Text -> a
str Text
"—") [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<>
    Int -> a -> [a]
forall a. Int -> a -> [a]
replicate Int
encount (Text -> a
forall a. IsInline a => Text -> a
str Text
"–")