From a17f49f17a875175a1c85922cae368f362919850 Mon Sep 17 00:00:00 2001 From: Phil Thomas Date: Sat, 1 Aug 2015 21:55:06 -0700 Subject: [PATCH 1/2] Type signatures for nested parameterized rules --- src/Grammar.lhs | 55 ++++++++++++++++++++++++++----------------------- 1 file changed, 29 insertions(+), 26 deletions(-) diff --git a/src/Grammar.lhs b/src/Grammar.lhs index f2658fa3..78067321 100644 --- a/src/Grammar.lhs +++ b/src/Grammar.lhs @@ -298,36 +298,39 @@ Translate the rules from string to name-based. > rules2 <- mapM transRule rules1 > let -> type_env = [(nt, t) | (nt, _, Just (t,[])) <- rules] ++ -> [(nt, getTokenType dirs) | nt <- terminal_strs] -- XXX: Doesn't handle $$ type! -> -> fixType (ty,s) = go "" ty -> where go acc [] = return (reverse acc) -> go acc (c:r) | isLower c = -- look for a run of alphanumerics starting with a lower case letter -> let (cs,r1) = span isAlphaNum r -> go1 x = go (reverse x ++ acc) r1 -> in case lookup (c:cs) s of -> Nothing -> go1 (c:cs) -- no binding found -> Just a -> case lookup a type_env of -> Nothing -> do -> addErr ("Parameterized rule argument '" ++ a ++ "' does not have type") -> go1 (c:cs) -> Just t -> go1 $ "(" ++ t ++ ")" -> | otherwise = go (c:acc) r -> -> convType (nm, t) -> = do t' <- fixType t -> return (nm, t') -> +> fixType :: (String, [(String,String)]) -> M (Array Int (Maybe String) -> String -> String) +> fixType (ty,env) = go ty $ const id +> where +> isIdent c = isAlphaNum c || c == '_' +> go [] f = return f +> go r@(c:_) f | isLower c = -- an identifier starting with a lower case letter +> let (cs,r1) = span isIdent r +> in case lookup cs env of -- try to map formal to actual +> Nothing -> -- no formal found +> go r1 $ \tys -> f tys . str cs -- do not expand +> Just a -> do -- found actual +> nm <- mapToName a +> go r1 $ \tys -> +> let t = fromMaybe cs (tys ! nm) +> in f tys . brack t +> | isIdent c = -- an identifier not starting with a lower case letter +> let (cs,r1) = span isIdent r +> in go r1 $ \tys -> f tys . str cs -- do not expand +> | otherwise = -- not an identifier +> let (cs,r1) = break isIdent r +> in go r1 $ \tys -> f tys . str cs -- do not expand +> mapSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b) +> mapSndM f (c, a) = f a >>= \b -> return (c, b) > -- in -> tys <- mapM convType [ (nm, t) | (nm, _, Just t) <- rules1 ] -> + +> tys <- (mapM . mapSndM) fixType [ (nm,ty) | (nm,_,Just ty) <- rules1 ] > let > type_array :: Array Int (Maybe String) -> type_array = accumArray (\_ x -> x) Nothing (first_nt, last_nt) -> [ (nm, Just t) | (nm, t) <- tys ] - +> type_array = accumArray (\_ x -> x) Nothing (0, last_t) $ +> [ (nm, Just (f type_array "")) | (nm, f) <- tys ] ++ -- tied a knot! +> [ (nm, Just (getTokenType dirs)) | nm <- terminal_names ] -- XXX: Doesn't handle $$ in token +> > env_array :: Array Int String > env_array = array (errorTok, last_t) name_env > -- in From b084ff1d919a72d247bf294342e773885462f774 Mon Sep 17 00:00:00 2001 From: Phil Thomas Date: Sat, 3 Sep 2016 23:43:45 -0700 Subject: [PATCH 2/2] No longer ties a knot. --- src/Grammar.lhs | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/src/Grammar.lhs b/src/Grammar.lhs index 78067321..f45943ea 100644 --- a/src/Grammar.lhs +++ b/src/Grammar.lhs @@ -29,6 +29,7 @@ Here is our mid-section datatype > import Data.Char > import Data.List > import Data.Maybe (fromMaybe) +> import Data.Traversable (traverse) > import Control.Monad.Writer @@ -298,39 +299,36 @@ Translate the rules from string to name-based. > rules2 <- mapM transRule rules1 > let -> fixType :: (String, [(String,String)]) -> M (Array Int (Maybe String) -> String -> String) -> fixType (ty,env) = go ty $ const id +> -- tys :: Array Int (M (Maybe (String -> String))) +> tys = accumArray (\_ x -> x) (return Nothing) (0, last_t) $ +> [ (nm, liftM Just $ fixType ty env) | (nm,_,Just (ty, env)) <- rules1 ] ++ +> [ (nm, return . Just . str . getTokenType $ dirs) | nm <- terminal_names ] -- XXX: Doesn't handle $$ in token +> +> -- fixType :: String -> Subst -> M (String -> String) +> fixType ty env = go ty id > where > isIdent c = isAlphaNum c || c == '_' -> go [] f = return f -> go r@(c:_) f | isLower c = -- an identifier starting with a lower case letter +> go [] s = return s +> go r@(c:_) s | isLower c = -- an identifier starting with a lower case letter > let (cs,r1) = span isIdent r > in case lookup cs env of -- try to map formal to actual > Nothing -> -- no formal found -> go r1 $ \tys -> f tys . str cs -- do not expand +> go r1 $ s . str cs -- do not expand > Just a -> do -- found actual > nm <- mapToName a -> go r1 $ \tys -> -> let t = fromMaybe cs (tys ! nm) -> in f tys . brack t +> t <- tys ! nm +> go r1 $ s . brack' (fromMaybe (str cs) t) > | isIdent c = -- an identifier not starting with a lower case letter > let (cs,r1) = span isIdent r -> in go r1 $ \tys -> f tys . str cs -- do not expand +> in go r1 $ s . str cs -- do not expand > | otherwise = -- not an identifier > let (cs,r1) = break isIdent r -> in go r1 $ \tys -> f tys . str cs -- do not expand -> mapSndM :: Monad m => (a -> m b) -> (c, a) -> m (c, b) -> mapSndM f (c, a) = f a >>= \b -> return (c, b) +> in go r1 $ s . str cs -- do not expand > -- in -> tys <- (mapM . mapSndM) fixType [ (nm,ty) | (nm,_,Just ty) <- rules1 ] +> type_array <- traverse ((fmap . fmap) ($ "")) tys > let -> type_array :: Array Int (Maybe String) -> type_array = accumArray (\_ x -> x) Nothing (0, last_t) $ -> [ (nm, Just (f type_array "")) | (nm, f) <- tys ] ++ -- tied a knot! -> [ (nm, Just (getTokenType dirs)) | nm <- terminal_names ] -- XXX: Doesn't handle $$ in token -> > env_array :: Array Int String > env_array = array (errorTok, last_t) name_env > -- in