Improve checkbox model (#66)

* checkbox: fix model & thence fix bizarre evaluation semantics

* improve type class instances

Added Ord instances all around so we don't need to compare through
strings, which is horrid.

* beautify

* update test

* remove no-longer-sensible validation

Author: jonsterling

bower.json

@@ -30,6 +30,7 @@
     "purescript-parsing": "^0.8.0",
     "purescript-prelude": "^0.1.3",
     "purescript-strongcheck": "^0.14.4",
-    "purescript-validation": "^0.2.1"
+    "purescript-validation": "^0.2.1",
+    "purescript-sets": "^0.5.7"
   }
 }

src/Text/Markdown/SlamDown/Eval.purs

@@ -4,12 +4,10 @@ module Text.Markdown.SlamDown.Eval
   ) where
 
 import Prelude
-import Control.Bind ((>=>))
 import Control.Alt ((<|>))
 import Data.Const (Const(..))
 import Data.Identity (Identity(..), runIdentity)
 import Data.Functor.Compose (Compose(..), decompose)
-import Data.Foldable as F
 import Data.List as L
 import Data.Maybe as M
 import Data.String as S
@@ -64,23 +62,20 @@ eval fs = everywhereM b i
   f (SD.RadioButtons sel opts) = do
     sel' ← evalExpr fs.value sel
     opts' ← evalExpr fs.list opts
-    pure $ SD.RadioButtons sel' (mergeSelection sel' opts')
+    pure $ SD.RadioButtons sel' (mergeSelection (L.singleton <$> sel') opts')
 
-  f (SD.CheckBoxes checkeds vals) = do
+  f (SD.CheckBoxes sel vals) = do
+    sel' ← evalExpr fs.list sel
     vals' ← evalExpr fs.list vals
-    checkeds' ← evalExpr (fs.list >=> \cs → pure $ map (_ `F.elem` cs) (getValues vals')) checkeds
-    pure $ SD.CheckBoxes checkeds' vals'
+    pure $ SD.CheckBoxes sel' (mergeSelection sel' vals')
 
   f (SD.DropDown msel opts) = do
     msel' ← T.traverse (evalExpr fs.value) msel
     opts' ← evalExpr fs.list opts
-    pure $ SD.DropDown msel' $ M.maybe opts' (flip mergeSelection opts') msel'
+    pure $ SD.DropDown msel' $ M.maybe opts' (flip mergeSelection opts' <<< map L.singleton) msel'
 
-  mergeSelection ∷ SD.Expr a → SD.Expr (L.List a) → SD.Expr (L.List a)
-  mergeSelection (SD.Literal x) (SD.Literal xs) =
-    if F.elem x xs
-    then SD.Literal xs
-    else SD.Literal $ L.Cons x xs
+  mergeSelection ∷ SD.Expr (L.List a) → SD.Expr (L.List a) → SD.Expr (L.List a)
+  mergeSelection (SD.Literal sel) (SD.Literal xs) = SD.Literal $ L.union sel xs
   mergeSelection _ exs = exs
 
   evalExpr ∷ ∀ e. (String → m e) → SD.Expr e → m (SD.Expr e)

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

@@ -98,8 +98,6 @@ validateFormField
   → V.V (Array String) (SD.FormField a)
 validateFormField field =
   case field of
-    SD.CheckBoxes (SD.Literal bs) (SD.Literal ls) | L.length bs /= L.length ls →
-      V.invalid ["Invalid checkboxes"]
     SD.CheckBoxes (SD.Literal _) (SD.Unevaluated _) →
       V.invalid ["Checkbox values & selection must be both literals or both unevaluated expressions"]
     SD.CheckBoxes (SD.Unevaluated _) (SD.Literal _) →
@@ -333,7 +331,7 @@ inlines = L.many inline2 <* PS.eof
             PU.skipSpaces
             l ← item
             return $ Tuple b l
-          return $ SD.CheckBoxes (SD.Literal (map fst ls)) (SD.Literal (map snd ls))
+          return $ SD.CheckBoxes (SD.Literal $ snd <$> L.filter fst ls) (SD.Literal $ snd <$> ls)
 
         evaluatedCheckBoxes =
           SD.CheckBoxes

src/Text/Markdown/SlamDown/Pretty.purs

@@ -6,7 +6,7 @@ module Text.Markdown.SlamDown.Pretty
 import Prelude
 
 import Data.Array as A
-import Data.Foldable (fold)
+import Data.Foldable (fold, elem)
 import Data.Identity (Identity(..))
 import Data.Functor.Compose (Compose(), decompose)
 import Data.HugeNum as HN
@@ -183,11 +183,11 @@ prettyPrintFormElement el =
         S.joinWith " " $ L.fromList (map radioButton ls)
     SD.RadioButtons (SD.Unevaluated bs) (SD.Unevaluated ls) →
       "(!`" <> bs <> "`) !`" <> ls <> "`"
-    SD.CheckBoxes (SD.Literal bs) (SD.Literal ls) →
+    SD.CheckBoxes (SD.Literal sel) (SD.Literal ls) →
       let
-        checkBox b l = (if b then "[x] " else "[] ") <> SD.renderValue l
+        checkBox l = (if elem l sel then "[x] " else "[] ") <> SD.renderValue l
       in
-        S.joinWith " " $ L.fromList (L.zipWith checkBox bs ls)
+        S.joinWith " " <<< L.fromList $ checkBox <$> ls
     SD.CheckBoxes (SD.Unevaluated bs) (SD.Unevaluated ls) →
       "[!`" <> bs <> "`] !`" <> ls <> "`"
     SD.DropDown sel lbls →

src/Text/Markdown/SlamDown/Syntax.purs

@@ -9,7 +9,6 @@ module Text.Markdown.SlamDown.Syntax
 
 import Prelude
 
-import Data.Function (on)
 import Data.List as L
 import Data.Monoid (class Monoid, mempty)
 import Test.StrongCheck as SC
@@ -30,12 +29,8 @@ instance functorSlamDownP ∷ Functor SlamDownP where
 instance showSlamDownP ∷ (Show a) ⇒ Show (SlamDownP a) where
   show (SlamDown bs) = "(SlamDown " ++ show bs ++ ")"
 
-instance eqSlamDownP ∷ (Eq a) ⇒ Eq (SlamDownP a) where
-  eq (SlamDown bs1) (SlamDown bs2) = bs1 == bs2
-
--- TODO: replace this with a proper `Ord` instance.
-instance ordSlamDownP ∷ (Show a, Eq a) ⇒ Ord (SlamDownP a) where
-  compare = compare `on` show
+derive instance eqSlamDownP ∷ (Eq a, Ord a) ⇒ Eq (SlamDownP a)
+derive instance ordSlamDownP ∷ (Eq a, Ord a) ⇒ Ord (SlamDownP a)
 
 instance semigroupSlamDownP ∷ Semigroup (SlamDownP a) where
   append (SlamDown bs1) (SlamDown bs2) = SlamDown (bs1 <> bs2)
@@ -45,4 +40,3 @@ instance monoidSlamDownP ∷ Monoid (SlamDownP a) where
 
 instance arbitrarySlamDownP ∷ (SC.Arbitrary a, Eq a) ⇒ SC.Arbitrary (SlamDownP a) where
   arbitrary = SlamDown <<< L.toList <$> Gen.arrayOf SC.arbitrary
-

src/Text/Markdown/SlamDown/Syntax/Block.purs

@@ -40,15 +40,8 @@ instance showBlock ∷ (Show a) ⇒ Show (Block a) where
   show (LinkReference l uri) = "(LinkReference " ++ show l ++ " " ++ show uri ++ ")"
   show Rule = "Rule"
 
-instance eqBlock ∷ (Eq a) ⇒ Eq (Block a) where
-  eq (Paragraph is1) (Paragraph is2) = is1 == is2
-  eq (Header n1 is1) (Header n2 is2) = n1 == n2 && is1 == is2
-  eq (Blockquote bs1) (Blockquote bs2) = bs1 == bs2
-  eq (Lst ty1 bss1) (Lst ty2 bss2) = ty1 == ty2 && bss1 == bss2
-  eq (CodeBlock ty1 ss1) (CodeBlock ty2 ss2) = ty1 == ty2 && ss1 == ss2
-  eq (LinkReference l1 uri1) (LinkReference l2 uri2) = l1 == l2 && uri1 == uri2
-  eq Rule Rule = true
-  eq _ _ = false
+derive instance eqBlock ∷ (Eq a, Ord a) ⇒ Eq (Block a)
+derive instance ordBlock ∷ (Ord a) ⇒ Ord (Block a)
 
 -- | Nota bene: this does not generate any recursive structure
 instance arbitraryBlock ∷ (SC.Arbitrary a, Eq a) ⇒ SC.Arbitrary (Block a) where
@@ -74,10 +67,8 @@ instance showListType ∷ Show ListType where
   show (Bullet s) = "(Bullet " ++ show s ++ ")"
   show (Ordered s) = "(Ordered " ++ show s ++ ")"
 
-instance eqListType ∷ Eq ListType where
-  eq (Bullet s1)  (Bullet s2) = s1 == s2
-  eq (Ordered s1) (Ordered s2) = s1 == s2
-  eq _ _ = false
+derive instance eqListType ∷ Eq ListType
+derive instance ordListType ∷ Ord ListType
 
 instance arbitraryListType ∷ SC.Arbitrary ListType where
   arbitrary = do
@@ -92,13 +83,10 @@ instance showCodeBlockType ∷ Show CodeBlockType where
   show Indented = "Indented"
   show (Fenced evaluated info) = "(Fenced " ++ show evaluated ++ " " ++ show info ++ ")"
 
-instance eqCodeBlockType ∷ Eq CodeBlockType where
-  eq Indented Indented = true
-  eq (Fenced b1 s1) (Fenced b2 s2) = b1 == b2 && s1 == s2
-  eq _ _ = false
+derive instance eqCodeBlockType ∷ Eq CodeBlockType
+derive instance ordCodeBlockType ∷ Ord CodeBlockType
 
 instance arbitraryCodeBlockType ∷ SC.Arbitrary CodeBlockType where
   arbitrary = do
     b ← SC.arbitrary
     if b then pure Indented else Fenced <$> SC.arbitrary <*> SC.arbitrary
-