packages feed

gentlemark (empty) → 1.0.0

raw patch · 7 files changed

+322/−0 lines, 7 filesdep +HUnitdep +basedep +parsecsetup-changed

Dependencies added: HUnit, base, parsec, transformers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Andriy Polishchuk++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of author, nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain
+ gentlemark.cabal view
@@ -0,0 +1,96 @@+name:          gentlemark
+synopsis:      Gentle markup language
+category:      Web, Text
+version:       1.0.0
+cabal-version: >= 1.10
+author:        Andriy Polishchuk
+maintainer:    Andriy Polishchuk <andriy.s.polishchuk@gmail.com>
+homepage:      http://github.com/andriyp/gentlemark
+bug-reports:   http://github.com/andriyp/gentlemark/issues
+copyright:     (c) 2012 Andriy Polishchuk
+license:       BSD3
+license-file:  LICENSE
+build-type:    Simple
+description:
+  GentleMark is a gentle markup language which is designed to fit forum-like systems.     
+  .
+  Styles:
+  .
+  @    
+    \*\*Bold\*\*
+    ~~Italic~~
+    __Underlined__  
+    !!Striked!!
+    %%Spoiler%%
+    \`\`Monospace\`\`
+    $$Latex$$
+  @
+  .
+  Accents:
+  .
+  @
+    /(Quote)/     > I think I can safely say that nobody understands quantum mechanics.
+    /(Reference)/ >>19991
+    /(Hyperlink)/ http:.., https:.., ftp:.., mailto:.., news:.., irc:..
+  @
+  .
+  Unordered lists:
+  .
+  @
+    \- Monad axioms:
+    \- Kleisli composition forms
+    \- a Category
+  @
+  .
+  Ordered lists:
+  .
+  @
+    1. cabal update
+    2. cabal install gentlemark
+  @  
+  .
+  Custom tags:
+  .
+  @
+    [code|haskell] fibs = 0 : 1 : zipWith (+) fibs (tail fibs) [/code]
+    [some-tag|some-option-1|...|some-option-n] something [/some-tag]
+    [foo] bar [/foo]
+  @
+
+source-repository head
+  type:     git
+  location: git://github.com/andriyp/gentlemark.git
+
+library
+  hs-source-dirs: src
+  build-depends:
+    base         >= 4 && < 5,
+    transformers == 0.3.*,
+    parsec       >= 3 && < 4
+  exposed-modules:
+    Text.GentleMark
+    Text.GentleMark.Term
+    Text.GentleMark.Parsec
+  default-language: Haskell2010
+  other-extensions:
+    FlexibleContexts
+    GADTs
+    ConstraintKinds
+    KindSignatures
+    StandaloneDeriving
+  ghc-options: -Wall -fwarn-tabs -O2
+
+test-suite hunit
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: src tests
+  main-is:        hunit.hs
+  build-depends:
+    base         >= 4 && < 5,
+    transformers == 0.3.*,
+    parsec       >= 3 && < 4,
+    HUnit        == 1.2.*
+  default-language: Haskell2010
+  other-extensions:
+    TemplateHaskell
+  ghc-options: -w -threaded
+
+ src/Text/GentleMark.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleContexts, DataKinds, ConstraintKinds #-}
+module Text.GentleMark ( module Text.GentleMark.Term, Source, parse ) where
+
+import Text.GentleMark.Term
+import Text.GentleMark.Parsec
+
+import Control.Applicative hiding ( many )
+import Data.Functor.Identity
+
+import Text.Parsec.Prim hiding ( parse )
+import Text.Parsec.Char
+
+type Source s = Stream s Identity Char
+
+parse :: Source s => s -> [Term Toplevel]
+parse = either (error . show) id . runParser (spaces *> many toplevelTerm) () ""
+ src/Text/GentleMark/Parsec.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE DataKinds, FlexibleContexts #-}
+
+module Text.GentleMark.Parsec
+       ( text
+       , bold, italic, underlined, striked, spoiler
+       , latex, monospace
+       , quote, reference, hyperlink
+       , ulist, olist
+       , tag
+       , paragraph, style, textualTerm, toplevelTerm
+       ) where
+
+import Text.GentleMark.Term
+
+import Control.Applicative hiding ( (<|>), many )
+import Data.Function
+import Data.List
+
+import Text.Parsec hiding ( newline, parse )
+import qualified Text.Parsec as P
+
+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
+(f .: g) x y = f (g x y)
+
+manyTill1 :: Stream s m Char => ParsecT s u m r -> ParsecT s u m e -> ParsecT s u m [r]
+manyTill1 p end = (:) <$> p <*> p `manyTill` end
+
+block :: Stream s m Char => ParsecT s u m r -> String -> ParsecT s u m [r]
+block p sep = (string sep) *> p `manyTill` try (string sep)
+
+eofOr :: Stream s m Char => ParsecT s u m a -> ParsecT s u m ()
+eofOr p = () <$ p <|> eof
+
+whitespaces :: Stream s m Char => ParsecT s u m [Char]
+whitespaces = many (char ' ')
+
+newline :: Stream s m Char => ParsecT s u m ()
+newline = () <$ many1 P.newline <* whitespaces
+
+hyperlinkPrefixes :: [String]
+hyperlinkPrefixes = ["http:", "https:", "ftp:", "mailto:", "news:", "irc:"]
+
+text, bold, italic, underlined, striked, spoiler, latex, monospace, reference, hyperlink, tag, style, textualTerm :: Stream s m Char => ParsecT s u m (Term Textual)
+
+bold       = Bold       <$> block textualTerm "**"
+italic     = Italic     <$> block textualTerm "~~"
+underlined = Underlined <$> block textualTerm "__"
+striked    = Striked    <$> block textualTerm "!!"
+spoiler    = Spoiler    <$> block textualTerm "%%"
+
+latex     = Latex     <$> block anyChar "$$"
+monospace = Monospace <$> block anyChar "``"
+
+reference = Reference <$> (string ">>" *> many1 digit)
+
+hyperlink = Hyperlink .: (++)
+              <$> choice (map string hyperlinkPrefixes)
+              <*> anyChar `manyTill` lookAhead (eofOr space)
+
+tag = do name <- char '[' *> many1 (noneOf "|]")
+         Tag name
+           <$> (many (char '|' *> many (noneOf "|]")) <* char ']')
+           <*> (anyChar `manyTill` eofOr (string ("[/" ++ name ++ "]")))
+
+text = Text .: (:)
+         <$> (noneOf "\n " <|> (char ' ' <* whitespaces))
+         <*> many ((char ' ' <* whitespaces) <|> noneOf (linkChars ++ styleChars ++ ">[\n") <|> nonLink <|> nonStyle)                   
+  where
+    linkChars = map head hyperlinkPrefixes
+    nonLink   = choice nonLinkParsers
+      where nonLinkParsers          = map tryNonLink (groupBy ((==) `on` head) hyperlinkPrefixes)
+            tryNonLink ws@((c:_):_) = try $ char c <* notFollowedBy (choice $ map (string . tail) ws)
+            tryNonLink _            = error "tryNonLink received unsuitable list!"
+    
+    styleChars = "*~_!%$`"
+    nonStyle   = choice $ map (\c -> try $ char c <* notFollowedBy (char c)) styleChars
+
+style        = choice $ map try [bold, italic, underlined, striked, spoiler, latex, monospace]
+textualTerm  = choice [ try reference, try hyperlink, style, try tag, try text ]
+
+quote, ulist, olist, paragraph, toplevelTerm :: Stream s m Char => ParsecT s u m (Term Toplevel)
+
+quote = Quote <$> (char '>' *> anyChar `manyTill` newline)
+
+ulist = UList <$> many1 (char '-' *> whitespaces *> textualTerm `manyTill` eofOr newline)
+
+olist = OList <$> many1 ((,) <$> (read <$> (many1 digit <* char '.'))
+                             <*> (whitespaces *> textualTerm `manyTill` eofOr newline))
+
+paragraph = Paragraph <$> (textualTerm `manyTill1` eofOr newline)
+
+toplevelTerm = choice $ map try [ ulist, olist, quote, paragraph ]
+ src/Text/GentleMark/Term.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving #-}
+module Text.GentleMark.Term ( Type(..), Term(..), tagName, tagOptions, tagBody ) where
+
+data Type = Toplevel | Textual
+
+data Term :: Type -> * where
+  
+  Text       :: String -> Term Textual
+
+  Bold       :: [Term Textual] -> Term Textual
+  Italic     :: [Term Textual] -> Term Textual
+  Underlined :: [Term Textual] -> Term Textual
+  Striked    :: [Term Textual] -> Term Textual
+  Spoiler    :: [Term Textual] -> Term Textual
+  
+  Latex      :: String -> Term Textual
+  Monospace  :: String -> Term Textual                          
+  Reference  :: String -> Term Textual
+  Hyperlink  :: String -> Term Textual
+            
+  Tag        :: String -> [String] -> String -> Term Textual
+
+  Quote      :: String                      -> Term Toplevel
+  UList      :: [[Term Textual]]            -> Term Toplevel
+  OList      :: [(Integer, [Term Textual])] -> Term Toplevel
+  Paragraph  :: [Term Textual]              -> Term Toplevel
+
+deriving instance Eq   (Term t)
+deriving instance Ord  (Term t)
+deriving instance Show (Term t)
+
+tagName :: Term Textual -> String
+tagName (Tag name _ _) = name
+tagName _              = error "Not a Tag-Term!"
+
+tagOptions :: Term Textual -> [String]
+tagOptions (Tag _ options _) = options
+tagOptions _                 = error "Not a Tag-Term!"
+
+tagBody :: Term Textual -> String
+tagBody (Tag _ _ body) = body
+tagBody _              = error "Not a Tag-Term!"
+ tests/hunit.hs view
@@ -0,0 +1,44 @@+module Main where
+
+import Text.GentleMark
+import Data.List
+
+import Test.HUnit
+
+p = parse . intercalate "\n"
+
+case_complex_1 =
+  p [ "  Hello, %%__**~~world~~**__%%:"
+    , "                  > This is quote"
+    , ">And this is quote"
+    , "This"
+    , "   is unordered list:   "
+    , "- foo   "
+    , "  - bar"
+    , "- bazzz"
+    , " This one is ordered:"
+    , "1.     Q"
+    , "  2. RR   RRR   **~~**"
+    , "    3.  [code|haskell]fix f = f (fix f)   [/code]"
+    , "4.    $$  x + y^2    $$"
+    , "   ``    lolo                    2123 lolol"
+    , " asdd 21 3             wioejf"
+    , "lol ``"
+    , " The End. "
+    ] @?= [ Paragraph [Text "Hello, ",Spoiler [Underlined [Bold [Italic [Text "world"]]]],Text ":"]
+          , Quote " This is quote"
+          , Quote "And this is quote"
+          , Paragraph [Text "This"]
+          , Paragraph [Text "is unordered list: "]
+          , UList [[Text "foo "],[Text "bar"],[Text "bazzz"]]
+          , Paragraph [Text "This one is ordered:"]
+          , OList [ (1,[Text "Q"])
+                  , (2,[Text "RR RRR ",Bold [Text "~~"]])
+                  , (3,[Tag "code" ["haskell"] "fix f = f (fix f)   "])
+                  , (4,[Latex "  x + y^2    "]) ]
+          , Paragraph [Monospace "    lolo                    2123 lolol\n asdd 21 3             wioejf\nlol "]
+          , Paragraph [Text "The End. "]
+          ]
+
+main :: IO ()
+main = case_complex_1