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