commonmark-0.3: src/Commonmark/Types.hs

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE MonoLocalBinds             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE UndecidableInstances       #-}

module Commonmark.Types
  ( Format(..)
  , ListSpacing(..)
  , ListType(..)
  , DelimiterType(..)
  , EnumeratorType(..)
  , IsInline(..)
  , IsBlock(..)
  , SourceRange(..)
  , Rangeable(..)
  , Attribute
  , Attributes
  , HasAttributes(..)
  , ToPlainText(..)

  -- * Re-exports
  , module Text.Parsec.Pos
  )
where
import           Data.Data            (Data)
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Data.Typeable        (Typeable)
import           Text.Parsec.Pos      (SourcePos, sourceColumn, sourceLine,
                                       sourceName)

newtype Format = Format Text
  deriving (Show, Data, Typeable)

instance Eq Format where
  (Format t1) == (Format t2) = T.toCaseFold t1 == T.toCaseFold t2

data ListSpacing =
       TightList
     | LooseList
     deriving (Show, Ord, Eq, Data, Typeable)

data EnumeratorType =
       Decimal
     | UpperAlpha
     | LowerAlpha
     | UpperRoman
     | LowerRoman
     deriving (Show, Ord, Eq, Data, Typeable)

data DelimiterType =
       Period
     | OneParen
     | TwoParens
     deriving (Show, Ord, Eq, Data, Typeable)

data ListType =
       BulletList !Char
     | OrderedList !Int !EnumeratorType !DelimiterType
     -- first Text is before, second Text is after enumerator
     deriving (Show, Ord, Eq, Data, Typeable)

class (Monoid a, Show a, Rangeable a, HasAttributes a) => IsInline a where
  lineBreak :: a
  softBreak :: a
  str :: Text -> a
  entity :: Text -> a
  escapedChar :: Char -> a
  emph :: a -> a
  strong :: a -> a
  link :: Text -- ^ Destination
       -> Text -- ^ Title
       -> a    -- ^ Link description
       -> a
  image :: Text -- ^ Source
        -> Text -- ^ Title
        -> a    -- ^ Description
        -> a
  code :: Text -> a
  rawInline :: Format -> Text -> a

instance {-# OVERLAPPABLE #-} (Applicative f, IsInline a, Monoid (f a), Show (f a)) => IsInline (f a) where
  lineBreak = pure lineBreak
  softBreak = pure softBreak
  str t = pure $ str t
  entity t = pure $ entity t
  escapedChar c = pure $ escapedChar c
  emph = fmap emph
  strong = fmap strong
  link d t = fmap $ link d t
  image s t = fmap $ image s t
  code t = pure $ code t
  rawInline f t = pure $ rawInline f t

class (Monoid b, Show b, Rangeable b, IsInline il, HasAttributes b)
      => IsBlock il b | b -> il where
  paragraph :: il -> b
  plain :: il -> b
  thematicBreak :: b
  blockQuote :: b -> b
  codeBlock :: Text -> Text -> b
  heading :: Int -- ^ Level
          -> il  -- ^ text
          -> b
  rawBlock :: Format -> Text -> b
  referenceLinkDefinition :: Text -- ^ Label
                          -> (Text, Text) -- ^ Destination, title
                          -> b
  list :: ListType -> ListSpacing -> [b] -> b

instance {-# OVERLAPPABLE #-} (Applicative f, Monoid (f il), Show (f il), Monoid (f b), Show (f b), IsBlock il b) => IsBlock (f il) (f b) where
  paragraph = fmap paragraph
  plain = fmap plain
  thematicBreak = pure thematicBreak
  blockQuote = fmap blockQuote
  codeBlock p q = pure $ codeBlock p q
  heading l = fmap $ heading l
  rawBlock f t = pure $ rawBlock f t
  referenceLinkDefinition l dt = pure $ referenceLinkDefinition l dt
  list lt ls fbs = fmap (list lt ls) $ sequenceA fbs

newtype SourceRange = SourceRange
        { unSourceRange :: [(SourcePos, SourcePos)] }
  deriving (Eq, Ord, Data, Typeable)

instance Semigroup SourceRange where
  (SourceRange xs) <> (SourceRange ys) =
    SourceRange (consolidateRanges xs ys)

instance Monoid SourceRange where
  mempty = SourceRange mempty
  mappend = (<>)

consolidateRanges :: Eq a => [(a,a)] -> [(a,a)] -> [(a,a)]
consolidateRanges [] xs = xs
consolidateRanges xs [] = xs
consolidateRanges xs@(_:_) ((s2,e2):ys) =
  if e1 == s2
     then init xs ++ (s1,e2):ys
     else xs ++ (s2,e2):ys
  where (s1,e1) = last xs

instance Show SourceRange where
  show = prettyRange

class Rangeable a where
  ranged :: SourceRange -> a -> a

instance {-# OVERLAPPABLE #-} (Functor f, Rangeable a) => Rangeable (f a) where
  ranged sr = fmap $ ranged sr

prettyRange :: SourceRange -> String
prettyRange (SourceRange xs) = go "" xs
  where
    go _ [] = ""
    go curname ((p1,p2):rest)
      = (if sourceName p1 /= curname
            then sourceName p1 ++ "@"
            else "") ++
         show (sourceLine p1) ++ ":" ++
         show (sourceColumn p1) ++ "-" ++
         (if sourceName p2 /= sourceName p1
             then sourceName p2 ++ "@"
             else "") ++
         show (sourceLine p2) ++
         ":" ++ show (sourceColumn p2) ++
         if null rest
            then ""
            else ";" ++ go (sourceName p2) rest

type Attribute = (Text, Text)

type Attributes = [Attribute]

class HasAttributes a where
  addAttributes :: Attributes -> a -> a

instance {-# OVERLAPPABLE #-} (Functor f, HasAttributes a) => HasAttributes (f a) where
  addAttributes attrs = fmap $ addAttributes attrs

class ToPlainText a where
  toPlainText :: a -> Text