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 import 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   = case str of
 232       []    -> []
 233
 234       -- whitespace and comments
 235       ' '       : cs -> lexIface cs
 236       '\t'      : cs -> lexIface cs
 237       '\n'      : cs -> lexIface cs
 238       '-' : '-' : cs -> lex_comment cs
 239       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 240
 241       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 242       '('                   : cs -> IToparen    : lexIface cs
 243       ')'                   : cs -> ITcparen    : lexIface cs
 244       '['                   : cs -> ITobrack    : lexIface cs
 245       ']'                   : cs -> ITcbrack    : lexIface cs
 246       '{'                   : cs -> ITocurly    : lexIface cs
 247       '}'                   : cs -> ITccurly    : lexIface cs
 248       ','                   : cs -> ITcomma     : lexIface cs
 249       ';'                   : cs -> ITsemi      : lexIface cs
 250       '`'                   : cs -> ITbquote    : lexIface cs
 251
 252       '_'                   : cs -> lex_name Nothing is_var_sym str
 253       c : cs | isUpper c         -> lex_word str -- don't know if "Module." on front or not
 254              | isDigit c         -> lex_num  str
 255              | isAlpha c         -> lex_name Nothing is_var_sym str
 256              | is_sym_sym c      -> lex_name Nothing is_sym_sym str
 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 c   = isAlphanum c
 282
 283     is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
 284
 285     ------------
 286     lex_word str@(c:cs) -- we know we have a capital letter to start
 287       = -- we first try for "<module>." on the front...
 288         case (module_dot str) of
 289           Nothing       -> lex_name Nothing  is_var_sym  str
 290           Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
 291             where
 292               in_the_club []    = panic "lex_word:in_the_club"
 293               in_the_club (c:_) | isAlpha    c = is_var_sym
 294                                 | is_sym_sym c = is_sym_sym
 295                                 | otherwise    = panic ("lex_word:in_the_club="++[c])
 296
 297     module_dot (c:cs)
 298       = if not (isUpper c) then
 299            Nothing
 300         else
 301            case (span is_var_sym cs) of { (word, rest) ->
 302            case rest of
 303              []                -> Nothing
 304              (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
 305              _                 -> Nothing
 306            }
 307
 308     lex_name module_dot in_the_club str
 309       = case (span in_the_club str)     of { (word, rest) ->
 310         case (lookupFM keywordsFM word) of
 311           Just xx -> ASSERT( not (maybeToBool module_dot) )
 312                      xx : lexIface rest
 313           Nothing ->
 314             (let
 315                 f = head word -- first char
 316                 n = _PK_ word
 317              in
 318              case module_dot of
 319                Nothing ->
 320                  categ n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
 321                Just m ->
 322                  let
 323                      q = if fromPrelude m then Unqual n else Qual m n
 324                  in
 325                  categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
 326
 327              ) : lexIface rest ;
 328         }
 329     ------------
 330     categ n conid varid consym varsym
 331       = if      isLexConId  n then conid
 332         else if isLexVarId  n then varid
 333         else if isLexConSym n then consym
 334         else                       varsym
 335
 336     ------------
 337     keywordsFM :: FiniteMap String IfaceToken
 338     keywordsFM = listToFM [
 339         ("interface",    ITinterface)
 340
 341        ,("__usages__",          ITusages)
 342        ,("__versions__",        ITversions)
 343        ,("__exports__",         ITexports)
 344        ,("__instance_modules__",ITinstance_modules)
 345        ,("__instances__",       ITinstances)
 346        ,("__fixities__",        ITfixities)
 347        ,("__declarations__",    ITdeclarations)
 348        ,("__pragmas__",         ITpragmas)
 349
 350        ,("data",                ITdata)
 351        ,("type",                ITtype)
 352        ,("newtype",             ITnewtype)
 353        ,("class",               ITclass)
 354        ,("where",               ITwhere)
 355        ,("instance",            ITinstance)
 356        ,("infixl",              ITinfixl)
 357        ,("infixr",              ITinfixr)
 358        ,("infix",               ITinfix)
 359
 360        ,("->",                  ITrarrow)
 361        ,("|",                   ITvbar)
 362        ,("!",                   ITbang)
 363        ,("::",                  ITdcolon)
 364        ,("=>",                  ITdarrow)
 365        ,("=",                   ITequal)
 366        ]
 367
 368 -----------------------------------------------------------------
 369 type IfM a = MaybeErr a Error
 370
 371 returnIf   :: a -> IfM a
 372 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 373 happyError :: Int -> [IfaceToken] -> IfM a
 374
 375 returnIf a = Succeeded a
 376
 377 thenIf (Succeeded a) k = k a
 378 thenIf (Failed  err) _ = Failed err
 379
 380 happyError ln toks = Failed (ifaceParseErr ln toks)
 381 -----------------------------------------------------------------
 382
 383 ifaceParseErr ln toks sty
 384   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]
 385 \end{code}