Commit 21eba71ed747d3beca8be4674441007062a93266 - telml

Updated TeLML to a parser-library-less, nearly dependency-less implementation Getty Ritter 9 years ago

6 changed file(s) with 101 addition(s) and 94 deletion(s). Collapse all Expand all

-43

~~Data/TeLML/New.hs~~ less more

1		import Data.Char
2
3		type Document = [Chunk]
4		data Chunk
5		= Text String
6		\| Tag String [Document]
7		deriving (Eq, Show)
8
9		isSpecial c = c `elem` "\\{}\|"
10
11
12		pText :: String -> (String, Chunk)
13		pText = fmap Text . go
14		where go ('\\':x:xs)
15		\| isSpecial x = fmap (x:) (go xs)
16		go i@(x:xs)
17		\| isSpecial x = (i, "")
18		\| otherwise = fmap (x:) (go xs)
19		go "" = ("", "")
20
21		pTagName :: String -> (String, String)
22		pTagName i@(x:xs)
23		\| isAlpha x = fmap (x:) (pTagName xs)
24		\| elem x "-_" = fmap (x:) (pTagName xs)
25		\| otherwise = (i, "")
26
27		skipSpace :: String -> (String, ())
28		skipSpace i@(x:xs)
29		\| isSpace x = skipSpace xs
30		\| otherwise = (i, ())
31
32		pTag :: String -> (String, Chunk)
33		pTag i =
34		let (i', name) = pTagName i
35		in case skipSpace i' of
36		('{':i'') -> fmap (Tag name) (pArgs i'')
37		otherwise -> error "expected start of block"
38
39		pArgs :: String -> (String, [Document])
40		pArgs ('\|')
41
42		pChunk :: String -> (String, Chunk)
43		pChunk = undefined

+67

-33

Data/TeLML/Parser.hs less more

1		{-# LANGUAGE ~~OverloadedStrings~~ #-}
	1	{-# LANGUAGE LambdaCase #-}
2	2
3		module Data.TeLML.Parser (Fragment(..), ~~parseDocument~~) where
	3	module Data.TeLML.Parser (Fragment(..), Document, parse) where
4	4
5		import Control.Applicative
6		import Data.Attoparsec.Text
7		import Data.Char (isAlphaNum)
8		import Data.Text (Text)
9		import qualified Data.Text as T
10		import Prelude hiding (takeWhile)
	5	import Data.Char (isAlpha, isSpace)
	6	import Data.TeLML.Type
11	7
12		data Fragment
13		= Chunk Text
14		\| Tag Text [Fragment]
15		deriving (Eq, Show)
	8	type Result a = Either String (String, a)
	9	type Parse a = String -> Result a
16	10
17	11	isSpecial :: Char -> Bool
18		isSpecial '\\' = True
19		isSpecial '{' = True
20		isSpecial '}' = True
21		isSpecial '\|' = True
22		isSpecial ~~_ = False~~
	12	isSpecial c = c `elem` "\\{}\|"
23	13
24		isTagChar :: Char -> Bool
25		isTagChar c = isAlphaNum c
	14	throw :: a -> Either a b
	15	throw = Left
26	16
27		parseFg :: Parser Fragment
28		parseFg = (char '\\' *> parseBk)
29		<\|> (char '{' *> parseFg)
30		<\|> (Chunk <$> takeWhile1 (not . isSpecial))
	17	over :: (a -> b) -> Result a -> Result b
	18	over _ (Left err) = Left err
	19	over f (Right (s, x)) = Right (s, f x)
31	20
32		parseBk :: Parser Fragment
33		parseBk = (char '\\' *> pure (Chunk "\\"))
34		<\|> (char '\|' *> pure (Chunk "\|"))
35		<\|> parseTag
	21	bind :: Result a -> ((String, a) -> Result b) -> Result b
	22	bind (Left err) _ = Left err
	23	bind (Right a) f = f a
36	24
37		parseTag :: Parser Fragment
38		parseTag =
39		Tag <$> (takeWhile isTagChar <* many space)
40		<> (char '{' > sepBy parseFg (char '\|') <* char '}')
	25	pText :: Parse Fragment
	26	pText = over Text . go
	27	where go ('\\':x:xs)
	28	\| isSpecial x = (x:) `over` go xs
	29	go i@(x:xs)
	30	\| isSpecial x = return (i, "")
	31	\| otherwise = (x:) `over` go xs
	32	go "" = return ("", "")
41	33
42		parseDocument :: Text -> Either String [Fragment]
43		parseDocument = parseOnly (many parseFg <* endOfInput)
	34	pTagName :: Parse String
	35	pTagName i@(x:xs)
	36	\| isAlpha x = (x:) `over` pTagName xs
	37	\| elem x "-_" = (x:) `over` pTagName xs
	38	\| otherwise = return (i, "")
	39
	40	skipSpace :: Parse ()
	41	skipSpace i@(x:xs)
	42	\| isSpace x = skipSpace xs
	43	\| otherwise = return (i, ())
	44
	45	pTag :: Parse Fragment
	46	pTag i =
	47	bind (pTagName i) $ \ (i', name) ->
	48	bind (skipSpace i') $ \case
	49	('{':i'', ()) -> Tag name `over` pArgs i''
	50	_ -> throw "expected start of block"
	51
	52	pArgs :: Parse [Document]
	53	pArgs ('}':xs) = return (xs, [])
	54	pArgs s = bind (pFragments s) $ \case
	55	('\|':xs, cs) -> (cs:) `over` pArgs xs
	56	('}':xs, cs) -> return (xs, [cs])
	57	_ -> throw "[unreachable]"
	58
	59	pFragment :: Parse Fragment
	60	pFragment s@('\\':c:_)
	61	\| isSpecial c = pText s
	62	pFragment ('\\':xs) = pTag xs
	63	pFragment s = pText s
	64
	65	pFragments :: Parse Document
	66	pFragments "" = return ("", [])
	67	pFragments s@(x:_)
	68	\| x `elem` "}\|" = return (s, [])
	69	\| otherwise =
	70	bind (pFragment s) $ \case
	71	(s', c) -> (c:) `over` pFragments s'
	72
	73	parse :: String -> Either String Document
	74	parse s = case pFragments s of
	75	Right ("", r) -> return r
	76	Right (s, _) -> throw ("expected end of document but found " ++ show s)
	77	Left err -> throw err

+21

-0

Data/TeLML/Type.hs less more

	1	{-# LANGUAGE DeriveDataTypeable #-}
	2
	3	module Data.TeLML.Type (Document, Fragment(..)) where
	4
	5	import Control.DeepSeq (NFData(..))
	6	import Data.Data (Data)
	7	import Data.Typeable (Typeable)
	8	import Data.String (IsString(..))
	9
	10	type Document = [Fragment]
	11	data Fragment
	12	= Text String
	13	\| Tag String [Document]
	14	deriving (Eq, Show, Typeable, Data)
	15
	16	instance IsString Fragment where
	17	fromString = Text
	18
	19	instance NFData Fragment where
	20	rnf (Text s) = rnf s
	21	rnf (Tag s l) = rnf s `seq` rnf l

-9

Data/TeLML.hs less more

1	1	module Data.TeLML(parse, Document, Fragment(..)) where
2	2
3	3	import Data.TeLML.Parser
4		import Data.Text (Text)
5
6		type Document = [Fragment]
7
8		parse :: Text -> Maybe Document
9		parse t =
10		case parseDocument t of
11		Left _ -> Nothing
12		Right d -> Just d

+11

-7

src/Main.hs less more

4	4
5	5	import Data.Aeson (Value(..), encode, object, (.=))
6	6	import qualified Data.ByteString.Lazy.Char8 as BS
7		import Data.Maybe (fromJust)
8	7	import Data.TeLML
9	8	import Data.Vector (fromList)
10	9	import qualified Data.Text as T
11		import qualified Data.Text.IO as T
12	10
13	11	telmlToValue :: Fragment -> Value
14		telmlToValue (~~Chunk t) = String t~~
	12	telmlToValue (Text t) = String (T.pack t)
15	13	telmlToValue (Tag t ts) = object
16		[ "name" .= String t
17		, "contents" .= Array (fromList (map telmlToValue ts))
	14	[ "name" .= String (T.pack t)
	15	, "contents" .= arr (map (arr . map telmlToValue) ts)
18	16	]
	17	where arr = Array . fromList
	18
	19	fromRight (Right x) = x
	20	fromRight _ = undefined
19	21
20	22	main = do
21		contents <- T.getContents
22		BS.putStrLn . encode . map telmlToValue . fromJust . parse $ contents
	23	r <- fmap parse getContents
	24	case r of
	25	Right x -> BS.putStrLn . encode . map telmlToValue $ x
	26	Left err -> putStrLn err

-2

telml.cabal less more

13	13
14	14	library
15	15	exposed-modules: Data.TeLML
16		other-modules: Data.TeLML.Parser
17		build-depends: base >=4.7 && <4.8, text, attoparsec
	16	other-modules: Data.TeLML.Parser, Data.TeLML.Type
	17	build-depends: base >=4.7 && <4.9, deepseq
18	18	default-language: Haskell2010
19	19
20	20	executable from-telml