phino-0.0.143: src/Language.hs
-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT
-- The set of λ names the key of a '--symbolic' entry matches, as the automaton
-- recognizing it, so that two keys can be asked for a name they both match.
-- Testing one key against the text of the other misses a name neither key
-- spells, such as 'L_number_plus' of 'L_[a-z]+_plus' and 'L_number_[a-z]+',
-- and leaves the answer to the order the file lists them in (#1440).
--
-- A key is read as the regular expressions of PCRE that describe a regular
-- language: characters, escapes, classes, the dot, groups, alternation and
-- quantifiers, lazy ones too. What goes beyond that, such as a back reference,
-- a lookaround or an anchor, is refused, since two such keys cannot be told
-- apart for certain. The dot stands for every character but a new line, and
-- '\d', '\w' and '\s' for their ASCII sets, the way PCRE reads them.
module Language (Language, language, shared) where
import Data.Char (isAlphaNum, isDigit)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Text.Printf (printf)
import Text.Read (readMaybe)
-- A set of characters, as sorted and disjoint ranges.
newtype Span = Span [(Char, Char)]
-- A regular expression, as the key spells it.
data Pattern
= Chars Span
| Chain [Pattern]
| Choice [Pattern]
| Repeat Int (Maybe Int) Pattern
-- A move of the automaton: to a state for free, or on a character of a span.
data Edge
= Free Int
| Step Span Int
-- The automaton recognizing the names a key matches, as the edges leaving
-- every state, starting at the state 0 and accepting at the state 1.
newtype Language = Language (Map.Map Int [Edge])
-- The language of a key, or the reason it cannot be read as one.
language :: Text -> Either String Language
language key = do
(pattern, rest) <- choice (T.unpack key)
case rest of
[] -> Right (automaton pattern)
_ -> Left (printf "the character '%s' is not expected" (take 1 rest))
where
choice :: String -> Either String (Pattern, String)
choice text = do
(first, rest) <- chain text
case rest of
'|' : more -> do
(other, left) <- choice more
Right (Choice [first, other], left)
_ -> Right (first, rest)
chain :: String -> Either String (Pattern, String)
chain = go []
where
go :: [Pattern] -> String -> Either String (Pattern, String)
go done text@(char : _)
| char `elem` ("|)" :: String) = Right (Chain (reverse done), text)
go done [] = Right (Chain (reverse done), [])
go done text = do
(atom, rest) <- single text
(quantified, left) <- quantifier atom rest
go (quantified : done) left
single :: String -> Either String (Pattern, String)
single ('(' : '?' : ':' : rest) = group rest
single ('(' : '?' : 'P' : '<' : rest) = group (drop 1 (dropWhile (/= '>') rest))
single ('(' : '?' : '<' : rest@(char : _))
| char `notElem` ("=!" :: String) = group (drop 1 (dropWhile (/= '>') rest))
single ('(' : '?' : _) = Left "a group of that kind cannot be compared"
single ('(' : rest) = group rest
single ('[' : rest) = klass rest
single ('.' : rest) = Right (Chars (complement (Span [('\n', '\n')])), rest)
single ('\\' : rest) = escape rest >>= \(span', left) -> Right (Chars span', left)
single (char : rest)
| char `elem` ("^$" :: String) = Left "an anchor cannot be compared"
| char `elem` ("*+?" :: String) = Left (printf "the quantifier '%s' quantifies nothing" [char])
| otherwise = Right (Chars (Span [(char, char)]), rest)
single [] = Left "the expression ends too early"
group :: String -> Either String (Pattern, String)
group text = do
(inner, rest) <- choice text
case rest of
')' : left -> Right (inner, left)
_ -> Left "a group is not closed"
quantifier :: Pattern -> String -> Either String (Pattern, String)
quantifier atom ('*' : rest) = lazy (Repeat 0 Nothing atom) rest
quantifier atom ('+' : rest) = lazy (Repeat 1 Nothing atom) rest
quantifier atom ('?' : rest) = lazy (Repeat 0 (Just 1) atom) rest
quantifier atom text@('{' : rest) =
case bounded rest of
Just (low, high, left) -> lazy (Repeat low high atom) left
Nothing -> Right (atom, text)
quantifier atom rest = Right (atom, rest)
lazy :: Pattern -> String -> Either String (Pattern, String)
lazy _ ('+' : _) = Left "a possessive quantifier cannot be compared"
lazy pattern ('?' : rest) = Right (pattern, rest)
lazy pattern rest = Right (pattern, rest)
bounded :: String -> Maybe (Int, Maybe Int, String)
bounded text = do
let (low, rest) = span isDigit text
from <- readMaybe low
case rest of
'}' : left -> Just (from, Just from, left)
',' : more -> do
let (high, left) = span isDigit more
case (high, left) of
([], '}' : after) -> Just (from, Nothing, after)
(_, '}' : after) -> readMaybe high >>= \to -> if to < from then Nothing else Just (from, Just to, after)
_ -> Nothing
_ -> Nothing
escape :: String -> Either String (Span, String)
escape (char : rest)
| Just span' <- lookup char sets = Right (span', rest)
| Just literal <- lookup char controls = Right (Span [(literal, literal)], rest)
| not (isAlphaNum char) = Right (Span [(char, char)], rest)
| otherwise = Left (printf "the escape '\\%s' cannot be compared" [char])
escape [] = Left "the expression ends with a backslash"
sets :: [(Char, Span)]
sets =
[ ('d', digits)
, ('D', complement digits)
, ('w', word)
, ('W', complement word)
, ('s', spaces)
, ('S', complement spaces)
]
controls :: [(Char, Char)]
controls = [('t', '\t'), ('n', '\n'), ('r', '\r'), ('f', '\f'), ('e', '\ESC')]
digits :: Span
digits = Span [('0', '9')]
word :: Span
word = union [Span [('0', '9')], Span [('A', 'Z')], Span [('_', '_')], Span [('a', 'z')]]
spaces :: Span
spaces = Span [('\t', '\r'), (' ', ' ')]
klass :: String -> Either String (Pattern, String)
klass ('^' : rest) = members rest >>= \(span', left) -> Right (Chars (complement span'), left)
klass rest = members rest >>= \(span', left) -> Right (Chars span', left)
members :: String -> Either String (Span, String)
members (']' : rest) = collect [Span [(']', ']')]] rest
members rest = collect [] rest
collect :: [Span] -> String -> Either String (Span, String)
collect done (']' : rest) = Right (union done, rest)
collect _ ('[' : ':' : _) = Left "a POSIX class cannot be compared"
collect done ('\\' : rest) = do
(span', left) <- escape rest
case (span', left) of
(Span [(low, _)], '-' : high : after)
| high /= ']' -> ranged done low (high : after)
_ -> collect (span' : done) left
collect done (low : '-' : high : rest)
| high /= ']' = ranged done low (high : rest)
collect done (char : rest) = collect (Span [(char, char)] : done) rest
collect _ [] = Left "a class is not closed"
ranged :: [Span] -> Char -> String -> Either String (Span, String)
ranged done low ('\\' : rest) = do
(span', left) <- escape rest
case span' of
Span [(high, high')] | high == high' -> bound done low high left
_ -> Left "a range ends at a set of characters"
ranged done low (high : rest) = bound done low high rest
ranged _ _ [] = Left "a class is not closed"
bound :: [Span] -> Char -> Char -> String -> Either String (Span, String)
bound done low high rest
| low <= high = collect (Span [(low, high)] : done) rest
| otherwise = Left "a range runs backwards"
-- A name both languages hold, if there is one, found by walking the two
-- automata side by side until both accept at once.
shared :: Language -> Language -> Maybe Text
shared (Language left) (Language right) = go (Set.singleton (0, 0)) [((0, 0), [])]
where
go :: Set.Set (Int, Int) -> [((Int, Int), String)] -> Maybe Text
go _ [] = Nothing
go seen (((here, there), name) : rest)
| here == 1 && there == 1 = Just (T.pack (reverse name))
| otherwise =
let fresh = filter ((`Set.notMember` seen) . fst) (moves here there name)
in go (foldr (Set.insert . fst) seen fresh) (rest ++ fresh)
moves :: Int -> Int -> String -> [((Int, Int), String)]
moves here there name =
[((state, there), name) | Free state <- edges left here]
++ [((here, state), name) | Free state <- edges right there]
++ [ ((this, that), char : name)
| Step first this <- edges left here
, Step second that <- edges right there
, Just char <- [sample (meet first second)]
]
edges :: Map.Map Int [Edge] -> Int -> [Edge]
edges table state = Map.findWithDefault [] state table
-- The automaton of a pattern, from the state 0 to the state 1.
automaton :: Pattern -> Language
automaton pattern = Language (Map.fromListWith (flip (++)) [(from, [edge]) | (from, edge) <- snd (build pattern 0 1 2)])
where
build :: Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build (Chars span') from to next = (next, [(from, Step span' to)])
build (Chain []) from to next = (next, [(from, Free to)])
build (Chain [single]) from to next = build single from to next
build (Chain (first : rest)) from to next =
let (after, head') = build first from next (next + 1)
(last', tail') = build (Chain rest) next to after
in (last', head' ++ tail')
build (Choice options) from to next =
foldl
(\(counter, done) option -> let (counter', made) = build option from to counter in (counter', done ++ made))
(next, [])
options
build (Repeat 0 (Just 0) _) from to next = (next, [(from, Free to)])
build (Repeat 0 Nothing inner) from to next =
let (after, made) = build inner next next (next + 1)
in (after, (from, Free next) : (next, Free to) : made)
build (Repeat 0 (Just high) inner) from to next =
build (Choice [Chain [], Chain [inner, Repeat 0 (Just (high - 1)) inner]]) from to next
build (Repeat low high inner) from to next =
build (Chain [inner, Repeat (low - 1) (subtract 1 <$> high) inner]) from to next
-- Every character in any of the spans.
union :: [Span] -> Span
union spans = Span (merge (Set.toAscList (Set.fromList (concat [ranges | Span ranges <- spans]))))
where
merge :: [(Char, Char)] -> [(Char, Char)]
merge ((low, high) : (low', high') : rest)
| low' <= succ' high = merge ((low, max high high') : rest)
merge (range : rest) = range : merge rest
merge [] = []
succ' :: Char -> Char
succ' char
| char == maxBound = char
| otherwise = succ char
-- Every character outside the span.
complement :: Span -> Span
complement (Span ranges) = Span (go minBound ranges)
where
go :: Char -> [(Char, Char)] -> [(Char, Char)]
go from [] = [(from, maxBound)]
go from ((low, high) : rest)
| high == maxBound = [(from, pred low) | from < low]
| otherwise = [(from, pred low) | from < low] ++ go (succ high) rest
-- Every character in both spans.
meet :: Span -> Span -> Span
meet (Span first) (Span second) =
Span [(max low low', min high high') | (low, high) <- first, (low', high') <- second, max low low' <= min high high']
-- A character of the span, a small letter if it has one, so the name an error
-- quotes reads like a λ name, and nothing if the span is empty.
sample :: Span -> Maybe Char
sample (Span ranges) =
case [max low 'a' | (low, high) <- ranges, max low 'a' <= min high 'z'] ++ [low | (low, _) <- ranges] of
char : _ -> Just char
[] -> Nothing