Add intermediate representation

commonmark-extensions/src/Commonmark/Extensions/Attributes.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.Attributes
   ( attributesSpec
   , HasDiv(..)
@@ -25,6 +27,7 @@ import Commonmark.SourceMap
 import Commonmark.Blocks
 import Commonmark.Entity (unEntity)
 import Commonmark.Html
+import Commonmark.Nodes hiding (Node (..))
 import Data.Dynamic
 import Data.Tree
 import Control.Monad (mzero, guard, void)
@@ -285,3 +288,35 @@ pKeyValue = do
                Tok (Symbol '\'') _ _:_:_ -> mzero
                _ -> val
   return $! (untokenize name, unEntity val')
+
+data NodeTypeDiv a
+  = NodeDiv_ (Nodes a)
+  deriving (Show)
+
+instance (Typeable a, Monoid a, HasAttributes a, Rangeable a) => NodeType NodeTypeDiv a where
+  type FromNodeType NodeTypeDiv a = HasDiv a
+  fromNodeType = \case
+    NodeDiv_ x -> div_ (fromNodes x)
+
+instance ToPlainText (NodeTypeDiv a) where
+  toPlainText = \case
+    NodeDiv_ x -> toPlainText x
+
+instance (Typeable a, HasDiv a, Monoid a, HasAttributes a, Rangeable a) => HasDiv (Nodes a) where
+  div_ x = singleNode $ NodeDiv_ x
+
+data NodeTypeSpan a
+  = NodeSpanWith Attributes (Nodes a)
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeSpan a where
+  type FromNodeType NodeTypeSpan a = HasSpan a
+  fromNodeType = \case
+    NodeSpanWith attrs x -> spanWith attrs (fromNodes x)
+
+instance ToPlainText (NodeTypeSpan a) where
+  toPlainText = \case
+    NodeSpanWith _ x -> toPlainText x
+
+instance (Typeable a, HasSpan a) => HasSpan (Nodes a) where
+  spanWith attrs x = singleNode $ NodeSpanWith attrs x

commonmark-extensions/src/Commonmark/Extensions/DefinitionList.hs

@@ -4,6 +4,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.DefinitionList
   ( definitionListSpec
   , HasDefinitionList(..)
@@ -15,9 +18,11 @@ import Commonmark.Blocks
 import Commonmark.SourceMap
 import Commonmark.TokParsers
 import Commonmark.Html
+import Commonmark.Nodes hiding (Node (..))
 import Control.Monad (mzero)
 import Data.Dynamic
 import Data.Tree
+import qualified Data.Text as T
 import Text.Parsec
 
 definitionListSpec :: (Monad m, IsBlock il bl, IsInline il,
@@ -194,3 +199,28 @@ instance (HasDefinitionList il bl, Semigroup bl, Semigroup il)
     let res = definitionList spacing (zip terms' defs')
     addName "definitionList"
     return res
+
+data NodeTypeDefinitionList a
+  = NodeDefinitionList ListSpacing [(Nodes a, [Nodes a])]
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeDefinitionList a where
+  type FromNodeType NodeTypeDefinitionList a = HasDefinitionList a a
+  fromNodeType = \case
+    NodeDefinitionList spacing items ->
+      definitionList
+        spacing
+        [ (fromNodes term, map fromNodes defs)
+        | (term, defs) <- items
+        ]
+
+instance ToPlainText (NodeTypeDefinitionList a) where
+  toPlainText = \case
+    NodeDefinitionList _ items ->
+      T.unlines . concat $
+        [ (toPlainText term <> ":") : map toPlainText defs
+        | (term, defs) <- items
+        ]
+
+instance (Typeable a, HasDefinitionList a a) => HasDefinitionList (Nodes a) (Nodes a) where
+  definitionList spacing items = singleNode $ NodeDefinitionList spacing items

commonmark-extensions/src/Commonmark/Extensions/Emoji.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.Emoji
   ( HasEmoji(..)
   , emojiSpec )
@@ -11,9 +14,11 @@ import Commonmark.Inlines
 import Commonmark.SourceMap
 import Commonmark.TokParsers
 import Commonmark.Html
+import Commonmark.Nodes
 import Text.Emoji (emojiFromAlias)
 import Text.Parsec
 import Data.Text (Text)
+import Data.Typeable (Typeable)
 
 emojiSpec :: (Monad m, IsBlock il bl, IsInline il, HasEmoji il)
           => SyntaxSpec m il bl
@@ -46,3 +51,19 @@ parseEmoji = try $ do
   case emojiFromAlias kw of
     Nothing -> fail "emoji not found"
     Just t  -> return $! emoji kw t
+
+data NodeTypeEmoji a
+  = NodeEmoji Text Text
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeEmoji a where
+  type FromNodeType NodeTypeEmoji a = HasEmoji a
+  fromNodeType = \case
+    NodeEmoji kw t -> emoji kw t
+
+instance ToPlainText (NodeTypeEmoji a) where
+  toPlainText = \case
+    NodeEmoji kw _ -> ":" <> kw <> ":"
+
+instance (Typeable a, HasEmoji a) => HasEmoji (Nodes a) where
+  emoji kw t = singleNode $ NodeEmoji kw t

commonmark-extensions/src/Commonmark/Extensions/Footnote.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.Footnote
   ( footnoteSpec
   , HasFootnote(..)
@@ -18,6 +20,7 @@ import Commonmark.Inlines
 import Commonmark.SourceMap
 import Commonmark.TokParsers
 import Commonmark.ReferenceMap
+import Commonmark.Nodes hiding (Node (..))
 import Control.Monad.Trans.Class (lift)
 import Control.Monad (mzero)
 import Data.List
@@ -169,3 +172,27 @@ instance (HasFootnote il bl, Semigroup bl, Semigroup il)
   footnote num lab' x = (footnote num lab' <$> x) <* addName "footnote"
   footnoteList items = footnoteList <$> sequence items
   footnoteRef x y z = (footnoteRef x y <$> z) <* addName "footnoteRef"
+
+data NodeTypeFootnote a
+  = NodeFootnote Int Text (Nodes a)
+  | NodeFootnoteList [Nodes a]
+  | NodeFootnoteRef Text Text (Nodes a)
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeFootnote a where
+  type FromNodeType NodeTypeFootnote a = HasFootnote a a
+  fromNodeType = \case
+    NodeFootnote num lab x -> footnote num lab (fromNodes x)
+    NodeFootnoteList items -> footnoteList (map fromNodes items)
+    NodeFootnoteRef x lab nodes -> footnoteRef x lab (fromNodes nodes)
+
+instance ToPlainText (NodeTypeFootnote a) where
+  toPlainText = \case
+    NodeFootnote num _ x -> T.pack (show num) <> ": " <> toPlainText x
+    NodeFootnoteList items -> T.unlines $ map toPlainText items
+    NodeFootnoteRef x _ _ -> "[" <> x <> "]"
+
+instance (Typeable a, HasFootnote a a) => HasFootnote (Nodes a) (Nodes a) where
+  footnote num lab x = singleNode $ NodeFootnote num lab x
+  footnoteList items = singleNode $ NodeFootnoteList items
+  footnoteRef x lab nodes = singleNode $ NodeFootnoteRef x lab nodes

commonmark-extensions/src/Commonmark/Extensions/Math.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.Math
   ( HasMath(..)
   , mathSpec )
@@ -12,9 +15,11 @@ import Commonmark.Inlines
 import Commonmark.SourceMap
 import Commonmark.TokParsers
 import Commonmark.Html
+import Commonmark.Nodes
 import Text.Parsec
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Typeable (Typeable)
 
 mathSpec :: (Monad m, IsBlock il bl, IsInline il, HasMath il)
          => SyntaxSpec m il bl
@@ -62,3 +67,23 @@ pDollarsMath n = do
        Symbol '}' | n > 0 -> (tk :) <$> pDollarsMath (n-1)
                   | otherwise -> mzero
        _ -> (tk :) <$> pDollarsMath n
+
+data NodeTypeMath a
+  = NodeInlineMath Text
+  | NodeDisplayMath Text
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeMath a where
+  type FromNodeType NodeTypeMath a = HasMath a
+  fromNodeType = \case
+    NodeInlineMath t -> inlineMath t
+    NodeDisplayMath t -> displayMath t
+
+instance ToPlainText (NodeTypeMath a) where
+  toPlainText = \case
+    NodeInlineMath t -> t
+    NodeDisplayMath t -> t
+
+instance (Typeable a, HasMath a) => HasMath (Nodes a) where
+  inlineMath t = singleNode $ NodeInlineMath t
+  displayMath t = singleNode $ NodeDisplayMath t

commonmark-extensions/src/Commonmark/Extensions/PipeTable.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE DeriveDataTypeable    #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE TypeFamilies          #-}
 
 module Commonmark.Extensions.PipeTable
  ( HasPipeTable(..)
@@ -20,10 +22,12 @@ import Commonmark.TokParsers
 import Commonmark.Blocks
 import Commonmark.SourceMap
 import Commonmark.Html
+import Commonmark.Nodes hiding (Node (..))
 import Text.Parsec
 import Data.Dynamic
 import Data.Tree
 import Data.Data
+import qualified Data.Text as T
 
 data ColAlignment = LeftAlignedCol
                   | CenterAlignedCol
@@ -211,3 +215,26 @@ pipeTableBlockSpec = BlockSpec
                then Node ndata children
                else Node ndata{ blockSpec = paraSpec } children) parent
      }
+
+data NodeTypePipeTable a
+  = NodePipeTable [ColAlignment] [Nodes a] [[Nodes a]]
+  deriving (Show)
+
+instance (Typeable a, Monoid a, HasAttributes a, Rangeable a) => NodeType NodeTypePipeTable a where
+  type FromNodeType NodeTypePipeTable a = HasPipeTable a a
+  fromNodeType = \case
+    NodePipeTable aligns headers rows -> pipeTable aligns (map fromNodes headers) (map (map fromNodes) rows)
+
+instance ToPlainText (NodeTypePipeTable a) where
+  toPlainText = \case
+    NodePipeTable _ headers rows ->
+      T.unlines $
+        fromRow (map toPlainText headers) :
+          [ fromRow (map toPlainText row)
+          | row <- rows
+          ]
+    where
+      fromRow = T.unwords
+
+instance (Typeable a, HasPipeTable a a, Monoid a, HasAttributes a, Rangeable a) => HasPipeTable (Nodes a) (Nodes a) where
+  pipeTable aligns headers rows = singleNode $ NodePipeTable aligns headers rows

commonmark-extensions/src/Commonmark/Extensions/Smart.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies         #-}
 module Commonmark.Extensions.Smart
   ( HasQuoted(..)
   , smartPunctuationSpec )
@@ -11,8 +14,10 @@ import Commonmark.Types
 import Commonmark.Syntax
 import Commonmark.Inlines
 import Commonmark.Html
+import Commonmark.Nodes
 import Commonmark.SourceMap
 import Commonmark.TokParsers (symbol)
+import Data.Typeable (Typeable)
 import Text.Parsec
 
 class IsInline il => HasQuoted il where
@@ -59,3 +64,23 @@ pDash = try $ do
   return $! mconcat $
     replicate emcount (str "—") <>
     replicate encount (str "–")
+
+data NodeTypeQuoted a
+  = NodeSingleQuoted (Nodes a)
+  | NodeDoubleQuoted (Nodes a)
+  deriving (Show)
+
+instance Typeable a => NodeType NodeTypeQuoted a where
+  type FromNodeType NodeTypeQuoted a = HasQuoted a
+  fromNodeType = \case
+    NodeSingleQuoted x -> singleQuoted (fromNodes x)
+    NodeDoubleQuoted x -> doubleQuoted (fromNodes x)
+
+instance ToPlainText (NodeTypeQuoted a) where
+  toPlainText = \case
+    NodeSingleQuoted x -> "‘" <> toPlainText x <> "’"
+    NodeDoubleQuoted x -> "“" <> toPlainText x <> "”"
+
+instance (Typeable a, HasQuoted a) => HasQuoted (Nodes a) where
+  singleQuoted x = singleNode $ NodeSingleQuoted x
+  doubleQuoted x = singleNode $ NodeDoubleQuoted x

commonmark-extensions/src/Commonmark/Extensions/Strikethrough.hs

@@ -1,5 +1,8 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
 module Commonmark.Extensions.Strikethrough
   ( HasStrikethrough(..)
   , strikethroughSpec )
@@ -9,6 +12,8 @@ import Commonmark.Syntax
 import Commonmark.Inlines
 import Commonmark.SourceMap
 import Commonmark.Html
+import Commonmark.Nodes
+import Data.Typeable (Typeable)
 
 strikethroughSpec :: (Monad m, IsBlock il bl, IsInline il, HasStrikethrough il)
               => SyntaxSpec m il bl
@@ -27,3 +32,19 @@ instance HasStrikethrough (Html a) where
 instance (HasStrikethrough i, Monoid i)
         => HasStrikethrough (WithSourceMap i) where
   strikethrough x = (strikethrough <$> x) <* addName "strikethrough"
+
+data NodeTypeStrikethrough a
+  = NodeStrikethrough (Nodes a)
+  deriving (Show)
+
+instance (Typeable a, Monoid a, HasAttributes a, Rangeable a) => NodeType NodeTypeStrikethrough a where
+  type FromNodeType NodeTypeStrikethrough a = HasStrikethrough a
+  fromNodeType = \case
+    NodeStrikethrough x -> strikethrough (fromNodes x)
+
+instance ToPlainText (NodeTypeStrikethrough a) where
+  toPlainText = \case
+    NodeStrikethrough x -> toPlainText x
+
+instance (Typeable a, HasStrikethrough a, Monoid a, HasAttributes a, Rangeable a) => HasStrikethrough (Nodes a) where
+  strikethrough x = singleNode $ NodeStrikethrough x