ghc/compiler/rename/ParseIface.y

   1 {
   2 #include "HsVersions.h"
   3
   4 module ParseIface (
   5         parseIface,
   6
   7         ParsedIface(..), RdrIfaceDecl(..),
   8
   9         ExportsMap(..), LocalDefsMap(..), LocalPragmasMap(..),
  10         LocalVersionsMap(..), PragmaStuff(..)
  11
  12     ) where
  13
  14 import Ubiq{-uitous-}
  15
  16 import HsSyn            ( ClassDecl, InstDecl, TyDecl, PolyType, InPat, Fake )
  17 import RdrHsSyn         ( RdrNameTyDecl(..), RdrNameClassDecl(..),
  18                           RdrNamePolyType(..), RdrNameInstDecl(..)
  19                         )
  20 import FiniteMap        ( emptyFM, listToFM, fmToList, lookupFM, keysFM, FiniteMap )
  21 import Name             ( ExportFlag(..) )
  22 import Util             ( startsWith )
  23 -----------------------------------------------------------------
  24
  25 parseIface = parseIToks . lexIface
  26
  27 type LocalVersionsMap = FiniteMap FAST_STRING Version
  28 type ExportsMap       = FiniteMap FAST_STRING (RdrName, ExportFlag)
  29 type LocalDefsMap     = FiniteMap FAST_STRING RdrIfaceDecl
  30 type LocalPragmasMap  = FiniteMap FAST_STRING PragmaStuff
  31
  32 type PragmaStuff = String
  33
  34 data ParsedIface
  35   = ParsedIface
  36       Module            -- Module name
  37       Version           -- Module version number
  38       (Maybe Version)   -- Source version number
  39       LocalVersionsMap  -- Local version numbers
  40       ExportsMap        -- Exported names
  41       [Module]          -- Special instance modules
  42       LocalDefsMap      -- Local names defined
  43       [RdrIfaceDecl]    -- Local instance declarations
  44       LocalPragmasMap   -- Pragmas for local names
  45
  46 {-
  47 instance Text ParsedIface where
  48     showsPrec _ (ParsedIface m v mv lcm exm ims ldm lids ldp)
  49       = showString "interface "
  50       . showString (_UNPK_ m)
  51       . showChar ' '
  52       . showInt  v
  53       . showString "\n__versions__\n"
  54       . showList (fmToList lcm)
  55       . showString "\n__exports__\n"
  56       . showList (fmToList exm)
  57       . showString "\n__instance_modules__\n"
  58       . showList (map _UNPK_ ims)
  59       . showString "\n__declarations__\n"
  60       . showList (map _UNPK_ (keysFM ldm))
  61       . showString "\n__instances__\n"
  62       . showList lids
  63       . showString "\n__pragmas__\n"
  64       . showList (map _UNPK_ (keysFM ldp))
  65 -}
  66
  67 -----------------------------------------------------------------
  68
  69 data RdrIfaceDecl
  70   = TypeSig    RdrName           Bool SrcLoc RdrNameTyDecl
  71   | NewTypeSig RdrName RdrName   Bool SrcLoc RdrNameTyDecl
  72   | DataSig    RdrName [RdrName] Bool SrcLoc RdrNameTyDecl
  73   | ClassSig   RdrName [RdrName] Bool SrcLoc RdrNameClassDecl
  74   | ValSig     RdrName           Bool SrcLoc RdrNamePolyType
  75   | InstSig    RdrName RdrName   Bool SrcLoc RdrNameInstDecl
  76                                 -- True => Source Iface decl
  77 -----------
  78 type Version = Int
  79
  80 -----------------------------------------------------------------
  81 }
  82
  83 %name       parseIToks
  84 %tokentype  { IfaceToken }
  85
  86 %token
  87         interface           { ITinterface }
  88         versions_part       { ITversions }
  89         exports_part        { ITexports }
  90         instance_modules_part { ITinstance_modules }
  91         instances_part      { ITinstances }
  92         declarations_part   { ITdeclarations }
  93         pragmas_part        { ITpragmas }
  94         data                { ITdata }
  95         type                { ITtype }
  96         newtype             { ITnewtype }
  97         class               { ITclass }
  98         where               { ITwhere }
  99         instance            { ITinstance }
 100         bar                 { ITbar }
 101         colons              { ITcolons }
 102         comma               { ITcomma }
 103         dblrarrow           { ITdblrarrow }
 104         dot                 { ITdot }
 105         dotdot              { ITdotdot }
 106         equal               { ITequal }
 107         lbrace              { ITlbrace }
 108         lbrack              { ITlbrack }
 109         lparen              { ITlparen }
 110         rarrow              { ITrarrow }
 111         rbrace              { ITrbrace }
 112         rbrack              { ITrbrack }
 113         rparen              { ITrparen }
 114         semicolon           { ITsemicolon }
 115         num                 { ITnum  $$ }
 116         name                { ITname $$ }
 117 %%
 118
 119 Iface           :: { ParsedIface }
 120 Iface           : interface name num
 121                   VersionsPart ExportsPart InstanceModulesPart
 122                   DeclsPart InstancesPart PragmasPart
 123                   { ParsedIface $2 (fromInteger $3) Nothing{-src version-}
 124                         $4  -- local versions
 125                         $5  -- exports map
 126                         $6  -- instance modules
 127                         $7  -- decls map
 128                         $8  -- local instances
 129                         $9  -- pragmas map
 130                   }
 131
 132 VersionsPart    :: { LocalVersionsMap }
 133 VersionsPart    :  versions_part NameVersionPairs
 134                    { listToFM $2 }
 135
 136 NameVersionPairs :: { [(FAST_STRING, Int)] }
 137 NameVersionPairs :  NameVersionPairs name lparen num rparen
 138                     { ($2, fromInteger $4) : $1 }
 139                  |  { [] }
 140
 141 ExportsPart     :: { ExportsMap }
 142 ExportsPart     :  exports_part ExportItems
 143                    { listToFM $2 }
 144
 145 ExportItems     :: { [(FAST_STRING, (RdrName, ExportFlag))] }
 146 ExportItems     :  ExportItems name dot name MaybeDotDot
 147                    { ($4, (Qual $2 $4, $5)) : $1 }
 148                 |  { [] }
 149
 150 MaybeDotDot     :: { ExportFlag }
 151 MaybeDotDot     :  dotdot { ExportAll }
 152                 |         { ExportAbs }
 153
 154 InstanceModulesPart :: { [Module] }
 155 InstanceModulesPart :  instance_modules_part ModList
 156                        { $2 }
 157
 158 ModList         :: { [Module] }
 159 ModList         :  ModList name { $2 : $1 }
 160                 |               { [] }
 161
 162 DeclsPart       :: { LocalDefsMap }
 163 DeclsPart       : declarations_part
 164                   { emptyFM }
 165
 166 InstancesPart   :: { [RdrIfaceDecl] }
 167 InstancesPart   :  instances_part
 168                    { [] }
 169
 170 PragmasPart     :: { LocalPragmasMap }
 171 PragmasPart     :  pragmas_part
 172                    { emptyFM }
 173 {
 174 -----------------------------------------------------------------
 175 happyError :: Int -> [IfaceToken] -> a
 176 happyError i _ = error ("Parse error in line " ++ show i ++ "\n")
 177
 178 -----------------------------------------------------------------
 179 data IfaceToken
 180   = ITinterface         -- keywords
 181   | ITversions
 182   | ITexports
 183   | ITinstance_modules
 184   | ITinstances
 185   | ITdeclarations
 186   | ITpragmas
 187   | ITdata
 188   | ITtype
 189   | ITnewtype
 190   | ITclass
 191   | ITwhere
 192   | ITinstance
 193   | ITbar               -- magic symbols
 194   | ITcolons
 195   | ITcomma
 196   | ITdblrarrow
 197   | ITdot
 198   | ITdotdot
 199   | ITequal
 200   | ITlbrace
 201   | ITlbrack
 202   | ITlparen
 203   | ITrarrow
 204   | ITrbrace
 205   | ITrbrack
 206   | ITrparen
 207   | ITsemicolon
 208   | ITnum   Integer     -- numbers and names
 209   | ITname  FAST_STRING
 210
 211 -----------------------------------------------------------------
 212 lexIface :: String -> [IfaceToken]
 213
 214 lexIface str
 215   = case str of
 216       []    -> []
 217
 218       -- whitespace and comments
 219       ' '       : cs -> lexIface cs
 220       '\t'      : cs -> lexIface cs
 221       '\n'      : cs -> lexIface cs
 222       '-' : '-' : cs -> lex_comment cs
 223       '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 224
 225       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 226       '('                   : cs -> ITlparen    : lexIface cs
 227       ')'                   : cs -> ITrparen    : lexIface cs
 228       '['                   : cs -> ITlbrack    : lexIface cs
 229       ']'                   : cs -> ITrbrack    : lexIface cs
 230       '{'                   : cs -> ITlbrace    : lexIface cs
 231       '}'                   : cs -> ITrbrace    : lexIface cs
 232       '-' : '>'             : cs -> ITrarrow    : lexIface cs
 233       '.'                   : cs -> ITdot       : lexIface cs
 234       '|'                   : cs -> ITbar       : lexIface cs
 235       ':' : ':'             : cs -> ITcolons    : lexIface cs
 236       '=' : '>'             : cs -> ITdblrarrow : lexIface cs
 237       '='                   : cs -> ITequal     : lexIface cs
 238       ','                   : cs -> ITcomma     : lexIface cs
 239       ';'                   : cs -> ITsemicolon : lexIface cs
 240
 241       '_'                   : cs -> lex_word str
 242       c : cs | isDigit c         -> lex_num  str
 243              | isAlpha c         -> lex_word str
 244
 245       other -> error ("lexing:"++other)
 246   where
 247     lex_comment str
 248       = case (span ((/=) '\n') str) of { (junk, rest) ->
 249         lexIface rest }
 250
 251     lex_nested_comment lvl [] = error "EOF in nested comment in interface"
 252     lex_nested_comment lvl str
 253       = case str of
 254           '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
 255           '-' : '}' : xs -> if lvl == 1
 256                             then lexIface xs
 257                             else lex_nested_comment (lvl-1) xs
 258           _         : xs -> lex_nested_comment lvl xs
 259
 260     lex_num str
 261       = case (span isDigit str) of { (num, rest) ->
 262         ITnum (read num) : lexIface rest }
 263
 264     lex_word str
 265       = case (span is_word_sym str)     of { (word, rest) ->
 266         case (lookupFM keywordsFM word) of {
 267           Nothing -> ITname (_PK_ word) : lexIface rest ;
 268           Just xx -> xx                 : lexIface rest
 269         }}
 270       where
 271         is_word_sym '_' = True
 272         is_word_sym c   = isAlphanum c
 273
 274         keywordsFM :: FiniteMap String IfaceToken
 275         keywordsFM = listToFM [
 276             ("interface",        ITinterface)
 277
 278            ,("__versions__",     ITversions)
 279            ,("__exports__",      ITexports)
 280            ,("__instance_modules__", ITinstance_modules)
 281            ,("__instances__",    ITinstances)
 282            ,("__declarations__", ITdeclarations)
 283            ,("__pragmas__",      ITpragmas)
 284
 285            ,("data",             ITdata)
 286            ,("class",            ITclass)
 287            ,("where",            ITwhere)
 288            ,("instance",         ITinstance)
 289            ]
 290 }