120 lines
3.1 KiB
Plaintext
120 lines
3.1 KiB
Plaintext
module Main where
|
|
|
|
import Prelude
|
|
|
|
import Data.Foldable (fold)
|
|
import Effect (Effect)
|
|
import TryPureScript (h1, h3, p, text, render, code)
|
|
import Parsing (Parser, runParser)
|
|
import Parsing.Combinators as PC
|
|
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)
|
|
|
|
domain :: Parser String 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 = 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_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_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 = 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 '-'
|
|
|
|
-- | 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> ]
|
|
-- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
|
|
-- <let-dig-hyp> ::= <let-dig> | "-"
|
|
-- <let-dig> ::= <letter> | <digit>
|
|
|
|
|
|
ayebee :: Parser String Boolean
|
|
ayebee = do
|
|
_ <- alphaNum
|
|
b <- char 'b' <|> alphaNum
|
|
pure (b == 'B')
|
|
|
|
tested_domain :: String
|
|
tested_domain = "example.com"
|
|
|
|
main :: Effect Unit
|
|
main =
|
|
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
|
|
|
|
-- 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
|