{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
module Kleene.Classes where

import Data.Char                          (ord)
import Data.Foldable                      (toList)
import Data.Function.Step.Discrete.Closed (SF)
import Data.Map                           (Map)
import Data.Maybe                         (mapMaybe)
import Data.RangeSet.Map                  (RSet)
import Data.Word                          (Word8)

import qualified Data.ByteString   as BS
import qualified Data.RangeSet.Map as RSet

import Kleene.Internal.Sets (dotRSet)

-- | Kleene algebra.
--
-- If 'k' is 'Monoid' it's expected that @'appends' = 'mappend'@;
-- if 'k' is 'Algebra.Lattice.Lattice' it's expected that @'unions' = 'Algebra.Lattice.joins'@.
--
-- [Wikipedia: Kleene Algebra](https://en.wikipedia.org/wiki/Kleene_algebra).
--
class Kleene k where
    -- | Empty regex. Doesn't accept anything.
    empty :: k

    -- | Empty string. /Note:/ different than 'empty'.
    eps :: k

    -- | Concatenation.
    appends :: [k] -> k

    -- | Union.
    unions :: [k] -> k

    -- | Kleene star.
    star :: k -> k

class Kleene k => CharKleene c k | k -> c where
    -- | Single character
    char :: c -> k

    string :: [c] -> k
    string = [k] -> k
forall k. Kleene k => [k] -> k
appends ([k] -> k) -> ([c] -> [k]) -> [c] -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> k) -> [c] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map c -> k
forall c k. CharKleene c k => c -> k
char

-- | One of the characters.
oneof :: (CharKleene c k, Foldable f) => f c -> k
oneof :: forall c k (f :: * -> *). (CharKleene c k, Foldable f) => f c -> k
oneof = [k] -> k
forall k. Kleene k => [k] -> k
unions ([k] -> k) -> (f c -> [k]) -> f c -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> k) -> [c] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map c -> k
forall c k. CharKleene c k => c -> k
char ([c] -> [k]) -> (f c -> [c]) -> f c -> [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f c -> [c]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

class CharKleene c k => FiniteKleene c k | k -> c where
    -- | Everything. \(\Sigma^\star\).
    everything :: k
    everything = k -> k
forall k. Kleene k => k -> k
star k
forall c k. FiniteKleene c k => k
anyChar

    -- | @'charRange' 'a' 'z' = ^[a-z]$@.
    charRange :: c -> c -> k

    -- | Generalisation of 'charRange'.
    fromRSet :: RSet c -> k

    -- | @.@ Every character except new line @\\n@.
    dot :: c ~ Char => k
    dot = RSet Char -> k
forall c k. FiniteKleene c k => RSet c -> k
fromRSet RSet Char
dotRSet

    -- | Any character. /Note:/ different than 'dot'!
    anyChar :: k

    notChar :: c -> k
    default notChar :: (Ord c, Enum c, Bounded c) => c -> k
    notChar = RSet c -> k
forall c k. FiniteKleene c k => RSet c -> k
fromRSet (RSet c -> k) -> (c -> RSet c) -> c -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSet c -> RSet c
forall a. (Ord a, Enum a, Bounded a) => RSet a -> RSet a
RSet.complement (RSet c -> RSet c) -> (c -> RSet c) -> c -> RSet c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> RSet c
forall a. a -> RSet a
RSet.singleton

class Derivate c k | k -> c where
    -- | Does language contain an empty string?
    nullable :: k -> Bool

    -- | Derivative of a language.
    derivate :: c -> k -> k

-- | An @f@ can be used to match on the input.
class Match c k | k -> c where
    match :: k -> [c] -> Bool

    match8 :: c ~ Word8 => k -> BS.ByteString -> Bool
    match8 k
k = k -> [Word8] -> Bool
forall c k. Match c k => k -> [c] -> Bool
match k
k ([Word8] -> Bool) -> (ByteString -> [Word8]) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

-- | Equivalence induced by 'Match'.
--
-- /Law:/
--
-- @
-- 'equivalent' re1 re2 <=> forall s. 'match' re1 s == 'match' re1 s
-- @
--
class Match c k => Equivalent c k | k -> c  where
    equivalent :: k -> k -> Bool

-- | Transition map.
class Derivate c k => TransitionMap c k | k -> c where
    transitionMap :: k -> Map k (SF c k)

-- | Complement of the language.
--
-- /Law:/
--
-- @
-- 'match' ('complement' f) xs = 'not' ('match' f) xs
-- @
class Complement c k | k -> c where
    complement :: k -> k

class ToLatin1 k where
    toLatin1 :: k Char -> k Word8

instance ToLatin1 RSet where
    toLatin1 :: RSet Char -> RSet Word8
toLatin1 = [(Word8, Word8)] -> RSet Word8
forall a. (Ord a, Enum a) => [(a, a)] -> RSet a
RSet.fromRangeList ([(Word8, Word8)] -> RSet Word8)
-> (RSet Char -> [(Word8, Word8)]) -> RSet Char -> RSet Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char, Char) -> Maybe (Word8, Word8))
-> [(Char, Char)] -> [(Word8, Word8)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Char, Char) -> Maybe (Word8, Word8)
f ([(Char, Char)] -> [(Word8, Word8)])
-> (RSet Char -> [(Char, Char)]) -> RSet Char -> [(Word8, Word8)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSet Char -> [(Char, Char)]
forall a. RSet a -> [(a, a)]
RSet.toRangeList where
        f :: (Char, Char) -> Maybe (Word8, Word8)
        f :: (Char, Char) -> Maybe (Word8, Word8)
f (Char
a, Char
b)
            | Char -> Int
ord Char
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
256 = Maybe (Word8, Word8)
forall a. Maybe a
Nothing
            | Bool
otherwise    = (Word8, Word8) -> Maybe (Word8, Word8)
forall a. a -> Maybe a
Just (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
a), Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (Char -> Int
ord Char
b)))