{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# 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

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 = forall a. Text -> Html a
htmlText Text
"‘" forall a. Semigroup a => a -> a -> a
<> Html a
x forall a. Semigroup a => a -> a -> a
<> forall a. Text -> Html a
htmlText Text
"’"
  doubleQuoted :: Html a -> Html a
doubleQuoted Html a
x = forall a. Text -> Html a
htmlText Text
"“" forall a. Semigroup a => a -> a -> a
<> Html a
x forall a. Semigroup a => a -> a -> 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 = (forall il. HasQuoted il => il -> il
singleQuoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap i
x) 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 = (forall il. HasQuoted il => il -> il
doubleQuoted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap i
x) 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 :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasQuoted il) =>
SyntaxSpec m il bl
smartPunctuationSpec = forall a. Monoid a => a
mempty
  { syntaxFormattingSpecs :: [FormattingSpec il]
syntaxFormattingSpecs = [forall il. (IsInline il, HasQuoted il) => FormattingSpec il
singleQuotedSpec, forall il. (IsInline il, HasQuoted il) => FormattingSpec il
doubleQuotedSpec]
  , syntaxInlineParsers :: [InlineParser m il]
syntaxInlineParsers = [forall (m :: * -> *) a. (Monad m, IsInline a) => InlineParser m a
pEllipses, forall (m :: * -> *) a. (Monad m, IsInline a) => InlineParser m a
pDash]
  }

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

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

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

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