-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com
-- SPDX-License-Identifier: MIT

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)

newtype Span = Span [(Char, Char)]

data Pattern
  = Chars Span
  | Chain [Pattern]
  | Choice [Pattern]
  | Repeat Int (Maybe Int) Pattern

data Edge
  = Free Int
  | Step Span Int

newtype Language = Language (Map.Map Int [Edge])

language :: Text -> Either String Language
language :: Text -> Either [Char] Language
language Text
key = do
  (Pattern
pattern, [Char]
rest) <- [Char] -> Either [Char] (Pattern, [Char])
choice (Text -> [Char]
T.unpack Text
key)
  case [Char]
rest of
    [] -> Language -> Either [Char] Language
forall a b. b -> Either a b
Right (Pattern -> Language
automaton Pattern
pattern)
    [Char]
_ -> [Char] -> Either [Char] Language
forall a b. a -> Either a b
Left ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"the character '%s' is not expected" (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
take Int
1 [Char]
rest))
  where
    choice :: String -> Either String (Pattern, String)
    choice :: [Char] -> Either [Char] (Pattern, [Char])
choice [Char]
text = do
      (Pattern
first, [Char]
rest) <- [Char] -> Either [Char] (Pattern, [Char])
chain [Char]
text
      case [Char]
rest of
        Char
'|' : [Char]
more -> do
          (Pattern
other, [Char]
left) <- [Char] -> Either [Char] (Pattern, [Char])
choice [Char]
more
          (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right ([Pattern] -> Pattern
Choice [Pattern
first, Pattern
other], [Char]
left)
        [Char]
_ -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
first, [Char]
rest)
    chain :: String -> Either String (Pattern, String)
    chain :: [Char] -> Either [Char] (Pattern, [Char])
chain = [Pattern] -> [Char] -> Either [Char] (Pattern, [Char])
go []
      where
        go :: [Pattern] -> String -> Either String (Pattern, String)
        go :: [Pattern] -> [Char] -> Either [Char] (Pattern, [Char])
go [Pattern]
done text :: [Char]
text@(Char
char : [Char]
_)
          | Char
char Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"|)" :: String) = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right ([Pattern] -> Pattern
Chain ([Pattern] -> [Pattern]
forall a. [a] -> [a]
reverse [Pattern]
done), [Char]
text)
        go [Pattern]
done [] = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right ([Pattern] -> Pattern
Chain ([Pattern] -> [Pattern]
forall a. [a] -> [a]
reverse [Pattern]
done), [])
        go [Pattern]
done [Char]
text = do
          (Pattern
atom, [Char]
rest) <- [Char] -> Either [Char] (Pattern, [Char])
single [Char]
text
          (Pattern
quantified, [Char]
left) <- Pattern -> [Char] -> Either [Char] (Pattern, [Char])
quantifier Pattern
atom [Char]
rest
          [Pattern] -> [Char] -> Either [Char] (Pattern, [Char])
go (Pattern
quantified Pattern -> [Pattern] -> [Pattern]
forall a. a -> [a] -> [a]
: [Pattern]
done) [Char]
left
    single :: String -> Either String (Pattern, String)
    single :: [Char] -> Either [Char] (Pattern, [Char])
single (Char
'(' : Char
'?' : Char
':' : [Char]
rest) = [Char] -> Either [Char] (Pattern, [Char])
group [Char]
rest
    single (Char
'(' : Char
'?' : Char
'P' : Char
'<' : [Char]
rest) = [Char] -> Either [Char] (Pattern, [Char])
group (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') [Char]
rest))
    single (Char
'(' : Char
'?' : Char
'<' : rest :: [Char]
rest@(Char
char : [Char]
_))
      | Char
char Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
"=!" :: String) = [Char] -> Either [Char] (Pattern, [Char])
group (Int -> [Char] -> [Char]
forall a. Int -> [a] -> [a]
drop Int
1 ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'>') [Char]
rest))
    single (Char
'(' : Char
'?' : [Char]
_) = [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left [Char]
"a group of that kind cannot be compared"
    single (Char
'(' : [Char]
rest) = [Char] -> Either [Char] (Pattern, [Char])
group [Char]
rest
    single (Char
'[' : [Char]
rest) = [Char] -> Either [Char] (Pattern, [Char])
klass [Char]
rest
    single (Char
'.' : [Char]
rest) = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Span -> Pattern
Chars (Span -> Span
complement ([(Char, Char)] -> Span
Span [(Char
'\n', Char
'\n')])), [Char]
rest)
    single (Char
'\\' : [Char]
rest) = [Char] -> Either [Char] (Span, [Char])
escape [Char]
rest Either [Char] (Span, [Char])
-> ((Span, [Char]) -> Either [Char] (Pattern, [Char]))
-> Either [Char] (Pattern, [Char])
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Span
span', [Char]
left) -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Span -> Pattern
Chars Span
span', [Char]
left)
    single (Char
char : [Char]
rest)
      | Char
char Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"^$" :: String) = [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left [Char]
"an anchor cannot be compared"
      | Char
char Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"*+?" :: String) = [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"the quantifier '%s' quantifies nothing" [Char
char])
      | Bool
otherwise = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Span -> Pattern
Chars ([(Char, Char)] -> Span
Span [(Char
char, Char
char)]), [Char]
rest)
    single [] = [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left [Char]
"the expression ends too early"
    group :: String -> Either String (Pattern, String)
    group :: [Char] -> Either [Char] (Pattern, [Char])
group [Char]
text = do
      (Pattern
inner, [Char]
rest) <- [Char] -> Either [Char] (Pattern, [Char])
choice [Char]
text
      case [Char]
rest of
        Char
')' : [Char]
left -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
inner, [Char]
left)
        [Char]
_ -> [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left [Char]
"a group is not closed"
    quantifier :: Pattern -> String -> Either String (Pattern, String)
    quantifier :: Pattern -> [Char] -> Either [Char] (Pattern, [Char])
quantifier Pattern
atom (Char
'*' : [Char]
rest) = Pattern -> [Char] -> Either [Char] (Pattern, [Char])
lazy (Int -> Maybe Int -> Pattern -> Pattern
Repeat Int
0 Maybe Int
forall a. Maybe a
Nothing Pattern
atom) [Char]
rest
    quantifier Pattern
atom (Char
'+' : [Char]
rest) = Pattern -> [Char] -> Either [Char] (Pattern, [Char])
lazy (Int -> Maybe Int -> Pattern -> Pattern
Repeat Int
1 Maybe Int
forall a. Maybe a
Nothing Pattern
atom) [Char]
rest
    quantifier Pattern
atom (Char
'?' : [Char]
rest) = Pattern -> [Char] -> Either [Char] (Pattern, [Char])
lazy (Int -> Maybe Int -> Pattern -> Pattern
Repeat Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) Pattern
atom) [Char]
rest
    quantifier Pattern
atom text :: [Char]
text@(Char
'{' : [Char]
rest) =
      case [Char] -> Maybe (Int, Maybe Int, [Char])
bounded [Char]
rest of
        Just (Int
low, Maybe Int
high, [Char]
left) -> Pattern -> [Char] -> Either [Char] (Pattern, [Char])
lazy (Int -> Maybe Int -> Pattern -> Pattern
Repeat Int
low Maybe Int
high Pattern
atom) [Char]
left
        Maybe (Int, Maybe Int, [Char])
Nothing -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
atom, [Char]
text)
    quantifier Pattern
atom [Char]
rest = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
atom, [Char]
rest)
    lazy :: Pattern -> String -> Either String (Pattern, String)
    lazy :: Pattern -> [Char] -> Either [Char] (Pattern, [Char])
lazy Pattern
_ (Char
'+' : [Char]
_) = [Char] -> Either [Char] (Pattern, [Char])
forall a b. a -> Either a b
Left [Char]
"a possessive quantifier cannot be compared"
    lazy Pattern
pattern (Char
'?' : [Char]
rest) = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
pattern, [Char]
rest)
    lazy Pattern
pattern [Char]
rest = (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Pattern
pattern, [Char]
rest)
    bounded :: String -> Maybe (Int, Maybe Int, String)
    bounded :: [Char] -> Maybe (Int, Maybe Int, [Char])
bounded [Char]
text = do
      let ([Char]
low, [Char]
rest) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
text
      Int
from <- [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
low
      case [Char]
rest of
        Char
'}' : [Char]
left -> (Int, Maybe Int, [Char]) -> Maybe (Int, Maybe Int, [Char])
forall a. a -> Maybe a
Just (Int
from, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
from, [Char]
left)
        Char
',' : [Char]
more -> do
          let ([Char]
high, [Char]
left) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit [Char]
more
          case ([Char]
high, [Char]
left) of
            ([], Char
'}' : [Char]
after) -> (Int, Maybe Int, [Char]) -> Maybe (Int, Maybe Int, [Char])
forall a. a -> Maybe a
Just (Int
from, Maybe Int
forall a. Maybe a
Nothing, [Char]
after)
            ([Char]
_, Char
'}' : [Char]
after) -> [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
high Maybe Int
-> (Int -> Maybe (Int, Maybe Int, [Char]))
-> Maybe (Int, Maybe Int, [Char])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
to -> if Int
to Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
from then Maybe (Int, Maybe Int, [Char])
forall a. Maybe a
Nothing else (Int, Maybe Int, [Char]) -> Maybe (Int, Maybe Int, [Char])
forall a. a -> Maybe a
Just (Int
from, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
to, [Char]
after)
            ([Char], [Char])
_ -> Maybe (Int, Maybe Int, [Char])
forall a. Maybe a
Nothing
        [Char]
_ -> Maybe (Int, Maybe Int, [Char])
forall a. Maybe a
Nothing
    escape :: String -> Either String (Span, String)
    escape :: [Char] -> Either [Char] (Span, [Char])
escape (Char
char : [Char]
rest)
      | Just Span
span' <- Char -> [(Char, Span)] -> Maybe Span
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
char [(Char, Span)]
sets = (Span, [Char]) -> Either [Char] (Span, [Char])
forall a b. b -> Either a b
Right (Span
span', [Char]
rest)
      | Just Char
literal <- Char -> [(Char, Char)] -> Maybe Char
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
char [(Char, Char)]
controls = (Span, [Char]) -> Either [Char] (Span, [Char])
forall a b. b -> Either a b
Right ([(Char, Char)] -> Span
Span [(Char
literal, Char
literal)], [Char]
rest)
      | Bool -> Bool
not (Char -> Bool
isAlphaNum Char
char) = (Span, [Char]) -> Either [Char] (Span, [Char])
forall a b. b -> Either a b
Right ([(Char, Char)] -> Span
Span [(Char
char, Char
char)], [Char]
rest)
      | Bool
otherwise = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"the escape '\\%s' cannot be compared" [Char
char])
    escape [] = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"the expression ends with a backslash"
    sets :: [(Char, Span)]
    sets :: [(Char, Span)]
sets =
      [ (Char
'd', Span
digits)
      , (Char
'D', Span -> Span
complement Span
digits)
      , (Char
'w', Span
word)
      , (Char
'W', Span -> Span
complement Span
word)
      , (Char
's', Span
spaces)
      , (Char
'S', Span -> Span
complement Span
spaces)
      ]
    controls :: [(Char, Char)]
    controls :: [(Char, Char)]
controls = [(Char
't', Char
'\t'), (Char
'n', Char
'\n'), (Char
'r', Char
'\r'), (Char
'f', Char
'\f'), (Char
'e', Char
'\ESC')]
    digits :: Span
    digits :: Span
digits = [(Char, Char)] -> Span
Span [(Char
'0', Char
'9')]
    word :: Span
    word :: Span
word = [Span] -> Span
union [[(Char, Char)] -> Span
Span [(Char
'0', Char
'9')], [(Char, Char)] -> Span
Span [(Char
'A', Char
'Z')], [(Char, Char)] -> Span
Span [(Char
'_', Char
'_')], [(Char, Char)] -> Span
Span [(Char
'a', Char
'z')]]
    spaces :: Span
    spaces :: Span
spaces = [(Char, Char)] -> Span
Span [(Char
'\t', Char
'\r'), (Char
' ', Char
' ')]
    klass :: String -> Either String (Pattern, String)
    klass :: [Char] -> Either [Char] (Pattern, [Char])
klass (Char
'^' : [Char]
rest) = [Char] -> Either [Char] (Span, [Char])
members [Char]
rest Either [Char] (Span, [Char])
-> ((Span, [Char]) -> Either [Char] (Pattern, [Char]))
-> Either [Char] (Pattern, [Char])
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Span
span', [Char]
left) -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Span -> Pattern
Chars (Span -> Span
complement Span
span'), [Char]
left)
    klass [Char]
rest = [Char] -> Either [Char] (Span, [Char])
members [Char]
rest Either [Char] (Span, [Char])
-> ((Span, [Char]) -> Either [Char] (Pattern, [Char]))
-> Either [Char] (Pattern, [Char])
forall a b.
Either [Char] a -> (a -> Either [Char] b) -> Either [Char] b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Span
span', [Char]
left) -> (Pattern, [Char]) -> Either [Char] (Pattern, [Char])
forall a b. b -> Either a b
Right (Span -> Pattern
Chars Span
span', [Char]
left)
    members :: String -> Either String (Span, String)
    members :: [Char] -> Either [Char] (Span, [Char])
members (Char
']' : [Char]
rest) = [Span] -> [Char] -> Either [Char] (Span, [Char])
collect [[(Char, Char)] -> Span
Span [(Char
']', Char
']')]] [Char]
rest
    members [Char]
rest = [Span] -> [Char] -> Either [Char] (Span, [Char])
collect [] [Char]
rest
    collect :: [Span] -> String -> Either String (Span, String)
    collect :: [Span] -> [Char] -> Either [Char] (Span, [Char])
collect [Span]
done (Char
']' : [Char]
rest) = (Span, [Char]) -> Either [Char] (Span, [Char])
forall a b. b -> Either a b
Right ([Span] -> Span
union [Span]
done, [Char]
rest)
    collect [Span]
_ (Char
'[' : Char
':' : [Char]
_) = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"a POSIX class cannot be compared"
    collect [Span]
done (Char
'\\' : [Char]
rest) = do
      (Span
span', [Char]
left) <- [Char] -> Either [Char] (Span, [Char])
escape [Char]
rest
      case (Span
span', [Char]
left) of
        (Span [(Char
low, Char
top)], Char
'-' : Char
high : [Char]
after)
          | Char
low Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
top Bool -> Bool -> Bool
&& Char
high Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']' -> [Span] -> Char -> [Char] -> Either [Char] (Span, [Char])
ranged [Span]
done Char
low (Char
high Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
after)
        (Span, [Char])
_ -> [Span] -> [Char] -> Either [Char] (Span, [Char])
collect (Span
span' Span -> [Span] -> [Span]
forall a. a -> [a] -> [a]
: [Span]
done) [Char]
left
    collect [Span]
done (Char
low : Char
'-' : Char
high : [Char]
rest)
      | Char
high Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']' = [Span] -> Char -> [Char] -> Either [Char] (Span, [Char])
ranged [Span]
done Char
low (Char
high Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
rest)
    collect [Span]
done (Char
char : [Char]
rest) = [Span] -> [Char] -> Either [Char] (Span, [Char])
collect ([(Char, Char)] -> Span
Span [(Char
char, Char
char)] Span -> [Span] -> [Span]
forall a. a -> [a] -> [a]
: [Span]
done) [Char]
rest
    collect [Span]
_ [] = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"a class is not closed"
    ranged :: [Span] -> Char -> String -> Either String (Span, String)
    ranged :: [Span] -> Char -> [Char] -> Either [Char] (Span, [Char])
ranged [Span]
done Char
low (Char
'\\' : [Char]
rest) = do
      (Span
span', [Char]
left) <- [Char] -> Either [Char] (Span, [Char])
escape [Char]
rest
      case Span
span' of
        Span [(Char
high, Char
high')] | Char
high Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
high' -> [Span] -> Char -> Char -> [Char] -> Either [Char] (Span, [Char])
bound [Span]
done Char
low Char
high [Char]
left
        Span
_ -> [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"a range ends at a set of characters"
    ranged [Span]
done Char
low (Char
high : [Char]
rest) = [Span] -> Char -> Char -> [Char] -> Either [Char] (Span, [Char])
bound [Span]
done Char
low Char
high [Char]
rest
    ranged [Span]
_ Char
_ [] = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"a class is not closed"
    bound :: [Span] -> Char -> Char -> String -> Either String (Span, String)
    bound :: [Span] -> Char -> Char -> [Char] -> Either [Char] (Span, [Char])
bound [Span]
done Char
low Char
high [Char]
rest
      | Char
low Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
high = [Span] -> [Char] -> Either [Char] (Span, [Char])
collect ([(Char, Char)] -> Span
Span [(Char
low, Char
high)] Span -> [Span] -> [Span]
forall a. a -> [a] -> [a]
: [Span]
done) [Char]
rest
      | Bool
otherwise = [Char] -> Either [Char] (Span, [Char])
forall a b. a -> Either a b
Left [Char]
"a range runs backwards"

shared :: Language -> Language -> Maybe Text
shared :: Language -> Language -> Maybe Text
shared (Language Map Int [Edge]
left) (Language Map Int [Edge]
right) = Set (Int, Int) -> [((Int, Int), [Char])] -> Maybe Text
go ((Int, Int) -> Set (Int, Int)
forall a. a -> Set a
Set.singleton (Int
0, Int
0)) [((Int
0, Int
0), [])]
  where
    go :: Set.Set (Int, Int) -> [((Int, Int), String)] -> Maybe Text
    go :: Set (Int, Int) -> [((Int, Int), [Char])] -> Maybe Text
go Set (Int, Int)
_ [] = Maybe Text
forall a. Maybe a
Nothing
    go Set (Int, Int)
seen (((Int
here, Int
there), [Char]
name) : [((Int, Int), [Char])]
rest)
      | Int
here Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Int
there Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Text -> Maybe Text
forall a. a -> Maybe a
Just ([Char] -> Text
T.pack ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
name))
      | Bool
otherwise =
          let fresh :: [((Int, Int), [Char])]
fresh = (((Int, Int), [Char]) -> Bool)
-> [((Int, Int), [Char])] -> [((Int, Int), [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (((Int, Int) -> Set (Int, Int) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Int, Int)
seen) ((Int, Int) -> Bool)
-> (((Int, Int), [Char]) -> (Int, Int))
-> ((Int, Int), [Char])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int), [Char]) -> (Int, Int)
forall a b. (a, b) -> a
fst) (Int -> Int -> [Char] -> [((Int, Int), [Char])]
moves Int
here Int
there [Char]
name)
           in Set (Int, Int) -> [((Int, Int), [Char])] -> Maybe Text
go ((((Int, Int), [Char]) -> Set (Int, Int) -> Set (Int, Int))
-> Set (Int, Int) -> [((Int, Int), [Char])] -> Set (Int, Int)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Int, Int) -> Set (Int, Int) -> Set (Int, Int)
forall a. Ord a => a -> Set a -> Set a
Set.insert ((Int, Int) -> Set (Int, Int) -> Set (Int, Int))
-> (((Int, Int), [Char]) -> (Int, Int))
-> ((Int, Int), [Char])
-> Set (Int, Int)
-> Set (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int), [Char]) -> (Int, Int)
forall a b. (a, b) -> a
fst) Set (Int, Int)
seen [((Int, Int), [Char])]
fresh) ([((Int, Int), [Char])]
rest [((Int, Int), [Char])]
-> [((Int, Int), [Char])] -> [((Int, Int), [Char])]
forall a. [a] -> [a] -> [a]
++ [((Int, Int), [Char])]
fresh)
    moves :: Int -> Int -> String -> [((Int, Int), String)]
    moves :: Int -> Int -> [Char] -> [((Int, Int), [Char])]
moves Int
here Int
there [Char]
name =
      [((Int
state, Int
there), [Char]
name) | Free Int
state <- Map Int [Edge] -> Int -> [Edge]
edges Map Int [Edge]
left Int
here]
        [((Int, Int), [Char])]
-> [((Int, Int), [Char])] -> [((Int, Int), [Char])]
forall a. [a] -> [a] -> [a]
++ [((Int
here, Int
state), [Char]
name) | Free Int
state <- Map Int [Edge] -> Int -> [Edge]
edges Map Int [Edge]
right Int
there]
        [((Int, Int), [Char])]
-> [((Int, Int), [Char])] -> [((Int, Int), [Char])]
forall a. [a] -> [a] -> [a]
++ [ ((Int
this, Int
that), Char
char Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
name)
           | Step Span
first Int
this <- Map Int [Edge] -> Int -> [Edge]
edges Map Int [Edge]
left Int
here
           , Step Span
second Int
that <- Map Int [Edge] -> Int -> [Edge]
edges Map Int [Edge]
right Int
there
           , Just Char
char <- [Span -> Maybe Char
sample (Span -> Span -> Span
meet Span
first Span
second)]
           ]
    edges :: Map.Map Int [Edge] -> Int -> [Edge]
    edges :: Map Int [Edge] -> Int -> [Edge]
edges Map Int [Edge]
table Int
state = [Edge] -> Int -> Map Int [Edge] -> [Edge]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Int
state Map Int [Edge]
table

automaton :: Pattern -> Language
automaton :: Pattern -> Language
automaton Pattern
pattern = Map Int [Edge] -> Language
Language (([Edge] -> [Edge] -> [Edge]) -> [(Int, [Edge])] -> Map Int [Edge]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (([Edge] -> [Edge] -> [Edge]) -> [Edge] -> [Edge] -> [Edge]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Edge] -> [Edge] -> [Edge]
forall a. [a] -> [a] -> [a]
(++)) [(Int
from, [Edge
edge]) | (Int
from, Edge
edge) <- (Int, [(Int, Edge)]) -> [(Int, Edge)]
forall a b. (a, b) -> b
snd (Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build Pattern
pattern Int
0 Int
1 Int
2)])
  where
    build :: Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
    build :: Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build (Chars Span
span') Int
from Int
to Int
next = (Int
next, [(Int
from, Span -> Int -> Edge
Step Span
span' Int
to)])
    build (Chain []) Int
from Int
to Int
next = (Int
next, [(Int
from, Int -> Edge
Free Int
to)])
    build (Chain [Pattern
single]) Int
from Int
to Int
next = Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build Pattern
single Int
from Int
to Int
next
    build (Chain (Pattern
first : [Pattern]
rest)) Int
from Int
to Int
next =
      let (Int
after, [(Int, Edge)]
head') = Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build Pattern
first Int
from Int
next (Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          (Int
last', [(Int, Edge)]
tail') = Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build ([Pattern] -> Pattern
Chain [Pattern]
rest) Int
next Int
to Int
after
       in (Int
last', [(Int, Edge)]
head' [(Int, Edge)] -> [(Int, Edge)] -> [(Int, Edge)]
forall a. [a] -> [a] -> [a]
++ [(Int, Edge)]
tail')
    build (Choice [Pattern]
options) Int
from Int
to Int
next =
      ((Int, [(Int, Edge)]) -> Pattern -> (Int, [(Int, Edge)]))
-> (Int, [(Int, Edge)]) -> [Pattern] -> (Int, [(Int, Edge)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
        (\(Int
counter, [(Int, Edge)]
done) Pattern
option -> let (Int
counter', [(Int, Edge)]
made) = Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build Pattern
option Int
from Int
to Int
counter in (Int
counter', [(Int, Edge)]
done [(Int, Edge)] -> [(Int, Edge)] -> [(Int, Edge)]
forall a. [a] -> [a] -> [a]
++ [(Int, Edge)]
made))
        (Int
next, [])
        [Pattern]
options
    build (Repeat Int
0 (Just Int
0) Pattern
_) Int
from Int
to Int
next = (Int
next, [(Int
from, Int -> Edge
Free Int
to)])
    build (Repeat Int
0 Maybe Int
Nothing Pattern
inner) Int
from Int
to Int
next =
      let (Int
after, [(Int, Edge)]
made) = Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build Pattern
inner Int
next Int
next (Int
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
       in (Int
after, (Int
from, Int -> Edge
Free Int
next) (Int, Edge) -> [(Int, Edge)] -> [(Int, Edge)]
forall a. a -> [a] -> [a]
: (Int
next, Int -> Edge
Free Int
to) (Int, Edge) -> [(Int, Edge)] -> [(Int, Edge)]
forall a. a -> [a] -> [a]
: [(Int, Edge)]
made)
    build (Repeat Int
0 (Just Int
high) Pattern
inner) Int
from Int
to Int
next =
      Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build ([Pattern] -> Pattern
Choice [[Pattern] -> Pattern
Chain [], [Pattern] -> Pattern
Chain [Pattern
inner, Int -> Maybe Int -> Pattern -> Pattern
Repeat Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
high Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) Pattern
inner]]) Int
from Int
to Int
next
    build (Repeat Int
low Maybe Int
high Pattern
inner) Int
from Int
to Int
next =
      Pattern -> Int -> Int -> Int -> (Int, [(Int, Edge)])
build ([Pattern] -> Pattern
Chain [Pattern
inner, Int -> Maybe Int -> Pattern -> Pattern
Repeat (Int
low Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
high) Pattern
inner]) Int
from Int
to Int
next

union :: [Span] -> Span
union :: [Span] -> Span
union [Span]
spans = [(Char, Char)] -> Span
Span ([(Char, Char)] -> [(Char, Char)]
merge (Set (Char, Char) -> [(Char, Char)]
forall a. Set a -> [a]
Set.toAscList ([(Char, Char)] -> Set (Char, Char)
forall a. Ord a => [a] -> Set a
Set.fromList ([[(Char, Char)]] -> [(Char, Char)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Char, Char)]
ranges | Span [(Char, Char)]
ranges <- [Span]
spans]))))
  where
    merge :: [(Char, Char)] -> [(Char, Char)]
    merge :: [(Char, Char)] -> [(Char, Char)]
merge ((Char
low, Char
high) : (Char
low', Char
high') : [(Char, Char)]
rest)
      | Char
low' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Char
succ' Char
high = [(Char, Char)] -> [(Char, Char)]
merge ((Char
low, Char -> Char -> Char
forall a. Ord a => a -> a -> a
max Char
high Char
high') (Char, Char) -> [(Char, Char)] -> [(Char, Char)]
forall a. a -> [a] -> [a]
: [(Char, Char)]
rest)
    merge ((Char, Char)
range : [(Char, Char)]
rest) = (Char, Char)
range (Char, Char) -> [(Char, Char)] -> [(Char, Char)]
forall a. a -> [a] -> [a]
: [(Char, Char)] -> [(Char, Char)]
merge [(Char, Char)]
rest
    merge [] = []
    succ' :: Char -> Char
    succ' :: Char -> Char
succ' Char
char
      | Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound = Char
char
      | Bool
otherwise = Char -> Char
forall a. Enum a => a -> a
succ Char
char

complement :: Span -> Span
complement :: Span -> Span
complement (Span [(Char, Char)]
ranges) = [(Char, Char)] -> Span
Span (Char -> [(Char, Char)] -> [(Char, Char)]
go Char
forall a. Bounded a => a
minBound [(Char, Char)]
ranges)
  where
    go :: Char -> [(Char, Char)] -> [(Char, Char)]
    go :: Char -> [(Char, Char)] -> [(Char, Char)]
go Char
from [] = [(Char
from, Char
forall a. Bounded a => a
maxBound)]
    go Char
from ((Char
low, Char
high) : [(Char, Char)]
rest)
      | Char
high Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
forall a. Bounded a => a
maxBound = [(Char
from, Char -> Char
forall a. Enum a => a -> a
pred Char
low) | Char
from Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
low]
      | Bool
otherwise = [(Char
from, Char -> Char
forall a. Enum a => a -> a
pred Char
low) | Char
from Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
low] [(Char, Char)] -> [(Char, Char)] -> [(Char, Char)]
forall a. [a] -> [a] -> [a]
++ Char -> [(Char, Char)] -> [(Char, Char)]
go (Char -> Char
forall a. Enum a => a -> a
succ Char
high) [(Char, Char)]
rest

meet :: Span -> Span -> Span
meet :: Span -> Span -> Span
meet (Span [(Char, Char)]
first) (Span [(Char, Char)]
second) =
  [(Char, Char)] -> Span
Span [(Char -> Char -> Char
forall a. Ord a => a -> a -> a
max Char
low Char
low', Char -> Char -> Char
forall a. Ord a => a -> a -> a
min Char
high Char
high') | (Char
low, Char
high) <- [(Char, Char)]
first, (Char
low', Char
high') <- [(Char, Char)]
second, Char -> Char -> Char
forall a. Ord a => a -> a -> a
max Char
low Char
low' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Char -> Char
forall a. Ord a => a -> a -> a
min Char
high Char
high']

sample :: Span -> Maybe Char
sample :: Span -> Maybe Char
sample (Span [(Char, Char)]
ranges) =
  case [Char -> Char -> Char
forall a. Ord a => a -> a -> a
max Char
low Char
'a' | (Char
low, Char
high) <- [(Char, Char)]
ranges, Char -> Char -> Char
forall a. Ord a => a -> a -> a
max Char
low Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char -> Char -> Char
forall a. Ord a => a -> a -> a
min Char
high Char
'z'] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
low | (Char
low, Char
_) <- [(Char, Char)]
ranges] of
    Char
char : [Char]
_ -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
char
    [] -> Maybe Char
forall a. Maybe a
Nothing