├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── bower.json ├── package.json ├── src └── Text │ └── Markdown │ ├── SlamDown.purs │ └── SlamDown │ ├── Eval.purs │ ├── Parser.purs │ ├── Parser │ ├── Inline.purs │ ├── References.purs │ └── Utils.purs │ ├── Pretty.purs │ ├── Syntax.purs │ ├── Syntax │ ├── Block.purs │ ├── FormField.purs │ ├── Inline.purs │ ├── TextBox.purs │ └── Value.purs │ └── Traverse.purs └── test └── src └── Test └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /.* 2 | !/.gitignore 3 | !/.travis.yml 4 | /bower_components/ 5 | /node_modules/ 6 | /output/ 7 | package-lock.json 8 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: node_js 2 | dist: trusty 3 | sudo: required 4 | node_js: stable 5 | install: 6 | - npm install -g bower 7 | - npm install 8 | - bower install --production 9 | script: 10 | - npm run -s build 11 | - bower install 12 | - npm -s test 13 | after_success: 14 | - >- 15 | test $TRAVIS_TAG && 16 | echo $GITHUB_TOKEN | pulp login && 17 | echo y | pulp publish --no-push 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 SlamData, Inc. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | 24 | 25 | purescript-markdown uses code from the following libraries. Their license files follow. 26 | 27 | cheapskate 28 | 29 | cheapskate LICENSE file: 30 | 31 | Copyright (c) 2013, John MacFarlane 32 | 33 | All rights reserved. 34 | 35 | Redistribution and use in source and binary forms, with or without 36 | modification, are permitted provided that the following conditions are met: 37 | 38 | * Redistributions of source code must retain the above copyright 39 | notice, this list of conditions and the following disclaimer. 40 | 41 | * Redistributions in binary form must reproduce the above 42 | copyright notice, this list of conditions and the following 43 | disclaimer in the documentation and/or other materials provided 44 | with the distribution. 45 | 46 | * Neither the name of John MacFarlane nor the names of other 47 | contributors may be used to endorse or promote products derived 48 | from this software without specific prior written permission. 49 | 50 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 51 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 52 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 53 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 54 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 55 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 56 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 57 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 58 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 59 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 60 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 61 | 62 | 63 | 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-markdown 2 | 3 | [![Latest release](http://img.shields.io/github/release/slamdata/purescript-markdown.svg)](https://github.com/slamdata/purescript-markdown/releases) 4 | [![Build status](https://travis-ci.org/slamdata/purescript-markdown.svg?branch=master)](https://travis-ci.org/slamdata/purescript-markdown) 5 | 6 | A Purescript library for parsing SlamData's dialect of Markdown, called *SlamDown*, which is mostly a safe, clean subset of CommonMark. 7 | 8 | ## Installation 9 | 10 | ``` 11 | bower install purescript-markdown 12 | ``` 13 | 14 | ## Usage 15 | 16 | 17 | ```purescript 18 | import Text.Markdown.SlamDown 19 | import Text.Markdown.SlamDown.Parser 20 | 21 | -- parsing 22 | case parseMd "# foo" of 23 | SlamDown [Header 1 (Text "foo")] -> trace "matched!" 24 | _ -> trace "did not match!" 25 | 26 | import Text.Markdown.SlamDown.Pretty 27 | 28 | -- rendering 29 | (trace <<< prettyPrintMd <<< parseMd) "# foo" 30 | ``` 31 | 32 | ### API 33 | 34 | Module documentation is [published on 35 | Pursuit](http://pursuit.purescript.org/packages/purescript-markdown). 36 | 37 | ## Features 38 | 39 | In general, SlamDown is a subset of [CommonMark](http://spec.commonmark.org/), supporting the following features: 40 | 41 | * Leaf Blocks 42 | * Horizontal rules 43 | * ATX headers 44 | * Setext headers 45 | * Indented code blocks 46 | * Fenced code blocks 47 | * Linked reference definitions 48 | * Paragraphs 49 | * Blank line 50 | * Container Blocks 51 | * Block quotes 52 | * List items 53 | * Lists 54 | * Inlines 55 | * Backslash escapes 56 | * Entities 57 | * Code span 58 | * Emphasis and strong emphasis 59 | * Links 60 | * Images 61 | * Autolinks 62 | * Hard line breaks 63 | * Soft line breaks 64 | * Strings 65 | 66 | Notably, HTML is not supported. Possibly, a safe subset of HTML could be added at some point in time. 67 | 68 | In addition, a few simplifications have been made to exclude some more obscure and redundant cases. This makes the parser much simpler and cleans up the code considerably (if you really need full compatibility, PRs are welcome!). 69 | 70 | The parser produces an ADT which describes the structure of the document. 71 | 72 | ## Extensions to CommonMark 73 | 74 | SlamDown extends CommonMark in several ways: 75 | 76 | * **Evaluated code blocks** — These code blocks are evaluated by the Markdown application and results of the evaluation are inserted into the document. This is similar to an image which is essentially an evaluated link (restricted to image links). 77 | * **Form Elements** — Form elements may be named, given default values, and embedded into a document. The host application decides what to do with them, if anything — beyond rendering them as forms. 78 | 79 | ### Code Evaluation 80 | 81 | Fenced code blocks may be evaluated by prefixing them with an exclamation point character (`!`). The result of evaluating the code is then inserted into the document at that location. 82 | 83 | For example, in a document supporting evaluation of Javascript, the inline code block !`1 + 2` would be evaluated and the resulting number (`3`) would be inserted into the document at that location. 84 | 85 | Code evaluation may be used for inline or block-level fenced code. 86 | 87 | If an info-string is specified, the evaluation must use the specified language or error. If no info-string is specified, the default language understood by the Markdown application is used. 88 | 89 | Note that code may be delimited by any number of backticks, so long as the same number of backticks is used on either side; in case the expression being embedded contains a backtick, longer delimiters can be used to prevent this backtick from being parsed as a delimiter. For example: 90 | 91 | !``the `backticks` are taking over!`` 92 | 93 | 94 | **Note**: This library does not provide any support for evaluation of code, and the code snippets are treated as completely opaque, but the documentation does define *semantics* for how these blocks interact with other elements and with the rendering of the document. 95 | 96 | Code evaluation is provided by the `eval` function, which takes an evaluation function, and replaces code blocks and inline code with the evaluated content. More general evaluation functions (for example, evaluating _form elements_ can be constructed using the `everywhere` function to traverse the `SlamDown` ADT). 97 | 98 | ### Form Elements 99 | 100 | Form fields allow the collection of named, weakly-typed user-input. All fields may have default values, and while it's possible to hard-code all static data and default values for all fields, it is also possible to use this feature in conjunction with code evaluation, so that data and default values are generated dynamically by evaluating code. 101 | 102 | Although the suggested syntax has been modified to be more consistent (with respect to default values) and extended to include other types (e.g. dates and times), original credit to [Yevgeniy Brikman](http://brikis98.blogspot.com/2011/07/proposal-extend-markdown-syntax-to.html) for the idea of allowing forms in Markdown. 103 | 104 | #### Text Input 105 | 106 | ``` 107 | name = ________ 108 | 109 | name = ________ (default) 110 | 111 | name = ________ (!`...`) 112 | ``` 113 | 114 | If code evaluation is used to produce the default, then the snippet must evaluate to textual content. 115 | 116 | #### Numeric Input 117 | 118 | ``` 119 | age = #________ 120 | 121 | age = #________ (29) 122 | 123 | age = #________ (!`...`) 124 | ``` 125 | 126 | If code evaluation is used to produce the default, then the snippet must evaluate to numeric content. 127 | 128 | #### Radio Buttons 129 | 130 | ``` 131 | sex = (x) male () female 132 | 133 | sex = (!`...`) !`...` 134 | ``` 135 | 136 | If code evaluation is used to produce the values, then the first snippet must evaluate to a label, and the second snippet must evaluate to a list of labels. 137 | 138 | #### Checkboxes 139 | 140 | ``` 141 | phones = [] Android [x] iPhone [x] Blackberry 142 | 143 | phones = [!`..`] !`...` 144 | ``` 145 | 146 | If code evaluation is used to produce the values, then both snippets must evaluate to a list of strings. The second list defines the checkboxes' labels and the first defines which checkboxes are to be checked. Checkboxes whose labels are included in the first list will be checked. 147 | 148 | #### Dropdowns 149 | 150 | ``` 151 | city = {BOS, SFO, NYC} 152 | 153 | city = {BOS, SFO, NYC} (NYC) 154 | 155 | city = {!`...`} (!`...`) 156 | ``` 157 | 158 | If code evaluation is used to produce the set of choices, the snippet must evaluate to a list of labels. If code evaluation is used to produce the default choice, the snippet must evaluate to a label. 159 | 160 | #### Date 161 | 162 | ``` 163 | start = __ - __ - ____ 164 | 165 | start = __ - __ - ____ (2015-06-06) 166 | 167 | start = __ - __ - ____ (!`...`) 168 | ``` 169 | 170 | If code evaluation is used to produce the default, the snippet must evaluate to a date. 171 | 172 | #### Time 173 | 174 | ``` 175 | start = __ : __ 176 | 177 | start = __ : __ (22:32) 178 | 179 | start = __ : __ (!`...`) 180 | ``` 181 | 182 | If code evaluation is used to produce the default, the snippet must evaluate to a time. 183 | 184 | #### DateTime 185 | 186 | ``` 187 | start = __ - __ - ____ __ : __ 188 | 189 | start = __ - __ - ____ __ : __ (2015-06-06T12:00) 190 | 191 | start = __ - __ - ____ __ : __ (!`...`) 192 | ``` 193 | 194 | If code evaluation is used to produce the default, the snippet must evaluate to a date / time. 195 | 196 | #### Required Fields 197 | 198 | ``` 199 | zip* = ________ (12345) 200 | ``` 201 | 202 | #### Fields with spaces in the label 203 | 204 | ``` 205 | [first name] = ________ (default) 206 | 207 | [zip code]* = ________ (12345) 208 | ``` 209 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-markdown", 3 | "license": "MIT", 4 | "authors": [ 5 | "John A. De Goes (http://degoes.net)", 6 | "Phil Freeman ", 7 | "Gary Burgess ", 8 | "Jon Sterling " 9 | ], 10 | "repository": { 11 | "type": "git", 12 | "url": "git://github.com/slamdata/purescript-markdown.git" 13 | }, 14 | "ignore": [ 15 | "**/.*", 16 | "bower_components", 17 | "node_modules", 18 | "output", 19 | "test", 20 | "bower.json", 21 | "gulpfile.js", 22 | "package.json" 23 | ], 24 | "dependencies": { 25 | "purescript-const": "^4.0.0", 26 | "purescript-datetime": "^4.0.0", 27 | "purescript-functors": "^3.0.1", 28 | "purescript-lists": "^5.0.0", 29 | "purescript-ordered-collections": "^1.0.0", 30 | "purescript-parsing": "^5.0.1", 31 | "purescript-partial": "^2.0.0", 32 | "purescript-precise": "^3.0.1", 33 | "purescript-prelude": "^4.0.1", 34 | "purescript-strings": "^4.0.0", 35 | "purescript-unicode": "^4.0.1", 36 | "purescript-validation": "^4.0.0" 37 | }, 38 | "devDependencies": { 39 | "purescript-assert": "^4.0.0" 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "clean": "rimraf output && rimraf .pulp-cache", 5 | "build": "pulp build -- --censor-lib --strict", 6 | "test": "pulp test" 7 | }, 8 | "devDependencies": { 9 | "pulp": "^12.3.0", 10 | "purescript": "^0.12.0", 11 | "purescript-psa": "^0.6.0", 12 | "rimraf": "^2.5.4" 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown 2 | ( module Text.Markdown.SlamDown.Syntax 3 | ) where 4 | 5 | import Text.Markdown.SlamDown.Syntax 6 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Eval.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Eval 2 | ( eval 3 | , LanguageId 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Control.Alt ((<|>)) 9 | 10 | import Data.Array as A 11 | import Data.Const (Const(..)) 12 | import Data.Functor.Compose (Compose(..)) 13 | import Data.Identity (Identity(..)) 14 | import Data.List as L 15 | import Data.Maybe as M 16 | import Data.Newtype (unwrap) 17 | import Data.String as S 18 | import Data.Traversable as T 19 | 20 | import Text.Markdown.SlamDown.Syntax as SD 21 | import Text.Markdown.SlamDown.Traverse (everywhereM) 22 | 23 | type LanguageId = String 24 | 25 | eval 26 | ∷ ∀ m a 27 | . Monad m 28 | ⇒ SD.Value a 29 | ⇒ { code ∷ M.Maybe LanguageId → String → m a 30 | , textBox ∷ String → SD.TextBox (Const String) → m (SD.TextBox Identity) 31 | , value ∷ String → String → m a 32 | , list ∷ String → String → m (L.List a) 33 | } 34 | → SD.SlamDownP a 35 | → m (SD.SlamDownP a) 36 | eval fs = everywhereM b i 37 | where 38 | 39 | b ∷ SD.Block a → m (SD.Block a) 40 | b (SD.CodeBlock (SD.Fenced true info) code) = 41 | SD.CodeBlock (SD.Fenced false info) <<< pure <<< SD.renderValue 42 | <$> fs.code (M.Just info) (S.joinWith "\n" (A.fromFoldable code)) 43 | b other = pure $ other 44 | 45 | i ∷ SD.Inline a → m (SD.Inline a) 46 | i (SD.Code true code) = SD.Code false <<< SD.renderValue <$> fs.code M.Nothing code 47 | i (SD.FormField lbl r field) = SD.FormField lbl r <$> f lbl field 48 | i other = pure $ other 49 | 50 | f ∷ String → SD.FormField a → m (SD.FormField a) 51 | f lbl (SD.TextBox tb) = SD.TextBox <<< M.fromMaybe tb <$> nbeTextBox tb 52 | where 53 | -- normalization-by-evaluation proceeds by evaluating an object into a semantic model 54 | -- (in this case, `Identity`), and then quoting the result back into the syntax. 55 | nbeTextBox ∷ SD.TextBox (Compose M.Maybe SD.Expr) → m (M.Maybe (SD.TextBox (Compose M.Maybe SD.Expr))) 56 | nbeTextBox = evalTextBox >>> map (map quoteTextBox) 57 | 58 | evalTextBox ∷ SD.TextBox (Compose M.Maybe SD.Expr) → m (M.Maybe (SD.TextBox Identity)) 59 | evalTextBox tb' = T.sequence $ fs.textBox lbl <$> asCode tb' <|> pure <$> asLit tb' 60 | where 61 | asLit = SD.traverseTextBox (unwrap >>> (_ >>= SD.getLiteral) >>> map Identity) 62 | asCode = SD.traverseTextBox (unwrap >>> (_ >>= SD.getUnevaluated) >>> map Const) 63 | 64 | quoteTextBox ∷ SD.TextBox Identity → SD.TextBox (Compose M.Maybe SD.Expr) 65 | quoteTextBox = SD.transTextBox (unwrap >>> SD.Literal >>> M.Just >>> Compose) 66 | 67 | f lbl (SD.RadioButtons sel opts) = do 68 | sel' ← evalExpr lbl fs.value sel 69 | opts' ← evalExpr lbl fs.list opts 70 | pure $ SD.RadioButtons sel' (mergeSelection (L.singleton <$> sel') opts') 71 | 72 | f lbl (SD.CheckBoxes sel vals) = do 73 | sel' ← evalExpr lbl fs.list sel 74 | vals' ← evalExpr lbl fs.list vals 75 | pure $ SD.CheckBoxes sel' (mergeSelection sel' vals') 76 | 77 | f lbl (SD.DropDown msel opts) = do 78 | msel' ← T.traverse (evalExpr lbl fs.value) msel 79 | opts' ← evalExpr lbl fs.list opts 80 | pure $ SD.DropDown msel' $ M.maybe opts' (flip mergeSelection opts' <<< map L.singleton) msel' 81 | 82 | mergeSelection ∷ SD.Expr (L.List a) → SD.Expr (L.List a) → SD.Expr (L.List a) 83 | mergeSelection (SD.Literal sel) (SD.Literal xs) = SD.Literal $ L.union sel xs 84 | mergeSelection _ exs = exs 85 | 86 | evalExpr ∷ ∀ e. String → (String → String → m e) → SD.Expr e → m (SD.Expr e) 87 | evalExpr _ _ (SD.Literal a) = pure $ SD.Literal a 88 | evalExpr l e (SD.Unevaluated s) = SD.Literal <$> e l s 89 | 90 | getValues ∷ ∀ e. SD.Expr (L.List e) → L.List e 91 | getValues (SD.Literal vs) = vs 92 | getValues _ = L.Nil 93 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Parser.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Parser 2 | ( parseMd 3 | , validateBlock 4 | , validateSlamDown 5 | ) where 6 | 7 | import Prelude hiding (min) 8 | 9 | import Data.Either (Either) 10 | import Data.Foldable (any, all) 11 | import Data.List ((:)) 12 | import Data.List as L 13 | import Data.Maybe as M 14 | import Data.String (Pattern(..), Replacement(..), drop, length, replace, split, take, trim) as S 15 | import Data.String.CodeUnits (countPrefix, dropWhile, singleton) as S 16 | import Data.String.Regex as RGX 17 | import Data.String.Regex.Unsafe as URX 18 | import Data.String.Regex.Flags as RXF 19 | import Data.Traversable (traverse) 20 | import Data.Validation.Semigroup as V 21 | 22 | import Partial.Unsafe (unsafePartial) 23 | 24 | import Text.Markdown.SlamDown.Parser.Inline as Inline 25 | import Text.Markdown.SlamDown.Parser.References as Ref 26 | import Text.Markdown.SlamDown.Syntax as SD 27 | 28 | data Container a 29 | = CText String 30 | | CBlank 31 | | CRule 32 | | CATXHeader Int String 33 | | CSetextHeader Int 34 | | CBlockquote (L.List (Container a)) 35 | | CListItem SD.ListType (L.List (Container a)) 36 | | CCodeBlockFenced Boolean String (L.List String) 37 | | CCodeBlockIndented (L.List String) 38 | | CLinkReference (SD.Block a) 39 | 40 | isSpace ∷ String → Boolean 41 | isSpace " " = true 42 | isSpace _ = false 43 | 44 | isDigit ∷ String → Boolean 45 | isDigit "0" = true 46 | isDigit "1" = true 47 | isDigit "2" = true 48 | isDigit "3" = true 49 | isDigit "4" = true 50 | isDigit "5" = true 51 | isDigit "6" = true 52 | isDigit "7" = true 53 | isDigit "8" = true 54 | isDigit "9" = true 55 | isDigit _ = false 56 | 57 | allChars ∷ (String → Boolean) → String → Boolean 58 | allChars p = all p <<< S.split (S.Pattern "") 59 | 60 | removeNonIndentingSpaces ∷ String → String 61 | removeNonIndentingSpaces s 62 | | S.countPrefix (isSpace <<< S.singleton) s < 4 = S.dropWhile (isSpace <<< S.singleton) s 63 | | otherwise = s 64 | 65 | isRuleChar ∷ String → Boolean 66 | isRuleChar "*" = true 67 | isRuleChar "-" = true 68 | isRuleChar "_" = true 69 | isRuleChar _ = false 70 | 71 | isRule ∷ String → Boolean 72 | isRule s = 73 | allChars isRuleChar s 74 | && S.length s >= 3 75 | && allChars ((==) (S.take 1 s)) s 76 | 77 | isATXHeader ∷ String → Boolean 78 | isATXHeader s = 79 | let 80 | level = S.countPrefix (\c → S.singleton c == "#") s 81 | rest = S.drop level s 82 | in 83 | level >= 1 && level <= 6 && S.take 1 rest == " " 84 | 85 | splitATXHeader ∷ String → { level ∷ Int, contents ∷ String } 86 | splitATXHeader s = 87 | let 88 | level = S.countPrefix (\c → S.singleton c == "#") s 89 | contents = S.drop (level + 1) s 90 | in 91 | { level: level 92 | , contents: contents 93 | } 94 | 95 | -- Takes the last parsed container as an argument 96 | -- to avoid parsing a rule as a header 97 | isSetextHeader ∷ ∀ a. String → M.Maybe (Container a) → Boolean 98 | isSetextHeader s (M.Just (CText _)) = S.length s >= 1 && any (\c → allChars ((==) c) s) ["=", "-"] 99 | isSetextHeader _ _ = false 100 | 101 | setextLevel ∷ String → Int 102 | setextLevel s 103 | | S.take 1 s == "=" = 1 104 | | otherwise = 2 105 | 106 | isBlockquoteLine ∷ String → Boolean 107 | isBlockquoteLine s = S.take 1 (removeNonIndentingSpaces s) == ">" 108 | 109 | splitBlockquote ∷ L.List String → { blockquoteLines ∷ L.List String , otherLines ∷ L.List String } 110 | splitBlockquote ss = 111 | let 112 | sp = L.span isBlockquoteLine ss 113 | bq = map (blockquoteContents <<< removeNonIndentingSpaces) sp.init 114 | in 115 | { blockquoteLines: bq 116 | , otherLines: sp.rest 117 | } 118 | where 119 | blockquoteContents ∷ String → String 120 | blockquoteContents s = S.drop (if S.take 2 s == "> " then 2 else 1) s 121 | 122 | countLeadingSpaces ∷ String → Int 123 | countLeadingSpaces = S.countPrefix (isSpace <<< S.singleton) 124 | 125 | isBulleted ∷ String → Boolean 126 | isBulleted s = 127 | let 128 | b = S.take 1 s 129 | ls = countLeadingSpaces (S.drop 1 s) 130 | in 131 | isBullet b && ls > 0 && ls < 5 132 | where 133 | isBullet ∷ String → Boolean 134 | isBullet "*" = true 135 | isBullet "+" = true 136 | isBullet "-" = true 137 | isBullet _ = false 138 | 139 | isOrderedListMarker ∷ String → Boolean 140 | isOrderedListMarker s = 141 | let 142 | n = S.countPrefix (isDigit <<< S.singleton) s 143 | next = S.take 1 (S.drop n s) 144 | ls = countLeadingSpaces (S.drop (n + 1) s) 145 | in 146 | n > 0 && (next == "." || next == ")") && ls > 0 147 | 148 | listItemType ∷ String → SD.ListType 149 | listItemType s 150 | | isBulleted s = SD.Bullet (S.take 1 s) 151 | | otherwise = 152 | let n = S.countPrefix (isDigit <<< S.singleton) s 153 | in SD.Ordered (S.take 1 (S.drop n s)) 154 | 155 | listItemIndent ∷ String → Int 156 | listItemIndent s 157 | | isBulleted s = 1 + min 4 (countLeadingSpaces (S.drop 1 s)) 158 | | otherwise = 159 | let n = S.countPrefix (isDigit <<< S.singleton) s 160 | in n + 1 + min 4 (countLeadingSpaces (S.drop (n + 1) s)) 161 | 162 | isListItemLine ∷ String → Boolean 163 | isListItemLine s = 164 | let s' = removeNonIndentingSpaces s 165 | in isBulleted s' || isOrderedListMarker s' 166 | 167 | isIndentedTo ∷ Int → String → Boolean 168 | isIndentedTo n s = countLeadingSpaces s >= n 169 | 170 | splitListItem 171 | ∷ String 172 | → L.List String 173 | → { listType ∷ SD.ListType 174 | , listItemLines ∷ L.List String 175 | , otherLines ∷ L.List String 176 | } 177 | splitListItem s ss = 178 | let 179 | s1 = removeNonIndentingSpaces s 180 | sp = L.span (isIndentedTo indent) ss 181 | indent = listItemIndent s1 182 | listItemLines = L.Cons (S.drop indent s1) $ map (S.drop indent) sp.init 183 | listType = listItemType s1 184 | in 185 | { listType: listType 186 | , listItemLines: listItemLines 187 | , otherLines: sp.rest 188 | } 189 | 190 | isIndentedChunk ∷ String → Boolean 191 | isIndentedChunk s = isIndentedTo 4 s 192 | 193 | fromIndentedChunk ∷ String → String 194 | fromIndentedChunk = S.drop 4 195 | 196 | splitIndentedChunks 197 | ∷ L.List String 198 | → { codeLines ∷ L.List String 199 | , otherLines ∷ L.List String 200 | } 201 | splitIndentedChunks ss = 202 | let 203 | sp = L.span isIndentedChunk ss 204 | codeLines = map fromIndentedChunk sp.init 205 | in 206 | { codeLines: codeLines 207 | , otherLines: sp.rest 208 | } 209 | 210 | isCodeFence ∷ String → Boolean 211 | isCodeFence s = isSimpleFence s || (isEvaluatedCode s && isSimpleFence (S.drop 1 s)) 212 | where 213 | isSimpleFence s' = S.countPrefix (isFenceChar <<< S.singleton) s' >= 3 214 | 215 | isEvaluatedCode ∷ String → Boolean 216 | isEvaluatedCode s = S.take 1 s == "!" 217 | 218 | isFenceChar ∷ String → Boolean 219 | isFenceChar "~" = true 220 | isFenceChar "`" = true 221 | isFenceChar _ = false 222 | 223 | codeFenceInfo ∷ String → String 224 | codeFenceInfo = S.trim <<< S.dropWhile (isFenceChar <<< S.singleton) 225 | 226 | codeFenceChar ∷ String → String 227 | codeFenceChar = S.take 1 228 | 229 | splitCodeFence 230 | ∷ Int 231 | → String 232 | → L.List String 233 | → { codeLines ∷ L.List String 234 | , otherLines ∷ L.List String 235 | } 236 | splitCodeFence indent fence ss = 237 | let 238 | sp = L.span (not <<< isClosingFence) ss 239 | codeLines = map removeIndentTo sp.init 240 | in 241 | { codeLines: codeLines 242 | , otherLines: L.drop 1 sp.rest 243 | } 244 | where 245 | isClosingFence ∷ String → Boolean 246 | isClosingFence s = S.countPrefix (\c → S.singleton c == fence) (removeNonIndentingSpaces s) >= 3 247 | 248 | removeIndentTo ∷ String → String 249 | removeIndentTo s = S.drop (min indent (countLeadingSpaces s)) s 250 | 251 | isLinkReference ∷ String → Boolean 252 | isLinkReference s = S.take 1 s == "[" && M.isJust (Ref.parseLinkReference s) 253 | 254 | min ∷ ∀ a. (Ord a) ⇒ a → a → a 255 | min n m = if n < m then n else m 256 | 257 | parseContainers 258 | ∷ ∀ a 259 | . L.List (Container a) 260 | → L.List String 261 | → L.List (Container a) 262 | parseContainers acc L.Nil = L.reverse acc 263 | parseContainers acc (L.Cons s ss) 264 | | allChars isSpace s = 265 | parseContainers (L.Cons CBlank acc) ss 266 | | isATXHeader (removeNonIndentingSpaces s) = 267 | let o = splitATXHeader (removeNonIndentingSpaces s) 268 | in parseContainers (L.Cons (CATXHeader o.level o.contents) acc) ss 269 | | isSetextHeader (removeNonIndentingSpaces (S.trim s)) (L.last acc) = 270 | parseContainers (L.Cons (CSetextHeader $ setextLevel (removeNonIndentingSpaces (S.trim s))) acc) ss 271 | | isRule (removeNonIndentingSpaces s) = 272 | parseContainers (L.Cons CRule acc) ss 273 | | isBlockquoteLine s = 274 | let o = splitBlockquote $ L.Cons s ss 275 | in parseContainers (L.Cons (CBlockquote (parseContainers mempty o.blockquoteLines)) acc) o.otherLines 276 | | isListItemLine s = 277 | let o = splitListItem s ss 278 | in parseContainers (L.Cons (CListItem o.listType $ parseContainers mempty o.listItemLines) acc) o.otherLines 279 | | isIndentedChunk s = 280 | let o = splitIndentedChunks (L.Cons s ss) 281 | in parseContainers (L.Cons (CCodeBlockIndented o.codeLines) acc) o.otherLines 282 | | isCodeFence (removeNonIndentingSpaces s) = 283 | let 284 | s1 = removeNonIndentingSpaces s 285 | eval = isEvaluatedCode s1 286 | s2 = if eval then S.drop 1 s1 else s1 287 | info = codeFenceInfo s2 288 | ch = codeFenceChar s2 289 | o = splitCodeFence (countLeadingSpaces s) ch ss 290 | in 291 | parseContainers (L.Cons (CCodeBlockFenced eval info o.codeLines) acc) o.otherLines 292 | | isLinkReference (removeNonIndentingSpaces s) = 293 | let 294 | s1 = removeNonIndentingSpaces s 295 | b = unsafePartial M.fromJust $ Ref.parseLinkReference s1 296 | in 297 | parseContainers (L.Cons (CLinkReference b) acc) ss 298 | | otherwise = parseContainers (L.Cons (CText s) acc) ss 299 | 300 | isTextContainer ∷ ∀ a. Container a → Boolean 301 | isTextContainer (CText _) = true 302 | isTextContainer _ = false 303 | 304 | getCText ∷ ∀ a. Container a → String 305 | getCText (CText s) = s 306 | getCText _ = "" 307 | 308 | isListItem ∷ ∀ a. SD.ListType → Container a → Boolean 309 | isListItem lt1 (CListItem lt2 _) = lt1 == lt2 310 | isListItem _ _ = false 311 | 312 | getCListItem ∷ ∀ a. Container a → L.List (Container a) 313 | getCListItem (CListItem _ cs) = cs 314 | getCListItem _ = L.Nil 315 | 316 | parseBlocks 317 | ∷ ∀ a 318 | . (SD.Value a) 319 | ⇒ L.List (Container a) 320 | → Either String (L.List (SD.Block a)) 321 | parseBlocks = 322 | case _ of 323 | L.Nil → pure L.Nil 324 | (CText s) : (CSetextHeader n) : cs → do 325 | hd ← Inline.parseInlines $ L.singleton s 326 | tl ← parseBlocks cs 327 | pure $ (SD.Header n hd) : tl 328 | (CText s) : cs → do 329 | let 330 | sp = L.span isTextContainer cs 331 | is ← Inline.parseInlines $ s : (map getCText sp.init) 332 | tl ← parseBlocks sp.rest 333 | pure $ (SD.Paragraph is) : tl 334 | CRule : cs → 335 | map (SD.Rule : _) $ parseBlocks cs 336 | (CATXHeader n s) : cs → do 337 | hd ← Inline.parseInlines $ L.singleton s 338 | tl ← parseBlocks cs 339 | pure $ (SD.Header n hd) : tl 340 | (CBlockquote cs) : cs1 → do 341 | hd ← parseBlocks cs 342 | tl ← parseBlocks cs1 343 | pure $ (SD.Blockquote hd) : tl 344 | (CListItem lt cs) : cs1 → do 345 | let 346 | sp = L.span (isListItem lt) cs1 347 | bs ← parseBlocks cs 348 | bss ← traverse (parseBlocks <<< getCListItem) sp.init 349 | tl ← parseBlocks sp.rest 350 | pure $ (SD.Lst lt (bs : bss)) : tl 351 | (CCodeBlockIndented ss) : cs → 352 | map ((SD.CodeBlock SD.Indented ss) : _) $ parseBlocks cs 353 | (CCodeBlockFenced eval info ss) : cs → 354 | map ((SD.CodeBlock (SD.Fenced eval info) ss) : _) $ parseBlocks cs 355 | (CLinkReference b) : cs → 356 | map (b : _) $ parseBlocks cs 357 | L.Cons _ cs → 358 | parseBlocks cs 359 | 360 | validateBlock ∷ ∀ a. SD.Block a → V.V (Array String) (SD.Block a) 361 | validateBlock = 362 | case _ of 363 | SD.Paragraph inls → SD.Paragraph <$> traverse Inline.validateInline inls 364 | SD.Header i inls → SD.Header i <$> traverse Inline.validateInline inls 365 | SD.Blockquote bls → SD.Blockquote <$> traverse validateBlock bls 366 | SD.Lst lt blss → SD.Lst lt <$> traverse (traverse validateBlock) blss 367 | b → pure b 368 | 369 | validateSlamDown ∷ ∀ a. SD.SlamDownP a → V.V (Array String) (SD.SlamDownP a) 370 | validateSlamDown (SD.SlamDown bls) = SD.SlamDown <$> traverse validateBlock bls 371 | 372 | tabsToSpaces ∷ String → String 373 | tabsToSpaces = S.replace (S.Pattern "\t") (S.Replacement " ") 374 | 375 | parseMd ∷ ∀ a. (SD.Value a) ⇒ String → Either String (SD.SlamDownP a) 376 | parseMd s = map SD.SlamDown bs 377 | where 378 | slashR = URX.unsafeRegex "\\r" RXF.global 379 | lines = L.fromFoldable $ S.split (S.Pattern "\n") $ RGX.replace slashR "" $ tabsToSpaces s 380 | ctrs = parseContainers mempty lines 381 | bs = parseBlocks ctrs 382 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Parser/Inline.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Parser.Inline 2 | ( parseInlines 3 | , validateFormField 4 | , validateInline 5 | , parseTextBox 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Control.Alt ((<|>)) 11 | import Control.Lazy as Lazy 12 | 13 | import Data.Array as A 14 | import Data.Bifunctor (lmap) 15 | import Data.Char.Unicode (isAlphaNum) 16 | import Data.Const (Const(..)) 17 | import Data.DateTime as DT 18 | import Data.Either (Either(..)) 19 | import Data.Enum (toEnum) 20 | import Data.Foldable (elem) 21 | import Data.Functor.Compose (Compose(..)) 22 | import Data.HugeNum as HN 23 | import Data.Int as Int 24 | import Data.List as L 25 | import Data.Maybe as M 26 | import Data.String (joinWith, trim) as S 27 | import Data.String.CodeUnits (fromCharArray, singleton, toCharArray) as S 28 | import Data.Traversable (traverse) 29 | import Data.Tuple (Tuple(..), fst, snd) 30 | import Data.Validation.Semigroup as V 31 | 32 | import Text.Parsing.Parser as P 33 | import Text.Parsing.Parser.Combinators as PC 34 | import Text.Parsing.Parser.String as PS 35 | 36 | import Text.Markdown.SlamDown.Parser.Utils as PU 37 | import Text.Markdown.SlamDown.Syntax as SD 38 | 39 | parseInlines 40 | ∷ ∀ a 41 | . (SD.Value a) 42 | ⇒ L.List String 43 | → Either String (L.List (SD.Inline a)) 44 | parseInlines s = 45 | map consolidate 46 | $ lmap P.parseErrorMessage 47 | $ P.runParser (S.joinWith "\n" $ A.fromFoldable s) inlines 48 | 49 | consolidate 50 | ∷ ∀ a 51 | . L.List (SD.Inline a) 52 | → L.List (SD.Inline a) 53 | consolidate xs = 54 | case xs of 55 | L.Nil → L.Nil 56 | L.Cons (SD.Str s1) (L.Cons (SD.Str s2) is) → 57 | consolidate $ L.Cons (SD.Str (s1 <> s2)) is 58 | L.Cons i is → L.Cons i $ consolidate is 59 | 60 | someOf 61 | ∷ (Char → Boolean) 62 | → P.Parser String String 63 | someOf = 64 | map (S.fromCharArray <<< A.fromFoldable) 65 | <<< L.some 66 | <<< PS.satisfy 67 | 68 | manyOf 69 | ∷ (Char → Boolean) 70 | → P.Parser String String 71 | manyOf = 72 | map (S.fromCharArray <<< A.fromFoldable) 73 | <<< L.many 74 | <<< PS.satisfy 75 | 76 | isNumeric ∷ Char → Boolean 77 | isNumeric c = 78 | s >= "0" && s <= "9" 79 | where 80 | s = S.singleton c 81 | 82 | dash ∷ P.Parser String Unit 83 | dash = void $ PS.string "-" 84 | 85 | colon ∷ P.Parser String Unit 86 | colon = void $ PS.string ":" 87 | 88 | dot ∷ P.Parser String Unit 89 | dot = void $ PS.string "." 90 | 91 | hash ∷ P.Parser String Unit 92 | hash = void $ PS.string "#" 93 | 94 | type TextParserKit 95 | = { plainText ∷ P.Parser String String 96 | , natural ∷ P.Parser String Int 97 | , decimal ∷ P.Parser String HN.HugeNum 98 | , numericPrefix ∷ P.Parser String Unit 99 | } 100 | 101 | validateFormField 102 | ∷ ∀ a 103 | . SD.FormField a 104 | → V.V (Array String) (SD.FormField a) 105 | validateFormField field = 106 | case field of 107 | SD.CheckBoxes (SD.Literal _) (SD.Unevaluated _) → 108 | V.invalid ["Checkbox values & selection must be both literals or both unevaluated expressions"] 109 | SD.CheckBoxes (SD.Unevaluated _) (SD.Literal _) → 110 | V.invalid ["Checkbox values & selection must be both literals or both unevaluated expressions"] 111 | _ → pure field 112 | 113 | validateInline 114 | ∷ ∀ a 115 | . SD.Inline a 116 | → V.V (Array String) (SD.Inline a) 117 | validateInline inl = 118 | case inl of 119 | SD.Emph inls → SD.Emph <$> traverse validateInline inls 120 | SD.Strong inls → SD.Strong <$> traverse validateInline inls 121 | SD.Link inls targ → SD.Link <$> traverse validateInline inls <*> pure targ 122 | SD.Image inls str → SD.Image <$> traverse validateInline inls <*> pure str 123 | SD.FormField str b ff → SD.FormField str b <$> validateFormField ff 124 | _ → pure inl 125 | 126 | 127 | inlines 128 | ∷ ∀ a 129 | . (SD.Value a) 130 | ⇒ P.Parser String (L.List (SD.Inline a)) 131 | inlines = L.many inline2 <* PS.eof 132 | where 133 | inline0 ∷ P.Parser String (SD.Inline a) 134 | inline0 = 135 | Lazy.fix \p → 136 | alphaNumStr 137 | <|> space 138 | <|> strongEmph p 139 | <|> strong p 140 | <|> emph p 141 | <|> code 142 | <|> autolink 143 | <|> entity 144 | 145 | inline1 ∷ P.Parser String (SD.Inline a) 146 | inline1 = 147 | PC.try inline0 148 | <|> PC.try link 149 | 150 | inline2 ∷ P.Parser String (SD.Inline a) 151 | inline2 = do 152 | res ← 153 | PC.try formField 154 | <|> PC.try (Right <$> inline1) 155 | <|> PC.try (Right <$> image) 156 | <|> (Right <$> other) 157 | case res of 158 | Right v → pure v 159 | Left e → P.fail e 160 | 161 | alphaNumStr ∷ P.Parser String (SD.Inline a) 162 | alphaNumStr = SD.Str <$> someOf isAlphaNum 163 | 164 | emphasis 165 | ∷ P.Parser String (SD.Inline a) 166 | → (L.List (SD.Inline a) → SD.Inline a) 167 | → String 168 | → P.Parser String (SD.Inline a) 169 | emphasis p f s = do 170 | _ ← PS.string s 171 | f <$> PC.manyTill p (PS.string s) 172 | 173 | emph ∷ P.Parser String (SD.Inline a) → P.Parser String (SD.Inline a) 174 | emph p = emphasis p SD.Emph "*" <|> emphasis p SD.Emph "_" 175 | 176 | strong ∷ P.Parser String (SD.Inline a) → P.Parser String (SD.Inline a) 177 | strong p = emphasis p SD.Strong "**" <|> emphasis p SD.Strong "__" 178 | 179 | strongEmph ∷ P.Parser String (SD.Inline a) → P.Parser String (SD.Inline a) 180 | strongEmph p = emphasis p f "***" <|> emphasis p f "___" 181 | where 182 | f is = SD.Strong $ L.singleton $ SD.Emph is 183 | 184 | space ∷ P.Parser String (SD.Inline a) 185 | space = (toSpace <<< (S.singleton <$> _)) <$> L.some (PS.satisfy PU.isWhitespace) 186 | where 187 | toSpace cs 188 | | "\n" `elem` cs = 189 | case L.take 2 cs of 190 | L.Cons " " (L.Cons " " L.Nil) → SD.LineBreak 191 | _ → SD.SoftBreak 192 | | otherwise = SD.Space 193 | 194 | code ∷ P.Parser String (SD.Inline a) 195 | code = do 196 | eval ← PC.option false (PS.string "!" *> pure true) 197 | ticks ← someOf (\x → S.singleton x == "`") 198 | contents ← (S.fromCharArray <<< A.fromFoldable) <$> PC.manyTill PS.anyChar (PS.string ticks) 199 | pure <<< SD.Code eval <<< S.trim $ contents 200 | 201 | 202 | link ∷ P.Parser String (SD.Inline a) 203 | link = SD.Link <$> linkLabel <*> linkTarget 204 | where 205 | linkLabel ∷ P.Parser String (L.List (SD.Inline a)) 206 | linkLabel = PS.string "[" *> PC.manyTill (inline0 <|> other) (PS.string "]") 207 | 208 | linkTarget ∷ P.Parser String SD.LinkTarget 209 | linkTarget = inlineLink <|> referenceLink 210 | 211 | inlineLink ∷ P.Parser String SD.LinkTarget 212 | inlineLink = SD.InlineLink <<< S.fromCharArray <<< A.fromFoldable <$> (PS.string "(" *> PC.manyTill PS.anyChar (PS.string ")")) 213 | 214 | referenceLink ∷ P.Parser String SD.LinkTarget 215 | referenceLink = SD.ReferenceLink <$> PC.optionMaybe ((S.fromCharArray <<< A.fromFoldable) <$> (PS.string "[" *> PC.manyTill PS.anyChar (PS.string "]"))) 216 | 217 | image ∷ P.Parser String (SD.Inline a) 218 | image = SD.Image <$> imageLabel <*> imageUrl 219 | where 220 | imageLabel ∷ P.Parser String (L.List (SD.Inline a)) 221 | imageLabel = PS.string "![" *> PC.manyTill (inline1 <|> other) (PS.string "]") 222 | 223 | imageUrl ∷ P.Parser String String 224 | imageUrl = S.fromCharArray <<< A.fromFoldable <$> (PS.string "(" *> PC.manyTill PS.anyChar (PS.string ")")) 225 | 226 | autolink ∷ P.Parser String (SD.Inline a) 227 | autolink = do 228 | _ ← PS.string "<" 229 | url ← (S.fromCharArray <<< A.fromFoldable) <$> (PS.anyChar `PC.many1Till` PS.string ">") 230 | pure $ SD.Link (L.singleton $ SD.Str (autoLabel url)) (SD.InlineLink url) 231 | where 232 | autoLabel ∷ String → String 233 | autoLabel s 234 | | PU.isEmailAddress s = "mailto:" <> s 235 | | otherwise = s 236 | 237 | entity ∷ P.Parser String (SD.Inline a) 238 | entity = do 239 | _ ← PS.string "&" 240 | s ← (S.fromCharArray <<< A.fromFoldable) <$> (PS.noneOf (S.toCharArray ";") `PC.many1Till` PS.string ";") 241 | pure $ SD.Entity $ "&" <> s <> ";" 242 | 243 | formField ∷ P.Parser String (Either String (SD.Inline a)) 244 | formField = 245 | do 246 | l ← label 247 | r ← do 248 | PU.skipSpaces 249 | required 250 | fe ← do 251 | PU.skipSpaces 252 | _ ← PS.string "=" 253 | PU.skipSpaces 254 | formElement 255 | pure $ map (SD.FormField l r) fe 256 | where 257 | label = 258 | someOf isAlphaNum 259 | <|> (S.fromCharArray 260 | <<< A.fromFoldable 261 | <$> (PS.string "[" *> PC.manyTill PS.anyChar (PS.string "]"))) 262 | 263 | required = PC.option false (PS.string "*" *> pure true) 264 | 265 | formElement ∷ P.Parser String (Either String (SD.FormField a)) 266 | formElement = 267 | PC.try textBox 268 | <|> PC.try (Right <$> radioButtons) 269 | <|> PC.try (Right <$> checkBoxes) 270 | <|> PC.try (Right <$> dropDown) 271 | where 272 | 273 | textBox ∷ P.Parser String (Either String (SD.FormField a)) 274 | textBox = do 275 | template ← parseTextBoxTemplate 276 | PU.skipSpaces 277 | defVal ← PC.optionMaybe $ PS.string "(" 278 | case defVal of 279 | M.Nothing → pure $ Right $ SD.TextBox $ SD.transTextBox (const $ Compose M.Nothing) template 280 | M.Just _ → do 281 | PU.skipSpaces 282 | mdef ← PC.optionMaybe $ PC.try $ parseTextBox (_ /= ')') (expr identity) template 283 | case mdef of 284 | M.Just def → do 285 | PU.skipSpaces 286 | _ ← PS.string ")" 287 | pure $ Right $ SD.TextBox $ SD.transTextBox (M.Just >>> Compose) def 288 | M.Nothing → 289 | pure $ Left case template of 290 | SD.DateTime SD.Minutes _ → 291 | "Invalid datetime default value, please use \"YYYY-MM-DD HH:mm\" format" 292 | SD.DateTime SD.Seconds _ → 293 | "Invalid datetime default value, please use \"YYYY-MM-DD HH:mm:ss\" format" 294 | SD.Date _ → 295 | "Invalid date default value, please use \"YYYY-MM-DD\" format" 296 | SD.Time SD.Minutes _ → 297 | "Invalid time default value, please use \"HH:mm\" format" 298 | SD.Time SD.Seconds _ → 299 | "Invalid time default value, please use \"HH:mm:ss\" format" 300 | SD.Numeric _ → 301 | "Invalid numeric default value" 302 | SD.PlainText _ → 303 | "Invalid default value" 304 | 305 | parseTextBoxTemplate ∷ P.Parser String (SD.TextBox (Const Unit)) 306 | parseTextBoxTemplate = 307 | SD.DateTime SD.Seconds (Const unit) <$ PC.try (parseDateTimeTemplate SD.Seconds) 308 | <|> SD.DateTime SD.Minutes (Const unit) <$ PC.try (parseDateTimeTemplate SD.Minutes) 309 | <|> SD.Date (Const unit) <$ PC.try parseDateTemplate 310 | <|> SD.Time SD.Seconds (Const unit) <$ PC.try (parseTimeTemplate SD.Seconds) 311 | <|> SD.Time SD.Minutes (Const unit) <$ PC.try (parseTimeTemplate SD.Minutes) 312 | <|> SD.Numeric (Const unit) <$ PC.try parseNumericTemplate 313 | <|> SD.PlainText (Const unit) <$ parsePlainTextTemplate 314 | 315 | where 316 | parseDateTimeTemplate prec = do 317 | _ ← parseDateTemplate 318 | PU.skipSpaces 319 | parseTimeTemplate prec 320 | 321 | parseDateTemplate = do 322 | _ ← und 323 | PU.skipSpaces *> dash *> PU.skipSpaces 324 | _ ← und 325 | PU.skipSpaces *> dash *> PU.skipSpaces 326 | und 327 | 328 | parseTimeTemplate prec = do 329 | _ ← und 330 | PU.skipSpaces *> colon *> PU.skipSpaces 331 | _ ← und 332 | when (prec == SD.Seconds) do 333 | PU.skipSpaces *> colon *> PU.skipSpaces 334 | void und 335 | 336 | parseNumericTemplate = do 337 | hash 338 | und 339 | 340 | parsePlainTextTemplate = 341 | und 342 | 343 | 344 | und ∷ P.Parser String String 345 | und = someOf (\x → x == '_') 346 | 347 | radioButtons ∷ P.Parser String (SD.FormField a) 348 | radioButtons = literalRadioButtons <|> evaluatedRadioButtons 349 | where 350 | literalRadioButtons = do 351 | ls ← L.some $ PC.try do 352 | let item = SD.stringValue <<< S.trim <$> manyOf \c → not $ c `elem` ['(',')','!','`'] 353 | PU.skipSpaces 354 | b ← (PS.string "(x)" *> pure true) <|> (PS.string "()" *> pure false) 355 | PU.skipSpaces 356 | l ← item 357 | pure $ Tuple b l 358 | sel ← 359 | case L.filter fst ls of 360 | L.Cons (Tuple _ l) L.Nil → pure l 361 | _ → P.fail "Invalid number of selected radio buttons" 362 | pure $ SD.RadioButtons (SD.Literal sel) (SD.Literal (map snd ls)) 363 | 364 | evaluatedRadioButtons = do 365 | SD.RadioButtons 366 | <$> PU.parens unevaluated 367 | <*> (PU.skipSpaces *> unevaluated) 368 | 369 | checkBoxes ∷ P.Parser String (SD.FormField a) 370 | checkBoxes = literalCheckBoxes <|> evaluatedCheckBoxes 371 | where 372 | literalCheckBoxes = do 373 | ls ← L.some $ PC.try do 374 | let item = SD.stringValue <<< S.trim <$> manyOf \c → not $ c `elem` ['[',']','!','`'] 375 | PU.skipSpaces 376 | b ← (PS.string "[x]" *> pure true) <|> (PS.string "[]" *> pure false) 377 | PU.skipSpaces 378 | l ← item 379 | pure $ Tuple b l 380 | pure $ SD.CheckBoxes (SD.Literal $ snd <$> L.filter fst ls) (SD.Literal $ snd <$> ls) 381 | 382 | evaluatedCheckBoxes = 383 | SD.CheckBoxes 384 | <$> PU.squares unevaluated 385 | <*> (PU.skipSpaces *> unevaluated) 386 | 387 | dropDown ∷ P.Parser String (SD.FormField a) 388 | dropDown = do 389 | let item = SD.stringValue <<< S.trim <$> manyOf \c → not $ c `elem` ['{','}',',','!','`','(',')'] 390 | ls ← PU.braces $ expr identity $ (PC.try (PU.skipSpaces *> item)) `PC.sepBy` (PU.skipSpaces *> PS.string ",") 391 | sel ← PC.optionMaybe $ PU.skipSpaces *> (PU.parens $ expr identity $ item) 392 | pure $ SD.DropDown sel ls 393 | 394 | other ∷ P.Parser String (SD.Inline a) 395 | other = do 396 | c ← S.singleton <$> PS.anyChar 397 | if c == "\\" 398 | then 399 | (SD.Str <<< S.singleton) <$> PS.anyChar 400 | <|> (PS.satisfy (\x → S.singleton x == "\n") *> pure SD.LineBreak) 401 | <|> pure (SD.Str "\\") 402 | else pure (SD.Str c) 403 | 404 | parseTextBox 405 | ∷ ∀ f g 406 | . (Char → Boolean) 407 | → (∀ a. P.Parser String a → P.Parser String (g a)) 408 | → SD.TextBox f 409 | → P.Parser String (SD.TextBox g) 410 | parseTextBox isPlainText eta template = 411 | case template of 412 | SD.DateTime prec _ → SD.DateTime prec <$> eta (parseDateTimeValue prec) 413 | SD.Date _ → SD.Date <$> eta parseDateValue 414 | SD.Time prec _ → SD.Time prec <$> eta (parseTimeValue prec) 415 | SD.Numeric _ → SD.Numeric <$> eta parseNumericValue 416 | SD.PlainText _ → SD.PlainText <$> eta parsePlainTextValue 417 | 418 | where 419 | parseDateTimeValue ∷ SD.TimePrecision → P.Parser String DT.DateTime 420 | parseDateTimeValue prec = do 421 | date ← parseDateValue 422 | (PC.try $ void $ PS.string "T") <|> PU.skipSpaces 423 | time ← parseTimeValue prec 424 | pure $ DT.DateTime date time 425 | 426 | parseDateValue ∷ P.Parser String DT.Date 427 | parseDateValue = do 428 | year ← parseYear 429 | PU.skipSpaces *> dash *> PU.skipSpaces 430 | month ← natural 431 | when (month > 12) $ P.fail "Invalid month" 432 | PU.skipSpaces *> dash *> PU.skipSpaces 433 | day ← natural 434 | when (day > 31) $ P.fail "Invalid day" 435 | case DT.canonicalDate <$> toEnum year <*> toEnum month <*> toEnum day of 436 | M.Nothing → P.fail "Invalid date" 437 | M.Just dt → pure dt 438 | 439 | parseTimeValue ∷ SD.TimePrecision → P.Parser String DT.Time 440 | parseTimeValue prec = do 441 | hours ← natural 442 | when (hours > 23) $ P.fail "Invalid hours" 443 | PU.skipSpaces *> colon *> PU.skipSpaces 444 | minutes ← natural 445 | when (minutes > 59) $ P.fail "Invalid minutes" 446 | seconds ← case prec of 447 | SD.Minutes -> do 448 | scolon ← PC.try $ PC.optionMaybe $ PU.skipSpaces *> colon 449 | when (M.isJust scolon) $ P.fail "Unexpected seconds component" 450 | pure M.Nothing 451 | SD.Seconds -> do 452 | PU.skipSpaces *> colon *> PU.skipSpaces 453 | secs ← natural 454 | when (secs > 59) $ P.fail "Invalid seconds" 455 | PU.skipSpaces 456 | pure $ M.Just secs 457 | PU.skipSpaces 458 | amPm ← 459 | PC.optionMaybe $ 460 | (false <$ (PS.string "PM" <|> PS.string "pm")) 461 | <|> (true <$ (PS.string "AM" <|> PS.string "am")) 462 | let hours' = 463 | case amPm of 464 | M.Nothing → hours 465 | M.Just isAM → 466 | if not isAM && hours < 12 467 | then hours + 12 468 | else if isAM && hours == 12 469 | then 0 470 | else hours 471 | case DT.Time <$> toEnum hours' <*> toEnum minutes <*> toEnum (M.fromMaybe 0 seconds) <*> pure bottom of 472 | M.Nothing → P.fail "Invalid time" 473 | M.Just t → pure t 474 | 475 | parseNumericValue = do 476 | sign ← PC.try (-1 <$ PS.char '-') <|> pure 1 477 | ms ← digits 478 | PU.skipSpaces 479 | gotDot ← PC.optionMaybe dot 480 | PU.skipSpaces 481 | 482 | ns ← 483 | case gotDot of 484 | M.Just _ → do 485 | PC.optionMaybe (PU.skipSpaces *> digits) 486 | M.Nothing → 487 | pure M.Nothing 488 | 489 | HN.fromString (ms <> "." <> M.fromMaybe "" ns) 490 | # M.maybe (P.fail "Failed parsing decimal") pure 491 | 492 | parsePlainTextValue = 493 | manyOf isPlainText 494 | 495 | natural = do 496 | xs ← digits 497 | Int.fromString xs 498 | # M.maybe (P.fail "Failed parsing natural") pure 499 | 500 | digit = 501 | PS.oneOf ['0','1','2','3','4','5','6','7','8','9'] 502 | 503 | digitN = do 504 | ds ← digit 505 | ds 506 | # pure 507 | # S.fromCharArray 508 | # Int.fromString 509 | # M.maybe (P.fail "Failed parsing digit") pure 510 | 511 | parseYear = do 512 | millenia ← digitN 513 | centuries ← digitN 514 | decades ← digitN 515 | years ← digitN 516 | pure $ 1000 * millenia + 100 * centuries + 10 * decades + years 517 | 518 | digits = 519 | L.some digit <#> 520 | A.fromFoldable >>> S.fromCharArray 521 | 522 | expr 523 | ∷ ∀ b 524 | . (∀ e. P.Parser String e → P.Parser String e) 525 | → P.Parser String b 526 | → P.Parser String (SD.Expr b) 527 | expr f p = 528 | PC.try (f unevaluated) 529 | <|> SD.Literal <$> p 530 | 531 | unevaluated ∷ ∀ b. P.Parser String (SD.Expr b) 532 | unevaluated = do 533 | _ ← PS.string "!" 534 | ticks ← someOf (\x → S.singleton x == "`") 535 | SD.Unevaluated <<< S.fromCharArray <<< A.fromFoldable <$> PC.manyTill PS.anyChar (PS.string ticks) 536 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Parser/References.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Parser.References 2 | ( parseLinkReference 3 | ) where 4 | 5 | import Prelude 6 | 7 | import Data.Array as A 8 | import Data.Either as E 9 | import Data.Maybe as M 10 | import Data.String (trim) as S 11 | import Data.String.CodeUnits (fromCharArray) as S 12 | 13 | import Text.Parsing.Parser as P 14 | import Text.Parsing.Parser.Combinators as PC 15 | import Text.Parsing.Parser.String as PS 16 | 17 | import Text.Markdown.SlamDown.Parser.Utils as PU 18 | import Text.Markdown.SlamDown.Syntax as SD 19 | 20 | parseLinkReference ∷ ∀ a. String → M.Maybe (SD.Block a) 21 | parseLinkReference = E.either (const M.Nothing) M.Just <<< flip P.runParser linkReference 22 | 23 | linkReference ∷ ∀ a. P.Parser String (SD.Block a) 24 | linkReference = do 25 | l ← 26 | charsToString <$> do 27 | _ ← PS.string "[" 28 | PU.skipSpaces 29 | PC.manyTill PS.anyChar (PS.string "]") 30 | _ ← PS.string ":" 31 | PU.skipSpaces 32 | uri ← charsToString <$> PC.manyTill PS.anyChar PS.eof 33 | pure $ SD.LinkReference l uri 34 | 35 | where 36 | charsToString = 37 | S.trim 38 | <<< S.fromCharArray 39 | <<< A.fromFoldable 40 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Parser/Utils.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Parser.Utils 2 | ( isWhitespace 3 | , isEmailAddress 4 | , parens 5 | , braces 6 | , squares 7 | , skipSpaces 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Either (fromRight) 13 | import Data.String.CodeUnits (singleton) 14 | import Data.String.Regex as R 15 | import Data.String.Regex.Flags as RF 16 | 17 | import Partial.Unsafe (unsafePartial) 18 | 19 | import Text.Parsing.Parser (Parser) 20 | import Text.Parsing.Parser.Combinators (skipMany) 21 | import Text.Parsing.Parser.String (string, satisfy) 22 | 23 | isWhitespace ∷ Char → Boolean 24 | isWhitespace = R.test wsRegex <<< singleton 25 | where 26 | wsRegex ∷ R.Regex 27 | wsRegex = unsafePartial fromRight $ 28 | R.regex "^\\s$" RF.noFlags 29 | 30 | isEmailAddress ∷ String → Boolean 31 | isEmailAddress = R.test wsEmail 32 | where 33 | wsEmail ∷ R.Regex 34 | wsEmail = unsafePartial fromRight $ 35 | R.regex """^[a-zA-Z0-9.!#$%&'*+/=?^_`{|}~-]+@[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?(?:\.[a-zA-Z0-9](?:[a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?)*$""" RF.noFlags 36 | 37 | parens ∷ ∀ a. Parser String a → Parser String a 38 | parens p = string "(" *> skipSpaces *> p <* skipSpaces <* string ")" 39 | 40 | braces ∷ ∀ a. Parser String a → Parser String a 41 | braces p = string "{" *> skipSpaces *> p <* skipSpaces <* string "}" 42 | 43 | squares ∷ ∀ a. Parser String a → Parser String a 44 | squares p = string "[" *> skipSpaces *> p <* skipSpaces <* string "]" 45 | 46 | skipSpaces ∷ Parser String Unit 47 | skipSpaces = skipMany (satisfy isWhitespace) 48 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Pretty.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Pretty 2 | ( prettyPrintMd 3 | , prettyPrintTextBoxValue 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Data.Array as A 9 | import Data.DateTime as DT 10 | import Data.Foldable (fold, elem) 11 | import Data.Functor.Compose (Compose) 12 | import Data.HugeNum as HN 13 | import Data.Identity (Identity(..)) 14 | import Data.List as L 15 | import Data.Maybe as M 16 | import Data.Enum (fromEnum) 17 | import Data.Newtype (unwrap) 18 | import Data.String (Pattern(..), indexOf, joinWith, length, split, stripSuffix) as S 19 | import Data.String.CodeUnits (fromCharArray) as S 20 | import Data.Unfoldable as U 21 | 22 | import Text.Markdown.SlamDown.Syntax as SD 23 | 24 | unlines ∷ L.List String → String 25 | unlines lst = S.joinWith "\n" $ A.fromFoldable lst 26 | 27 | prettyPrintMd ∷ ∀ a. (SD.Value a) ⇒ SD.SlamDownP a → String 28 | prettyPrintMd (SD.SlamDown bs) = unlines $ L.concatMap prettyPrintBlock bs 29 | 30 | replicateS ∷ Int → String → String 31 | replicateS n s = fold (const s <$> (1 L... n)) 32 | 33 | indent ∷ Int → String → String 34 | indent n s = replicateS n " " <> s 35 | 36 | overLines ∷ (String → String) → L.List String → L.List String 37 | overLines f = map f <<< L.concatMap lines 38 | 39 | lines ∷ String → L.List String 40 | lines "" = mempty 41 | lines s = L.fromFoldable $ S.split (S.Pattern "\n") s 42 | 43 | prettyPrintBlock ∷ ∀ a. (SD.Value a) ⇒ SD.Block a → L.List String 44 | prettyPrintBlock bl = 45 | case bl of 46 | SD.Paragraph is → L.Cons (prettyPrintInlines is) (L.Cons "" L.Nil) 47 | SD.Header n is → L.singleton (replicateS n "#" <> " " <> prettyPrintInlines is) 48 | SD.Blockquote bs → overLines ((<>) "> ") (L.concatMap prettyPrintBlock bs) 49 | SD.Lst lt bss → 50 | let 51 | addMarker ∷ L.List String → L.List String 52 | addMarker L.Nil = L.Nil 53 | addMarker (L.Cons s ss) = 54 | let 55 | m = prettyPrintMarker lt 56 | len = S.length m 57 | in 58 | L.Cons (m <> " " <> s) $ overLines (indent (len + 1)) ss 59 | 60 | prettyPrintMarker ∷ SD.ListType → String 61 | prettyPrintMarker (SD.Bullet s) = s 62 | prettyPrintMarker (SD.Ordered s) = "1" <> s 63 | 64 | listItem ∷ L.List (SD.Block a) → L.List String 65 | listItem = addMarker <<< L.concatMap lines <<< L.concatMap prettyPrintBlock 66 | in 67 | L.concatMap listItem bss 68 | SD.CodeBlock ct ss → 69 | case ct of 70 | SD.Indented → indent 4 <$> ss 71 | SD.Fenced eval info → 72 | let 73 | bang 74 | | eval = "!" 75 | | otherwise = "" 76 | in 77 | L.singleton (bang <> "```" <> info) <> ss <> L.singleton "```" 78 | SD.LinkReference l url → L.singleton $ squares l <> ": " <> url 79 | SD.Rule → L.singleton "***" 80 | 81 | prettyPrintInlines ∷ ∀ a. (SD.Value a) ⇒ L.List (SD.Inline a) → String 82 | prettyPrintInlines is = S.joinWith "" $ A.fromFoldable $ (map prettyPrintInline is) 83 | 84 | prettyPrintInline ∷ ∀ a. (SD.Value a) ⇒ SD.Inline a → String 85 | prettyPrintInline il = 86 | case il of 87 | SD.Str s → s 88 | SD.Entity s → s 89 | SD.Space → " " 90 | SD.SoftBreak → "\n" 91 | SD.LineBreak → " \n" 92 | SD.Emph is → "*" <> prettyPrintInlines is <> "*" 93 | SD.Strong is → "**" <> prettyPrintInlines is <> "**" 94 | SD.Code e s → 95 | let 96 | bang = if e then "!" else "" 97 | in 98 | bang <> "`" <> s <> "`" 99 | SD.Link is tgt → "[" <> prettyPrintInlines is <> "]" <> printTarget tgt 100 | SD.Image is url → "![" <> prettyPrintInlines is <> "](" <> url <> ")" 101 | SD.FormField l r e → 102 | let 103 | star = if r then "*" else" " 104 | in 105 | esc l <> star <> " = " <> prettyPrintFormElement e 106 | where 107 | 108 | esc s = M.maybe s (const $ "[" <> s <> "]") $ S.indexOf (S.Pattern " ") s 109 | 110 | printTarget ∷ SD.LinkTarget → String 111 | printTarget (SD.InlineLink url) = parens url 112 | printTarget (SD.ReferenceLink tgt) = squares (M.fromMaybe "" tgt) 113 | 114 | 115 | prettyPrintTextBoxValue ∷ SD.TextBox Identity → String 116 | prettyPrintTextBoxValue t = 117 | case t of 118 | SD.PlainText (Identity def) → def 119 | SD.Numeric (Identity def) → 120 | let s = HN.toString def in 121 | M.fromMaybe s $ S.stripSuffix (S.Pattern ".") $ HN.toString def 122 | SD.Date (Identity def) → prettyPrintDate def 123 | SD.Time prec (Identity def) → prettyPrintTime prec def 124 | SD.DateTime prec (Identity def) → prettyPrintDateTime prec def 125 | 126 | prettyPrintDate ∷ DT.Date → String 127 | prettyPrintDate d = 128 | printIntPadded 4 (fromEnum $ DT.year d) 129 | <> "-" 130 | <> printIntPadded 2 (fromEnum $ DT.month d) 131 | <> "-" 132 | <> printIntPadded 2 (fromEnum $ DT.day d) 133 | 134 | prettyPrintTime ∷ SD.TimePrecision → DT.Time → String 135 | prettyPrintTime prec t = 136 | printIntPadded 2 (fromEnum $ DT.hour t) 137 | <> ":" 138 | <> printIntPadded 2 (fromEnum $ DT.minute t) 139 | <> case prec of 140 | SD.Seconds -> ":" <> printIntPadded 2 (fromEnum $ DT.second t) 141 | _ -> "" 142 | 143 | prettyPrintDateTime ∷ SD.TimePrecision → DT.DateTime → String 144 | prettyPrintDateTime prec dt = 145 | prettyPrintDate (DT.date dt) 146 | <> "T" 147 | <> prettyPrintTime prec (DT.time dt) 148 | 149 | printIntPadded ∷ Int → Int → String 150 | printIntPadded l i = 151 | if dl > 0 152 | then S.fromCharArray (U.replicate dl '0') <> s 153 | else s 154 | where 155 | s = show i 156 | dl = l - S.length s 157 | 158 | prettyPrintTextBox ∷ SD.TextBox (Compose M.Maybe SD.Expr) → String 159 | prettyPrintTextBox t = 160 | prettyPrintTemplate t 161 | <> M.maybe "" (\x → " (" <> prettyPrintDefault x <> ")") (SD.traverseTextBox unwrap t) 162 | where 163 | prettyPrintTemplate ∷ ∀ f. SD.TextBox f → String 164 | prettyPrintTemplate = 165 | case _ of 166 | SD.PlainText _ → "______" 167 | SD.Numeric _ → "#______" 168 | SD.Date _ → "__-__-____" 169 | SD.Time SD.Minutes _ → "__:__" 170 | SD.Time SD.Seconds _ → "__:__:__" 171 | SD.DateTime SD.Minutes _ → "__-__-____ __:__" 172 | SD.DateTime SD.Seconds _ → "__-__-____ __:__:__" 173 | 174 | prettyPrintDefault ∷ SD.TextBox SD.Expr → String 175 | prettyPrintDefault = 176 | case _ of 177 | SD.PlainText def → prettyPrintExpr identity identity def 178 | SD.Numeric def → prettyPrintExpr identity HN.toString def 179 | SD.Date def → prettyPrintExpr identity prettyPrintDate def 180 | SD.Time prec def → prettyPrintExpr identity (prettyPrintTime prec) def 181 | SD.DateTime prec def → prettyPrintExpr identity (prettyPrintDateTime prec) def 182 | 183 | 184 | prettyPrintFormElement ∷ ∀ a. (SD.Value a) ⇒ SD.FormField a → String 185 | prettyPrintFormElement el = 186 | case el of 187 | SD.TextBox tb → prettyPrintTextBox tb 188 | SD.RadioButtons (SD.Literal sel) (SD.Literal ls) → 189 | let 190 | radioButton l = (if l == sel then "(x) " else "() ") <> SD.renderValue l 191 | in 192 | S.joinWith " " $ A.fromFoldable (map radioButton ls) 193 | SD.RadioButtons (SD.Unevaluated bs) (SD.Unevaluated ls) → 194 | "(!`" <> bs <> "`) !`" <> ls <> "`" 195 | SD.CheckBoxes (SD.Literal sel) (SD.Literal ls) → 196 | let 197 | checkBox l = (if elem l sel then "[x] " else "[] ") <> SD.renderValue l 198 | in 199 | S.joinWith " " <<< A.fromFoldable $ checkBox <$> ls 200 | SD.CheckBoxes (SD.Unevaluated bs) (SD.Unevaluated ls) → 201 | "[!`" <> bs <> "`] !`" <> ls <> "`" 202 | SD.DropDown sel lbls → 203 | braces (prettyPrintExpr identity (A.fromFoldable >>> map SD.renderValue >>> S.joinWith ", ") lbls) 204 | <> M.maybe "" (parens <<< prettyPrintExpr identity SD.renderValue) sel 205 | _ → "Unsupported form element" 206 | 207 | prettyPrintExpr ∷ ∀ a. (String → String) → (a → String) → SD.Expr a → String 208 | prettyPrintExpr _ f (SD.Literal a) = f a 209 | prettyPrintExpr wrap _ (SD.Unevaluated c) = wrap $ "!`" <> c <> "`" 210 | 211 | parens ∷ String → String 212 | parens s = "(" <> s <> ")" 213 | 214 | braces ∷ String → String 215 | braces s = "{" <> s <> "}" 216 | 217 | squares ∷ String → String 218 | squares s = "[" <> s <> "]" 219 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax 2 | ( SlamDownP(..) 3 | , SlamDown 4 | 5 | , module SDF 6 | , module SDI 7 | , module SDB 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Eq (class Eq1) 13 | import Data.List as L 14 | import Data.Ord (class Ord1) 15 | import Text.Markdown.SlamDown.Syntax.Block (Block(..), CodeBlockType(..), ListType(..)) as SDB 16 | import Text.Markdown.SlamDown.Syntax.FormField (class Value, Expr(..), FormField, FormFieldP(..), TextBox(..), TimePrecision(..), getLiteral, getUnevaluated, renderValue, stringValue, transFormField, transTextBox, traverseFormField, traverseTextBox) as SDF 17 | import Text.Markdown.SlamDown.Syntax.Inline (Inline(..), LinkTarget(..)) as SDI 18 | 19 | -- | `SlamDownP` is the type of SlamDown abstract syntax trees which take values in `a`. 20 | newtype SlamDownP a = SlamDown (L.List (SDB.Block a)) 21 | 22 | type SlamDown = SlamDownP String 23 | 24 | derive instance functorSlamDownP ∷ Functor SlamDownP 25 | 26 | instance showSlamDownP ∷ (Show a) ⇒ Show (SlamDownP a) where 27 | show (SlamDown bs) = "(SlamDown " <> show bs <> ")" 28 | 29 | derive newtype instance eqSlamDownP ∷ Eq a ⇒ Eq (SlamDownP a) 30 | derive instance eq1SlamDownP ∷ Eq1 SlamDownP 31 | 32 | derive newtype instance ordSlamDownP ∷ Ord a ⇒ Ord (SlamDownP a) 33 | derive instance ord1SlamDownP ∷ Ord1 SlamDownP 34 | 35 | derive newtype instance semigroupSlamDownP ∷ Semigroup (SlamDownP a) 36 | derive newtype instance monoidSlamDownP ∷ Monoid (SlamDownP a) 37 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax/Block.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax.Block 2 | ( Block(..) 3 | , ListType(..) 4 | , CodeBlockType(..) 5 | ) where 6 | 7 | import Prelude 8 | 9 | import Data.Eq (class Eq1) 10 | import Data.List as L 11 | import Data.Ord (class Ord1) 12 | import Text.Markdown.SlamDown.Syntax.Inline (Inline) 13 | 14 | data Block a 15 | = Paragraph (L.List (Inline a)) 16 | | Header Int (L.List (Inline a)) 17 | | Blockquote (L.List (Block a)) 18 | | Lst ListType (L.List (L.List (Block a))) 19 | | CodeBlock CodeBlockType (L.List String) 20 | | LinkReference String String 21 | | Rule 22 | 23 | derive instance functorBlock ∷ Functor Block 24 | 25 | instance showBlock ∷ Show a ⇒ Show (Block a) where 26 | show (Paragraph is) = "(Paragraph " <> show is <> ")" 27 | show (Header n is) = "(Header " <> show n <> " " <> show is <> ")" 28 | show (Blockquote bs) = "(Blockquote " <> show bs <> ")" 29 | show (Lst lt bss) = "(List " <> show lt <> " " <> show bss <> ")" 30 | show (CodeBlock ca s) = "(CodeBlock " <> show ca <> " " <> show s <> ")" 31 | show (LinkReference l uri) = "(LinkReference " <> show l <> " " <> show uri <> ")" 32 | show Rule = "Rule" 33 | 34 | derive instance eqBlock ∷ Eq a ⇒ Eq (Block a) 35 | derive instance eq1Block ∷ Eq1 Block 36 | derive instance ordBlock ∷ Ord a ⇒ Ord (Block a) 37 | derive instance ord1Block ∷ Ord1 Block 38 | 39 | data ListType 40 | = Bullet String 41 | | Ordered String 42 | 43 | instance showListType ∷ Show ListType where 44 | show (Bullet s) = "(Bullet " <> show s <> ")" 45 | show (Ordered s) = "(Ordered " <> show s <> ")" 46 | 47 | derive instance eqListType ∷ Eq ListType 48 | derive instance ordListType ∷ Ord ListType 49 | 50 | data CodeBlockType 51 | = Indented 52 | | Fenced Boolean String 53 | 54 | instance showCodeBlockType ∷ Show CodeBlockType where 55 | show Indented = "Indented" 56 | show (Fenced evaluated info) = "(Fenced " <> show evaluated <> " " <> show info <> ")" 57 | 58 | derive instance eqCodeBlockType ∷ Eq CodeBlockType 59 | derive instance ordCodeBlockType ∷ Ord CodeBlockType 60 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax/FormField.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax.FormField 2 | ( FormFieldP(..) 3 | , FormField 4 | , transFormField 5 | , traverseFormField 6 | 7 | , Expr(..) 8 | , getLiteral 9 | , getUnevaluated 10 | 11 | , module Value 12 | , module TB 13 | ) where 14 | 15 | import Prelude 16 | 17 | import Data.Eq (class Eq1, eq1) 18 | import Data.Functor.Compose (Compose(..)) 19 | import Data.Identity (Identity(..)) 20 | import Data.List as L 21 | import Data.Maybe as M 22 | import Data.Newtype (unwrap) 23 | import Data.Ord (class Ord1, compare1) 24 | import Data.Traversable as TR 25 | import Text.Markdown.SlamDown.Syntax.TextBox (TextBox(..), TimePrecision(..), transTextBox, traverseTextBox) as TB 26 | import Text.Markdown.SlamDown.Syntax.Value (class Value, renderValue, stringValue) as Value 27 | 28 | data FormFieldP f a 29 | = TextBox (TB.TextBox (Compose M.Maybe f)) 30 | | RadioButtons (f a) (f (L.List a)) 31 | | CheckBoxes (f (L.List a)) (f (L.List a)) 32 | | DropDown (M.Maybe (f a)) (f (L.List a)) 33 | 34 | type FormField a = FormFieldP Expr a 35 | 36 | transFormField 37 | ∷ ∀ f g 38 | . (f ~> g) 39 | → FormFieldP f 40 | ~> FormFieldP g 41 | transFormField eta = 42 | unwrap <<< 43 | traverseFormField (eta >>> Identity) 44 | 45 | traverseFormField 46 | ∷ ∀ f g h a 47 | . Applicative h 48 | ⇒ (∀ x. f x → h (g x)) 49 | → FormFieldP f a 50 | → h (FormFieldP g a) 51 | traverseFormField eta field = 52 | case field of 53 | TextBox tb → TextBox <$> TB.traverseTextBox (unwrap >>> TR.traverse eta >>> map Compose) tb 54 | RadioButtons sel ls → RadioButtons <$> eta sel <*> eta ls 55 | CheckBoxes sel ls → CheckBoxes <$> eta sel <*> eta ls 56 | DropDown sel ls → DropDown <$> TR.traverse eta sel <*> eta ls 57 | 58 | instance functorFormField ∷ (Functor f) ⇒ Functor (FormFieldP f) where 59 | map f x = 60 | case x of 61 | TextBox tb → TextBox tb 62 | RadioButtons sel ls → RadioButtons (f <$> sel) (map f <$> ls) 63 | CheckBoxes sel ls → CheckBoxes (map f <$> sel) (map f <$> ls) 64 | DropDown sel ls → DropDown (map f <$> sel) (map f <$> ls) 65 | 66 | instance showFormField ∷ (Functor f, Show (f a), Show (TB.TextBox (Compose M.Maybe f)), Show (f (L.List a))) ⇒ Show (FormFieldP f a) where 67 | show = 68 | case _ of 69 | TextBox tb → "(TextBox " <> show tb <> ")" 70 | RadioButtons sel ls → "(RadioButtons " <> show sel <> " " <> show ls <> ")" 71 | CheckBoxes sel ls → "(CheckBoxes " <> show sel <> " " <> show ls <> ")" 72 | DropDown sel ls → "(DropDown " <> show sel <> " " <> show ls <> ")" 73 | 74 | instance eq1FormField ∷ Eq1 f ⇒ Eq1 (FormFieldP f) where 75 | eq1 = case _, _ of 76 | TextBox tb1, TextBox tb2 -> tb1 == tb2 77 | RadioButtons sel1 ls1, RadioButtons sel2 ls2 -> sel1 `eq1` sel2 && ls1 `eq1` ls2 78 | CheckBoxes sel1 ls1, CheckBoxes sel2 ls2 -> sel1 `eq1` sel2 && ls1 `eq1` ls2 79 | DropDown M.Nothing ls1, DropDown M.Nothing ls2 -> ls1 `eq1` ls2 80 | DropDown (M.Just sel1) ls1, DropDown (M.Just sel2) ls2 -> sel1 `eq1` sel2 && ls1 `eq1` ls2 81 | _, _ -> false 82 | 83 | instance eqFormField :: (Eq1 f, Eq a) => Eq (FormFieldP f a) where 84 | eq = eq1 85 | 86 | instance ord1FormField ∷ Ord1 f ⇒ Ord1 (FormFieldP f) where 87 | compare1 = 88 | case _, _ of 89 | TextBox tb1, TextBox tb2 → compare tb1 tb2 90 | TextBox _, _ → LT 91 | _, TextBox _ → GT 92 | 93 | RadioButtons sel1 ls1, RadioButtons sel2 ls2 → compare1 sel1 sel2 <> compare1 ls1 ls2 94 | RadioButtons _ _, _ → LT 95 | _, RadioButtons _ _ → GT 96 | 97 | CheckBoxes sel1 ls1, CheckBoxes sel2 ls2 → compare1 sel1 sel2 <> compare1 ls1 ls2 98 | CheckBoxes _ _, _ → LT 99 | _, CheckBoxes _ _ → GT 100 | 101 | DropDown M.Nothing ls1, DropDown M.Nothing ls2 → compare1 ls1 ls2 102 | DropDown (M.Just sel1) ls1, DropDown (M.Just sel2) ls2 → compare1 sel1 sel2 <> compare1 ls1 ls2 103 | _, _ -> EQ 104 | 105 | instance ordFormField :: (Ord1 f, Ord a) => Ord (FormFieldP f a) where 106 | compare = compare1 107 | 108 | newtype ArbIdentity a = ArbIdentity a 109 | 110 | getArbIdentity 111 | ∷ ∀ a 112 | . ArbIdentity a 113 | → Identity a 114 | getArbIdentity (ArbIdentity x) = 115 | Identity x 116 | 117 | instance functorArbIdentity ∷ Functor ArbIdentity where 118 | map f (ArbIdentity x) = 119 | ArbIdentity $ f x 120 | 121 | newtype ArbCompose f g a = ArbCompose (f (g a)) 122 | 123 | getArbCompose 124 | ∷ ∀ f g a 125 | . ArbCompose f g a 126 | → Compose f g a 127 | getArbCompose (ArbCompose x) = 128 | Compose x 129 | 130 | instance functorArbCompose ∷ (Functor f, Functor g) ⇒ Functor (ArbCompose f g) where 131 | map f (ArbCompose x) = 132 | ArbCompose $ 133 | map (map f) x 134 | 135 | data Expr a 136 | = Literal a 137 | | Unevaluated String 138 | 139 | getUnevaluated ∷ ∀ e. Expr e → M.Maybe String 140 | getUnevaluated (Unevaluated s) = M.Just s 141 | getUnevaluated _ = M.Nothing 142 | 143 | getLiteral ∷ ∀ e. Expr e → M.Maybe e 144 | getLiteral (Literal e) = M.Just e 145 | getLiteral _ = M.Nothing 146 | 147 | instance functorExpr ∷ Functor Expr where 148 | map f = 149 | case _ of 150 | Literal a → Literal $ f a 151 | Unevaluated e → Unevaluated e 152 | 153 | instance showExpr ∷ (Show a) ⇒ Show (Expr a) where 154 | show = 155 | case _ of 156 | Literal a → "(Literal " <> show a <> ")" 157 | Unevaluated e → "(Unevaluated " <> show e <> ")" 158 | 159 | derive instance eqExpr ∷ Eq a ⇒ Eq (Expr a) 160 | derive instance eq1 ∷ Eq1 Expr 161 | 162 | derive instance ord1Expr ∷ Ord1 Expr 163 | derive instance ordExpr ∷ Ord a ⇒ Ord (Expr a) 164 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax/Inline.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax.Inline 2 | ( Inline(..) 3 | , LinkTarget(..) 4 | ) where 5 | 6 | import Prelude 7 | 8 | import Data.Eq (class Eq1) 9 | import Data.List as L 10 | import Data.Maybe as M 11 | import Data.Ord (class Ord1) 12 | import Text.Markdown.SlamDown.Syntax.FormField (FormField) 13 | 14 | data Inline a 15 | = Str String 16 | | Entity String 17 | | Space 18 | | SoftBreak 19 | | LineBreak 20 | | Emph (L.List (Inline a)) 21 | | Strong (L.List (Inline a)) 22 | | Code Boolean String 23 | | Link (L.List (Inline a)) LinkTarget 24 | | Image (L.List (Inline a)) String 25 | | FormField String Boolean (FormField a) 26 | 27 | derive instance functorInline ∷ Functor Inline 28 | 29 | instance showInline ∷ (Show a) ⇒ Show (Inline a) where 30 | show (Str s) = "(Str " <> show s <> ")" 31 | show (Entity s) = "(Entity " <> show s <> ")" 32 | show Space = "Space" 33 | show SoftBreak = "SoftBreak" 34 | show LineBreak = "LineBreak" 35 | show (Emph is) = "(Emph " <> show is <> ")" 36 | show (Strong is) = "(Strong " <> show is <> ")" 37 | show (Code e s) = "(Code " <> show e <> " " <> show s <> ")" 38 | show (Link is tgt) = "(Link " <> show is <> " " <> show tgt <> ")" 39 | show (Image is uri) = "(Image " <> show is <> " " <> show uri <> ")" 40 | show (FormField l r f) = "(FormField " <> show l <> " " <> show r <> " " <> show f <> ")" 41 | 42 | derive instance eqInline ∷ Eq a ⇒ Eq (Inline a) 43 | derive instance eq1Inline ∷ Eq1 Inline 44 | derive instance ordInline ∷ Ord a ⇒ Ord (Inline a) 45 | derive instance ord1Inline ∷ Ord1 Inline 46 | 47 | data LinkTarget 48 | = InlineLink String 49 | | ReferenceLink (M.Maybe String) 50 | 51 | derive instance eqLinkTarget ∷ Eq LinkTarget 52 | derive instance ordLinkTarget ∷ Ord LinkTarget 53 | 54 | instance showLinkTarget ∷ Show LinkTarget where 55 | show (InlineLink uri) = "(InlineLink " <> show uri <> ")" 56 | show (ReferenceLink tgt) = "(ReferenceLink " <> show tgt <> ")" 57 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax/TextBox.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax.TextBox 2 | ( TimePrecision(..) 3 | , TextBox(..) 4 | , transTextBox 5 | , traverseTextBox 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.DateTime as DT 11 | import Data.Eq (class Eq1) 12 | import Data.HugeNum as HN 13 | import Data.Identity (Identity(..)) 14 | import Data.Newtype (unwrap) 15 | import Data.Ord (class Ord1) 16 | 17 | data TimePrecision 18 | = Minutes 19 | | Seconds 20 | 21 | derive instance eqTimePrecision ∷ Eq TimePrecision 22 | derive instance ordTimePrecision ∷ Ord TimePrecision 23 | 24 | instance showTimePrecision ∷ Show TimePrecision where 25 | show Minutes = "Minutes" 26 | show Seconds = "Seconds" 27 | 28 | data TextBox f 29 | = PlainText (f String) 30 | | Numeric (f HN.HugeNum) 31 | | Date (f DT.Date) 32 | | Time TimePrecision (f DT.Time) 33 | | DateTime TimePrecision (f DT.DateTime) 34 | 35 | transTextBox ∷ ∀ f g. (f ~> g) → TextBox f → TextBox g 36 | transTextBox eta = unwrap <<< traverseTextBox (Identity <<< eta) 37 | 38 | traverseTextBox 39 | ∷ ∀ f g h 40 | . Applicative h 41 | ⇒ (∀ a. f a → h (g a)) 42 | → TextBox f 43 | → h (TextBox g) 44 | traverseTextBox eta = case _ of 45 | PlainText def → PlainText <$> eta def 46 | Numeric def → Numeric <$> eta def 47 | Date def → Date <$> eta def 48 | Time prec def → Time prec <$> eta def 49 | DateTime prec def → DateTime prec <$> eta def 50 | 51 | instance showTextBox ∷ (Show (f String), Show (f HN.HugeNum), Show (f DT.Time), Show (f DT.Date), Show (f DT.DateTime)) ⇒ Show (TextBox f) where 52 | show = case _ of 53 | PlainText def → "(PlainText " <> show def <> ")" 54 | Numeric def → "(Numeric " <> show def <> ")" 55 | Date def → "(Date " <> show def <> ")" 56 | Time prec def → "(Time " <> show prec <> " " <> show def <> ")" 57 | DateTime prec def → "(DateTime " <> show prec <> " " <> show def <> ")" 58 | 59 | derive instance eqTextBox ∷ Eq1 f ⇒ Eq (TextBox f) 60 | derive instance ordTextBox ∷ Ord1 f ⇒ Ord (TextBox f) 61 | 62 | eraseMillis ∷ DT.Time → DT.Time 63 | eraseMillis (DT.Time h m s _) = DT.Time h m s bottom 64 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Syntax/Value.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Syntax.Value 2 | ( class Value 3 | , stringValue 4 | , renderValue 5 | ) where 6 | 7 | import Prelude 8 | 9 | class (Eq a, Ord a) ⇐ Value a where 10 | stringValue 11 | ∷ String 12 | → a 13 | renderValue 14 | ∷ a 15 | → String 16 | 17 | instance valueString ∷ Value String where 18 | stringValue = identity 19 | renderValue = identity 20 | -------------------------------------------------------------------------------- /src/Text/Markdown/SlamDown/Traverse.purs: -------------------------------------------------------------------------------- 1 | module Text.Markdown.SlamDown.Traverse 2 | ( everywhereM 3 | , everywhere 4 | , everywhereTopDownM 5 | , everywhereTopDown 6 | , everythingM 7 | , everything 8 | ) where 9 | 10 | import Prelude 11 | 12 | import Data.Foldable as F 13 | import Data.Identity as Id 14 | import Data.Newtype (un) 15 | import Data.Traversable as T 16 | 17 | import Text.Markdown.SlamDown.Syntax as SD 18 | 19 | everywhereM 20 | ∷ ∀ m a 21 | . Monad m 22 | ⇒ (SD.Block a → m (SD.Block a)) 23 | → (SD.Inline a → m (SD.Inline a)) 24 | → SD.SlamDownP a 25 | → m (SD.SlamDownP a) 26 | everywhereM b i (SD.SlamDown bs) = 27 | SD.SlamDown <$> T.traverse b' bs 28 | 29 | where 30 | b' ∷ SD.Block a → m (SD.Block a) 31 | b' (SD.Paragraph is) = (SD.Paragraph <$> T.traverse i' is) >>= b 32 | b' (SD.Header n is) = (SD.Header n <$> T.traverse i' is) >>= b 33 | b' (SD.Blockquote bs') = (SD.Blockquote <$> T.traverse b' bs') >>= b 34 | b' (SD.Lst lt bss) = (SD.Lst lt <$> T.traverse (T.traverse b') bss) >>= b 35 | b' other = b other 36 | 37 | i' ∷ SD.Inline a → m (SD.Inline a) 38 | i' (SD.Emph is) = (SD.Emph <$> T.traverse i' is) >>= i 39 | i' (SD.Strong is) = (SD.Strong <$> T.traverse i' is) >>= i 40 | i' (SD.Link is uri) = (flip SD.Link uri <$> T.traverse i' is) >>= i 41 | i' (SD.Image is uri) = (flip SD.Image uri <$> T.traverse i' is) >>= i 42 | i' other = i other 43 | 44 | everywhere 45 | ∷ ∀ a 46 | . (SD.Block a → SD.Block a) 47 | → (SD.Inline a → SD.Inline a) 48 | → SD.SlamDownP a 49 | → SD.SlamDownP a 50 | everywhere b i = 51 | un Id.Identity 52 | <<< everywhereM (pure <<< b) (pure <<< i) 53 | 54 | everywhereTopDownM 55 | ∷ ∀ m a 56 | . Monad m 57 | ⇒ (SD.Block a → m (SD.Block a)) 58 | → (SD.Inline a → m (SD.Inline a)) 59 | → SD.SlamDownP a 60 | → m (SD.SlamDownP a) 61 | everywhereTopDownM b i (SD.SlamDown bs) = 62 | SD.SlamDown <$> 63 | T.traverse (b' <=< b) bs 64 | where 65 | b' ∷ SD.Block a → m (SD.Block a) 66 | b' (SD.Paragraph is) = SD.Paragraph <$> T.traverse (i' <=< i) is 67 | b' (SD.Header n is) = SD.Header n <$> T.traverse (i' <=< i) is 68 | b' (SD.Blockquote bs') = SD.Blockquote <$> T.traverse (b' <=< b) bs' 69 | b' (SD.Lst ty bss) = SD.Lst ty <$> T.traverse (T.traverse (b' <=< b)) bss 70 | b' other = b other 71 | 72 | i' ∷ SD.Inline a → m (SD.Inline a) 73 | i' (SD.Emph is) = SD.Emph <$> T.traverse (i' <=< i) is 74 | i' (SD.Strong is) = SD.Strong <$> T.traverse (i' <=< i) is 75 | i' (SD.Link is uri) = flip SD.Link uri <$> T.traverse (i' <=< i) is 76 | i' (SD.Image is uri) = flip SD.Image uri <$> T.traverse (i' <=< i) is 77 | i' other = i other 78 | 79 | everywhereTopDown 80 | ∷ ∀ a 81 | . (SD.Block a → SD.Block a) 82 | → (SD.Inline a → SD.Inline a) 83 | → SD.SlamDownP a 84 | → SD.SlamDownP a 85 | everywhereTopDown b i = 86 | un Id.Identity <<< 87 | everywhereTopDownM 88 | (pure <<< b) 89 | (pure <<< i) 90 | 91 | everythingM 92 | ∷ ∀ m a r 93 | . Monad m 94 | ⇒ Monoid r 95 | ⇒ (SD.Block a → m r) 96 | → (SD.Inline a → m r) 97 | → SD.SlamDownP a 98 | → m r 99 | everythingM b i (SD.SlamDown bs) = 100 | F.fold <$> T.traverse b' bs 101 | where 102 | b' ∷ SD.Block a → m r 103 | b' x@(SD.Paragraph is) = b x >>= \r → F.foldl (<>) r <$> T.traverse i' is 104 | b' x@(SD.Header _ is) = b x >>= \r → F.foldl (<>) r <$> T.traverse i' is 105 | b' x@(SD.Blockquote bs') = b x >>= \r → F.foldl (<>) r <$> T.traverse b' bs' 106 | b' x@(SD.Lst _ bss) = b x >>= \r → F.foldl (<>) r <<< join <$> T.traverse (\bs' → T.traverse b' bs') bss 107 | b' x = b x 108 | 109 | i' ∷ SD.Inline a → m r 110 | i' x@(SD.Emph is) = i x >>= \r → F.foldl (<>) r <$> T.traverse i' is 111 | i' x@(SD.Strong is) = i x >>= \r → F.foldl (<>) r <$> T.traverse i' is 112 | i' x@(SD.Link is _) = i x >>= \r → F.foldl (<>) r <$> T.traverse i' is 113 | i' x@(SD.Image is _) = i x >>= \r → F.foldl (<>) r <$> T.traverse i' is 114 | i' x = i x 115 | 116 | everything 117 | ∷ ∀ r a 118 | . Monoid r 119 | ⇒ (SD.Block a → r) 120 | → (SD.Inline a → r) 121 | → SD.SlamDownP a 122 | → r 123 | everything b i = 124 | un Id.Identity <<< 125 | everythingM 126 | (pure <<< b) 127 | (pure <<< i) 128 | -------------------------------------------------------------------------------- /test/src/Test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Data.DateTime as DT 6 | import Data.Either (Either(..), isLeft) 7 | import Data.Enum (toEnum) 8 | import Data.HugeNum as HN 9 | import Data.Identity as ID 10 | import Data.List as L 11 | import Data.Maybe as M 12 | import Data.Newtype (un) 13 | import Effect (Effect) 14 | import Effect.Console as C 15 | import Partial.Unsafe (unsafePartial) 16 | import Test.Assert (assert, assertEqual) 17 | import Text.Markdown.SlamDown.Eval as SDE 18 | import Text.Markdown.SlamDown.Parser as SDP 19 | import Text.Markdown.SlamDown.Pretty as SDPR 20 | import Text.Markdown.SlamDown.Syntax as SD 21 | 22 | testDocument ∷ Either String (SD.SlamDownP String) → Effect Unit 23 | testDocument sd = do 24 | let printed = SDPR.prettyPrintMd <$> sd 25 | parsed = printed >>= SDP.parseMd 26 | 27 | C.log 28 | $ "Original: \n " 29 | <> show sd 30 | <> "\nPrinted:\n " 31 | <> show printed 32 | <> "\nParsed:\n " 33 | <> show parsed 34 | assertEqual { expected: parsed, actual: sd } 35 | 36 | failDocument ∷ Either String (SD.SlamDownP String) → Effect Unit 37 | failDocument sd = assert (isLeft sd) 38 | 39 | main ∷ Effect Unit 40 | main = do 41 | testDocument $ SDP.parseMd "Paragraph" 42 | testDocument $ SDP.parseMd "Paragraph with spaces" 43 | testDocument $ SDP.parseMd "Paragraph with an entity: ©" 44 | testDocument $ SDP.parseMd "Paragraph with a [link](http://purescript.org)" 45 | testDocument $ SDP.parseMd "Paragraph with an ![image](image.png)" 46 | testDocument $ SDP.parseMd "Paragraph with some `embedded code`" 47 | testDocument $ SDP.parseMd "Paragraph with some !`code which can be evaluated`" 48 | testDocument $ SDP.parseMd "Paragraph with _emphasis_" 49 | testDocument $ SDP.parseMd "Paragraph with _emphasis_ and __strong text__" 50 | 51 | testDocument $ 52 | SDP.parseMd 53 | "Paragraph with a\n\ 54 | \soft break" 55 | 56 | testDocument $ 57 | SDP.parseMd 58 | "Paragraph with a \n\ 59 | \line break" 60 | 61 | testDocument $ 62 | SDP.parseMd 63 | "Two\n\ 64 | \\n\ 65 | \paragraphs" 66 | 67 | testDocument $ 68 | SDP.parseMd 69 | "Header\n\ 70 | \===" 71 | 72 | testDocument $ 73 | SDP.parseMd 74 | "# Header\n\ 75 | \\n\ 76 | \Paragraph text" 77 | 78 | testDocument $ 79 | SDP.parseMd 80 | "## Header\n\ 81 | \\n\ 82 | \Paragraph text" 83 | 84 | testDocument $ 85 | SDP.parseMd 86 | "### Header\n\ 87 | \\n\ 88 | \Paragraph text" 89 | 90 | testDocument $ 91 | SDP.parseMd 92 | "#### Header\n\ 93 | \\n\ 94 | \Paragraph text" 95 | 96 | testDocument $ 97 | SDP.parseMd 98 | "##### Header\n\ 99 | \\n\ 100 | \Paragraph text" 101 | 102 | testDocument $ 103 | SDP.parseMd 104 | "###### Header\n\ 105 | \\n\ 106 | \Paragraph text" 107 | 108 | testDocument $ 109 | SDP.parseMd 110 | "Rule:\n\ 111 | \\n\ 112 | \-----" 113 | 114 | testDocument $ 115 | SDP.parseMd 116 | "A blockquote:\n\ 117 | \\n\ 118 | \> Here is some text\n\ 119 | \> inside a blockquote" 120 | 121 | testDocument $ 122 | SDP.parseMd 123 | "A nested blockquote:\n\ 124 | \\n\ 125 | \> Here is some text\n\ 126 | \> > Here is some more text" 127 | 128 | testDocument $ 129 | SDP.parseMd 130 | "An unordered list:\n\ 131 | \\n\ 132 | \* Item 1\n\ 133 | \* Item 2" 134 | 135 | testDocument $ 136 | SDP.parseMd 137 | "An ordered list:\n\ 138 | \\n\ 139 | \1. Item 1\n\ 140 | \1. Item 2" 141 | 142 | testDocument $ 143 | SDP.parseMd 144 | "A nested list:\n\ 145 | \\n\ 146 | \1. Item 1\n\ 147 | \1. 1. Item 2\n\ 148 | \ 1. Item 3" 149 | 150 | testDocument $ 151 | SDP.parseMd 152 | "Some indented code:\n\ 153 | \\n\ 154 | \ import Debug.Log\n\ 155 | \ \n\ 156 | \ main = log \"Hello World\"" 157 | 158 | testDocument $ 159 | SDP.parseMd 160 | "Some fenced code:\n\ 161 | \\n\ 162 | \```purescript\n\ 163 | \import Debug.Log\n\ 164 | \\n\ 165 | \main = log \"Hello World\"\n\ 166 | \```" 167 | 168 | testDocument $ 169 | SDP.parseMd 170 | "Some fenced code which can be evaluated:\n\ 171 | \\n\ 172 | \!~~~purescript\n\ 173 | \import Debug.Log\n\ 174 | \\n\ 175 | \main = log \"Hello World\"\n\ 176 | \~~~" 177 | 178 | let 179 | probablyParsedCodeForEvaluation = 180 | SDP.parseMd 181 | "Some evaluated fenced code:\n\ 182 | \\n\ 183 | \!~~~purescript\n\ 184 | \import Debug.Log\n\ 185 | \\n\ 186 | \main = log \"Hello World\"\n\ 187 | \~~~" 188 | 189 | testDocument 190 | case probablyParsedCodeForEvaluation of 191 | Right sd → 192 | Right 193 | $ un ID.Identity 194 | $ SDE.eval 195 | { code: \_ _ → pure $ SD.stringValue "Evaluated code block!" 196 | , textBox: \_ t → 197 | case t of 198 | SD.PlainText _ → pure $ SD.PlainText $ pure "Evaluated plain text!" 199 | SD.Numeric _ → pure $ SD.Numeric $ pure $ HN.fromNumber 42.0 200 | SD.Date _ → pure $ SD.Date $ pure $ unsafeDate 1992 7 30 201 | SD.Time (prec@SD.Minutes) _ → pure $ SD.Time prec $ pure $ unsafeTime 4 52 0 202 | SD.Time (prec@SD.Seconds) _ → pure $ SD.Time prec $ pure $ unsafeTime 4 52 10 203 | SD.DateTime (prec@SD.Minutes) _ → 204 | pure $ SD.DateTime prec $ pure $ 205 | DT.DateTime (unsafeDate 1992 7 30) (unsafeTime 4 52 0) 206 | SD.DateTime (prec@SD.Seconds) _ → 207 | pure $ SD.DateTime prec $ pure $ 208 | DT.DateTime (unsafeDate 1992 7 30) (unsafeTime 4 52 10) 209 | , value: \_ _ → pure $ SD.stringValue "Evaluated value!" 210 | , list: \_ _ → pure $ L.singleton $ SD.stringValue "Evaluated list!" 211 | } sd 212 | a → a 213 | 214 | testDocument $ SDP.parseMd "name = __ (Phil Freeman)" 215 | testDocument $ SDP.parseMd "name = __ (!`name`)" 216 | testDocument $ SDP.parseMd "sex* = (x) male () female () other" 217 | testDocument $ SDP.parseMd "sex* = (!`def`) !`others`" 218 | testDocument $ SDP.parseMd "city = {BOS, SFO, NYC} (NYC)" 219 | testDocument $ SDP.parseMd "city = {!`...`} (!`...`)" 220 | testDocument $ SDP.parseMd "phones = [] Android [x] iPhone [x] Blackberry" 221 | testDocument $ SDP.parseMd "phones = [!`...`] !`...`" 222 | testDocument $ SDP.parseMd "start = __ - __ - ____ (06-06-2015)" 223 | testDocument $ SDP.parseMd "start = __ - __ - ____ (!`...`)" 224 | testDocument $ SDP.parseMd "start = __ : __ (10:32 PM)" 225 | failDocument $ SDP.parseMd "start = __ : __ (10:32:46 PM)" 226 | failDocument $ SDP.parseMd "start = __ : __ : __ (10:32 PM)" 227 | testDocument $ SDP.parseMd "start = __ : __ : __ (10:32:46 PM)" 228 | testDocument $ SDP.parseMd "start = __ : __ (!`...`)" 229 | testDocument $ SDP.parseMd "start = __-__-____ __:__ (06-06-2015 12:00 PM)" 230 | testDocument $ SDP.parseMd "start = __ - __ - ____ __ : __ (!`...`)" 231 | testDocument $ SDP.parseMd "[zip code]* = __ (12345)" 232 | testDocument $ SDP.parseMd "defaultless = __" 233 | testDocument $ SDP.parseMd "city = {BOS, SFO, NYC}" 234 | testDocument $ SDP.parseMd "start = __ - __ - ____" 235 | testDocument $ SDP.parseMd "start = __ : __" 236 | testDocument $ SDP.parseMd "start = __ : __ : __" 237 | testDocument $ SDP.parseMd "start = __ - __ - ____ __ : __ : __" 238 | testDocument $ SDP.parseMd "zip* = ________" 239 | testDocument $ SDP.parseMd "[numeric field] = #______ (23)" 240 | testDocument $ SDP.parseMd "i9a0qvg8* = ______ (9a0qvg8h)" 241 | testDocument $ SDP.parseMd "xeiodbdy = [x] " 242 | 243 | C.log "All static tests passed!" 244 | 245 | unsafeDate ∷ Int → Int → Int → DT.Date 246 | unsafeDate y m d = unsafePartial $ M.fromJust $ join $ DT.exactDate <$> toEnum y <*> toEnum m <*> toEnum d 247 | 248 | unsafeTime ∷ Int → Int → Int → DT.Time 249 | unsafeTime h m s = unsafePartial $ M.fromJust $ DT.Time <$> toEnum h <*> toEnum m <*> toEnum s <*> toEnum bottom 250 | --------------------------------------------------------------------------------