Commit 2fa68df9 authored by partain's avatar partain
Browse files

[project @ 1996-04-21 13:39:09 by partain]

Add ParseUtils.lhs
parent 2f51f140
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ParseUtils]{Help the interface parser}
\begin{code}
#include "HsVersions.h"
module ParseUtils where
import Ubiq{-uitous-}
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas,
noInstancePragmas
)
import ErrUtils ( Error(..) )
import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
import Maybes ( maybeToBool, MaybeErr(..) )
import Name ( isLexConId, isLexVarId, isLexConSym,
mkTupNameStr,
RdrName(..){-instance Outputable:ToDo:rm-}
)
import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
import PrelMods ( fromPrelude )
import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( startsWith, isIn, panic, assertPanic )
\end{code}
\begin{code}
type LocalVersionsMap = FiniteMap FAST_STRING Version
type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
type PragmaStuff = String
data ParsedIface
= ParsedIface
Module -- Module name
Version -- Module version number
(Maybe Version) -- Source version number
LocalVersionsMap -- Local version numbers
ExportsMap -- Exported names
(Bag Module) -- Special instance modules
FixitiesMap -- fixities of local things
LocalTyDefsMap -- Local TyCon/Class names defined
LocalValDefsMap -- Local value names defined
(Bag RdrIfaceInst)-- Local instance declarations
LocalPragmasMap -- Pragmas for local names
-----------------------------------------------------------------
data RdrIfaceDecl
= TypeSig RdrName SrcLoc RdrNameTyDecl
| NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
| DataSig RdrName [RdrName] SrcLoc RdrNameTyDecl
| ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
| ValSig RdrName SrcLoc RdrNamePolyType
data RdrIfaceInst
= InstSig RdrName RdrName SrcLoc RdrNameInstDecl
\end{code}
\begin{code}
-----------------------------------------------------------------
data IfaceToken
= ITinterface -- keywords
| ITversions
| ITexports
| ITinstance_modules
| ITinstances
| ITfixities
| ITdeclarations
| ITpragmas
| ITdata
| ITtype
| ITnewtype
| ITclass
| ITwhere
| ITinstance
| ITinfixl
| ITinfixr
| ITinfix
| ITbang -- magic symbols
| ITvbar
| ITbquote
| ITdcolon
| ITcomma
| ITdarrow
| ITdotdot
| ITequal
| ITocurly
| ITobrack
| IToparen
| ITrarrow
| ITccurly
| ITcbrack
| ITcparen
| ITsemi
| ITinteger Integer -- numbers and names
| ITvarid FAST_STRING
| ITconid FAST_STRING
| ITvarsym FAST_STRING
| ITconsym FAST_STRING
| ITqvarid RdrName
| ITqconid RdrName
| ITqvarsym RdrName
| ITqconsym RdrName
deriving Text -- debugging
instance Text RdrName where -- debugging
showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
-----------------------------------------------------------------
de_qual (Unqual n) = n
de_qual (Qual _ n) = n
en_mono :: FAST_STRING -> RdrNameMonoType
en_mono tv = MonoTyVar (Unqual tv)
type2context (MonoTupleTy tys) = map type2class_assertion tys
type2context other_ty = [ type2class_assertion other_ty ]
type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
type2class_assertion _ = panic "type2class_assertion: bad format"
-----------------------------------------------------------------
mk_type :: (RdrName, [FAST_STRING])
-> RdrNameMonoType
-> LocalTyDefsMap
mk_type (qtycon, tyvars) ty
= let
tycon = de_qual qtycon
qtyvars = map Unqual tyvars
in
unitFM tycon (TypeSig qtycon mkIfaceSrcLoc (
TySynonym qtycon qtyvars ty mkIfaceSrcLoc))
mk_data :: RdrNameContext
-> (RdrName, [FAST_STRING])
-> [(RdrName, RdrNameConDecl)]
-> (LocalTyDefsMap, LocalValDefsMap)
mk_data ctxt (qtycon, tyvars) names_and_constrs
= let
(qconnames, constrs) = unzip names_and_constrs
tycon = de_qual qtycon
connames = map de_qual qconnames
qtyvars = map Unqual tyvars
decl = DataSig qtycon qconnames mkIfaceSrcLoc (
TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
in
(unitFM tycon decl, listToFM [(c,decl) | c <- connames])
mk_new :: RdrNameContext
-> (RdrName, [FAST_STRING])
-> (RdrName, RdrNameMonoType)
-> (LocalTyDefsMap, LocalValDefsMap)
mk_new ctxt (qtycon, tyvars) (qconname, ty)
= let
tycon = de_qual qtycon
conname = de_qual qconname
qtyvars = map Unqual tyvars
constr = NewConDecl qconname ty mkIfaceSrcLoc
decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
in
(unitFM tycon decl, unitFM conname decl)
mk_class :: RdrNameContext
-> (RdrName, RdrName)
-> [(FAST_STRING, RdrNameSig)]
-> (LocalTyDefsMap, LocalValDefsMap)
mk_class ctxt (qclas, tyvar) ops_and_sigs
= case (unzip ops_and_sigs) of { (opnames, sigs) ->
let
qopnames = map Unqual opnames
clas = de_qual qclas
op_sigs = map opify sigs
decl = ClassSig qclas qopnames mkIfaceSrcLoc (
ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
in
(unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
where
opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
mk_inst :: RdrNameContext
-> RdrName -- class
-> RdrNameMonoType -- fish the tycon out yourself...
-> RdrIfaceInst
mk_inst ctxt clas mono_ty
= InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
InstDecl clas (HsPreForAllTy ctxt mono_ty)
EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
noInstancePragmas mkIfaceSrcLoc)
where
tycon_name (MonoTyApp tc _) = tc
tycon_name (MonoListTy _) = Unqual SLIT("[]")
tycon_name (MonoFunTy _ _) = Unqual SLIT("->")
tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
-----------------------------------------------------------------
lexIface :: String -> [IfaceToken]
lexIface str
= case str of
[] -> []
-- whitespace and comments
' ' : cs -> lexIface cs
'\t' : cs -> lexIface cs
'\n' : cs -> lexIface cs
'-' : '-' : cs -> lex_comment cs
'{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
'(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
'(' : cs -> IToparen : lexIface cs
')' : cs -> ITcparen : lexIface cs
'[' : cs -> ITobrack : lexIface cs
']' : cs -> ITcbrack : lexIface cs
'{' : cs -> ITocurly : lexIface cs
'}' : cs -> ITccurly : lexIface cs
',' : cs -> ITcomma : lexIface cs
';' : cs -> ITsemi : lexIface cs
'`' : cs -> ITbquote : lexIface cs
'_' : cs -> lex_name Nothing is_var_sym str
c : cs | isUpper c -> lex_word str -- don't know if "Module." on front or not
| isDigit c -> lex_num str
| isAlpha c -> lex_name Nothing is_var_sym str
| is_sym_sym c -> lex_name Nothing is_sym_sym str
other -> error ("lexing:"++other)
where
lex_comment str
= case (span ((/=) '\n') str) of { (junk, rest) ->
lexIface rest }
------------------
lex_nested_comment lvl [] = error "EOF in nested comment in interface"
lex_nested_comment lvl str
= case str of
'{' : '-' : xs -> lex_nested_comment (lvl+1) xs
'-' : '}' : xs -> if lvl == 1
then lexIface xs
else lex_nested_comment (lvl-1) xs
_ : xs -> lex_nested_comment lvl xs
-----------
lex_num str
= case (span isDigit str) of { (num, rest) ->
ITinteger (read num) : lexIface rest }
-----------
is_var_sym '_' = True
is_var_sym c = isAlphanum c
is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
------------
lex_word str@(c:cs) -- we know we have a capital letter to start
= -- we first try for "<module>." on the front...
case (module_dot str) of
Nothing -> lex_name Nothing is_var_sym str
Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
where
in_the_club [] = panic "lex_word:in_the_club"
in_the_club (c:_) | isAlpha c = is_var_sym
| is_sym_sym c = is_sym_sym
| otherwise = panic ("lex_word:in_the_club="++[c])
module_dot (c:cs)
= if not (isUpper c) then
Nothing
else
case (span is_var_sym cs) of { (word, rest) ->
case rest of
[] -> Nothing
(r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
_ -> Nothing
}
lex_name module_dot in_the_club str
= case (span in_the_club str) of { (word, rest) ->
case (lookupFM keywordsFM word) of
Just xx -> ASSERT( not (maybeToBool module_dot) )
xx : lexIface rest
Nothing ->
(let
f = head word -- first char
n = _PK_ word
in
case module_dot of
Nothing ->
categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
Just m ->
let
q = if fromPrelude m then Unqual n else Qual m n
in
categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
) : lexIface rest ;
}
------------
categ n conid varid consym varsym
= if isLexConId n then conid
else if isLexVarId n then varid
else if isLexConSym n then consym
else varsym
------------
keywordsFM :: FiniteMap String IfaceToken
keywordsFM = listToFM [
("interface", ITinterface)
,("__versions__", ITversions)
,("__exports__", ITexports)
,("__instance_modules__",ITinstance_modules)
,("__instances__", ITinstances)
,("__fixities__", ITfixities)
,("__declarations__", ITdeclarations)
,("__pragmas__", ITpragmas)
,("data", ITdata)
,("type", ITtype)
,("newtype", ITnewtype)
,("class", ITclass)
,("where", ITwhere)
,("instance", ITinstance)
,("infixl", ITinfixl)
,("infixr", ITinfixr)
,("infix", ITinfix)
,("->", ITrarrow)
,("|", ITvbar)
,("!", ITbang)
,("::", ITdcolon)
,("=>", ITdarrow)
,("=", ITequal)
]
-----------------------------------------------------------------
type IfM a = MaybeErr a Error
returnIf :: a -> IfM a
thenIf :: IfM a -> (a -> IfM b) -> IfM b
happyError :: Int -> [IfaceToken] -> IfM a
returnIf a = Succeeded a
thenIf (Succeeded a) k = k a
thenIf (Failed err) _ = Failed err
happyError ln toks = Failed (ifaceParseErr ln toks)
-----------------------------------------------------------------
ifaceParseErr ln toks sty
= ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]
\end{code}
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment