ghc/compiler/rename/ParseUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[ParseUtils]{Help the interface parser}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module ParseUtils where
  10
  11 IMP_Ubiq(){-uitous-}
  12
  13 import HsSyn            -- quite a bit of stuff
  14 import RdrHsSyn         -- oodles of synonyms
  15 import HsPragmas        ( noDataPragmas, noClassPragmas, noClassOpPragmas,
  16                           noInstancePragmas
  17                         )
  18
  19 import ErrUtils         ( Error(..) )
  20 import FiniteMap        ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
  21 import Maybes           ( maybeToBool, MaybeErr(..) )
  22 import Name             ( isLexConId, isLexVarId, isLexConSym,
  23                           mkTupNameStr, preludeQual, isRdrLexCon,
  24                           RdrName(..){-instance Outputable:ToDo:rm-}
  25                         )
  26 import PprStyle         ( PprStyle(..) ) -- ToDo: rm debugging
  27 import PrelMods         ( pRELUDE )
  28 import Pretty           ( ppCat, ppPStr, ppInt, ppShow, ppStr )
  29 import SrcLoc           ( mkIfaceSrcLoc )
  30 import Util             ( startsWith, isIn, panic, assertPanic )
  31 \end{code}
  32
  33 \begin{code}
  34 type UsagesMap        = FiniteMap Module (Version, VersionsMap)
  35                         -- module => its version, then to all its entities
  36                         -- and their versions; "instance" is a magic entity
  37                         -- representing all the instances def'd in that module
  38 type VersionsMap      = FiniteMap FAST_STRING Version
  39                         -- Versions for things def'd in this module
  40 type ExportsMap       = FiniteMap FAST_STRING (OrigName, ExportFlag)
  41 type FixitiesMap      = FiniteMap FAST_STRING RdrNameFixityDecl
  42 type LocalTyDefsMap   = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
  43 type LocalValDefsMap  = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
  44 type LocalPragmasMap  = FiniteMap FAST_STRING PragmaStuff
  45
  46 type PragmaStuff = String
  47
  48 data ParsedIface
  49   = ParsedIface
  50       Module             -- Module name
  51       (Bool, Bag Module) -- From a merging of these modules; True => merging occured
  52       Version            -- Module version number
  53       (Maybe Version)    -- Source version number
  54       UsagesMap          -- Used when compiling this module
  55       VersionsMap        -- Version numbers of things from this module
  56       ExportsMap         -- Exported names
  57       (Bag Module)       -- Special instance modules
  58       FixitiesMap        -- fixities of local things
  59       LocalTyDefsMap     -- Local TyCon/Class names defined
  60       LocalValDefsMap    -- Local value names defined
  61       (Bag RdrIfaceInst) -- Local instance declarations
  62       LocalPragmasMap    -- Pragmas for local names
  63
  64 -----------------------------------------------------------------
  65
  66 data RdrIfaceDecl
  67   = TypeSig    RdrName                     SrcLoc RdrNameTyDecl
  68   | NewTypeSig RdrName RdrName             SrcLoc RdrNameTyDecl
  69   | DataSig    RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
  70   | ClassSig   RdrName [RdrName]           SrcLoc RdrNameClassDecl
  71   | ValSig     RdrName                     SrcLoc RdrNamePolyType
  72
  73 data RdrIfaceInst
  74   = InstSig    RdrName RdrName  SrcLoc (Module -> RdrNameInstDecl)
  75         -- InstDecl minus a Module name
  76 \end{code}
  77
  78 \begin{code}
  79 -----------------------------------------------------------------
  80 data IfaceToken
  81   = ITinterface         -- keywords
  82   | ITusages
  83   | ITversions
  84   | ITexports
  85   | ITinstance_modules
  86   | ITinstances
  87   | ITfixities
  88   | ITdeclarations
  89   | ITpragmas
  90   | ITdata
  91   | ITtype
  92   | ITnewtype
  93   | ITclass
  94   | ITwhere
  95   | ITinstance
  96   | ITinfixl
  97   | ITinfixr
  98   | ITinfix
  99   | ITbang              -- magic symbols
 100   | ITvbar
 101   | ITdcolon
 102   | ITcomma
 103   | ITdarrow
 104   | ITdotdot
 105   | ITequal
 106   | ITocurly
 107   | ITdccurly
 108   | ITdocurly
 109   | ITobrack
 110   | IToparen
 111   | ITrarrow
 112   | ITccurly
 113   | ITcbrack
 114   | ITcparen
 115   | ITsemi
 116   | ITinteger Integer   -- numbers and names
 117   | ITvarid   FAST_STRING
 118   | ITconid   FAST_STRING
 119   | ITvarsym  FAST_STRING
 120   | ITconsym  FAST_STRING
 121   | ITqvarid  RdrName
 122   | ITqconid  RdrName
 123   | ITqvarsym RdrName
 124   | ITqconsym RdrName
 125   deriving Text -- debugging
 126
 127 instance Text RdrName where -- debugging
 128     showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
 129
 130 -----------------------------------------------------------------
 131 de_qual (Unqual n) = n
 132 de_qual (Qual _ n) = n
 133
 134 en_mono :: FAST_STRING -> RdrNameMonoType
 135 en_mono tv = MonoTyVar (Unqual tv)
 136
 137 {-OLD:
 138 type2context (MonoTupleTy tys) = map type2class_assertion tys
 139 type2context other_ty          = [ type2class_assertion other_ty ]
 140
 141 type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
 142 type2class_assertion _ = panic "type2class_assertion: bad format"
 143 -}
 144
 145 -----------------------------------------------------------------
 146 mk_type :: (RdrName, [FAST_STRING])
 147         -> RdrNameMonoType
 148         -> LocalTyDefsMap
 149
 150 mk_type (qtycon@(Qual mod tycon), tyvars) ty
 151   = let
 152         qtyvars = map Unqual tyvars
 153     in
 154     unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $
 155                   TySynonym qtycon qtyvars ty mkIfaceSrcLoc)
 156
 157 mk_data :: RdrNameContext
 158         -> (RdrName, [FAST_STRING])
 159         -> [(RdrName, RdrNameConDecl)]
 160         -> (LocalTyDefsMap, LocalValDefsMap)
 161
 162 mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs
 163   = let
 164         (qthingnames, constrs) = unzip names_and_constrs
 165         (qconnames, qfieldnames) = partition isRdrLexCon qthingnames
 166         thingnames = [ t | (Qual _ t) <- qthingnames]
 167         qtyvars    = map Unqual tyvars
 168
 169         decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $
 170                 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc
 171     in
 172     (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames])
 173
 174 mk_new  :: RdrNameContext
 175         -> (RdrName, [FAST_STRING])
 176         -> (RdrName, RdrNameMonoType)
 177         -> (LocalTyDefsMap, LocalValDefsMap)
 178
 179 mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty)
 180   = ASSERT(mod1 == mod2)
 181     let
 182         qtyvars = map Unqual tyvars
 183         constr  = NewConDecl qconname ty mkIfaceSrcLoc
 184
 185         decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $
 186                 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc
 187     in
 188     (unitFM tycon decl, unitFM conname decl)
 189
 190 mk_class :: RdrNameContext
 191          -> (RdrName, RdrName)
 192          -> [(FAST_STRING, RdrNameSig)]
 193          -> (LocalTyDefsMap, LocalValDefsMap)
 194
 195 mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
 196   = case (unzip ops_and_sigs) of { (opnames, sigs) ->
 197     let
 198         qopnames = map (Qual mod) opnames
 199         op_sigs  = map opify sigs
 200
 201         decl = ClassSig qclas qopnames mkIfaceSrcLoc $
 202                 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc
 203     in
 204     (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
 205   where
 206     opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
 207
 208 mk_inst :: RdrNameContext
 209         -> RdrName -- class
 210         -> RdrNameMonoType  -- fish the tycon out yourself...
 211         -> RdrIfaceInst
 212
 213 mk_inst ctxt qclas@(Qual cmod cname) mono_ty
 214   = InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
 215         InstDecl qclas (HsPreForAllTy ctxt mono_ty)
 216             EmptyMonoBinds False mod [{-sigs-}]
 217             noInstancePragmas mkIfaceSrcLoc
 218   where
 219     tycon_name (MonoTyApp tc _) = tc
 220     tycon_name (MonoListTy   _) = preludeQual SLIT("[]")
 221     tycon_name (MonoFunTy  _ _) = preludeQual SLIT("->")
 222     tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
 223
 224 -----------------------------------------------------------------
 225 lexIface :: String -> [IfaceToken]
 226
 227 lexIface input
 228   = _scc_ "Lexer"
 229     case input of
 230       []    -> []
 231
 232       -- whitespace and comments
 233       ' '       : cs -> lexIface cs
 234       '\t'      : cs -> lexIface cs
 235       '\n'      : cs -> lexIface cs
 236       '-' : '-' : cs -> lex_comment cs
 237       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 238
 239       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 240       '{' : '{'             : cs -> ITdocurly   : lexIface cs
 241       '}' : '}'             : cs -> ITdccurly   : lexIface cs
 242       '{'                   : cs -> ITocurly    : lexIface cs
 243       '}'                   : cs -> ITccurly    : lexIface cs
 244       '('                   : cs -> IToparen    : lexIface cs
 245       ')'                   : cs -> ITcparen    : lexIface cs
 246       '['                   : cs -> ITobrack    : lexIface cs
 247       ']'                   : cs -> ITcbrack    : lexIface cs
 248       ','                   : cs -> ITcomma     : lexIface cs
 249       ';'                   : cs -> ITsemi      : lexIface cs
 250
 251       '_' : '_' : cs -> lex_keyword cs
 252
 253       c : cs | isUpper c         -> lex_word input -- don't know if "Module." on front or not
 254              | isDigit c         -> lex_num  input
 255              | isAlpha c         -> lex_name Nothing is_var_sym input
 256              | is_sym_sym c      -> lex_name Nothing is_sym_sym input
 257
 258       other -> error ("lexing:"++other)
 259   where
 260     lex_comment str
 261       = case (span ((/=) '\n') str) of { (junk, rest) ->
 262         lexIface rest }
 263
 264     ------------------
 265     lex_nested_comment lvl [] = error "EOF in nested comment in interface"
 266     lex_nested_comment lvl str
 267       = case str of
 268           '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
 269           '-' : '}' : xs -> if lvl == 1
 270                             then lexIface xs
 271                             else lex_nested_comment (lvl-1) xs
 272           _         : xs -> lex_nested_comment lvl xs
 273
 274     -----------
 275     lex_num str
 276       = case (span isDigit str) of { (num, rest) ->
 277         ITinteger (read num) : lexIface rest }
 278
 279     -----------
 280     is_var_sym '_'  = True
 281     is_var_sym '\'' = True
 282     is_var_sym '#'  = True -- for Glasgow-extended names
 283     is_var_sym c    = isAlphanum c
 284
 285     is_var_sym1 '\'' = False
 286     is_var_sym1 '#'  = False
 287     is_var_sym1 '_'  = False
 288     is_var_sym1 c    = is_var_sym c
 289
 290     is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
 291
 292     ------------
 293     lex_word str@(c:cs) -- we know we have a capital letter to start
 294       = -- we first try for "<module>." on the front...
 295         case (module_dot str) of
 296           Nothing       -> lex_name Nothing  (in_the_club str)  str
 297           Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
 298       where
 299         in_the_club []    = panic "lex_word:in_the_club"
 300         in_the_club (x:_) | isAlpha    x = is_var_sym
 301                           | is_sym_sym x = is_sym_sym
 302                           | otherwise    = panic ("lex_word:in_the_club="++[x])
 303
 304     module_dot (c:cs)
 305       = if not (isUpper c) || c == '\'' then
 306            Nothing
 307         else
 308            case (span is_var_sym cs) of { (word, rest) ->
 309            case rest of
 310              []                -> Nothing
 311              (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
 312              _                 -> Nothing
 313            }
 314
 315     lex_keyword str
 316       = case (span is_var_sym str)    of { (kw, rest) ->
 317         case (lookupFM keywordsFM kw) of
 318           Nothing -> panic ("lex_keyword:"++str)
 319           Just xx -> xx : lexIface rest
 320         }
 321
 322     lex_name module_dot in_the_club str
 323       = case (span in_the_club str)     of { (word, rest) ->
 324         case (lookupFM keywordsFM word) of
 325           Just xx -> let
 326                         cont = xx : lexIface rest
 327                      in
 328                      case xx of
 329                        ITbang -> case module_dot of
 330                                    Nothing -> cont
 331                                    Just  m -> ITqvarsym (Qual m SLIT("!"))
 332                                               : lexIface rest
 333                        _ -> cont
 334           Nothing ->
 335             (let
 336                 f = head word -- first char
 337                 n = _PK_ word
 338              in
 339              case module_dot of
 340                Nothing ->
 341                  categ n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
 342                Just m ->
 343                  let
 344                      q = Qual m n
 345                  in
 346                  categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
 347
 348              ) : lexIface rest ;
 349         }
 350     ------------
 351     categ n conid varid consym varsym
 352       = if      isLexConId  n then conid
 353         else if isLexVarId  n then varid
 354         else if isLexConSym n then consym
 355         else                       varsym
 356
 357     ------------
 358     keywordsFM :: FiniteMap String IfaceToken
 359     keywordsFM = listToFM [
 360         ("interface",    ITinterface)
 361
 362        ,("usages__",            ITusages)
 363        ,("versions__",          ITversions)
 364        ,("exports__",           ITexports)
 365        ,("instance_modules__",  ITinstance_modules)
 366        ,("instances__",         ITinstances)
 367        ,("fixities__",          ITfixities)
 368        ,("declarations__",      ITdeclarations)
 369        ,("pragmas__",           ITpragmas)
 370
 371        ,("data",                ITdata)
 372        ,("type",                ITtype)
 373        ,("newtype",             ITnewtype)
 374        ,("class",               ITclass)
 375        ,("where",               ITwhere)
 376        ,("instance",            ITinstance)
 377        ,("infixl",              ITinfixl)
 378        ,("infixr",              ITinfixr)
 379        ,("infix",               ITinfix)
 380
 381        ,("->",                  ITrarrow)
 382        ,("|",                   ITvbar)
 383        ,("!",                   ITbang)
 384        ,("::",                  ITdcolon)
 385        ,("=>",                  ITdarrow)
 386        ,("=",                   ITequal)
 387        ]
 388
 389 -----------------------------------------------------------------
 390 type IfM a = MaybeErr a Error
 391
 392 returnIf   :: a -> IfM a
 393 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 394 happyError :: Int -> [IfaceToken] -> IfM a
 395
 396 returnIf a = Succeeded a
 397
 398 thenIf (Succeeded a) k = k a
 399 thenIf (Failed  err) _ = Failed err
 400
 401 happyError ln toks = Failed (ifaceParseErr ln toks)
 402 -----------------------------------------------------------------
 403
 404 ifaceParseErr ln toks sty
 405   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
 406 \end{code}