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