module Nondet
(
    nondeterministic
)
where

import Isomorphism
import MonadF
import Package
import Char

-- Figure 10: The nondeterministic building block

data TermL u t = Fail | Amb u u | OtherTL t

newtype ValueL u v = List [v]

instance PseudounitF TermL where
    pseudounit = OtherTL

instance (MonadF m) => PseudobindF m TermL where
    pseudobind (Fail     ) f = unit (Fail   )
    pseudobind (Amb x y  ) f = unit (Amb x y)
    pseudobind (OtherTL x) f = f x

instance Wrap (TermL u t) t where
    wiso (OtherTL x) = x
    wosi             = pseudounit

instance PseudounitF ValueL where
    pseudounit x = List [x]

instance (MonadF m) => PseudobindF m ValueL where
    pseudobind (List x) f = foldr c (unit (List [])) [ f a | a <- x ] where
        c x y = x <<>> (\(List q) -> y <<>> (\(List r) -> unit (List (q ++ r))))

instance Wrap (ValueL u v) v where
    wiso (List [x]) = x
    wosi            = pseudounit

nondeterministic :: (MonadF mt, MonadF mv)
        => Prepackage t v
                      (Amp mt TermL ut t) (Amp mv ValueL uv v)
                      ve ut uv
        -> Prepackage (TermL ut t) (ValueL uv v)
                      (mt ut (TermL ut t)) (mv uv (ValueL uv v))
                      ve ut uv

nondeterministic oldprepkg = Prepackage my_isom_t'' my_isom_v'' my_finalize
  where
    Prepackage my_isom_t'' my_isom_v'' old_finalize = wosi oldprepkg
    my_finalize realTop = oldpkg { parser   = parseL
                                 , interpr  = interpL
                                 , showvalr = showvalL
                                 , namer    = nameL }
      where
        oldpkg = old_finalize realTop
        top = lowerTop my_isom_t'' my_isom_v'' realTop
        vosi = osi my_isom_v''

        parseL s = (pfail s ++ pchoice s ++ parser oldpkg s) where
            pfail s = [(unit Fail, s1)
                      | ('f':'a':'i':'l':s1) <- [dropWhile isSpace s]]
            pchoice s = [(unit (Amb x y), s5)
                        | ('(':s1) <- [dropWhile isSpace s],
                          (x, s2) <- parser realTop s1,
                          ('|':s3) <- [dropWhile isSpace s2],
                          (y, s4) <- parser realTop s3,
                          (')':s5) <- [dropWhile isSpace s4]]

        interpL Fail _ = unit (List [])
        interpL (Amb x y) env = vosi (interpr realTop x env) <<>> (\(List u) ->
                                vosi (interpr realTop y env) <<>> (\(List v) ->
                                unit (List (u ++ v))))
        interpL x env = interpr oldpkg x env

        showvalL (List m) = unlines [ showvalr oldpkg (List [x]) | x <- m ]
                            ++ "That's all!"

        nameL = "nondeterministic " ++ namer oldpkg