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,
  24                           RdrName(..){-instance Outputable:ToDo:rm-}
  25                         )
  26 import PprStyle         ( PprStyle(..) ) -- ToDo: rm debugging
  27 import PrelMods         ( fromPrelude )
  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 (RdrName, 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 RdrNameInstDecl
  75 \end{code}
  76
  77 \begin{code}
  78 -----------------------------------------------------------------
  79 data IfaceToken
  80   = ITinterface         -- keywords
  81   | ITusages
  82   | ITversions
  83   | ITexports
  84   | ITinstance_modules
  85   | ITinstances
  86   | ITfixities
  87   | ITdeclarations
  88   | ITpragmas
  89   | ITdata
  90   | ITtype
  91   | ITnewtype
  92   | ITclass
  93   | ITwhere
  94   | ITinstance
  95   | ITinfixl
  96   | ITinfixr
  97   | ITinfix
  98   | ITbang              -- magic symbols
  99   | ITvbar
 100   | ITbquote
 101   | ITdcolon
 102   | ITcomma
 103   | ITdarrow
 104   | ITdotdot
 105   | ITequal
 106   | ITocurly
 107   | ITobrack
 108   | IToparen
 109   | ITrarrow
 110   | ITccurly
 111   | ITcbrack
 112   | ITcparen
 113   | ITsemi
 114   | ITinteger Integer   -- numbers and names
 115   | ITvarid   FAST_STRING
 116   | ITconid   FAST_STRING
 117   | ITvarsym  FAST_STRING
 118   | ITconsym  FAST_STRING
 119   | ITqvarid  RdrName
 120   | ITqconid  RdrName
 121   | ITqvarsym RdrName
 122   | ITqconsym RdrName
 123   deriving Text -- debugging
 124
 125 instance Text RdrName where -- debugging
 126     showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
 127
 128 -----------------------------------------------------------------
 129 de_qual (Unqual n) = n
 130 de_qual (Qual _ n) = n
 131
 132 en_mono :: FAST_STRING -> RdrNameMonoType
 133 en_mono tv = MonoTyVar (Unqual tv)
 134
 135 type2context (MonoTupleTy tys) = map type2class_assertion tys
 136 type2context other_ty          = [ type2class_assertion other_ty ]
 137
 138 type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
 139 type2class_assertion _ = panic "type2class_assertion: bad format"
 140
 141 -----------------------------------------------------------------
 142 mk_type :: (RdrName, [FAST_STRING])
 143         -> RdrNameMonoType
 144         -> LocalTyDefsMap
 145
 146 mk_type (qtycon, tyvars) ty
 147   = let
 148         tycon   = de_qual qtycon
 149         qtyvars = map Unqual tyvars
 150     in
 151     unitFM tycon (TypeSig qtycon mkIfaceSrcLoc (
 152                   TySynonym qtycon qtyvars ty mkIfaceSrcLoc))
 153
 154 mk_data :: RdrNameContext
 155         -> (RdrName, [FAST_STRING])
 156         -> [(RdrName, RdrNameConDecl)]
 157         -> (LocalTyDefsMap, LocalValDefsMap)
 158
 159 mk_data ctxt (qtycon, tyvars) names_and_constrs
 160   = let
 161         (qconnames, constrs) = unzip names_and_constrs
 162         qfieldnames = [] -- ToDo ...
 163         tycon      = de_qual qtycon
 164         connames   = map de_qual qconnames
 165         fieldnames = map de_qual qfieldnames
 166         qtyvars    = map Unqual tyvars
 167
 168         decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
 169                 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
 170     in
 171     (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
 172                         `plusFM`
 173                         listToFM [(f,decl) | f <- fieldnames])
 174
 175 mk_new  :: RdrNameContext
 176         -> (RdrName, [FAST_STRING])
 177         -> (RdrName, RdrNameMonoType)
 178         -> (LocalTyDefsMap, LocalValDefsMap)
 179
 180 mk_new ctxt (qtycon, tyvars) (qconname, ty)
 181   = let
 182         tycon   = de_qual qtycon
 183         conname = de_qual qconname
 184         qtyvars = map Unqual tyvars
 185         constr  = NewConDecl qconname ty mkIfaceSrcLoc
 186
 187         decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
 188                 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
 189     in
 190     (unitFM tycon decl, unitFM conname decl)
 191
 192 mk_class :: RdrNameContext
 193          -> (RdrName, RdrName)
 194          -> [(FAST_STRING, RdrNameSig)]
 195          -> (LocalTyDefsMap, LocalValDefsMap)
 196
 197 mk_class ctxt (qclas, tyvar) ops_and_sigs
 198   = case (unzip ops_and_sigs) of { (opnames, sigs) ->
 199     let
 200         qopnames = map Unqual opnames
 201         clas     = de_qual qclas
 202         op_sigs  = map opify sigs
 203
 204         decl = ClassSig qclas qopnames mkIfaceSrcLoc (
 205                 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
 206     in
 207     (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
 208   where
 209     opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
 210
 211 mk_inst :: RdrNameContext
 212         -> RdrName -- class
 213         -> RdrNameMonoType  -- fish the tycon out yourself...
 214         -> RdrIfaceInst
 215
 216 mk_inst ctxt clas mono_ty
 217   = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
 218         InstDecl clas (HsPreForAllTy ctxt mono_ty)
 219             EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
 220             noInstancePragmas mkIfaceSrcLoc)
 221   where
 222     tycon_name (MonoTyApp tc _) = tc
 223     tycon_name (MonoListTy   _) = Unqual SLIT("[]")
 224     tycon_name (MonoFunTy  _ _) = Unqual SLIT("->")
 225     tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
 226
 227 -----------------------------------------------------------------
 228 lexIface :: String -> [IfaceToken]
 229
 230 lexIface str
 231   = _scc_ "Lexer"
 232     case str of
 233       []    -> []
 234
 235       -- whitespace and comments
 236       ' '       : cs -> lexIface cs
 237       '\t'      : cs -> lexIface cs
 238       '\n'      : cs -> lexIface cs
 239       '-' : '-' : cs -> lex_comment cs
 240       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 241
 242       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 243       '('                   : cs -> IToparen    : lexIface cs
 244       ')'                   : cs -> ITcparen    : lexIface cs
 245       '['                   : cs -> ITobrack    : lexIface cs
 246       ']'                   : cs -> ITcbrack    : lexIface cs
 247       '{'                   : cs -> ITocurly    : lexIface cs
 248       '}'                   : cs -> ITccurly    : lexIface cs
 249       ','                   : cs -> ITcomma     : lexIface cs
 250       ';'                   : cs -> ITsemi      : lexIface cs
 251       '`'                   : cs -> ITbquote    : lexIface cs
 252
 253       '_'                   : cs -> lex_name Nothing is_var_sym str
 254       c : cs | isUpper c         -> lex_word str -- don't know if "Module." on front or not
 255              | isDigit c         -> lex_num  str
 256              | isAlpha c         -> lex_name Nothing is_var_sym str
 257              | is_sym_sym c      -> lex_name Nothing is_sym_sym str
 258
 259       other -> error ("lexing:"++other)
 260   where
 261     lex_comment str
 262       = case (span ((/=) '\n') str) of { (junk, rest) ->
 263         lexIface rest }
 264
 265     ------------------
 266     lex_nested_comment lvl [] = error "EOF in nested comment in interface"
 267     lex_nested_comment lvl str
 268       = case str of
 269           '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
 270           '-' : '}' : xs -> if lvl == 1
 271                             then lexIface xs
 272                             else lex_nested_comment (lvl-1) xs
 273           _         : xs -> lex_nested_comment lvl xs
 274
 275     -----------
 276     lex_num str
 277       = case (span isDigit str) of { (num, rest) ->
 278         ITinteger (read num) : lexIface rest }
 279
 280     -----------
 281     is_var_sym '_'  = True
 282     is_var_sym '\'' = True
 283     is_var_sym '#'  = True -- for Glasgow-extended names
 284     is_var_sym c    = isAlphanum c
 285
 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 (c:_) | isAlpha    c = is_var_sym
 301                           | c == '_'     = is_var_sym
 302                           | is_sym_sym c = is_sym_sym
 303                           | otherwise    = panic ("lex_word:in_the_club="++[c])
 304
 305     module_dot (c:cs)
 306       = if not (isUpper c) || c == '\'' then
 307            Nothing
 308         else
 309            case (span is_var_sym cs) of { (word, rest) ->
 310            case rest of
 311              []                -> Nothing
 312              (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
 313              _                 -> Nothing
 314            }
 315
 316     lex_name module_dot in_the_club str
 317       = case (span in_the_club str)     of { (word, rest) ->
 318         case (lookupFM keywordsFM word) of
 319           Just xx -> let
 320                         cont = xx : lexIface rest
 321                      in
 322                      case xx of
 323                        ITbang -> case module_dot of
 324                                    Nothing -> cont
 325                                    Just  m -> ITqvarsym (Qual m SLIT("!"))
 326                                               : lexIface rest
 327                        _ -> cont
 328           Nothing ->
 329             (let
 330                 f = head word -- first char
 331                 n = _PK_ word
 332              in
 333              case module_dot of
 334                Nothing ->
 335                  categ n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
 336                Just m ->
 337                  let
 338                      q = if fromPrelude m then Unqual n else Qual m n
 339                  in
 340                  categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
 341
 342              ) : lexIface rest ;
 343         }
 344     ------------
 345     categ n conid varid consym varsym
 346       = if      isLexConId  n then conid
 347         else if isLexVarId  n then varid
 348         else if isLexConSym n then consym
 349         else                       varsym
 350
 351     ------------
 352     keywordsFM :: FiniteMap String IfaceToken
 353     keywordsFM = listToFM [
 354         ("interface",    ITinterface)
 355
 356        ,("__usages__",          ITusages)
 357        ,("__versions__",        ITversions)
 358        ,("__exports__",         ITexports)
 359        ,("__instance_modules__",ITinstance_modules)
 360        ,("__instances__",       ITinstances)
 361        ,("__fixities__",        ITfixities)
 362        ,("__declarations__",    ITdeclarations)
 363        ,("__pragmas__",         ITpragmas)
 364
 365        ,("data",                ITdata)
 366        ,("type",                ITtype)
 367        ,("newtype",             ITnewtype)
 368        ,("class",               ITclass)
 369        ,("where",               ITwhere)
 370        ,("instance",            ITinstance)
 371        ,("infixl",              ITinfixl)
 372        ,("infixr",              ITinfixr)
 373        ,("infix",               ITinfix)
 374
 375        ,("->",                  ITrarrow)
 376        ,("|",                   ITvbar)
 377        ,("!",                   ITbang)
 378        ,("::",                  ITdcolon)
 379        ,("=>",                  ITdarrow)
 380        ,("=",                   ITequal)
 381        ]
 382
 383 -----------------------------------------------------------------
 384 type IfM a = MaybeErr a Error
 385
 386 returnIf   :: a -> IfM a
 387 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 388 happyError :: Int -> [IfaceToken] -> IfM a
 389
 390 returnIf a = Succeeded a
 391
 392 thenIf (Succeeded a) k = k a
 393 thenIf (Failed  err) _ = Failed err
 394
 395 happyError ln toks = Failed (ifaceParseErr ln toks)
 396 -----------------------------------------------------------------
 397
 398 ifaceParseErr ln toks sty
 399   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
 400 \end{code}