cheapskate 0.1.0.1 → 0.1.0.2
raw patch · 5 files changed
+110/−15 lines, 5 filesdep +aesondep +http-typesdep +waidep ~basedep ~blaze-htmldep ~mtlnew-component:exe:cheapskate-dingus
Dependencies added: aeson, http-types, wai, wai-extra
Dependency ranges changed: base, blaze-html, mtl, text
Files
- Cheapskate/ParserCombinators.hs +30/−8
- bin/cheapskate-dingus.hs +45/−0
- bin/main.hs +2/−2
- changelog +11/−0
- cheapskate.cabal +22/−5
Cheapskate/ParserCombinators.hs view
@@ -2,6 +2,7 @@ Position(..) , Parser , parse+ , (<?>) , satisfy , peekChar , peekLastChar@@ -38,10 +39,12 @@ import qualified Data.Set as Set data Position = Position { line :: Int, column :: Int }+ deriving (Ord, Eq) instance Show Position where show (Position ln cn) = "line " ++ show ln ++ " column " ++ show cn +-- the String indicates what the parser was expecting data ParseError = ParseError Position String deriving Show data ParserState = ParserState { subject :: Text@@ -87,11 +90,20 @@ {-# INLINE (<*>) #-} instance Alternative Parser where- empty = Parser $ \st -> Left $ ParseError (position st) "empty"+ empty = Parser $ \st -> Left $ ParseError (position st) "(empty)" (Parser f) <|> (Parser g) = Parser $ \st -> case f st of- Right res -> Right res- _ -> g st+ Right res -> Right res+ Left (ParseError pos msg) ->+ case g st of+ Right res -> Right res+ Left (ParseError pos' msg') -> Left $+ case () of+ -- return error for farthest match+ _ | pos' > pos -> ParseError pos' msg'+ | pos' < pos -> ParseError pos msg+ | otherwise {- pos' == pos -}+ -> ParseError pos (msg ++ " or " ++ msg') {-# INLINE empty #-} {-# INLINE (<|>) #-} @@ -106,7 +118,7 @@ {-# INLINE (>>=) #-} instance MonadPlus Parser where- mzero = Parser $ \st -> Left $ ParseError (position st) "mzero"+ mzero = Parser $ \st -> Left $ ParseError (position st) "(mzero)" mplus p1 p2 = Parser $ \st -> case evalParser p1 st of Right res -> Right res@@ -114,6 +126,16 @@ {-# INLINE mzero #-} {-# INLINE mplus #-} +(<?>) :: Parser a -> String -> Parser a+p <?> msg = Parser $ \st ->+ let startpos = position st in+ case evalParser p st of+ Left (ParseError _ _) ->+ Left $ ParseError startpos msg+ Right r -> Right r+{-# INLINE (<?>) #-}+infixl 5 <?>+ parse :: Parser a -> Text -> Either ParseError a parse p t = fmap snd $ evalParser p ParserState{ subject = t@@ -133,7 +155,7 @@ where g st = case T.uncons (subject st) of Just (c, _) | f c -> success (advance st (T.singleton c)) c- _ -> failure st "satisfy"+ _ -> failure st "character meeting condition" {-# INLINE satisfy #-} peekChar :: Parser (Maybe Char)@@ -175,7 +197,7 @@ endOfInput = Parser $ \st -> if T.null (subject st) then success st ()- else failure st "endOfInput"+ else failure st "end of input" {-# INLINE endOfInput #-} char :: Char -> Parser Char@@ -211,7 +233,7 @@ takeWhile1 :: (Char -> Bool) -> Parser Text takeWhile1 f = Parser $ \st -> case T.takeWhile f (subject st) of- t | T.null t -> failure st "takeWhile1"+ t | T.null t -> failure st "characters satisfying condition" | otherwise -> success (advance st t) t {-# INLINE takeWhile1 #-} @@ -225,7 +247,7 @@ skip f = Parser $ \st -> case T.uncons (subject st) of Just (c,_) | f c -> success (advance st (T.singleton c)) ()- _ -> failure st "skip"+ _ -> failure st "character satisfying condition" {-# INLINE skip #-} skipWhile :: (Char -> Bool) -> Parser ()
+ bin/cheapskate-dingus.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where+import Network.Wai.Handler.CGI+import Network.Wai+import Control.Applicative ((<$>))+import Data.Maybe (mapMaybe, fromMaybe)+import Network.HTTP.Types.Status (status200)+import Network.HTTP.Types.Header (hContentType)+import Network.HTTP.Types.URI (queryToQueryText)+import Cheapskate+import Paths_cheapskate (version)+import Data.Version (showVersion)+import qualified Data.Text as T+import Text.Blaze.Html.Renderer.Text+import Text.Blaze.Html+import Data.Aeson+import qualified Data.Text as T+import Data.Text (Text)+import System.Timeout++main :: IO ()+main = do+ mbres <- timeout (4 * 10^6) $ run app+ case mbres of+ Just r -> return r+ Nothing -> error "Pandoc timed out."++app :: Application+app req respond = do+ let query = queryToQueryText $ queryString req+ let getParam x = maybe (error $ T.unpack x ++ " parameter not set")+ return $ lookup x query+ text <- getParam "text" >>= checkLength . fromMaybe T.empty+ let html = renderHtml $ toHtml $ markdown def{ sanitize = False } text+ let output = encode $ object [ T.pack "name" .= T.pack "cheapskate"+ , T.pack "html" .= html+ , T.pack "version" .= T.pack (showVersion version)]+ respond $ responseLBS status200 [(hContentType,"text/json; charset=UTF-8")] output++checkLength :: Text -> IO Text+checkLength t =+ if T.length t > 1000+ then error "exceeds length limit of 1000 characters"+ else return t+
bin/main.hs view
@@ -27,12 +27,12 @@ main = do argv <- getArgs let (flags, args, errs) = getOpt Permute options argv- let header = "Usage: citeproc [OPTION..] [FILE..]"+ let header = "Usage: cheapskate [OPTION..] [FILE..]" unless (null errs) $ do hPutStr stderr $ usageInfo (unlines $ errs ++ [header]) options exitWith $ ExitFailure 1 when (Version `elem` flags) $ do- putStrLn $ "biblio2yaml " ++ showVersion version+ putStrLn $ "cheapskate " ++ showVersion version exitWith ExitSuccess when (Help `elem` flags) $ do putStrLn $ usageInfo header options
changelog view
@@ -1,3 +1,14 @@+cheapskate 0.1.0.2 (08 Dec 2014)++ * Increased upper bounds for text (RyanGlScott), mtl.+ * Fixed usage message in command-line utility (cdosborn).+ * Added flag to build `cheapskate-dingus`.+ * Dingus: extract version from Paths_cheapskate.+ * Fixed compiler warnings.+ * Added `(<?>)`, made string in `ParseError` describe what is expected.+ * On parse failure, return error with greatest position. This generally+ gives more useful messages.+ cheapskate 0.1.0.1 (10 Mar 2014) * Increased version bounds for text, blaze-html.
cheapskate.cabal view
@@ -1,5 +1,5 @@ name: cheapskate-version: 0.1.0.1+version: 0.1.0.2 synopsis: Experimental markdown processor. description: This is an experimental Markdown processor in pure Haskell. It aims to process Markdown efficiently and in@@ -27,6 +27,10 @@ type: git location: git://github.com/jgm/cheapskate.git +Flag dingus+ Description: Build cheapskate-dingus cgi script.+ Default: False+ library hs-source-dirs: . exposed-modules: Cheapskate@@ -36,10 +40,11 @@ other-modules: Cheapskate.Util Cheapskate.Inlines Cheapskate.ParserCombinators+ Paths_cheapskate build-depends: base >=4.4 && <4.8, containers >=0.4 && <0.6,- mtl >=2.1 && <2.2,- text >= 0.9 && < 1.2,+ mtl >=2.1 && <2.3,+ text >= 0.9 && < 1.3, blaze-html >=0.6 && < 0.8, xss-sanitize >= 0.3 && < 0.4, data-default >= 0.5 && < 0.6,@@ -52,12 +57,24 @@ executable cheapskate main-is: main.hs hs-source-dirs: bin- other-extensions: OverloadedStrings build-depends: base >=4.4 && <4.8, cheapskate, bytestring, blaze-html >=0.6 && < 0.8,- text >= 0.9 && < 1.2+ text >= 0.9 && < 1.3 default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind+ ghc-prof-options: -auto-all -caf-all -rtsopts++executable cheapskate-dingus+ main-is: cheapskate-dingus.hs+ hs-source-dirs: bin+ build-depends: base, aeson, cheapskate, blaze-html,+ text, wai-extra, wai >= 0.3, http-types+ default-language: Haskell2010+ if flag(dingus)+ Buildable: True+ else+ Buildable: False ghc-options: -Wall -fno-warn-unused-do-bind ghc-prof-options: -auto-all -caf-all -rtsopts