propagate default errors

Author: cryogenian

.travis.yml

@@ -4,7 +4,7 @@ sudo: required
 node_js:
   - 5
 install:
-  - npm install pulp bower -g
+  - npm install pulp@8.2.1 bower -g
   - npm install && bower install
 script:
   - pulp test

src/Text/Markdown/SlamDown/Parser.purs

@@ -7,6 +7,7 @@ module Text.Markdown.SlamDown.Parser
 import Prelude
 
 import Data.Foldable (any, all)
+import Data.Either (Either)
 import Data.List as L
 import Data.Maybe as M
 import Data.Monoid (mempty)
@@ -18,6 +19,9 @@ import Text.Markdown.SlamDown.Syntax as SD
 import Text.Markdown.SlamDown.Parser.Inline as Inline
 import Text.Markdown.SlamDown.Parser.References as Ref
 
+infixr 6 L.Cons as :
+
+
 data Container a
   = CText String
   | CBlank
@@ -310,37 +314,43 @@ parseBlocks
   ∷ ∀ a
   . (SD.Value a)
   ⇒ L.List (Container a)
-  → L.List (SD.Block a)
+  → Either String (L.List (SD.Block a))
 parseBlocks cs =
   case cs of
-    L.Nil → L.Nil
-    L.Cons (CText s) (L.Cons (CSetextHeader n) cs) →
-      L.Cons (SD.Header n (Inline.parseInlines $ L.singleton s)) $ parseBlocks cs
-    L.Cons (CText s) cs →
+    L.Nil → pure L.Nil
+    (CText s) : (CSetextHeader n) : cs → do
+      hd ← Inline.parseInlines $ L.singleton s
+      tl ← parseBlocks cs
+      pure $ (SD.Header n hd) : tl
+    (CText s) : cs → do
       let
         sp = L.span isTextContainer cs
-        is = Inline.parseInlines $ L.Cons s (map getCText sp.init)
-      in
-        L.Cons (SD.Paragraph is) $ parseBlocks sp.rest
-    L.Cons CRule cs →
-      L.Cons SD.Rule $ parseBlocks cs
-    L.Cons (CATXHeader n s) cs →
-      L.Cons (SD.Header n (Inline.parseInlines $ L.singleton s)) $ parseBlocks cs
-    L.Cons (CBlockquote cs) cs1 →
-      L.Cons (SD.Blockquote $ parseBlocks cs) $ parseBlocks cs1
-    L.Cons (CListItem lt cs) cs1 →
+      is ← Inline.parseInlines $ s : (map getCText sp.init)
+      tl ← parseBlocks sp.rest
+      pure $ (SD.Paragraph is) : tl
+    CRule : cs →
+      map (SD.Rule : _) $ parseBlocks cs
+    (CATXHeader n s) : cs → do
+      hd ← Inline.parseInlines $ L.singleton s
+      tl ← parseBlocks cs
+      pure $ (SD.Header n hd) : tl
+    (CBlockquote cs) : cs1 → do
+      hd ← parseBlocks cs
+      tl ← parseBlocks cs1
+      pure $ (SD.Blockquote hd) : tl
+    (CListItem lt cs) : cs1 → do
       let
         sp = L.span (isListItem lt) cs1
-        bs = parseBlocks cs
-        bss = map (parseBlocks <<< getCListItem) sp.init
-      in
-        L.Cons (SD.Lst lt (L.Cons bs bss)) $ parseBlocks sp.rest
-    L.Cons (CCodeBlockIndented ss) cs →
-      L.Cons (SD.CodeBlock SD.Indented ss) $ parseBlocks cs
-    L.Cons (CCodeBlockFenced eval info ss) cs →
-      L.Cons (SD.CodeBlock (SD.Fenced eval info) ss) $ parseBlocks cs
-    L.Cons (CLinkReference b) cs →
-      L.Cons b $ parseBlocks cs
+      bs ← parseBlocks cs
+      bss ← traverse (parseBlocks <<< getCListItem) sp.init
+      tl ← parseBlocks sp.rest
+      pure $ (SD.Lst lt (bs : bss)) : tl
+    (CCodeBlockIndented ss) : cs →
+      map ((SD.CodeBlock SD.Indented ss) : _) $ parseBlocks cs
+    (CCodeBlockFenced eval info ss) : cs →
+      map ((SD.CodeBlock (SD.Fenced eval info) ss) : _) $ parseBlocks cs
+    (CLinkReference b) : cs →
+      map (b : _) $ parseBlocks cs
     L.Cons _ cs →
       parseBlocks cs
 
@@ -359,8 +369,8 @@ validateSlamDown (SD.SlamDown bls) = SD.SlamDown <$> traverse validateBlock bls
 tabsToSpaces ∷ String → String
 tabsToSpaces = S.replace "\t" "    "
 
-parseMd ∷ ∀ a. (SD.Value a) ⇒ String → SD.SlamDownP a
-parseMd s = SD.SlamDown bs
+parseMd ∷ ∀ a. (SD.Value a) ⇒ String → Either String (SD.SlamDownP a)
+parseMd s = map SD.SlamDown bs
   where
     lines = L.toList $ S.split "\n" $ S.replace "\r" "" $ tabsToSpaces s
     ctrs = parseContainers mempty lines

src/Text/Markdown/SlamDown/Parser/Inline.purs

@@ -10,8 +10,11 @@ import Prelude
 import Control.Alt ((<|>))
 import Control.Apply ((<*), (*>))
 import Control.Lazy as Lazy
+import Control.Monad (when)
 
+import Data.Bifunctor (lmap)
 import Data.Const (Const(..))
+import Data.Either (Either(..))
 import Data.Foldable (elem)
 import Data.Functor ((<$))
 import Data.Functor.Compose (Compose(..))
@@ -34,11 +37,11 @@ parseInlines
   ∷ ∀ a
   . (SD.Value a)
   ⇒ L.List String
-  → L.List (SD.Inline a)
+  → Either String (L.List (SD.Inline a))
 parseInlines s =
-  -- Note: `fromRight` is benign, because the parser never fails
-  consolidate <<< Data.Either.Unsafe.fromRight $
-    P.runParser (S.joinWith "\n" $ L.fromList s) inlines
+  map consolidate
+    $ lmap (\(P.ParseError {message}) → message)
+    $ P.runParser (S.joinWith "\n" $ L.fromList s) inlines
 
 consolidate
   ∷ ∀ a
@@ -142,11 +145,15 @@ inlines = L.many inline2 <* PS.eof
       <|> PC.try link
 
   inline2 ∷ P.Parser String (SD.Inline a)
-  inline2 =
-    PC.try formField
-      <|> PC.try inline1
-      <|> PC.try image
-      <|> other
+  inline2 = do
+    res ←
+      PC.try formField
+      <|> PC.try (Right <$> inline1)
+      <|> PC.try (Right <$> image)
+      <|> (Right <$> other)
+    case res of
+      Right v → pure v
+      Left e → P.fail e
 
   alphaNumStr ∷ P.Parser String (SD.Inline a)
   alphaNumStr = SD.Str <$> someOf isAlphaNum
@@ -158,7 +165,11 @@ inlines = L.many inline2 <* PS.eof
     (s >= "0" && s <= "9")
     where s = S.fromChar c
 
-  emphasis ∷ P.Parser String (SD.Inline a) → (L.List (SD.Inline a) → SD.Inline a) → String → P.Parser String (SD.Inline a)
+  emphasis
+    ∷ P.Parser String (SD.Inline a)
+    → (L.List (SD.Inline a) → SD.Inline a)
+    → String
+    → P.Parser String (SD.Inline a)
   emphasis p f s = do
     PS.string s
     f <$> PC.manyTill p (PS.string s)
@@ -233,33 +244,63 @@ inlines = L.many inline2 <* PS.eof
     s ← (S.fromCharArray <<< L.fromList) <$> (PS.noneOf (S.toCharArray ";") `PC.many1Till` PS.string ";")
     return $ SD.Entity $ "&" <> s <> ";"
 
-  formField ∷ P.Parser String (SD.Inline a)
+  formField ∷ P.Parser String (Either String (SD.Inline a))
   formField =
-    SD.FormField
-      <$> label
-      <*> (PU.skipSpaces *> required)
-      <*> (PU.skipSpaces *> PS.string "=" *> PU.skipSpaces *> formElement)
+    do
+      l ← label
+      r ← do
+          PU.skipSpaces
+          required
+      fe ← do
+        PU.skipSpaces
+        PS.string "="
+        PU.skipSpaces
+        formElement
+      pure $ map (SD.FormField l r) fe
     where
-    label = someOf isAlphaNum <|> (S.fromCharArray <<< L.fromList <$> (PS.string "[" *> PC.manyTill PS.anyChar (PS.string "]")))
+    label =
+      someOf isAlphaNum
+      <|> (S.fromCharArray
+             <<< L.fromList
+             <$> (PS.string "[" *> PC.manyTill PS.anyChar (PS.string "]")))
+
     required = PC.option false (PS.string "*" *> pure true)
 
-  formElement ∷ P.Parser String (SD.FormField a)
+  formElement ∷ P.Parser String (Either String (SD.FormField a))
   formElement =
     PC.try textBox
-      <|> PC.try radioButtons
-      <|> PC.try checkBoxes
-      <|> PC.try dropDown
+      <|> PC.try (Right <$> radioButtons)
+      <|> PC.try (Right <$> checkBoxes)
+      <|> PC.try (Right <$> dropDown)
     where
 
-    textBox ∷ P.Parser String (SD.FormField a)
+    textBox ∷ P.Parser String (Either String (SD.FormField a))
     textBox = do
       template ← parseTextBoxTemplate
       PU.skipSpaces
-      mdef ← PC.optionMaybe $ PU.parens $ parseTextBox (\x → x /= ')') (expr id) template
-      pure $ SD.TextBox $
-        case mdef of
-          M.Nothing → SD.transTextBox (const $ Compose M.Nothing) template
-          M.Just def → SD.transTextBox (M.Just >>> Compose) def
+      defVal ← PC.optionMaybe $ PS.string "("
+      case defVal of
+        M.Nothing → pure $ Right $ SD.TextBox $ SD.transTextBox (const $ Compose M.Nothing) template
+        M.Just _ → do
+          PU.skipSpaces
+          mdef ← PC.optionMaybe $ PC.try $ parseTextBox (_ /= ')') (expr id) template
+          case mdef of
+            M.Just def → do
+              PU.skipSpaces
+              PS.string ")"
+              pure $ Right $ SD.TextBox $ SD.transTextBox (M.Just >>> Compose) def
+            M.Nothing →
+              pure $ Left case template of
+                SD.DateTime _ →
+                  "Incorrect datetime default value, please use \"YYYY-MM-DD HH:mm\" or \"YYYY-MM-DDTHH:mm\" format"
+                SD.Date _ →
+                  "Incorrect date default value, please use \"YYYY-MM-DD\" format"
+                SD.Time _ →
+                  "Incorrect time default value, please use \"HH:mm\" or \"HH:mm:ss\" format"
+                SD.Numeric _ →
+                  "Incorrect numeric default value"
+                SD.PlainText _ →
+                  "Incorrect default value"
 
     parseTextBoxTemplate ∷ P.Parser String (SD.TextBox (Const Unit))
     parseTextBoxTemplate =
@@ -372,22 +413,26 @@ parseTextBox isPlainText eta template =
   where
     parseDateTimeValue = do
       date ← parseDateValue
-      PU.skipSpaces
+      (PC.try $ void $ PS.string "T") <|> PU.skipSpaces
       time ← parseTimeValue
       pure { date, time }
 
     parseDateValue = do
-      year ← natural
+      year ← parseYear
       PU.skipSpaces *> dash *> PU.skipSpaces
       month ← natural
+      when (month > 12) $ P.fail "Incorrect month"
       PU.skipSpaces *> dash *> PU.skipSpaces
       day ← natural
+      when (day > 31) $ P.fail "Incorrect day"
       pure { month, day, year }
 
     parseTimeValue = do
       hours ← natural
+      when (hours > 23) $ P.fail "Incorrect hours"
       PU.skipSpaces *> colon *> PU.skipSpaces
       minutes ← natural
+      when (minutes > 59) $ P.fail "Incorrect minutes"
       PU.skipSpaces
       amPm ←
         PC.optionMaybe $
@@ -432,6 +477,21 @@ parseTextBox isPlainText eta template =
     digit =
       PS.oneOf ['0','1','2','3','4','5','6','7','8','9']
 
+    digitN = do
+      ds ← digit
+      ds
+        # pure
+        # S.fromCharArray
+        # Data.Int.fromString
+        # M.maybe (P.fail "Failed parsing digit") pure
+
+    parseYear = do
+      millenia ← digitN
+      centuries ← digitN
+      decades ← digitN
+      years ← digitN
+      pure $ 1000 * millenia + 100 * centuries + 10 * decades + years
+
     digits =
       L.some digit <#>
         L.fromList >>> S.fromCharArray

src/Text/Markdown/SlamDown/Pretty.purs

@@ -136,7 +136,7 @@ prettyPrintTime { hours, minutes }=
 prettyPrintDateTime ∷ SD.DateTimeValue → String
 prettyPrintDateTime { date, time } =
   prettyPrintDate date
-    <> " "
+    <> "T"
     <> prettyPrintTime time
 
 printIntPadded ∷ Int → Int → String