halogen-websocket-ipc-playzone/drop/PlayingWithParsers.purs

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