Playing with parsers some more.

This commit is contained in:
Philippe Pittoli 2023-07-22 14:58:52 +02:00
parent fb2b4ec86a
commit 37de517c60

View File

@ -1,4 +1,4 @@
module PlayingWithParsers where module Main where
import Prelude import Prelude
@ -7,42 +7,79 @@ import Effect (Effect)
import TryPureScript (h1, h3, p, text, render, code) import TryPureScript (h1, h3, p, text, render, code)
import Parsing (Parser, runParser) import Parsing (Parser, runParser)
import Parsing.Combinators as PC 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 Parsing.String.Basic (alphaNum, letter)
import Control.Alt ((<|>)) import Control.Alt ((<|>))
import Control.Lazy (defer) import Control.Lazy (defer)
import Data.Array (many) -- import Data.Array (many)
domain :: Parser String String 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 :: 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 :: 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_then_alpha :: Parser String String
let_str_alpha = do let_then_alpha = do
_ <- letter l <- letter
_ <- ldhstr a <- alphaNum
_ <- alphaNum pure $ CU.singleton l <> CU.singleton a
pure ""
let_alpha :: Parser String String
let_alpha = do
_ <- letter
_ <- alphaNum
pure ""
ldhstr :: Parser String String 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 :: Parser String Char
let_dig_hyp = alphaNum <|> char '-' let_dig_hyp = alphaNum <|> char '-'
aye :: Parser String Char -- | Converting a single letter parser to a String parser.
aye = defer \_ -> char 'a' *> aye let_to_string :: Parser String Char -> Parser String String
let_to_string p = do
a <- p
pure $ CU.singleton a
-- From RFC 1035 -- From RFC 1035
-- <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ] -- <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
@ -62,16 +99,21 @@ tested_domain = "example.com"
main :: Effect Unit main :: Effect Unit
main = main =
render $ fold render $ fold $
[ h1 $ text "Examples of domain parsing in Purescript" [ 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." -- tests_on_domain :: String -> _
, h3 $ code (text $ "runParser '" <> tested_domain <> "' domain") tests_on_domain d
, h3 $ code $ text $ show $ runParser tested_domain domain = [ h3 $ code (text $ "domain: " <> d <> " [ldhstr, label, subdomain, domain]")
, p $ code $ text $ show $ runParser d ldhstr
, h1 $ text "something else" , p $ code $ text $ show $ runParser d label
, p $ text "Run the " <> code (text "ayebee") <> text " parser with the " <> code (text "many") <> text " combinator." , p $ code $ text $ show $ runParser d subdomain
, h3 $ code (text "runParser \"aBabaB\" (many ayebee)") , p $ code $ text $ show $ runParser d domain
, h3 $ code $ text $ show $ runParser "aBabax" (many ayebee) ]
]
aye :: Parser String Char
aye = defer \_ -> char 'a' *> aye