datatype 'a Maybe = Just of 'a | Nothing;

datatype RE =
   Lit of string
 | Or of (RE*RE)
 | Concat of (RE*RE)
 | Star of RE;

fun prefix [] xs = Just xs
  | prefix (y::ys) (x::xs) = if  y=x then prefix ys xs else Nothing
  | prefix ys xs = Nothing;

fun eval (Lit s) input = 
     (case prefix (explode s) input of
        Just more => Just(s,more) 
      | Nothing => Nothing)
  | eval (Or(a,b)) input = 
     (case eval a input of
        Nothing => eval b input
      | Just pair => Just pair)
  | eval (Concat(a,b)) input =
     (case (eval a input) of
        Just(zs,rest) => 
         (case eval b rest of
            Just (bs,more) => Just (zs ^ bs,more)
          | Nothing => Nothing)
      | Nothing => Nothing)
  | eval (Star x) input = 
     let fun f input = case eval x input of
                         Nothing => ("",input)
                       | Just (cs,zs) => let val (bs,ws) = f zs
                                         in (cs ^ bs,ws) end
     in  Just(f input) end;



fun Seval (Lit s) input = 
     <case prefix (explode ~(lift s)) ~input of
        Just more => Just(~(lift s),more) 
      | Nothing => Nothing>
  | Seval (Or(a,b)) input = 
     <case ~(Seval a input) of
        Nothing => ~(Seval b input)
      | Just pair => Just pair>
  | Seval (Concat(a,b)) input =
     <case ~(Seval a input) of
        Just(zs,rest) => 
         (case ~(Seval b <rest>) of
            Just (bs,more) => Just (zs ^ bs,more)
          | Nothing => Nothing)
      | Nothing => Nothing>
  | Seval (Star x) input = 
     <let fun f input = case ~(Seval x <input>) of
                         Nothing => ("",input)
                       | Just (cs,zs) => let val (bs,ws) = f zs
                                         in (cs ^ bs,ws) end
      in  Just(f ~input) end>;
   
fun test x = <fn s => ~(Seval x <s>)>;

val t1 = Concat(Or(Lit "tim",Lit "mary"),Star (Lit "x"));

fun f x = (run(test t1)) (explode x);

(* ******************************************************* *)

datatype 'a M = M of (char list -> ('a* char list) Maybe);
fun unM (M x) = x;

val mm = let fun return x = M (fn s => Just(x,s));
             fun bind (M f) g = 
                  let fun h s = case f s of
                                  Just(a,s2) => unM (g a) s2
                                  | Nothing => Nothing
                  in M h end 
         in Mon(return,bind) end;        

fun prefix2 s = 
   let fun h x = case prefix s x of
                   Nothing => Nothing
                 | Just m => Just(s,m)
   in M h end;

fun test (M f) =
  let fun h s = case f s of
                  Nothing => Just(Nothing,s)
                | Just(a,rest) => Just(Just a,rest)
  in M h end;     
          
fun prefix2 s = 
   let fun h x = case prefix s x of
                   Nothing => Nothing
                 | Just m => Just(s,m)
   in M h end;
           
fun try (M f) (M g) =
  let fun h s = case f s of
                  Nothing => g s
                | Just pair => Just pair
  in M h end


(* ******************************************************* *)
   

val maybeM = let fun return x = Just x;
             fun bind (Just x) g = g x
               | bind Nothing g = Nothing;
         in Mon(return,bind) end;


(* ******************************************** *)


fun star m = 
  Do mm { mx <- test m
        ; case mx of
            Just x => Do mm { xs <- star m
                            ; Return mm (x::xs) }
          | Nothing => Return mm []};

fun eval2 (Lit s) = prefix2 (explode s) 
  | eval2 (Or(a,b)) = try (eval2 a) (eval2 b)
  | eval2 (Concat(a,b)) = 
       Do mm { x <- eval2 a
             ; y <- eval2 b
             ; Return mm (x@y)}
  | eval2 (Star x) = 
       Do mm { xss <- star (eval2 x)
             ; Return mm (concat xss) }
     
fun Seval2 (Lit s) = <prefix2 (explode ~(lift s))> 
  | Seval2 (Or(a,b)) = <try ~(Seval2 a) ~(Seval2 b)>
  | Seval2 (Concat(a,b)) = 
      <Do mm { x <- ~(Seval2 a)
             ; y <- ~(Seval2 b)
             ; Return mm (x@y)}>
  | Seval2 (Star x) = 
     <Do mm { xss <- star ~(Seval2 x)
            ; Return mm (concat xss) }>;