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] [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         qfieldnames = [] -- ToDo ...
 155         tycon      = de_qual qtycon
 156         connames   = map de_qual qconnames
 157         fieldnames = map de_qual qfieldnames
 158         qtyvars    = map Unqual tyvars
 159
 160         decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc (
 161                 TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc)
 162     in
 163     (unitFM tycon decl, listToFM [(c,decl) | c <- connames]
 164                         `plusFM`
 165                         listToFM [(f,decl) | f <- fieldnames])
 166
 167 mk_new  :: RdrNameContext
 168         -> (RdrName, [FAST_STRING])
 169         -> (RdrName, RdrNameMonoType)
 170         -> (LocalTyDefsMap, LocalValDefsMap)
 171
 172 mk_new ctxt (qtycon, tyvars) (qconname, ty)
 173   = let
 174         tycon   = de_qual qtycon
 175         conname = de_qual qconname
 176         qtyvars = map Unqual tyvars
 177         constr  = NewConDecl qconname ty mkIfaceSrcLoc
 178
 179         decl = NewTypeSig qtycon qconname mkIfaceSrcLoc (
 180                 TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc)
 181     in
 182     (unitFM tycon decl, unitFM conname decl)
 183
 184 mk_class :: RdrNameContext
 185          -> (RdrName, RdrName)
 186          -> [(FAST_STRING, RdrNameSig)]
 187          -> (LocalTyDefsMap, LocalValDefsMap)
 188
 189 mk_class ctxt (qclas, tyvar) ops_and_sigs
 190   = case (unzip ops_and_sigs) of { (opnames, sigs) ->
 191     let
 192         qopnames = map Unqual opnames
 193         clas     = de_qual qclas
 194         op_sigs  = map opify sigs
 195
 196         decl = ClassSig qclas qopnames mkIfaceSrcLoc (
 197                 ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc)
 198     in
 199     (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
 200   where
 201     opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
 202
 203 mk_inst :: RdrNameContext
 204         -> RdrName -- class
 205         -> RdrNameMonoType  -- fish the tycon out yourself...
 206         -> RdrIfaceInst
 207
 208 mk_inst ctxt clas mono_ty
 209   = InstSig clas (tycon_name mono_ty) mkIfaceSrcLoc (
 210         InstDecl clas (HsPreForAllTy ctxt mono_ty)
 211             EmptyMonoBinds False Nothing{-lying-} [{-sigs-}]
 212             noInstancePragmas mkIfaceSrcLoc)
 213   where
 214     tycon_name (MonoTyApp tc _) = tc
 215     tycon_name (MonoListTy   _) = Unqual SLIT("[]")
 216     tycon_name (MonoFunTy  _ _) = Unqual SLIT("->")
 217     tycon_name (MonoTupleTy ts) = Unqual (mkTupNameStr (length ts))
 218
 219 -----------------------------------------------------------------
 220 lexIface :: String -> [IfaceToken]
 221
 222 lexIface str
 223   = case str of
 224       []    -> []
 225
 226       -- whitespace and comments
 227       ' '       : cs -> lexIface cs
 228       '\t'      : cs -> lexIface cs
 229       '\n'      : cs -> lexIface cs
 230       '-' : '-' : cs -> lex_comment cs
 231       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 232
 233       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 234       '('                   : cs -> IToparen    : lexIface cs
 235       ')'                   : cs -> ITcparen    : lexIface cs
 236       '['                   : cs -> ITobrack    : lexIface cs
 237       ']'                   : cs -> ITcbrack    : lexIface cs
 238       '{'                   : cs -> ITocurly    : lexIface cs
 239       '}'                   : cs -> ITccurly    : lexIface cs
 240       ','                   : cs -> ITcomma     : lexIface cs
 241       ';'                   : cs -> ITsemi      : lexIface cs
 242       '`'                   : cs -> ITbquote    : lexIface cs
 243
 244       '_'                   : cs -> lex_name Nothing is_var_sym str
 245       c : cs | isUpper c         -> lex_word str -- don't know if "Module." on front or not
 246              | isDigit c         -> lex_num  str
 247              | isAlpha c         -> lex_name Nothing is_var_sym str
 248              | is_sym_sym c      -> lex_name Nothing is_sym_sym str
 249
 250       other -> error ("lexing:"++other)
 251   where
 252     lex_comment str
 253       = case (span ((/=) '\n') str) of { (junk, rest) ->
 254         lexIface rest }
 255
 256     ------------------
 257     lex_nested_comment lvl [] = error "EOF in nested comment in interface"
 258     lex_nested_comment lvl str
 259       = case str of
 260           '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
 261           '-' : '}' : xs -> if lvl == 1
 262                             then lexIface xs
 263                             else lex_nested_comment (lvl-1) xs
 264           _         : xs -> lex_nested_comment lvl xs
 265
 266     -----------
 267     lex_num str
 268       = case (span isDigit str) of { (num, rest) ->
 269         ITinteger (read num) : lexIface rest }
 270
 271     -----------
 272     is_var_sym '_' = True
 273     is_var_sym c   = isAlphanum c
 274
 275     is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
 276
 277     ------------
 278     lex_word str@(c:cs) -- we know we have a capital letter to start
 279       = -- we first try for "<module>." on the front...
 280         case (module_dot str) of
 281           Nothing       -> lex_name Nothing  is_var_sym  str
 282           Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
 283             where
 284               in_the_club []    = panic "lex_word:in_the_club"
 285               in_the_club (c:_) | isAlpha    c = is_var_sym
 286                                 | is_sym_sym c = is_sym_sym
 287                                 | otherwise    = panic ("lex_word:in_the_club="++[c])
 288
 289     module_dot (c:cs)
 290       = if not (isUpper c) then
 291            Nothing
 292         else
 293            case (span is_var_sym cs) of { (word, rest) ->
 294            case rest of
 295              []                -> Nothing
 296              (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
 297              _                 -> Nothing
 298            }
 299
 300     lex_name module_dot in_the_club str
 301       = case (span in_the_club str)     of { (word, rest) ->
 302         case (lookupFM keywordsFM word) of
 303           Just xx -> ASSERT( not (maybeToBool module_dot) )
 304                      xx : lexIface rest
 305           Nothing ->
 306             (let
 307                 f = head word -- first char
 308                 n = _PK_ word
 309              in
 310              case module_dot of
 311                Nothing ->
 312                  categ n (ITconid  n) (ITvarid  n) (ITconsym  n) (ITvarsym  n)
 313                Just m ->
 314                  let
 315                      q = if fromPrelude m then Unqual n else Qual m n
 316                  in
 317                  categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
 318
 319              ) : lexIface rest ;
 320         }
 321     ------------
 322     categ n conid varid consym varsym
 323       = if      isLexConId  n then conid
 324         else if isLexVarId  n then varid
 325         else if isLexConSym n then consym
 326         else                       varsym
 327
 328     ------------
 329     keywordsFM :: FiniteMap String IfaceToken
 330     keywordsFM = listToFM [
 331         ("interface",    ITinterface)
 332
 333        ,("__versions__",        ITversions)
 334        ,("__exports__",         ITexports)
 335        ,("__instance_modules__",ITinstance_modules)
 336        ,("__instances__",       ITinstances)
 337        ,("__fixities__",        ITfixities)
 338        ,("__declarations__",    ITdeclarations)
 339        ,("__pragmas__",         ITpragmas)
 340
 341        ,("data",                ITdata)
 342        ,("type",                ITtype)
 343        ,("newtype",             ITnewtype)
 344        ,("class",               ITclass)
 345        ,("where",               ITwhere)
 346        ,("instance",            ITinstance)
 347        ,("infixl",              ITinfixl)
 348        ,("infixr",              ITinfixr)
 349        ,("infix",               ITinfix)
 350
 351        ,("->",                  ITrarrow)
 352        ,("|",                   ITvbar)
 353        ,("!",                   ITbang)
 354        ,("::",                  ITdcolon)
 355        ,("=>",                  ITdarrow)
 356        ,("=",                   ITequal)
 357        ]
 358
 359 -----------------------------------------------------------------
 360 type IfM a = MaybeErr a Error
 361
 362 returnIf   :: a -> IfM a
 363 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 364 happyError :: Int -> [IfaceToken] -> IfM a
 365
 366 returnIf a = Succeeded a
 367
 368 thenIf (Succeeded a) k = k a
 369 thenIf (Failed  err) _ = Failed err
 370
 371 happyError ln toks = Failed (ifaceParseErr ln toks)
 372 -----------------------------------------------------------------
 373
 374 ifaceParseErr ln toks sty
 375   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)]
 376 \end{code}