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