{-# LANGUAGE TypeFamilies, FlexibleInstances, LambdaCase #-}
-- TypeSynonymInstances, ScopedTypeVariables, MultiParamTypeClasses
             
-- July 14, 2019

module Compiler where

import Prelude hiding (seq)
import Control.Exception
import Control.Applicative (Applicative(pure,(<*>)))
import Control.Monad
import Data.Maybe
import Data.Map.Strict (Map,keys,(!))
import qualified Data.Map.Strict as DMS(empty,fromList)

import Painter (Tree(F),mkTreeC,update,insert,union,unionMap,subset,
		readFileContinue)
import Coalg (DAut(DAut,delta,beta),DAutC(New),dAutC,unfoldBeh)

rel :: String -> Int -> Int -> Bool
rel = \case "<"  -> (<)
	    ">"  -> (>)
	    "<=" -> (<=)
	    ">=" -> (>=)
	    "==" -> (==)
	    "!=" -> (/=)
	    	    				 		       
-- TRANSITION MONAD
	       
newtype StateT state m a = StateT {runST :: state -> m (a,state)}

instance Monad m => Functor (StateT state m) where fmap = liftM
 	 
instance Monad m => Applicative (StateT state m) where pure  = return
         					       (<*>) = liftM2 id

instance Monad m => Monad (StateT state m) where
	 return a = StateT $ \st -> return (a,st)
         StateT h >>= f = StateT $ (>>= \(a,st) -> runST (f a) st) . h

type Trans m = StateT (Input m) m

done ::  Monad m => Trans m ()
done = return ()

runAndApp :: Trans (Either String) a -> (String -> b) -> (a -> b) -> String -> b
runAndApp comp applyL applyR input = case runC comp ((1,1),input) of 
        		                  Left str -> applyL str
        		                  Right a -> applyR a
				 		       
-- COMPILER 

class Monad m => Compiler m where
                 type Input m :: *
                 errmsg :: Input m -> m a
                 empty  :: Input m -> m Bool
                 ht     :: Input m -> m (Char,Input m)
                 plus   :: m a -> m a -> m a

instance Compiler [ ] where 
	 type Input [ ] = String
	 errmsg _ = []
	 empty = return . null
	 ht (c:str) = [(c,str)]
	 plus = (++)
	 
instance Compiler (Either String) where
         type Input (Either String) = (Pos,String)
	 errmsg (pos,_) = Left $ "error at position "++show pos
         empty = return . null . snd
         ht ((i,j),c:str) = Right (c,(pos,str)) where
                            pos = if c == '\n' then (i+1,1) else (i,j+1)
         Left _ `plus` m = m
         m `plus` _      = m

runC :: Compiler m => Trans m a -> Input m -> m a
runC comp input = do (a,input) <- runST comp input
 		     b <- empty input
                     if b then return a else errmsg input
			     
cplus :: Compiler m => Trans m a -> Trans m a -> Trans m a
StateT g `cplus` StateT h = StateT $ liftM2 plus g h

csum :: Compiler m => [Trans m a] -> Trans m a
csum = foldr1 cplus 

some, many :: Compiler m => Trans m a -> Trans m [a]
some comp = do a <- comp; as <- many comp; return $ a:as
many comp = csum [some comp, return []]

cguard :: Compiler m => Bool -> Trans m ()
cguard b = if b then done else StateT errmsg

sat :: Compiler m => (Char -> Bool) -> Trans m Char
sat f = StateT $ \input -> do b <- empty input
                              let err = errmsg input
			      p@(c,_) <- if b then err else ht input
                              if f c then return p else err
		 
char :: Compiler m => Char -> Trans m Char
char chr = sat (== chr)

nchar :: Compiler m => String -> Trans m Char
nchar chrs = sat (`notElem` chrs)
    	     
digit,letter,delim :: Compiler m => Trans m Char
digit  = csum $ map char ['0'..'9']
letter = csum $ map char $ ['a'..'z']++['A'..'Z']
delim  = csum $ map char " \n\t"

string :: Compiler m => String -> Trans m String
string = mapM char

bool :: Compiler m => Trans m Bool
bool  = csum [do string "True"; return True,
              do string "False"; return False]

nat,int :: Compiler m => Trans m Int
nat = do ds <- some digit; return $ read ds
int = csum [nat, do char '-'; n <- nat; return $ -n]

identifier :: Compiler m => Trans m String 
identifier = do liftM2 (:) letter $ many $ nchar "(){}<>=!&|+-*/^.,:; \n\t"
		 
relation :: Compiler m => Trans m String
relation  = csum $ map string $ words "<= >= < > == !="

token :: Compiler m => Trans m a -> Trans m a
token comp = do many delim; a <- comp; many delim; return a 

tchar :: Compiler m => Char -> Trans m Char
tchar = token . char

tstring :: Compiler m => String -> Trans m String
tstring = token . string

tbool :: Compiler m => Trans m Bool
tbool = token bool

tint :: Compiler m => Trans m Int
tint = token int

tidentifier,trelation :: Compiler m => Trans m String
tidentifier = token identifier
trelation   = token relation

-- REGULAR EXPRESSIONS AND LANGUAGES 

data Reg reg = Reg {par,seq :: reg -> reg -> reg, 		-- signature
		    iter :: reg -> reg, con :: String -> reg}
		    
-- con enclose names of base languages or nonterminals of a context-free grammar
-- (see below).

infixr 6 :+
infixr 7 :*
			  
data RegT = RegT :+ RegT | RegT :* RegT | Iter RegT | Con String 
	    deriving (Eq,Show)					-- terms

one = Con "eps"
mt  = Con "mt"
	   
regT :: Reg RegT						-- term algebra
regT = Reg (:+) (:*) Iter Con

foldReg :: Reg reg -> RegT -> reg				-- fold
foldReg alg = \case t :+ u -> par alg (f t) $ f u
		    t :* u -> seq alg (f t) $ f u
		    Iter t  -> iter alg $ f t
		    Con b   -> con alg b
	      where f = foldReg alg		
		
-- The Reg-algebra regNorm interprets a regular expression by its additive
-- normal form, which can be obtained by applying semiring equations. 

regNorm :: Reg RegT
regNorm = Reg {par  = \t u -> let ts = summands $ t :+ u
			      in if null ts then mt else foldr1 (:+) ts,
               seq  = \t u -> let ts = factors $ t :* u
               		      in if null ts then one
	       		                    else if mt `elem` ts 
	       		         	         then mt else foldr1 (:*) ts,
               iter = \t -> if t `elem` [one,mt] then one else Iter t,
               con  = Con}	        

summands,factors :: RegT -> [RegT]
summands (t :+ u)   = summands t `union` summands u
summands (Con "mt") = []
summands t          = [t]
factors (t :* u)    = factors t ++ factors u
factors (Con "eps") = []
factors t           = [t]

-- Folding a Reg-term in the Reg-algebra regWord leads to a string with as less
-- brackets as possible, in accordance with the usual priorities of regular 
-- operators: prio(par) = 0, prio(seq) = 1, prio(iter) = 3. 
	      
regWord :: Reg (Int -> String)
regWord = Reg {par  = \f g n -> enclose (n > 0) $ f 0 ++ '+':g 0,
               seq  = \f g n -> enclose (n > 1) $ f 1 ++ '.':g 1,
               iter = \f n -> enclose (n > 2) $ f 2 ++ "*",
               con  = const}
	  where enclose b w = if b then '(':w++")" else w

showReg :: RegT -> String
showReg = flip (foldReg regWord) 0

-- The Reg-algebra regNDA computes the nondeterministic acceptor of a regular
-- language.

type NDA = Int -> String -> [Int]

regNDA :: Reg ((NDA,Int,Int,Int) -> (NDA,Int))
regNDA = Reg {par  = \f g (d,s,s',next) -> let (d',next') = f (d,s,s',next) 
                                           in g (d',s,s',next'),
              seq  = \f g (d,s,s',next) -> let (d',next') = f (d,s,next,next+1) 
              				   in g (d',next,s',next'),
              iter = \f (d,s,s',next) -> let next1 = next+1
			       	             next2 = next1+1
				             (d1,next3) = f (d,next,next1,next2)
				             d2 = addTo d1 s "eps" next
				             d3 = addTo d2 next1 "eps" next
				             d4 = addTo d3 next1 "eps" s'   
				         in (addTo d4 s "eps" s',next3),
	      con  = \case "mt" -> \(d,_,_,next) -> (d,next)
	      		   b    -> \(d,s,s',next) -> (addTo d s b s',next)}

addTo :: (Eq a,Eq b,Eq c) => (a -> b -> [c]) -> a -> b -> c -> a -> b -> [c]
addTo f a b c = update f a $ update (f a) b $ insert c $ f a b

type CFG = Map String RegT

-- The following two Reg-algebras interpret a regular expressionin AccC and 
-- [String] -> Bool, respectively.

regAccC :: Reg AccC
regAccC = Reg {par = par, seq = seq, iter = iter,
               con = \case "mt"   -> mt 
                  	   "eps"  -> one
                  	   "Int"  -> mkCon int
                  	   "Bool" -> mkCon bool
                  	   x      -> New (\y -> if x == y then one else mt) 
                  	   		 False}
          where par (New f b) (New g c) = New (\x -> par (f x) $ g x) (b || c)
                seq (New f b) t@(New g c) 
                                | b   =  New (\x -> par (seq (f x) t) $ g x) c
                                | True = New (\x -> seq (f x) t) False
                iter t@(New f _) = New (\x -> seq (f x) $ iter t) True
                mt  = New (const mt) False
                one = New (const mt) True
                mkCon p  = New (runAndApp p (const mt) $ const one) False

regBeh :: Reg ([String] -> Bool)
regBeh = Reg {par  = liftM2 (||),
              seq  = \f g w -> f [] && g w || f w && g [] ||
		               or [f w1 && g w2 | [w1,w2] <- mkParts w],
	      iter = \f w -> null w || or [all f ws | ws <- mkParts w],
	      con  = \case "eps"    -> null
                  	   "mt"     -> const False
	                   "Int"    -> \case [x] -> mkFun int x;  _ -> False
	                   "Bool"   -> \case [x] -> mkFun bool x; _ -> False
                 	   x        -> \case [y] -> x == y; _ -> False}
	 where mkParts [x]    = [[[x]]]
	       mkParts (x:w)  = concatMap glue $ mkParts w
	                        where glue p@(w:p') = [[x]:p,(x:w):p']
	       mkParts _      = []
	       mkFun p = runAndApp p (const False) $ const True
       		
-- DETERMINISTIC STRING ACCEPTORS

type Acc = DAut String Bool			   	   -- signature

type AccC = DAutC String Bool				   -- coterms

accC :: Acc AccC					   -- coterm algebra
accC = dAutC
	
-- The Acc(String)-algebras accT cfg and accNorm cfg are BRZOZOWSKI AUTOMATA for
-- regular expressions and the context-free grammar cfg.

accT,accNorm :: CFG -> Acc RegT 

accT cfg = DAut delta beta where
           delta = \case t :+ u       -> \x -> delta t x :+ delta u x
			 t :* u       -> \x -> let v = delta t x :* u
			                       in if beta t then v :+ delta u x 
			                       		    else v
		         Iter t       -> \x -> delta t x :* Iter t
		         Con "eps"    -> const mt
		         Con "mt"     -> const mt
		         Con "Int"    -> mkReg int
		         Con "Bool"   -> mkReg bool
		         Con x | x `elem` keys cfg
		         	      -> delta $ cfg!x
		               | True -> \y -> if x == y then one else mt
	   beta  = \case t :+ u -> beta t || beta u
		         t :* u -> beta t && beta u
		         Iter t  -> True
		         Con x   -> x == "eps" || 
		                    x `elem` keys cfg && beta (cfg!x)
	   mkReg p = runAndApp p (const mt) $ const one	
	   
accNorm cfg = DAut (\state -> foldReg regNorm . delta alg state) $ beta alg
              where alg = accT cfg

-- The Acc-algebra accNDA f is the power automaton obtained from the 
-- nondeterministic acceptor f.

accNDA :: NDA -> (Acc [Int],[Int])
accNDA nda = (DAut (\qs -> epsHull . deltaP qs) (1 `elem`), 
	      epsHull [0])
           where deltaP :: [Int] -> String -> [Int]
                 deltaP qs x = unionMap (flip nda $ scan x) qs 
                 epsHull :: [Int] -> [Int]
                 epsHull qs = if qs' `subset` qs then qs 
           		      else epsHull $ qs `union` qs'
                              where qs' = deltaP qs "eps"
                 scan :: String -> String
                 scan x = case runC int ((1,1),x) :: Either String Int of 
                   	  Right _ -> "Int"
                   	  _ -> case runC bool ((1,1),x) :: Either String Bool of
        		         	 Right _ -> "Bool"
        		         	 _ -> x

-- Reg(String)-compiler

compReg :: Compiler m => Reg reg -> Trans m reg 
compReg alg = do r <- summand; csum [do tchar '+'; r' <- compReg alg
	                                return $ par alg r r',
			             return r] 
	        where summand = do r <- iterC; csum [do tchar '.'; r' <- summand
		                                        return $ seq alg r r',
			                             return r]
	              iterC = do r <- factor
		                 csum [do stars <- some $ tchar '*'
				          return $ iterate (iter alg) r
				    	           !!length stars,
	                               return r]
	              factor = csum [do x <- tidentifier
			                return $ con alg x,
			             do tchar '('; r <- compReg alg; tchar ')'
			                return r]

getCFG :: String -> IO CFG
getCFG cfg = do w <- readFile cfg `catch` handler
                let ws = words w
                    rules = if null ws then [] else zip (init ws) $ tail ws
                    f (x,w) = (x,runAndApp (compReg regT) (const mt) id
                  		           $ fromJust $ lookup x rules)
                return $ DMS.fromList $ map f rules
             where handler :: IOError -> IO String
		   handler _ = return ""

-- reg2alg n cfg reg loads the context-free grammar from file cfg and compiles  
-- the regular expression reg (possibly involving nonterminals of cfg) into an 
-- element a of a Reg-algebra. In some cases, a is unfolded into the behavior 
-- of a.

reg2alg :: Int -> String -> String -> IO ()
reg2alg n file reg = 
                do cfg <- getCFG file
                   let run :: Reg a -> (a -> IO ()) -> IO ()
                       run alg continue = runAndApp (compReg alg) putStrLn 
                       				    continue reg
                   case n of 1 -> run regBeh loop
          	             2 -> run regAccC $ loop . unfoldBeh accC
         	             3 -> run regNDA $ loop . uncurry unfoldBeh . accNDA
         	           			    . fst . ($ emptyNDA)
        	             4 -> run regT $ loop . unfoldBeh (accT cfg)
         	             5 -> run regT $ loop . unfoldBeh (accNorm cfg)
         	             6 -> run regT $ mkTreeC "regterm" . show
         	             7 -> run regNorm $ mkTreeC "regnorm" . show
         	             _ -> run regWord $ \f -> putStrLn $ f 0 
                   where emptyNDA = (const $ const [],0,1,2)
	       
-- loop beh applies the behavior function beh to interactively entered lists of 
-- strings.

loop :: ([String] -> Bool) -> IO ()
loop beh = do putStrLn $ "Enter a list of strings separated " ++
                         "by blanks or a call of the function exa!"
	      str <- getLine 
	      let ws = words str
	          ws' = case ws of ["exa",arg] -> words $ exa $ read arg
	          		   _ -> ws
              when (not $ null ws') $ do putStrLn $ if beh ws' then "accepted" 
              						       else "rejected"
              			         loop beh

-- Alternative parser of regular expressions involving nonterminals of a cfg              

regP :: Compiler m => CFG -> RegT -> Trans m ()
regP cfg = f where f (Con "eps")    = done
                   f (Con "mt")     = StateT errmsg
		   f (Con "Bool")   = bool >> done
		   f (Con "Int")    = int >> done
		   f (Con x) | x `elem` keys cfg 
		                    = f (cfg!x) >> done
		             | True = string x >> done
		   f (t :+ u)       = f t `cplus` f u
		   f (t :* u)       = f t >> f u
		   f (Iter t)       = (f t >> f (Iter t)) `cplus` done
          	 
-- Examples

reg1 = "((aa.Int+b)*+cc.Bool.d*)*"
reg2 = "(Bool+Int+c+ab)*"
reg3 = "((a+b.a)*.c)*"
reg4 = "(a.a*+b.c.(b.c)*)*"

-- reg2alg n "" reg1  accepts  "aa 666 b cc True d".
-- reg2alg n "" reg2  accepts  "c ab -4 ab True c".
-- reg2alg n "" reg3  accepts  "c b a c a a c".
-- reg2alg n "" reg4  accepts  "a b c a".
-- reg2alg n "" reg4  rejects  "b c a c".

-- contents of sab: S  a.B+b.A+eps   A  a.S+b.A.A   B  b.S+a.B.B"
--       	    T  a.T.U+a.U     U  b+Int
-- S generates the language of words with the same number of a's and b's

exa 0 = "a b b b a a"
exa 1 = "a b a b b a b a a b"
exa 2 = "a b a b b a a a b a b b a b a b b a a b b a b a a b b a" 
exa 3 = "a b a b b a b b a b"
exa 4 = "a a b a b b a b a a b d"
exa 5 = unwords $ replicate 55 "a"++replicate 55 "b"		  
exa 6 = unwords $ replicate 55 "a"++replicate 54 "77"++["87"]
exa 7 = unwords $ replicate 55 "a"++replicate 56 "b"
              
test0 = unfoldBeh (accT DMS.empty) s . words . exa        
        where s = Con"a":*b:+Con"b":*a:+Con"eps"
              a = Con"a":*s:+Con"b":*a:*a
              b = Con"b":*s:+Con"a":*b:*b
              t = Con"a":*t:*Con"b":+Con"eps"
              i = Con"a":*i:*Con"Int":*Con" ":+Con"eps"
              		             -- accepts exa 0,exa 1,exa 2; rejects exa 3
              		             -- does not terminate with accNorm 

reg :: Int -> RegT
reg 1 = Iter $ Con"Bool":+Con"Int":+Con"c":+Con"ab"
reg 2 = Con"a":*Con"B":+Con"b":*Con"A":+Con"eps"
reg 3 = Con"a":*Con"S":+Con"b":*Con"A":*Con"A"
reg 4 = Con"b":*Con"S":+Con"a":*Con"B":*Con"B"
reg 5 = Con"a":*Con"T":*Con"b":+Con"eps"
reg 6 = Con"a":*Con"I":*Con"Int":*Con" ":+Con"eps"

cfg1 :: CFG
cfg1 = DMS.fromList $ zip (words "S A B T I") $ map reg [2..6] 	
              
test1 = unfoldBeh (accT cfg1) (Con"S") . words . exa 
              		          
test2 n = reg2alg n "sab" "S"        -- accepts exa 0,exa 1,exa 2; rejects exa 3
test3 n = reg2alg n "sab" "a.S.d"    -- accepts exa 4
test4 n = reg2alg n "sab" "T" 	     -- accepts exa 5,exa 6; rejects exa 7
		   
pa :: Int -> [((),String)]
pa 0 = runST (regP DMS.empty $ Con"ab":*Con"mt") "ab"                -- no parse
pa 1 = runST (regP DMS.empty $ Iter $ Con"c":+Con"ab") "cabacc"      -- no parse
pa 2 = runST (regP DMS.empty $ reg 1) "cab-4abTruec"           		 
pa 3 = runST (regP DMS.empty $ reg 1) "cab55abcc"              		
pa 4 = runST (regP cfg1 $ Con"S") "ababbabaab"            		
pa 5 = runST (regP cfg1 $ Con"S") "ababbabbab"                       -- no parse
pa 6 = runST (regP cfg1 $ Con"S") "abaaababbbba"          	      
pa 7 = runST (regP cfg1 $ Con"S") "ababbaaababbababbaabbabaabba"       
pa 8 = runST (regP cfg1 $ Con"T") $ replicate 55'a'++replicate 55'b'
pa 9 = runST (regP cfg1 $ Con"T") $ replicate 55'a'++replicate 56'b' -- no parse
pa _ = runST (regP cfg1 $ Con"I") $ replicate 55'a'++
				    concat (replicate 54 "77 ")++"8 " 

-- BINARY NUMBERS

data Bin nat rat = Bin {o,i :: nat, appN0 :: nat -> nat, appN1 :: nat -> nat,
		        nat_ :: nat -> rat, appR0 :: rat -> rat, 
		        appR1 :: rat -> rat}			-- signature

floatAlg :: Bin Float (Float,Float)
floatAlg = Bin {o = 0, i = 1, appN0 = \n -> 2*n, appN1 = \n -> 2*n+1,
	        nat_ = \n -> (n,1), 
	        appR0 = \(r,inc) -> (r,inc/2),
	        appR1 = \(r,inc) -> (r+inc/2,inc/2)}

binNat :: Compiler m => Bin nat rat -> Trans m nat
binNat alg = csum [do tchar '0'; loop $ o alg,
  	           do tchar '1'; loop $ i alg]
             where loop bin = csum [do tchar '0'; loop $ appN0 alg bin,
		   	            do tchar '1'; loop $ appN1 alg bin,
		   	            return bin]
				 
binRat :: Compiler m => Bin nat rat -> Trans m rat
binRat alg = csum [do bin <- binNat alg
                      csum [do tchar '.'; loop $ nat_ alg bin,
			    return $ nat_ alg bin]]
	     where loop bin = csum [do tchar '0'; loop $ appR0 alg bin,
		   	            do tchar '1'; loop $ appR1 alg bin,
		   	            return bin]

bin1 = runAndApp (binRat floatAlg) id show "101.011"
						    -- > (5.375,0.125)
bin2 = runAndApp (binRat floatAlg) id show "101.021"
						    -- > error at position (1,6)

data NatT = O | I | AppN0 NatT | AppN1 NatT 
data RatT = N NatT | AppR0 RatT | AppR1 RatT 

compNat :: NatT -> Float
compNat O 	  = 0
compNat I 	  = 1
compNat (AppN0 n) = 2*compNat n
compNat (AppN1 n) = 2*compNat n+1

compRat :: RatT -> (Float,Float)
compRat (N n)     = (compNat n,1)
compRat (AppR0 r) = (val,inc/2)       where (val,inc) = compRat r
compRat (AppR1 r) = (val+inc/2,inc/2) where (val,inc) = compRat r
		        
foldBinN :: Bin nat rat -> NatT -> nat
foldBinN alg O = o alg
foldBinN alg I = i alg
foldBinN alg (AppN0 n) = appN0 alg $ foldBinN alg n
foldBinN alg (AppN1 n) = appN1 alg $ foldBinN alg n
		        
foldBinR :: Bin nat rat -> RatT -> rat
foldBinR alg (N n)     = nat_ alg $ foldBinN alg n
foldBinR alg (AppR0 r) = appR0 alg $ foldBinR alg r
foldBinR alg (AppR1 r) = appR1 alg $ foldBinR alg r

-- LL-COMPILER FOR SAB

-- r1 = S -> aB 	 r2 = S -> bA		r3 = S -> eps	
-- r4 = A -> aS		 r5 = A -> bAA          
-- r6 = B -> bS		 r7 = B -> aBB	 

-- S generates the language of words with the same number of a's and b's

data SAB s a b = SAB {f_1 :: b -> s, f_2 :: a -> s, f_3 :: s,
		      f_4 :: s -> a, f_5 :: a -> a -> a,
		      f_6 :: s -> b, f_7 :: b -> b -> b}	-- signature

transS :: Compiler m => SAB s a b -> Trans m s
transS alg = csum [do char 'a'; c <- transB alg; return $ f_1 alg c,
                   do char 'b'; c <- transA alg; return $ f_2 alg c,
		   return $ f_3 alg]
		  
transA :: Compiler m => SAB s a b -> Trans m a
transA alg = csum [do char 'a'; c <- transS alg; return $ f_4 alg c,
 		   do char 'b'; c <- transA alg; d <- transA alg
		      return $ f_5 alg c d]
		  
transB :: Compiler m => SAB s a b -> Trans m b
transB alg = csum [do char 'b'; c <- transS alg; return $ f_6 alg c,
		   do char 'a'; c <- transB alg; d <- transB alg
		      return $ f_7 alg c d]

type Pos = (Int,Int)
			    
sabCount :: SAB Pos Pos Pos
sabCount = SAB {f_1 = suc1, f_2 = suc2, f_3 = (0,0), 
		f_4 = suc1, f_5 = \(i,j) (k,l) -> (i+k,j+l+1),
		f_6 = suc2, f_7 = \(i,j) (k,l) -> (i+k+1,j+l)}
	   where suc1 (i,j) = (i+1,j); suc2 (i,j) = (i,j+1)

sab1 = runAndApp (transS sabCount) id show "aabaabbabb" 	
						    -- > (5,5)
sab2 = runAndApp (transS sabCount) id show "aababbabb" 	
						    -- > error at position (1,9)
sab3 = runAndApp (transB sabCount) id show "aababbabb" 	
						    -- > (4,5)
				   
data S = F1 B | F2 A | F3  deriving Show
data A = F4 S | F5 A A     deriving Show
data B = F6 S | F7 B B     deriving Show
				   
sabTerm :: SAB S A B
sabTerm = SAB F1 F2 F3 F4 F5 F6 F7

-- LL-COMPILER FOR AN XML SPECIFICATION

data XMLstore store orders person emails email items stock suppliers id =
     XMLstore {store     :: stock -> store, 
               storeO    :: orders -> stock -> store, 
               orders    :: person -> items -> orders -> orders,
               embedO    :: person -> items -> orders,
               person    :: String -> person, 
               personE   :: String -> emails -> person, 
               emails    :: email -> emails -> emails,
               none      :: emails,
               email     :: String -> email,
               items     :: id -> String -> items -> items,
               embedI    :: id -> String -> items,
               stock     :: id -> Int -> suppliers -> stock -> stock,
               embedS    :: id -> Int -> suppliers -> stock,
               supplier  :: person -> suppliers,
               parts     :: stock -> suppliers,
               id_       :: String -> id}			-- signature

data Store     = Store Stock | StoreO (Orders,Stock) deriving Show
data Orders    = Orders (Person,Items,Orders) | EmbedP (Person,Items)
		 deriving Show
data Person    = Person String | PersonE (String,Emails) deriving Show
data Emails    = Emails (Email,Emails) | None deriving Show
data Email     = Email String deriving Show 
data Items     = Items (Id,String,Items) | EmbedI (Id,String) deriving Show
data Stock     = Stock (Id,Int,Suppliers,Stock) | EmbedS (Id,Int,Suppliers) 
		 deriving Show
data Suppliers = Supplier Person | Parts Stock deriving Show
data Id        = Id String deriving Show

xmlTerm :: XMLstore Store Orders Person Emails Email Items Stock Suppliers Id 
xmlTerm = XMLstore Store (curry StoreO) (curry3 Orders) (curry EmbedP) Person 
                   (curry PersonE) (curry Emails) None Email (curry3 Items)
                   (curry EmbedI) (curry4 Stock) (curry3 EmbedS) Supplier Parts 
                   Id
		 
curry3 f a b c   = f (a,b,c) 
curry4 f a b c d = f (a,b,c,d) 

type Store'     = (Orders',Stock')
type Orders'    = [(Person',Items')]
type Person'    = (String,Emails') 
type Emails'    = [Email']
type Email'     = String
type Items'     = [(Id',String)]
type Stock'     = [(Id',Int,Suppliers')]
data Suppliers' = Pers Person' | Stoc Stock' deriving Show
type Id'        = String

xmlList :: XMLstore Store' Orders' Person' Emails' Email' Items' Stock' 
                    Suppliers' Id'
xmlList  = XMLstore {store = \st -> ([],st),
                     storeO = \ords st -> (ords,st),
		     orders = \p i os -> (p,i):os,
		     embedO = \p i -> [(p,i)],
		     person = \str -> (str,[]),
		     personE = \str ems -> (str,ems),
		     emails = \em ems -> em:ems,
		     none = [],
		     email = id,
		     items = \id str is -> (id,str):is,
		     embedI = \id str -> [(id,str)],
		     stock = \id qty supps st -> (id,qty,supps):st,
		     embedS = \id qty supps -> [(id,qty,supps)],
		     supplier = Pers,
		     parts = Stoc,
		     id_ = id}

compStore :: Compiler m => XMLstore s1 s2 s3 s4 s5 s6 s7 s8 s9 -> Trans m s1
compStore alg = do tstring "<store>"
	           csum [do stck <- stock'; return $ store alg stck,
		         do ords <- ordersC; stck <- stock'
			    return $ storeO alg ords stck] where
	           stock'    = do tstring "<stock>"; stck <- stockC
	      		          tstring "</stock>"; tstring "</store>"
	      		          return stck
                   ordersC   = do (p,is) <- order
                                  csum [do os <- ordersC
                                           return $ orders alg p is os,
                                        return $ embedO alg p is]
                   order     = do tstring "<order>"; tstring "<customer>"
		                  p <- personC; tstring "</customer>"
			          is <- itemsC; tstring "</order>"
			          return (p,is)
	           personC   = do tstring "<name>"; name <- text
	                          tstring "</name>"
         	                  csum [do ems <- emailsC
         	            	           return $ personE alg name ems,
				        return $ person alg name]
	           emailsC   = csum [do em <- emailC; ems <- emailsC
	                                return $ emails alg em ems,
			             return $ none alg]
	           emailC    = do tstring "<email>"; em <- text
	                          tstring "</email>"; return $ email alg em
	           itemsC    = do (id,price) <- item
	      		          csum [do is <- itemsC
	      		    	           return $ items alg id price is,
	      		      	        return $ embedI alg id price]
	           item      = do tstring "<item>"; id <- idC; tstring "<price>"
		                  price <- text; tstring "</price>"
			          tstring "</item>"; return (id,price)
	           stockC    = do (id,qty,supps) <- iqs
	      		          csum [do is <- stockC
	      		      	           return $ stock alg id qty supps is,
	      		      	        return $ embedS alg id qty supps]
	           iqs       = do tstring "<item>"; id <- idC
	                          tstring "<quantity>"; qty <- tint
	                          tstring "</quantity>"; supps <- suppliers
	                          tstring "</item>"; return (id,qty,supps)
	           suppliers = csum [do tstring "<supplier>"; p <- personC
		                        tstring "</supplier>"
		                        return $ supplier alg p,
			             do stck <- stockC; return $ parts alg stck]
	           idC       = do tstring "<id>"; t <- text; tstring "</id>"
		                  return $ id_ alg t
	       
text :: Compiler m => Trans m String
text = do strs <- some $ token $ some $ nchar "< \n\t"
          return $ unwords strs
			      
-- xml2alg file compiles the XML text stored in file to an element of xmlTerm
-- or xmlList and draws the result in Pix/xmllist.svg.
			    
xml2alg :: String -> Int -> IO ()
xml2alg file = readFileContinue () file .
		               \case 1 -> runAndApp (compStore xmlTerm) putStrLn
		 			            $ mkTreeC "xmlterm" . show
		 	             _ -> runAndApp (compStore xmlList) putStrLn
		 			            $ mkTreeC "xmllist" . show