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

208 lines
7.1 KiB
Plaintext

-- | `App.HomeInterface` presents the website and its features.
module App.HomeInterface where
import Prelude
import Control.Alt ((<|>))
import Control.Lazy (defer)
import Data.Array (many, length, snoc, last)
import Data.Either (Either(..))
import Data.Foldable (fold, foldl)
import Data.Maybe (Maybe(..))
import Data.Array.NonEmpty as NonEmpty
import Data.String.CodeUnits as CU
import Data.String as S -- length
-- import Data.String.Regex as R
-- import Data.String.Regex.Flags as RF
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff)
import Effect (Effect)
import Halogen as H
import Halogen.HTML as HH
-- import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Parsing
import Parsing.Combinators as PC
import Parsing.Combinators.Array (many1)
import Parsing (Parser, runParser)
import Parsing.String
import Parsing.String.Basic
import Parsing.String.Basic (alphaNum, letter)
import Parsing.String (char, string, eof)
-- import TryPureScript (h1, h3, p, text, render, code)
import Bulma (h1, h3, p, text, code)
import Bulma as Bulma
type Input = Unit
data Action = UpdateStuff String
data Query a = DoNothing a
type Output = Unit
type Slot = H.Slot Query Output
type State = { stuff :: String }
component :: forall m. MonadAff m => H.Component Query Input Output m
component =
H.mkComponent
{ initialState
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
}
}
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
UpdateStuff val -> H.modify_ _ { stuff = val }
initialState :: forall input. input -> State
initialState _ = { stuff: "" }
render :: forall m. State -> H.ComponentHTML Action () m
render state
= HH.div_ $
[ Bulma.hero_danger "A simple input" "Nothing much to see"
, Bulma.section_small $
[ h1 "Examples of domain parsing in Purescript"
] <> test_domains [ "ex.net"
, "e-x.net"
, "way-too-long--way-too-long--way-too-long--way-too-long--way-too-long.net"
, "way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.way-too-long--way-too-long--way-too-long--way-too-long.net"
, "e-.net"
, "-x.net"
, "truc-blah.example.com"
, "te.s-t.net"
, "example.com"
]
, Bulma.section_small [ render_stuff ]
]
where
-- Some helpers.
title = Bulma.h3
p = Bulma.p
b x = Bulma.column_ [ Bulma.box x ]
render_stuff = Bulma.columns_ [ b [ title "stuff"
, stuff_input
]
, b [ title "result"
, p $ case runParser state.stuff parse_stuff of
Left _ -> "NOT OKAY"
Right _ -> "OKAY"
]
]
stuff_input
= Bulma.box_input "stuff" "stuff" "stuff"
UpdateStuff
state.stuff
true
should_be_disabled
should_be_disabled = (if true then (HP.enabled true) else (HP.disabled true))
-- test_domains :: Array String -> _
test_domains doms = fold $ map tests_on_domain doms
-- tests_on_domain :: String -> _
tests_on_domain d
= [ Bulma.strong $ d <> " -> [ldhstr, label, subdomain, domain]"
, p $ d <> " : ldhstr : " <> (show $ runParser d ldhstr)
, p $ d <> " : label : " <> (show $ runParser d label)
, p $ d <> " : subdomain : " <> (show $ runParser d subdomain)
, p $ d <> " : domain : " <> (show $ runParser d domain)
]
aye :: Parser String Char
aye = defer \_ -> char 'a' *> aye
ayebee :: Parser String Boolean
ayebee = do
_ <- char 'a'
b <- char 'b' <|> char 'B'
pure (b == 'B')
parse_stuff :: Parser String Boolean
parse_stuff = do
void $ label
void $ eof
pure true
-- From RFC 1035: <domain> ::= <subdomain> | " "
domain :: Parser String String
domain = PC.try (string " ") <|> sub_eof
sub_eof :: Parser String String
sub_eof = do
sub <- subdomain
-- TODO: optional "." at the end?
eof
pure sub
-- From RFC 1035: <subdomain> ::= <label> | <subdomain> "." <label>
subdomain :: Parser String String
subdomain = defer \_ -> sub_point_label <|> label
sub_point_label :: Parser String String
sub_point_label = do
lab <- label
point <- string "."
sub <- defer \_ -> subdomain
let result = lab <> point <> sub
if S.length result > 255
then fail $ "domain length is > 255 bytes (" <> show (S.length result) <> ")"
else pure result
-- From RFC 1035: <label> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
label :: Parser String String
label = let_then_str_then_alpha
where
let_then_str_then_alpha :: Parser String String
let_then_str_then_alpha = do
l <- letter
s <- many let_dig_hyp
case last s of
Nothing -> pure $ CU.singleton l
Just last_char -> case runParser (CU.singleton last_char) alphaNum of
Left _ -> fail $ "Label is wrong: last char is '" <> (CU.singleton last_char) <> "' which isn't an alphanum"
Right _ -> if length s > 62 -- Remember: we already did read a letter (l).
then fail $ "Label is larger than expected (max 63 characters, current: " <> show (1 + length s) <> ")"
else pure $ CU.singleton l <> CU.fromCharArray (foldl (\acc x -> snoc acc x) [] s)
-- From RFC 1035: <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
ldhstr :: Parser String String
ldhstr = PC.try ldh_then_str <|> just_ldh
where
just_ldh :: Parser String String
just_ldh = char_to_string let_dig_hyp
ldh_then_str :: Parser String String
ldh_then_str = do
ldh <- let_dig_hyp
str <- defer \_ -> ldhstr
pure $ CU.singleton ldh <> str
-- From RFC 1035: <let-dig-hyp> ::= <let-dig> | "-"
-- Either a Letter, Digital or an Hyphenation character.
let_dig_hyp :: Parser String Char
let_dig_hyp = let_dig <|> char '-'
-- From RFC 1035: <let-dig> ::= <letter> | <digit>
let_dig :: Parser String Char
let_dig = alphaNum
-- | Converting a single letter parser to a String parser.
char_to_string :: Parser String Char -> Parser String String
char_to_string p = do
a <- p
pure $ CU.singleton a
-- Not used currently.
hyp_then_string :: Parser String String
hyp_then_string = do
a <- char_to_string let_dig_hyp
b <- ldhstr
pure $ a <> b