Markdown.hs

{-# LANGUAGE Arrows, RecursiveDo, EmptyDataDecls, TemplateHaskell, PostfixOperators #-}

module Document.Grammars.Markdown where

import Control.Applicative
import Prelude hiding ((+),(*))
import Language.Grammars.Grammar
import Language.Grammars.Murder
import Language.Grammars.Murder.Derive
import Language.Grammars.Murder.UUParsing
import Language.Grammars.Grammar.AG

import Document.Decl
import Utils

$(csLabels  ["cs_header", "cs_atxPrefix", "cs_atxTitle"])


gMarkdown sem syms = proc () -> do
    
    rec 
        document  <-addNT-< iI (pDocument sem) blockL Ii


        blockL    <-addNT-< pMany $ iI block Ii

        block     <-addNT-< iI header Ii
                     <|>    iI paragraph Ii


        -- Block level

        paragraph <-addNT-< iI concat (textLine+) (ign blankLine) Ii

        header    <-addNT-< iI ((++) . show) atxPrefix atxTitle Ii

        atxPrefix <-addNT-< fmap length $ iI (someOf "#") Ii        
        atxTitle  <-addNT-< iI (\x xs -> value x : xs) (anyExcept "#") (manyExcept "\n") "\n" Ii



        inlineL   <-addNT-< pMany $ iI inline Ii

        -- Inline level

        inline    <-addNT-< iI bold Ii 
                     <|>    iI italics Ii 
                     <|>    iI plain Ii

        plain     <-addNT-< iI (\x xs x'-> value x : xs ++ [value x']) (anyExcept "*_") (someExcept "*_\n") (anyOf "\n") Ii

        bold      <-addNT-< iI "**" (someExcept "*\n") "**" Ii
                      <|>   iI "__" (someExcept "_\n") "__" Ii

        italics   <-addNT-< iI "*" (someExcept "*\n") "*" Ii
                     <|>    iI "_" (someExcept "_\n") "_" Ii


        -- primitives
        textLine  <-addNT-< iI (\x xs -> value x : xs) (anyExcept syms) (manyExcept "\n") "\n" Ii
        blankLine <-addNT-< iI (someOf " \n\t\r") Ii
    
    exportNTs -< exportList inlineL ( export cs_header    header
                                   . export cs_atxPrefix atxPrefix 
                                   . export cs_atxTitle      atxTitle)









lineChars = ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ " ':;!@()\""


-- Semantics for building the AST
semLine = map value

--semNewLine :: Maybe (DTerm String) -> ()
semNewLine _ = ()

semHeaderAtx :: [DTerm String] -> String -> Block
semHeaderAtx x str = let hlevel = length x
                     in  Header hlevel [Plain str]

semHeaderSetext :: String -> (DTerm String) -> Block
semHeaderSetext str hsym = let hlevel = if (value hsym) == "=" then 1 else 2
                           in  Header hlevel [Plain str]