> module Grammar (
> Name, isEmpty,
>
> Production, Grammar(..), mangler,
>
> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..),
> Assoc(..),
>
> errorName, errorTok, startName, firstStartTok, dummyTok,
> eofName, epsilonTok
> ) where
> import GenUtils
> import AbsSyn
> import ParseMonad
> import AttrGrammar
> import AttrGrammarParser
> import ParamRules
> import Data.Array
> import Data.Char
> import Data.List
> import Data.Maybe (fromMaybe)
> import Control.Monad.Writer
#ifdef DEBUG
> import System.IOExts
#endif
> type Name = Int
> type Production = (Name,[Name],(String,[Int]),Priority)
> data Grammar
> = Grammar {
> productions :: [Production],
> lookupProdNo :: Int -> Production,
> lookupProdsOfName :: Name -> [Int],
> token_specs :: [(Name,String)],
> terminals :: [Name],
> non_terminals :: [Name],
> starts :: [(String,Name,Name,Bool)],
> types :: Array Int (Maybe String),
> token_names :: Array Int String,
> first_nonterm :: Name,
> first_term :: Name,
> eof_term :: Name,
> priorities :: [(Name,Priority)],
> token_type :: String,
> imported_identity :: Bool,
> monad :: (Bool,String,String,String,String),
> expect :: Maybe Int,
> attributes :: [(String,String)],
> attributetype :: String,
> lexer :: Maybe (String,String),
> error_handler :: Maybe String
> }
#ifdef DEBUG
> instance Show Grammar where
> showsPrec _ (Grammar
> { productions = p
> , token_specs = t
> , terminals = ts
> , non_terminals = nts
> , starts = starts
> , types = tys
> , token_names = e
> , first_nonterm = fnt
> , first_term = ft
> , eof_term = eof
> })
> = showString "productions = " . shows p
> . showString "\ntoken_specs = " . shows t
> . showString "\nterminals = " . shows ts
> . showString "\nnonterminals = " . shows nts
> . showString "\nstarts = " . shows starts
> . showString "\ntypes = " . shows tys
> . showString "\ntoken_names = " . shows e
> . showString "\nfirst_nonterm = " . shows fnt
> . showString "\nfirst_term = " . shows ft
> . showString "\neof = " . shows eof
> . showString "\n"
#endif
> data Assoc = LeftAssoc | RightAssoc | None
#ifdef DEBUG
> deriving Show
#endif
> data Priority = No | Prio Assoc Int
#ifdef DEBUG
> deriving Show
#endif
> instance Eq Priority where
> No == No = True
> Prio _ i == Prio _ j = i == j
> _ == _ = False
> mkPrio :: Int -> Directive a -> Priority
> mkPrio i (TokenNonassoc _) = Prio None i
> mkPrio i (TokenRight _) = Prio RightAssoc i
> mkPrio i (TokenLeft _) = Prio LeftAssoc i
> mkPrio _ _ = error "Panic: impossible case in mkPrio"
> startName, eofName, errorName, dummyName :: String
> startName = "%start"
> eofName = "%eof"
> errorName = "error"
> dummyName = "%dummy"
> firstStartTok, dummyTok, errorTok, epsilonTok :: Name
> firstStartTok = 3
> dummyTok = 2
> errorTok = 1
> epsilonTok = 0
> isEmpty :: Name -> Bool
> isEmpty n | n == epsilonTok = True
> | otherwise = False
> type ErrMsg = String
> type M a = Writer [ErrMsg] a
> addErr :: ErrMsg -> M ()
> addErr e = tell [e]
> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]
> mangler file abssyn
> | null errs = Succeeded g
> | otherwise = Failed errs
> where (g, errs) = runWriter (manglerM file abssyn)
> manglerM :: FilePath -> AbsSyn -> M Grammar
> manglerM file (AbsSyn _hd dirs rules' _tl) =
>
> mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do
> rules <- case expand_rules rules' of
> Left err -> addErr err >> return []
> Right as -> return as
> nonterm_strs <- checkRules ([n | (n,_,_) <- rules]) "" []
> let
> terminal_strs = concat (map getTerm dirs) ++ [eofName]
> n_starts = length starts'
> n_nts = length nonterm_strs
> n_ts = length terminal_strs
> first_nt = firstStartTok + n_starts
> first_t = first_nt + n_nts
> last_start = first_nt - 1
> last_nt = first_t - 1
> last_t = first_t + n_ts - 1
> start_names = [ firstStartTok .. last_start ]
> nonterm_names = [ first_nt .. last_nt ]
> terminal_names = [ first_t .. last_t ]
> starts' = case getParserNames dirs of
> [] -> [TokenName "happyParse" Nothing False]
> ns -> ns
>
> start_strs = [ startName++'_':p | (TokenName p _ _) <- starts' ]
> name_env = (errorTok, errorName) :
> (dummyTok, dummyName) :
> zip start_names start_strs ++
> zip nonterm_names nonterm_strs ++
> zip terminal_names terminal_strs
> lookupName :: String -> [Name]
> lookupName n = [ t | (t,r) <- name_env, r == n ]
> mapToName str' =
> case lookupName str' of
> [a] -> return a
> [] -> do addErr ("unknown identifier '" ++ str' ++ "'")
> return errorTok
> (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'")
> return a
>
> lookupStart (TokenName _ Nothing _) = return first_nt
> lookupStart (TokenName _ (Just n) _) = mapToName n
> lookupStart _ = error "lookupStart: Not a TokenName"
>
> start_toks <- mapM lookupStart starts'
> let
> parser_names = [ s | TokenName s _ _ <- starts' ]
> start_partials = [ b | TokenName _ _ b <- starts' ]
> start_prods = zipWith (\nm tok -> (nm, [tok], ("no code",[]), No))
> start_names start_toks
> priodir = zip [1..] (getPrios dirs)
>
> prios = [ (name,mkPrio i dir)
> | (i,dir) <- priodir
> , nm <- AbsSyn.getPrioNames dir
> , name <- lookupName nm
> ]
> prioByString = [ (name, mkPrio i dir)
> | (i,dir) <- priodir
> , name <- AbsSyn.getPrioNames dir
> ]
> convNT (nt, prods, ty)
> = do nt' <- mapToName nt
> return (nt', prods, ty)
>
> attrs = getAttributes dirs
> attrType = fromMaybe "HappyAttrs" (getAttributetype dirs)
>
> transRule (nt, prods, _ty)
> = mapM (finishRule nt) prods
>
> finishRule nt (lhs,code,line,prec)
> = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do
> lhs' <- mapM mapToName lhs
> code' <- checkCode (length lhs) lhs' nonterm_names code attrs
> case mkPrec lhs' prec of
> Left s -> do addErr ("Undeclared precedence token: " ++ s)
> return (nt, lhs', code', No)
> Right p -> return (nt, lhs', code', p)
>
> mkPrec :: [Name] -> Maybe String -> Either String Priority
> mkPrec lhs prio =
> case prio of
> Nothing -> case filter (flip elem terminal_names) lhs of
> [] -> Right No
> xs -> case lookup (last xs) prios of
> Nothing -> Right No
> Just p -> Right p
> Just s -> case lookup s prioByString of
> Nothing -> Left s
> Just p -> Right p
>
> rules1 <- mapM convNT rules
> rules2 <- mapM transRule rules1
> let
> tys = accumArray (\_ x -> x) Nothing (first_nt, last_nt)
> [ (nm, Just ty) | (nm, _, Just ty) <- rules1 ]
> env_array :: Array Int String
> env_array = array (errorTok, last_t) name_env
>
> let
> fixTokenSpec (a,b) = do n <- mapToName a; return (n,b)
>
> tokspec <- mapM fixTokenSpec (getTokenSpec dirs)
> let
> ass = combinePairs [ (a,no)
> | ((a,_,_,_),no) <- zip productions' [0..] ]
> arr = array (firstStartTok, length ass - 1 + firstStartTok) ass
> lookup_prods :: Name -> [Int]
> lookup_prods x | x >= firstStartTok && x < first_t = arr ! x
> lookup_prods _ = error "lookup_prods"
>
> productions' = start_prods ++ concat rules2
> prod_array = listArray' (0,length productions' - 1) productions'
>
> return (Grammar {
> productions = productions',
> lookupProdNo = (prod_array !),
> lookupProdsOfName = lookup_prods,
> token_specs = tokspec,
> terminals = errorTok : terminal_names,
> non_terminals = start_names ++ nonterm_names,
>
> starts = zip4 parser_names start_names start_toks
> start_partials,
> types = tys,
> token_names = env_array,
> first_nonterm = first_nt,
> first_term = first_t,
> eof_term = last terminal_names,
> priorities = prios,
> imported_identity = getImportedIdentity dirs,
> monad = getMonad dirs,
> lexer = getLexer dirs,
> error_handler = getError dirs,
> token_type = getTokenType dirs,
> expect = getExpect dirs,
> attributes = attrs,
> attributetype = attrType
> })
> addLine :: Int -> String -> String
> addLine l s = show l ++ ": " ++ s
> getTerm :: Directive a -> [a]
> getTerm (TokenSpec stuff) = map fst stuff
> getTerm _ = []
> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
> checkRules (name:rest) above nonterms
> | name == above = checkRules rest name nonterms
> | name `elem` nonterms
> = do addErr ("Multiple rules for '" ++ name ++ "'")
> checkRules rest name nonterms
> | otherwise = checkRules rest name (name : nonterms)
> checkRules [] _ nonterms = return (reverse nonterms)
> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> checkCode arity _ _ code [] = doCheckCode arity code
> checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs
> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
> rewriteAttributeGrammar arity lhs nonterm_names code attrs =
> case runP agParser code 0 of
> FailP msg -> do addErr ("error in attribute grammar rules: "++msg)
> return ("",[])
> OkP rules ->
> let (selfRules,subRules,conditions) = partitionRules [] [] [] rules
> attrNames = map fst attrs
> defaultAttr = head attrNames
> in do let prods = mentionedProductions rules
> mapM checkArity prods
> rulesStr <- formatRules arity attrNames defaultAttr
> allSubProductions selfRules
> subRules conditions
> return (rulesStr,nub (allSubProductions++prods))
> where partitionRules a b c [] = (a,b,c)
> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs
> partitionRules a b c (x@(SelfAssign _ _ ) : xs) = partitionRules (x:a) b c xs
> partitionRules a b c (x@(SubAssign _ _) : xs) = partitionRules a (x:b) c xs
> partitionRules a b c (x@(Conditional _) : xs) = partitionRules a b (x:c) xs
> allSubProductions = map (+1) (findIndices (`elem` nonterm_names) lhs)
> mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ]
> getTokens (SelfAssign _ toks) = toks
> getTokens (SubAssign _ toks) = toks
> getTokens (Conditional toks) = toks
> getTokens (RightmostAssign _ toks) = toks
>
> checkArity x = when (x > arity) $ addErr (show x++" out of range")
> formatRules :: Int -> [String] -> String -> [Name]
> -> [AgRule] -> [AgRule] -> [AgRule]
> -> M String
> formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $
> concat [ "\\happyInhAttrs -> let { "
> , "happySelfAttrs = happyInhAttrs",formattedSelfRules
> , subProductionRules
> , "; happyConditions = ", formattedConditions
> , " } in (happyConditions,happySelfAttrs)"
> ]
>
> where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }"
> formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules
> formatSelfRule (SelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks)
> formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks)
> formatSelfRule _ = error "formatSelfRule: Not a self rule"
> subRulesMap :: [(Int,[(String,[AgToken])])]
> subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs))
> (fst $ head l,[snd $ head l])
> (tail l) ) .
> groupBy (\x y -> (fst x) == (fst y)) .
> sortBy (\x y -> compare (fst x) (fst y)) .
> map (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules
> subProductionRules = concat $ map formatSubRules prods
> formatSubRules i =
> let attrs = fromMaybe [] . lookup i $ subRulesMap
> attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs
> attrUpdates = case attrUpdates' of [] -> []; x -> "{ "++x++" }"
> in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i
> ," happyEmptyAttrs"
> , attrUpdates
> ]
>
> formattedConditions = concat $ intersperse "++" $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods)
> localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]"
> formatCondition (Conditional toks) = formatTokens toks
> formatCondition _ = error "formatCondition: Not a condition"
> formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks)
> formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks)
> formatTokens tokens = concat (map formatToken tokens)
> formatToken AgTok_LBrace = "{ "
> formatToken AgTok_RBrace = "} "
> formatToken AgTok_Where = "where "
> formatToken AgTok_Semicolon = "; "
> formatToken AgTok_Eq = "="
> formatToken (AgTok_SelfRef []) = "("++defaultAttr++" happySelfAttrs) "
> formatToken (AgTok_SelfRef x) = "("++x++" happySelfAttrs) "
> formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x))
> formatToken (AgTok_SubRef (i,[]))
> | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") "
> | otherwise = mkHappyVar i ++ " "
> formatToken (AgTok_SubRef (i,x))
> | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") "
> | otherwise = error ("lhs "++(show i)++" is not a non-terminal")
> formatToken (AgTok_Unknown x) = x++" "
> formatToken AgTok_EOF = error "formatToken AgTok_EOF"
> doCheckCode :: Int -> String -> M (String, [Int])
> doCheckCode arity code0 = go code0 "" []
> where go code acc used =
> case code of
> [] -> return (reverse acc, used)
>
> '"' :r -> case reads code :: [(String,String)] of
> [] -> go r ('"':acc) used
> (s,r'):_ -> go r' (reverse (show s) ++ acc) used
> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) used
> '\'' :r -> case reads code :: [(Char,String)] of
> [] -> go r ('\'':acc) used
> (c,r'):_ -> go r' (reverse (show c) ++ acc) used
> '\\':'$':r -> go r ('$':acc) used
>
> '$':'>':r
> | arity == 0 -> do addErr "$> in empty rule"
> go r acc used
> | otherwise -> go r (reverse (mkHappyVar arity) ++ acc)
> (arity : used)
>
> '$':r@(i:_) | isDigit i ->
> case reads r :: [(Int,String)] of
> (j,r'):_ ->
> if j > arity
> then do addErr ('$': show j ++ " out of range")
> go r' acc used
> else go r' (reverse (mkHappyVar j) ++ acc)
> (j : used)
> [] -> error "doCheckCode []"
> c:r -> go r (c:acc) used
> mkHappyVar :: Int -> String
> mkHappyVar n = "happy_var_" ++ show n
> data LRAction = LR'Shift Int Priority
> | LR'Reduce Int Priority
> | LR'Accept
> | LR'Fail
> | LR'MustFail
> | LR'Multiple [LRAction] LRAction
> deriving(Eq
#ifdef DEBUG
> ,Show
#endif
> )
> type ActionTable = Array Int (Array Int LRAction)
> data Goto = Goto Int | NoGoto
> deriving(Eq
#ifdef DEBUG
> ,Show
#endif
> )
> type GotoTable = Array Int (Array Int Goto)