Skip to content

Type signatures for nested parameterized rules #52

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Type signatures for nested parameterized rules #52

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
a17f49f
Type signatures for nested parameterized rules
PhilThomas Aug 2, 2015
b084ff1
No longer ties a knot.
PhilThomas Sep 4, 2016
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
53 changes: 27 additions & 26 deletions src/Grammar.lhs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -298,36 +299,36 @@ 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')
> -- 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 [] 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 $ s . str cs -- do not expand
> Just a -> do -- found actual
> nm <- mapToName a
> 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 $ s . str cs -- do not expand
> | otherwise = -- not an identifier
> let (cs,r1) = break isIdent r
> in go r1 $ s . str cs -- do not expand
> -- in
> tys <- mapM convType [ (nm, t) | (nm, _, Just t) <- 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 <- traverse ((fmap . fmap) ($ "")) tys

> let
> env_array :: Array Int String
> env_array = array (errorTok, last_t) name_env
> -- in
Expand Down