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 :: Maybe [RdrName] -- ToDo: de-maybe
 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 = case tvs of
 221                Nothing -> HsPreForAllTy ctxt mono_ty -- ToDo: get rid of this
 222                Just ts -> HsForAllTy ts ctxt mono_ty
 223     in
 224     -- pprTrace "mk_inst:" (ppr PprDebug ty) $
 225     InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod ->
 226         InstDecl qclas ty
 227             EmptyMonoBinds False{-not from_here-} mod [{-sigs-}]
 228             noInstancePragmas mkIfaceSrcLoc
 229   where
 230     tycon_name (MonoTyApp tc _) = tc
 231     tycon_name (MonoListTy   _) = preludeQual SLIT("[]")
 232     tycon_name (MonoFunTy  _ _) = preludeQual SLIT("->")
 233     tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
 234
 235 -----------------------------------------------------------------
 236 lexIface :: String -> [IfaceToken]
 237
 238 lexIface input
 239   = _scc_ "Lexer"
 240     case input of
 241       []    -> []
 242
 243       -- whitespace and comments
 244       ' '       : cs -> lexIface cs
 245       '\t'      : cs -> lexIface cs
 246       '\n'      : cs -> lexIface cs
 247       '-' : '-' : cs -> lex_comment cs
 248       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 249
 250       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 251       '{' : '{'             : cs -> ITdocurly   : lexIface cs
 252       '}' : '}'             : cs -> ITdccurly   : lexIface cs
 253       '{'                   : cs -> ITocurly    : lexIface cs
 254       '}'                   : cs -> ITccurly    : lexIface cs
 255       '('                   : cs -> IToparen    : lexIface cs
 256       ')'                   : cs -> ITcparen    : lexIface cs
 257       '['                   : cs -> ITobrack    : lexIface cs
 258       ']'                   : cs -> ITcbrack    : lexIface cs
 259       ','                   : cs -> ITcomma     : lexIface cs
 260       ';'                   : cs -> ITsemi      : lexIface cs
 261
 262       '_' : '_' : cs -> lex_keyword cs
 263
 264       c : cs | isUpper c         -> lex_word input -- don't know if "Module." on front or not
 265              | isDigit c         -> lex_num  input
 266              | isAlpha c         -> lex_name Nothing is_var_sym input
 267              | is_sym_sym c      -> lex_name Nothing is_sym_sym input
 268
 269       other -> error ("lexing:"++other)
 270   where
 271     lex_comment str
 272       = case (span ((/=) '\n') str) of { (junk, rest) ->
 273         lexIface rest }
 274
 275     ------------------
 276     lex_nested_comment lvl [] = error "EOF in nested comment in interface"
 277     lex_nested_comment lvl str
 278       = case str of
 279           '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
 280           '-' : '}' : xs -> if lvl == 1
 281                             then lexIface xs
 282                             else lex_nested_comment (lvl-1) xs
 283           _         : xs -> lex_nested_comment lvl xs
 284
 285     -----------
 286     lex_num str
 287       = case (span isDigit str) of { (num, rest) ->
 288         ITinteger (read num) : lexIface rest }
 289
 290     -----------
 291     is_var_sym c    = isAlphanum c || c `elem` "_'#"
 292          -- the last few for for Glasgow-extended names
 293
 294     is_var_sym1 '\'' = False
 295     is_var_sym1 '#'  = False
 296     is_var_sym1 '_'  = False
 297     is_var_sym1 c    = is_var_sym c
 298
 299     is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
 300
 301     is_list_sym '[' = True
 302     is_list_sym ']' = True
 303     is_list_sym _   = False
 304
 305     is_tuple_sym '(' = True
 306     is_tuple_sym ')' = True
 307     is_tuple_sym ',' = True
 308     is_tuple_sym _   = False
 309
 310     ------------
 311     lex_word str@(c:cs) -- we know we have a capital letter to start
 312       = -- we first try for "<module>." on the front...
 313         case (module_dot str) of
 314           Nothing       -> lex_name Nothing  (in_the_club str)  str
 315           Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
 316       where
 317         in_the_club []    = panic "lex_word:in_the_club"
 318         in_the_club (x:_) | isAlpha    x = is_var_sym
 319                           | is_sym_sym x = is_sym_sym
 320                           | x == '['     = is_list_sym
 321                           | x == '('     = is_tuple_sym
 322                           | otherwise    = panic ("lex_word:in_the_club="++[x])
 323
 324     module_dot (c:cs)
 325       = if not (isUpper c) || c == '\'' then
 326            Nothing
 327         else
 328            case (span is_var_sym cs) of { (word, rest) ->
 329            case rest of
 330              []                -> Nothing
 331              (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
 332              _                 -> Nothing
 333            }
 334
 335     lex_keyword str
 336       = case (span is_var_sym str)    of { (kw, rest) ->
 337         case (lookupFM keywordsFM kw) of
 338           Nothing -> panic ("lex_keyword:"++str)
 339           Just xx -> xx : lexIface rest
 340         }
 341
 342     lex_name module_dot in_the_club str
 343       = case (span in_the_club str)     of { (word, rest) ->
 344         case (lookupFM keywordsFM word) of
 345           Just xx -> let
 346                         cont = xx : lexIface rest
 347                      in
 348                      case xx of
 349                        ITbang -> case module_dot of
 350                                    Nothing -> cont
 351                                    Just  m -> ITqvarsym (Qual m SLIT("!"))
 352                                               : lexIface rest
 353                        _ -> cont
 354           Nothing ->
 355             (let
 356                 f = head word -- first char
 357                 n = _PK_ word
 358              in
 359              case module_dot of
 360                Nothing ->
 361                  categ f n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
 362                Just m ->
 363                  let
 364                      q = Qual m n
 365                  in
 366                  categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
 367
 368              ) : lexIface rest ;
 369         }
 370     ------------
 371     categ f n conid varid consym varsym
 372       = if f == '[' || f == '(' then
 373            conid
 374         else if isLexConId  n then conid
 375         else if isLexVarId  n then varid
 376         else if isLexConSym n then consym
 377         else                       varsym
 378
 379     ------------
 380     keywordsFM :: FiniteMap String IfaceToken
 381     keywordsFM = listToFM [
 382         ("interface",    ITinterface)
 383
 384        ,("usages__",            ITusages)
 385        ,("versions__",          ITversions)
 386        ,("exports__",           ITexports)
 387        ,("instance_modules__",  ITinstance_modules)
 388        ,("instances__",         ITinstances)
 389        ,("fixities__",          ITfixities)
 390        ,("declarations__",      ITdeclarations)
 391        ,("pragmas__",           ITpragmas)
 392        ,("forall__",            ITforall)
 393
 394        ,("data",                ITdata)
 395        ,("type",                ITtype)
 396        ,("newtype",             ITnewtype)
 397        ,("class",               ITclass)
 398        ,("where",               ITwhere)
 399        ,("instance",            ITinstance)
 400        ,("infixl",              ITinfixl)
 401        ,("infixr",              ITinfixr)
 402        ,("infix",               ITinfix)
 403
 404        ,("->",                  ITrarrow)
 405        ,("|",                   ITvbar)
 406        ,("!",                   ITbang)
 407        ,("::",                  ITdcolon)
 408        ,("=>",                  ITdarrow)
 409        ,("=",                   ITequal)
 410        ]
 411
 412 -----------------------------------------------------------------
 413 type IfM a = MaybeErr a Error
 414
 415 returnIf   :: a -> IfM a
 416 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 417 happyError :: Int -> [IfaceToken] -> IfM a
 418
 419 returnIf a = Succeeded a
 420
 421 thenIf (Succeeded a) k = k a
 422 thenIf (Failed  err) _ = Failed err
 423
 424 happyError ln toks = Failed (ifaceParseErr ln toks)
 425 -----------------------------------------------------------------
 426
 427 ifaceParseErr ln toks sty
 428   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
 429 \end{code}