1 module Gram2FA
    2 
    3 ( gram
    4 
    5 )
    6 
    7 where
    8 
    9 
   10 import Maybes
   11 
   12 import Set           -- syslib ghc
   13 import FiniteMap        -- syslib ghc
   14 
   15 import State
   16 
   17 import Options
   18 
   19 import Grammar
   20 
   21 import Ids
   22 import Syntax
   23 
   24 import Semantik
   25 
   26 import TA
   27 import FAtypes
   28 import FA
   29 
   30 import FAmap
   31 import FAcmpct
   32 import FAconv
   33 
   34 import Exp2FA
   35 
   36 
   37 mapL             :: Monad m => (a -> m b) -> ([a] -> m [b])
   38 mapL f []         = return []
   39 mapL f (x:xs)     = do y<-f x; ys<-mapL f xs; return (y:ys)
   40 
   41 
   42 -- converts an Exp describing a grammar into an ETNFA
   43 
   44 
   45 gram :: Opts -> Env (Auto) (Auto) -> [Exp] -> FIO (Auto, Env (Auto) (Auto))
   46 gram opts env xs =
   47     do  { moops (length xs /= 2)
   48                 ( "grammar needs exactly two arguments "
   49                   ++ "(start expression and rule set): " ++ show xs )
   50         ; let [ s, r ] = xs
   51 
   52         ; moops (not (isColl r) || cType r /= CSet) 
   53                 ( "grammar rules must be given as set: " ++ show r)
   54         ; let rs = cArgs r
   55 
   56         ; rss <- mapL convertrule rs
   57         ; let b = mkgram opts env s rss
   58 
   59         ; 
   60 --        trace ("\ngram.xs = " ++ show xs) $
   61 --        trace ("\ngram.rss = " ++ show rss) $
   62 --        trace ("\ngram.b = " ++ show b) $
   63           return (b, env)
   64         }
   65 
   66 
   67 
   68 convertrule r =
   69     do  { moops (not (isApp r)) 
   70                 ("rule in grammar must use (->): " ++ show r)
   71         ; let App id xs = r
   72         ; moops (idname id /= "->")
   73                 ("rule in grammar must use (->): " ++ show r)
   74         ; moops (length xs /= 2)
   75                 ("(->) needs exactly two arguments: " ++ show r)
   76         ; let [lhs, rhs] = xs
   77         ; moops (not (isAppId lhs))
   78                 ("left hand arg of (->) must be identifier: " ++ show r)
   79         ; let lhsname = idname (unAppId lhs)
   80         ; return (lhsname, rhs)
   81         }
   82 
   83 -------------------------------------------------------------------------
   84 
   85 mkgram :: Opts -> Env (Auto) (Auto) -> Exp -> [(String, Exp)] -> Auto
   86 mkgram opts e x rs = 
   87     let vs = [ i | (i, _) <- rs ]       -- local variables
   88         e' = delListFromFM e vs               -- they shadow global ones
   89         (start, rules) = dosym (mkgs opts e' (mkSet vs) x rs)
   90         d = g2t opts (start, rules)
   91     in  
   92 
   93 --      trace ("\nmkgram.vs = " ++ show vs) $
   94 --      trace ("\nmkgram.start = " ++ show start) $
   95 --      trace ("\nmkgram.rules = " ++ show rules) $
   96 --      trace ("\nmkgram.d = " ++ show d) $
   97 
   98         d
   99         
  100 ------------------------------------------------------------------------
  101 
  102 
  103 type MK a = Sym (Int, [(String, Either String (STerm String))]) a
  104 
  105 
  106 
  107 --tnfa2grammar :: Ord a => Opts -> String -> TNFA a -> MK ()
  108 tnfa2grammar opts name b @ (TNFA consb allb startsb movesb) =
  109 
  110 --  trace ("\ntnfa2grammar.b : " ++ show b) $
  111 
  112     do  { n <- mapL (\ a -> gensym >>= \ k -> return (a, k)) (setToList allb)
  113         ; let h = listToFM n   
  114         ; let c @ (TNFA consc allc startsc movesc) = 
  115                 mapTNFA opts (lookupWithDefaultFM h (error "tnfa2grammar.c")) b
  116         ; sequence_ [ push (v, Right t)   
  117                 | (v, ts) <- fmToList movesc, t <- setToList ts ]
  118         ; sequence_[ push (name, Left s) | s <- setToList startsc ]
  119         }
  120 
  121 --------------------------------------------------------------------------
  122  
  123 mkgs :: Opts -> Env (Auto) (Auto) -> Set String -> Exp -> [(String, Exp)]
  124         -> MK String
  125 mkgs opts env vars x rs =
  126     do  { sequence_ (map (mkg opts env vars) rs)
  127         ; start <- gensym
  128         ; mkg opts env vars (start, x)
  129         ; return start
  130         }
  131 
  132 mkg :: Opts -> Env (Auto) (Auto) -> Set String -> (String, Exp) -> MK ()
  133 
  134 mkg opts env vars (name, exp) 
  135   | isEmptySet (mkSet (map idname (appids exp)) `intersectSet` vars) =
  136     do  { let (val, _) = forceFIO (comp opts env exp)
  137         ; tnfa2grammar opts name val
  138         }
  139 
  140 mkg opts env vars (name, App id []) = 
  141         -- must be a variable of the grammar
  142     push (name, Left (idname id))
  143 
  144 mkg opts env vars (name, App id xs) | idname id == "++" =
  145     sequence_   [ do     { nx <- gensym
  146                         ; push (name, Left nx) 
  147                         ; mkg opts env vars (nx, x)
  148                         }
  149                 | x <- xs ]
  150 
  151 mkg opts env vars (name, x @ (App id xs)) = 
  152         -- a constructor (good)
  153         -- or a function call (bad)
  154     mkgname opts env vars name x id xs
  155 
  156 
  157 mkg opts env vars (name, x) = 
  158     error ("cannot handle rule: " ++ show x)
  159 
  160 
  161 mkgname opts env vars name x id xs =
  162     if exists (lookupFM env (idname id))
  163     then error ("function calls cannot have grammar vars as args: " ++ show x)
  164     else -- it's a constructor
  165      do { args <- mapL ( \ x -> do 
  166                 { k <- gensym; mkg opts env vars (k, x); return k } ) xs
  167         ; push (name, Right (mksterm id args))
  168         }
  169 
  170 --------------------------------------------------------------------
  171 
  172 
  173 g2t :: (Show a, Ord a) => Opts -> Grammar a -> TNFA Int
  174 g2t opts = cmpctTNFA opts . etnfa2tnfa opts . grammar2etnfa opts
  175