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