Commit 19bc152093d47fba96be1e7de497abefc3815a47 - ptolemy

+1

-0

cabal.project less more

1	1	packages: ptolemy-core/ptolemy-core.cabal,
2	2	ptolemy-reader-markdown/ptolemy-reader-markdown.cabal,
	3	ptolemy-reader-slackdown/ptolemy-reader-slackdown.cabal,
3	4	ptolemy-writer-html/ptolemy-writer-html.cabal,
4	5	ptolemy-bridge/ptolemy-bridge.cabal
5	6	ptolemy/ptolemy.cabal

+19

-2

ptolemy-core/Text/Ptolemy/Core.hs less more

1	1	module Text.Ptolemy.Core where
2	2
3	3	import Data.Text (Text)
4		import qualified Data.Text as T
5	4	import Data.Vector (Vector)
6	5	import qualified Data.Vector as V
7	6
8	7	type Document = Vector Block
9	8	type DocumentList = Vector Document
10	9	type Chunk = Vector Inline
	10
	11	newtype PtolemyError = PtolemyError { ptolemyErrorMessage :: String }
	12	deriving (Eq, Show)
	13
	14	vec :: [a] -> Vector a
	15	vec = V.fromList
11	16
12	17	data Block
13	18	= Plain Chunk

17	22	\| BlockQuote Document
18	23	\| OrderedList ListAttributes DocumentList
19	24	\| BulletList DocumentList
20		\| DefinitionList (Vector ~~(Chunk, DocumentList)~~)
	25	\| DefinitionList (Vector Definition)
21	26	\| Header Int Attr Chunk
22	27	\| HorizontalRule
23	28	-- \| Table ???
24	29	\| Div Attr Document
25	30	\| Null
26	31	deriving (Eq, Show, Read, Ord)
	32
	33	data Definition = Definition
	34	{ dfTerm :: Chunk
	35	, dfDefinition :: DocumentList
	36	} deriving (Eq, Show, Read, Ord)
27	37
28	38	data Inline
29	39	= Str Text

52	62	, attrClasses :: Vector Text
53	63	, attrProps :: Vector (Text, Text)
54	64	} deriving (Eq, Show, Read, Ord)
	65
	66	emptyAttr :: Attr
	67	emptyAttr = Attr
	68	{ attrIdentifier = ""
	69	, attrClasses = vec []
	70	, attrProps = vec []
	71	}
55	72
56	73	data ListAttributes = ListAttributes
57	74	{ laWhatever :: Int -- XXX What is this field for?

+31

-0

ptolemy-reader-slackdown/README.md less more

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

+73

-0

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

	1	module Text.Ptolemy.Slackdown.Reader
	2	( SlackdownOpts(..)
	3	, defaultOpts
	4	, inlineOpts
	5	, readSlackdown
	6	) where
	7
	8	import Control.Applicative (empty)
	9	import Data.Text (Text)
	10	import qualified Data.Text as T
	11	import qualified Data.Vector as V
	12	import Text.Megaparsec
	13	import Text.Megaparsec.Text
	14	import Text.Ptolemy.Core (PtolemyError, Document)
	15	import qualified Text.Ptolemy.Core as P
	16
	17	data SlackdownOpts = SlackdownOpts
	18	{ tdBlockElems :: Bool
	19	} deriving (Eq, Show)
	20
	21	defaultOpts :: SlackdownOpts
	22	defaultOpts = SlackdownOpts
	23	{ tdBlockElems = True
	24	}
	25
	26	inlineOpts :: SlackdownOpts
	27	inlineOpts = SlackdownOpts
	28	{ tdBlockElems = False
	29	}
	30
	31	readSlackdown :: SlackdownOpts -> Text -> Either PtolemyError Document
	32	readSlackdown opts tx = case runParser (pSlackdown opts) "[]" tx of
	33	Right x -> Right x
	34	Left err -> Left (P.PtolemyError (show err))
	35
	36	enables :: Bool -> Parser a -> Parser a
	37	enables True p = p
	38	enables False _ = empty
	39
	40	pSlackdown :: SlackdownOpts -> Parser Document
	41	pSlackdown SlackdownOpts { tdBlockElems = blockElems } =
	42	P.vec <$> (many pBlock <* eof)
	43	where pBlock =
	44	blockElems `enables` (pCodeBlock <\|> pQuote) <\|>
	45	pLine
	46
	47	pLine = (P.Plain . flip V.snoc P.LineBreak . P.vec) <$>
	48	manyTill pInline (char '\n')
	49
	50	pQuote = (P.BlockQuote . P.vec) <$> some (char '>' *> pLine)
	51
	52	pCodeBlock = (P.CodeBlock P.emptyAttr . T.concat) <$>
	53	(string "```\n" *> manyTill pPlainLine (string "```\n"))
	54
	55	pPlainLine = T.pack <$> manyTill (noneOf ("\n\r" :: String))
	56	(char '\n')
	57
	58	pInline = pWhitespace
	59	<\|> pString
	60	<\|> (P.Code P.emptyAttr . T.pack) <$>
	61	(char '`' > many (satisfy (/= '`')) < char '`')
	62	<\|> P.Strong <$> pSurrounded '*'
	63	<\|> P.Emph <$> pSurrounded '_'
	64	<\|> P.Strikeout <$> pSurrounded '~'
	65
	66	pWhitespace = (P.Space) <$ some (oneOf (" \t" :: String))
	67
	68	pString = (P.Str . T.pack) <$> some (noneOf ("*_~` \t\r\n" :: String))
	69
	70	pSurrounded :: Char -> Parser P.Chunk
	71	pSurrounded c = try (char c *> rest)
	72	where rest = P.vec <$> (many (notFollowedBy (char c) *> pInline)
	73	<* char c)

+24

-0

ptolemy-reader-slackdown/ptolemy-reader-slackdown.cabal less more

	1	name: ptolemy-reader-slackdown
	2	version: 0.1.0.0
	3	-- synopsis:
	4	-- description
	5	license: BSD3
	6	license-file: LICENSE
	7	author: Getty Ritter
	8	maintainer: gettyritter@gmail.com
	9	copyright: ©2016 Getty Ritter
	10	category: Text
	11	build-type: Simple
	12	cabal-version: >=1.12
	13
	14	library
	15	exposed-modules: Text.Ptolemy.Slackdown.Reader
	16	ghc-options: -Wall
	17	build-depends: base >=4.7 && <4.9,
	18	text,
	19	megaparsec,
	20	vector,
	21	ptolemy-core ==0.1.0.0
	22	default-language: Haskell2010
	23	default-extensions: OverloadedStrings,
	24	ScopedTypeVariables