From 37de517c606660c35390748d055f2b15850224dc Mon Sep 17 00:00:00 2001
From: Philippe Pittoli <karchnu@karchnu.fr>
Date: Sat, 22 Jul 2023 14:58:52 +0200
Subject: [PATCH] Playing with parsers some more.

---
 drop/PlayingWithParsers.purs | 104 ++++++++++++++++++++++++-----------
 1 file changed, 73 insertions(+), 31 deletions(-)

diff --git a/drop/PlayingWithParsers.purs b/drop/PlayingWithParsers.purs
index ceaae71..7680aeb 100644
--- a/drop/PlayingWithParsers.purs
+++ b/drop/PlayingWithParsers.purs
@@ -1,4 +1,4 @@
-module PlayingWithParsers where
+module Main where
 
 import Prelude
 
@@ -7,42 +7,79 @@ import Effect (Effect)
 import TryPureScript (h1, h3, p, text, render, code)
 import Parsing (Parser, runParser)
 import Parsing.Combinators as PC
-import Parsing.String (char, string)
+import Data.String.CodeUnits as CU
+-- import Data.String (joinWith)
+
+import Parsing.String (char, string, eof)
 import Parsing.String.Basic (alphaNum, letter)
 import Control.Alt ((<|>))
 import Control.Lazy (defer)
-import Data.Array (many)
+-- import Data.Array (many)
 
 domain :: Parser String String
-domain = subdomain <|> string " "
+domain = sub_eof <|> string " "
+
+sub_eof :: Parser String String
+sub_eof = do
+  sub <- PC.try subdomain
+  eof
+  pure sub
 
 subdomain :: Parser String String
-subdomain = label <|> defer \_ -> subdomain *> string "." *> label
+subdomain = PC.try label <|> defer \_ -> sub_point_label
+
+sub_point_label :: Parser String String
+sub_point_label = do
+  sub <- defer \_ -> subdomain
+  point <- string "."
+  lab <- label
+  pure $ sub <> point <> lab
 
 label :: Parser String String
-label = PC.try let_str_alpha <|> let_alpha <|> (letter >>= \_ -> string "")
+label = PC.try let_then_str_then_alpha <|> PC.try let_then_alpha <|> let_to_string letter
+  where
+    let_then_str_then_alpha :: Parser String String
+    let_then_str_then_alpha = do
+      l <- letter
+      s <- ldhstr
+      a <- alphaNum
+      pure $ CU.singleton l <> s <> CU.singleton a
 
-let_str_alpha :: Parser String String
-let_str_alpha = do
-  _ <- letter
-  _ <- ldhstr
-  _ <- alphaNum
-  pure ""
-
-let_alpha :: Parser String String
-let_alpha = do
-  _ <- letter
-  _ <- alphaNum
-  pure ""
+    let_then_alpha :: Parser String String
+    let_then_alpha = do
+      l <- letter
+      a <- alphaNum
+      pure $ CU.singleton l <> CU.singleton a
 
 ldhstr :: Parser String String
-ldhstr = let_dig_hyp *> (defer \_ -> ldhstr) <|> defer \_ -> let_dig_hyp *> string ""
+ldhstr = PC.try (defer \_ -> actual_ldhstr) <|> (defer \_ -> just_ldh)
+  where
+    actual_ldhstr :: Parser String String
+    actual_ldhstr = do
+      ldh <- let_dig_hyp
+      str <- ldhstr
+      pure $ CU.singleton ldh <> str
 
+    just_ldh :: Parser String String
+    just_ldh = let_to_string let_dig_hyp
+
+-- Not used currently.
+hyp_then_string :: Parser String String
+hyp_then_string = do
+  a <- let_to_string let_dig_hyp
+  b <- ldhstr
+  pure $ a <> b
+
+-- Either a Letter, Digital or an Hyphenation character.
 let_dig_hyp :: Parser String Char
 let_dig_hyp = alphaNum <|> char '-'
 
-aye :: Parser String Char
-aye = defer \_ -> char 'a' *> aye
+-- | Converting a single letter parser to a String parser.
+let_to_string :: Parser String Char -> Parser String String
+let_to_string p = do
+  a <- p
+  pure $ CU.singleton a
+
 
 -- From RFC 1035
 -- <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
@@ -62,16 +99,21 @@ tested_domain = "example.com"
 
 main :: Effect Unit
 main =
-  render $ fold
+  render $ fold $
     [ h1 $ text "Examples of domain parsing in Purescript"
+    ] <> test_domains [ "ex.net", "e-.net", "-x.net", "te.s-t.net", "example.com" ]
+  where
+    -- test_domains :: Array String -> _
+    test_domains doms = fold $ map tests_on_domain doms
     
-    , p $ text "Run the " <> (code $ text "domain") <> text " parser."
-    , h3 $ code (text $ "runParser '" <> tested_domain <> "' domain")
-    , h3 $ code $ text $ show $ runParser tested_domain domain
-  
-    , h1 $ text "something else"  
-    , p $ text "Run the " <> code (text "ayebee") <> text " parser with the " <> code (text "many") <> text " combinator."
-    , h3 $ code (text "runParser \"aBabaB\" (many ayebee)")
-    , h3 $ code $ text $ show $ runParser "aBabax" (many ayebee)
-    ]
+    -- tests_on_domain :: String -> _
+    tests_on_domain d
+      = [ h3 $ code (text $ "domain: " <> d <> " [ldhstr, label, subdomain, domain]")
+        , p $ code $ text $ show $ runParser d ldhstr
+        , p $ code $ text $ show $ runParser d label
+        , p $ code $ text $ show $ runParser d subdomain
+        , p $ code $ text $ show $ runParser d domain
+        ]
 
+aye :: Parser String Char
+aye = defer \_ -> char 'a' *> aye