Typelevel-checked regular expressions

Rady.hs

{-# LANGUAGE GADTs #-}
module Rady where

import Data.Void

data Node = Node String [Node]
          | Text String
    deriving (Show)

tagged :: String -> Shape Node a -> Shape Node a
tagged tag shape = Match tagPMatch (Node tag . generate shape)
    where tagPMatch (Node s xs) = if tag == s then parse shape xs else Nothing
          tagPMatch (Text text) = Nothing

anything :: Shape x [x]
anything = Star (Match pure id)

text :: Shape Node String
text = Iso concat pure (Star (Match maybeText Text))

maybeText :: Node -> Maybe String
maybeText (Text s) = Just s
maybeText _        = Nothing

soup = tagged "a" anything `Group` (tagged "b" anything `Group` tagged "c" anything)

minimal = tagged "head" (tagged "title" text `Interleave` anything)
 `Group` tagged "body" anything


parse :: Shape x y -> [x] -> Maybe y
parse shape [] = accept (pattern shape)
parse shape (x:xs) = accept (foldl deriv (pattern shape `deriv` x) xs)


data Shape x y where
    Reject     :: Shape x Void
    Empty      :: Shape x ()
    Match      :: (x -> Maybe y) -> (y -> x) -> Shape x y
    Group      :: Shape x a -> Shape x b -> Shape x (a,b)
    Alt        :: Shape x a -> Shape x b -> Shape x (Either a b)
    Star       :: Shape x a -> Shape x [a]
    Interleave :: Shape x a -> Shape x b -> Shape x (a,b)
    Iso        :: (a -> b) -> (b -> a) -> Shape x a -> Shape x b


generate :: Shape x a -> a -> [x]
generate Reject a = absurd a
generate (Empty) _ = []
generate (Match _ f) x = [f x]
generate (Group f g) (x,y) = generate f x ++ generate g y
generate (Alt f g) (Left x) = generate f x
generate (Alt f g) (Right y) = generate g y
generate (Star f) xs = concat (map (generate f) xs)
generate (Interleave f g) (x,y) = generate f x ++ generate g y
generate (Iso k f z) x = generate z (f x)

pattern :: Shape x a -> Pattern x a
pattern Reject = PReject
pattern (Empty) = PAccept ()
pattern (Match f _) = PMatch f
pattern (Group f g) = PGroup (,) (pattern f) (pattern g)
pattern (Alt f g) = PAlt id (pattern f) (pattern g)
pattern (Star f) = PStar (pattern f)
pattern (Interleave f g) = PInterleave (pattern f) (pattern g)
pattern (Iso f g z) = PWith f (pattern z)

data Pattern x a where
    PReject     :: Pattern x a
    PAccept     :: a -> Pattern x a
    PMatch      :: (x -> Maybe y) -> Pattern x y
    PGroup      :: (a -> b -> c) -> Pattern x a -> Pattern x b -> Pattern x c
    PAlt        :: (Either a b -> c) -> Pattern x a -> Pattern x b -> Pattern x c
    PStar       :: Pattern x a -> Pattern x [a]
    PInterleave :: Pattern x a -> Pattern x b -> Pattern x (a,b)
    PWith       :: (a -> b) -> Pattern x a -> Pattern x b

deriv :: Pattern x a -> x -> Pattern x a
deriv PReject      j      = PReject
deriv (PAccept _)  j      = PReject
deriv (PMatch f)   j      = case f j of
                           Nothing -> PReject
                           Just x  -> PAccept x
deriv (PGroup k f g) j    = case accept f of
                           Just x  -> alt vanish (group k (deriv f j) g) (PWith (k x) (deriv g j))
                           Nothing -> group k (deriv f j) g
deriv (PAlt k f g)   j    = alt k (deriv f j) (deriv g j)
deriv (PStar f)    j      = group (:) (deriv f j) (PStar f)
deriv (PInterleave f g) j = alt vanish (interleave (deriv f j) g)
                                (interleave f (deriv g j))
deriv (PWith h f) j       = case (deriv f j) of
                           PAccept x -> PAccept (h x)
                           PReject   -> PReject
                           g'       -> PWith h g'

group :: (a -> b -> c) -> Pattern x a -> Pattern x b -> Pattern x c
group k (PAccept x) g = PWith (k x) g
group k f (PAccept y) = PWith (\x -> k x y) f
group _ PReject     g = PReject
group _ _     PReject = PReject
group k f           g = PGroup k f g

alt :: (Either a b -> c) -> Pattern x a -> Pattern x b -> Pattern x c
alt k PReject g = PWith (k.Right) g
alt k f PReject = PWith (k.Left)  f
alt k f       g = PAlt k f g

vanish :: Either a a -> a
vanish (Left a)  = a
vanish (Right a) = a

interleave :: Pattern x a -> Pattern x b -> Pattern x (a,b)
interleave (PAccept x) g = PWith (\y -> (x,y)) g
interleave f (PAccept y) = PWith (\x -> (x,y)) f
interleave PReject     g = PReject
interleave f     PReject = PReject
interleave f           g = PInterleave f g

accept :: Pattern x a -> Maybe a
accept PReject           = Nothing
accept (PAccept x)       = Just x
accept (PMatch _)        = Nothing
accept (PGroup k f g)    = k <$> accept f <*> accept g
accept (PAlt k f g)      = case accept f of
    Just x  -> pure (k (Left x))      -- I would prefer to check ambiguity on regexes, but this is ok.
    Nothing -> (k.Right) <$> accept g
accept (PStar f)         = Just []
accept (PWith h g)       = fmap h (accept g)
accept (PInterleave f g) = (,) <$> accept f <*> accept g

Rady.purs

module Rady where

import Data.Exists

import Control.Applicative (pure)
import Control.Apply ((<*>))
import Control.Bind (composeKleisli, (>>=))
import Control.Category (identity)
import Control.Semigroupoid ((<<<))
import Data.Array (concat, uncons, (:))
import Data.Array.NonEmpty (intersect)
import Data.Either (Either(..))
import Data.Eq ((==))
import Data.Foldable (foldl, intercalate)
import Data.Functor (map, (<$>))
import Data.Maybe (Maybe(..))
import Data.Semigroup ((<>))
import Data.Show (class Show, show)
import Data.Tuple (Tuple(..))
import Data.Unit (unit)
import Data.Void (Void, absurd)
import Prelude (Unit(..), bind)
import Unsafe.Coerce (unsafeCoerce)

matchAny :: ∀x. Match x x
matchAny = Match pure (\x -> x)

testpattern = (Group matchAny matchAny)

foo :: ∀ x. Tuple x x -> Array x
foo = generate testpattern

bar = parse testpattern


data Reject         = Reject
data Empty          = Empty
data Match x t      = Match (x -> Maybe t) (t -> x)
data Group a b      = Group a b
data Alt a b        = Alt a b
data Star a         = Star a
data Interleave a b = Interleave a b

class Pattern a x t | a -> x t where
    generate :: a -> t -> Array x
    pattern :: a -> P x t

parse :: ∀a x t. Pattern a x t => a -> Array x -> Maybe t
parse pat xs = accept (foldl deriv (pattern pat) xs)

instance patternReject :: Pattern Reject x Void where
    generate _ x = absurd x
    pattern _ = PReject

instance patternEmpty :: Pattern Empty x Unit where
    generate _ _ = []
    pattern _ = PAccept unit

instance patternMatch :: Pattern (Match x t) x t where
    generate (Match f g) x = [g x]
    pattern (Match f g) = PMatch f

instance patternGroup :: (Pattern f x a, Pattern g x b)
                       => Pattern (Group f g) x (Tuple a b) where
    generate (Group f g) (Tuple x y) = generate f x <> generate g y
    pattern (Group f g) = (PGroup (mkExists2 (GroupF {fst:pattern f, snd:pattern g, k:Tuple})))

instance patternAlt :: (Pattern f x a, Pattern g x b)
                       => Pattern (Alt f g) x (Either a b) where
    generate (Alt f g) (Left x) = generate f x
    generate (Alt f g) (Right y) = generate g y
    pattern (Alt f g) = PAlt (mkExists2 (AltF {fst:pattern f, snd:pattern g, k:(\a -> a)}))

instance patternStar :: (Pattern f x a)
                       => Pattern (Star f) x (Array a) where
    generate (Star f) xs = concat (map (generate f) xs)
    pattern (Star f) = (PStar (mkExists (StarF {p:pattern f, k:(:), e:[]})))

instance patternInterleave :: (Pattern f x a, Pattern g x b)
                       => Pattern (Interleave f g) x (Tuple a b) where
    generate (Interleave f g) (Tuple x y) = generate f x <> generate g y
    pattern (Interleave f g) = PInterleave (mkExists2 (GroupF {fst:pattern f, snd:pattern g, k:Tuple}))

data P x c = PReject
           | PAccept c
           | PMatch (x -> Maybe c)
           | PGroup (Exists2 (GroupF x c))
           | PAlt (Exists2 (AltF x c))
           | PStar (Exists (StarF x c))
           | PInterleave (Exists2 (GroupF x c))
           | PWith (Exists (ItemF x c))

data GroupF x c a b = GroupF { fst :: P x a
                             , snd :: P x b
                             , k :: a -> b -> c }

data AltF x c a b = AltF { fst :: P x a
                         , snd :: P x b
                         , k :: Either a b -> c }

data ItemF x c a = ItemF { p :: P x a
                         , k :: a -> c }

data StarF x c a = StarF { p :: P x a
                         , k :: a -> c -> c
                         , e :: c }

deriv :: ∀x a. P x a -> x -> P x a
deriv PReject           a = PReject
deriv (PAccept _)       a = PReject
deriv (PMatch f)        a = case f a of
                            Nothing -> PReject
                            Just x -> PAccept x
deriv (PGroup box)      a = runExists2 (\(GroupF {fst, snd, k}) ->
                              case accept fst of
                                Just x -> alt vanish (group k (deriv fst a) snd) (PWith (mkExists (ItemF {p:(deriv snd a), k:k x})))
                                Nothing -> (group k (deriv fst a) snd)) box
deriv (PAlt box)        a = runExists2 (\(AltF {fst, snd, k}) -> alt k (deriv fst a) (deriv snd a)) box
deriv (PStar box)       a = runExists (\(StarF {p, k, e}) -> 
                                group k (deriv p a) (PStar (mkExists (StarF {p, k, e})))) box
deriv (PInterleave box) a = runExists2 (\(GroupF {fst, snd, k}) ->
     alt vanish (interleave k (deriv fst a) snd) (interleave k fst (deriv snd a))
     ) box
deriv (PWith box)       a = runExists (\(ItemF {p, k}) -> case deriv p a of
                              PAccept x -> PAccept (k x)
                              PReject   -> PReject
                              p'        -> PWith (mkExists (ItemF {p:p', k:k}))) box

-- The PAlt in 'accept' determines how ambiguous parses are treated. Now we catch the leftmost parse.
accept :: ∀ x a. P x a -> Maybe a
accept PReject           = Nothing
accept (PAccept x)       = Just x
accept (PMatch _)        = Nothing
accept (PGroup box)      = runExists2 (\(GroupF {fst, snd, k}) -> k <$> accept fst <*> accept snd) box
accept (PAlt box)        = runExists2 (\(AltF {fst, snd, k}) -> case accept fst of
    Just x -> pure (k (Left x))
    Nothing -> (k <<< Right) <$> accept snd) box
accept (PStar box)       = runExists (\(StarF {p, k, e}) -> Just e) box
accept (PInterleave box) = runExists2 (\(GroupF {fst, snd, k}) -> k <$> accept fst <*> accept snd) box
accept (PWith box)       = runExists (\(ItemF {p, k}) -> map k (accept p)) box

group :: ∀a b c x. (a -> b -> c) -> P x a -> P x b -> P x c
group k (PAccept x) g = PWith (mkExists (ItemF {p:g, k:k x}))
group k f (PAccept y) = PWith (mkExists (ItemF {p:f, k:(\x -> k x y)}))
group k PReject g = PReject
group k f PReject = PReject
group k f g = (PGroup (mkExists2 (GroupF {fst:f, snd:g, k:k})))

alt :: ∀a b c x. (Either a b -> c) -> P x a -> P x b -> P x c
alt k PReject g = PWith (mkExists (ItemF {p:g, k:(k <<< Right)}))
alt k f PReject = PWith (mkExists (ItemF {p:f, k:(k <<< Left)}))
alt k f g       = PAlt (mkExists2 (AltF {fst:f, snd:g, k:k}))

interleave :: ∀a b c x. (a -> b -> c) -> P x a -> P x b -> P x c
interleave k (PAccept x) g = PWith (mkExists (ItemF {p:g, k:k x}))
interleave k f (PAccept y) = PWith (mkExists (ItemF {p:f, k:(\x -> k x y)}))
interleave k PReject g = PReject
interleave k f PReject = PReject
interleave k f g = (PInterleave (mkExists2 (GroupF {fst:f, snd:g, k:k})))

foreign import data Exists2 :: (Type -> Type -> Type) -> Type

mkExists2 :: forall f a b. f a b -> Exists2 f
mkExists2 = unsafeCoerce

runExists2 :: forall f r. (forall a b. f a b -> r) -> Exists2 f -> r
runExists2 = unsafeCoerce

vanish :: ∀a. Either a a -> a
vanish (Left a)  = a
vanish (Right a) = a