Added Slackdown (minimal Markdown-like formatting) reader

cabal.project

@@ -1,5 +1,6 @@
 packages: ptolemy-core/ptolemy-core.cabal,
           ptolemy-reader-markdown/ptolemy-reader-markdown.cabal,
+          ptolemy-reader-slackdown/ptolemy-reader-slackdown.cabal,
           ptolemy-writer-html/ptolemy-writer-html.cabal,
           ptolemy-bridge/ptolemy-bridge.cabal
           ptolemy/ptolemy.cabal

ptolemy-core/Text/Ptolemy/Core.hs

@@ -1,7 +1,6 @@
 module Text.Ptolemy.Core where
 
 import           Data.Text (Text)
-import qualified Data.Text as T
 import           Data.Vector (Vector)
 import qualified Data.Vector as V
 
@@ -9,6 +8,12 @@ type Document = Vector Block
 type DocumentList = Vector Document
 type Chunk = Vector Inline
 
+newtype PtolemyError = PtolemyError { ptolemyErrorMessage :: String }
+  deriving (Eq, Show)
+
+vec :: [a] -> Vector a
+vec = V.fromList
+
 data Block
   = Plain Chunk
   | Para Chunk
@@ -17,7 +22,7 @@ data Block
   | BlockQuote Document
   | OrderedList ListAttributes DocumentList
   | BulletList DocumentList
-  | DefinitionList (Vector (Chunk, DocumentList))
+  | DefinitionList (Vector Definition)
   | Header Int Attr Chunk
   | HorizontalRule
 --  | Table ???
@@ -25,6 +30,11 @@ data Block
   | Null
     deriving (Eq, Show, Read, Ord)
 
+data Definition = Definition
+  { dfTerm       :: Chunk
+  , dfDefinition :: DocumentList
+  } deriving (Eq, Show, Read, Ord)
+
 data Inline
   = Str Text
   | Emph Chunk
@@ -53,6 +63,13 @@ data Attr = Attr
   , attrProps :: Vector (Text, Text)
   } deriving (Eq, Show, Read, Ord)
 
+emptyAttr :: Attr
+emptyAttr = Attr
+  { attrIdentifier = ""
+  , attrClasses    = vec []
+  , attrProps      = vec []
+  }
+
 data ListAttributes = ListAttributes
   { laWhatever    :: Int -- XXX What is this field for?
   , laNumberStyle :: ListNumberStyle

ptolemy-reader-slackdown/README.md

@@ -0,0 +1,31 @@
+# `ptolemy-slackdown-reader`
+
+This module implements a `ptolemy` reader for the limited
+Markdown-like language understood by Slack and other chat
+services. This understands only a few basic inline markup
+constructs:
+
+- `*asterisks*` for *bold text*
+- `_underscores_` for _emphasized text_
+- `~tildes~` for ~strikethrough text~
+- `backticks` for `inline code`
+
+It also understands two block-level constructs, but these
+can be turned off using the `SlackdownOpts` value passed to
+the parser:
+
+- A set of lines started with `>` become a blockquote
+- A set of lines with triple backticks above and below become
+  verbatim code blocks
+
+Among other things, this is a good idea for situations where
+the full generality of Markdown is probably unnecessary. You
+don't want your blog comments or chat messages to include
+H2 headers or horizontal rules, but some bold and italic text
+would be fine!
+
+Right now this is largely untested, and it badly needs QuickCheck
+or fuzzing, because it should _absolutely_ be the case that every
+possible string parses as _something_, even if that something
+just doesn't include markup. This is certainly not the case
+right now.

ptolemy-reader-slackdown/Text/Ptolemy/Slackdown/Reader.hs

@@ -0,0 +1,73 @@
+module Text.Ptolemy.Slackdown.Reader
+         ( SlackdownOpts(..)
+         , defaultOpts
+         , inlineOpts
+         , readSlackdown
+         ) where
+
+import           Control.Applicative (empty)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Vector as V
+import           Text.Megaparsec
+import           Text.Megaparsec.Text
+import           Text.Ptolemy.Core (PtolemyError, Document)
+import qualified Text.Ptolemy.Core as P
+
+data SlackdownOpts = SlackdownOpts
+  { tdBlockElems :: Bool
+  } deriving (Eq, Show)
+
+defaultOpts :: SlackdownOpts
+defaultOpts = SlackdownOpts
+  { tdBlockElems = True
+  }
+
+inlineOpts :: SlackdownOpts
+inlineOpts = SlackdownOpts
+  { tdBlockElems = False
+  }
+
+readSlackdown :: SlackdownOpts -> Text -> Either PtolemyError Document
+readSlackdown opts tx = case runParser (pSlackdown opts) "[]" tx of
+  Right x -> Right x
+  Left err -> Left (P.PtolemyError (show err))
+
+enables :: Bool -> Parser a -> Parser a
+enables True  p = p
+enables False _ = empty
+
+pSlackdown :: SlackdownOpts -> Parser Document
+pSlackdown SlackdownOpts { tdBlockElems = blockElems } =
+    P.vec <$> (many pBlock <* eof)
+  where pBlock =
+          blockElems `enables` (pCodeBlock <|> pQuote) <|>
+            pLine
+
+        pLine = (P.Plain . flip V.snoc P.LineBreak . P.vec) <$>
+                  manyTill pInline (char '\n')
+
+        pQuote = (P.BlockQuote . P.vec) <$> some (char '>' *> pLine)
+
+        pCodeBlock = (P.CodeBlock P.emptyAttr . T.concat) <$>
+                     (string "```\n" *> manyTill pPlainLine (string "```\n"))
+
+        pPlainLine = T.pack <$> manyTill (noneOf ("\n\r" :: String))
+                                         (char '\n')
+
+        pInline = pWhitespace
+          <|> pString
+          <|> (P.Code P.emptyAttr . T.pack) <$>
+                  (char '`' *> many (satisfy (/= '`')) <* char '`')
+          <|> P.Strong <$> pSurrounded '*'
+          <|> P.Emph <$> pSurrounded '_'
+          <|> P.Strikeout <$> pSurrounded '~'
+
+        pWhitespace = (P.Space) <$ some (oneOf (" \t" :: String))
+
+        pString = (P.Str . T.pack) <$> some (noneOf ("*_~` \t\r\n" :: String))
+
+        pSurrounded :: Char -> Parser P.Chunk
+        pSurrounded c = try (char c *> rest)
+           where rest = P.vec <$> (many (notFollowedBy (char c) *> pInline)
+                                   <* char c)

ptolemy-reader-slackdown/ptolemy-reader-slackdown.cabal

@@ -0,0 +1,24 @@
+name:             ptolemy-reader-slackdown
+version:          0.1.0.0
+-- synopsis:
+-- description
+license:          BSD3
+license-file:     LICENSE
+author:           Getty Ritter
+maintainer:       gettyritter@gmail.com
+copyright:        ©2016 Getty Ritter
+category:         Text
+build-type:       Simple
+cabal-version:    >=1.12
+
+library
+  exposed-modules:     Text.Ptolemy.Slackdown.Reader
+  ghc-options:         -Wall
+  build-depends:       base >=4.7 && <4.9,
+                       text,
+                       megaparsec,
+                       vector,
+                       ptolemy-core ==0.1.0.0
+  default-language:    Haskell2010
+  default-extensions:  OverloadedStrings,
+                       ScopedTypeVariables