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