ghc/compiler/reader/Lex.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Lexical analysis]{Lexical analysis}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Lex (
  10
  11         isLexCon, isLexVar, isLexId, isLexSym,
  12         isLexConId, isLexConSym, isLexVarId, isLexVarSym,
  13         mkTupNameStr,
  14
  15         -- Monad for parser
  16         IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError
  17
  18     ) where
  19
  20
  21 IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
  22
  23 import Demand           ( Demand {- instance Read -} )
  24 import FiniteMap        ( FiniteMap, listToFM, lookupFM )
  25 import Maybes           ( Maybe(..), MaybeErr(..) )
  26 import Pretty
  27 import CharSeq          ( CSeq )
  28 import ErrUtils         ( Error(..) )
  29 import Outputable       ( Outputable(..) )
  30 import PprStyle         ( PprStyle(..) )
  31 import Util             ( nOfThem, panic )
  32
  33 \end{code}
  34
  35 %************************************************************************
  36 %*                                                                      *
  37 \subsection{Lexical categories}
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 These functions test strings to see if they fit the lexical categories
  42 defined in the Haskell report.  Normally applied as in e.g. @isCon
  43 (getLocalName foo)@.
  44
  45 \begin{code}
  46 isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
  47  isLexVarId, isLexVarSym  :: FAST_STRING -> Bool
  48
  49 isLexCon cs = isLexConId  cs || isLexConSym cs
  50 isLexVar cs = isLexVarId  cs || isLexVarSym cs
  51
  52 isLexId  cs = isLexConId  cs || isLexVarId  cs
  53 isLexSym cs = isLexConSym cs || isLexVarSym cs
  54
  55 -------------
  56
  57 isLexConId cs
  58   | _NULL_ cs        = False
  59   | cs == SLIT("[]") = True
  60   | c  == '('        = True     -- (), (,), (,,), ...
  61   | otherwise        = isUpper c || isUpperISO c
  62   where
  63     c = _HEAD_ cs
  64
  65 isLexVarId cs
  66   | _NULL_ cs    = False
  67   | otherwise    = isLower c || isLowerISO c
  68   where
  69     c = _HEAD_ cs
  70
  71 isLexConSym cs
  72   | _NULL_ cs   = False
  73   | otherwise   = c  == ':'
  74                || cs == SLIT("->")
  75   where
  76     c = _HEAD_ cs
  77
  78 isLexVarSym cs
  79   | _NULL_ cs = False
  80   | otherwise = isSymbolASCII c
  81              || isSymbolISO c
  82   where
  83     c = _HEAD_ cs
  84
  85 -------------
  86 isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
  87 isSymbolISO   c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
  88 isUpperISO    c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
  89 isLowerISO    c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
  90 \end{code}
  91
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection{Tuple strings -- ugh!}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 \begin{code}
 100 mkTupNameStr 0 = SLIT("()")
 101 mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
 102 mkTupNameStr 2 = _PK_ "(,)"   -- not strictly necessary
 103 mkTupNameStr 3 = _PK_ "(,,)"  -- ditto
 104 mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
 105 mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
 106 \end{code}
 107
 108
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{Data types}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 \begin{code}
 117 data IfaceToken
 118   = ITinterface         -- keywords
 119   | ITusages
 120   | ITversions
 121   | ITexports
 122   | ITinstance_modules
 123   | ITinstances
 124   | ITfixities
 125   | ITdeclarations
 126   | ITpragmas
 127   | ITdata
 128   | ITtype
 129   | ITnewtype
 130   | ITderiving
 131   | ITclass
 132   | ITwhere
 133   | ITinstance
 134   | ITinfixl
 135   | ITinfixr
 136   | ITinfix
 137   | ITforall
 138   | ITbang              -- magic symbols
 139   | ITvbar
 140   | ITdcolon
 141   | ITcomma
 142   | ITdarrow
 143   | ITdotdot
 144   | ITequal
 145   | ITocurly
 146   | ITdccurly
 147   | ITdocurly
 148   | ITobrack
 149   | IToparen
 150   | ITrarrow
 151   | ITccurly
 152   | ITcbrack
 153   | ITcparen
 154   | ITsemi
 155   | ITinteger Integer   -- numbers and names
 156   | ITvarid   FAST_STRING
 157   | ITconid   FAST_STRING
 158   | ITvarsym  FAST_STRING
 159   | ITconsym  FAST_STRING
 160   | ITqvarid  (FAST_STRING,FAST_STRING)
 161   | ITqconid  (FAST_STRING,FAST_STRING)
 162   | ITqvarsym (FAST_STRING,FAST_STRING)
 163   | ITqconsym (FAST_STRING,FAST_STRING)
 164
 165         -- Stuff for reading unfoldings
 166   | ITarity | ITstrict | ITunfold
 167   | ITdemand [Demand] | ITbottom
 168   | ITlam | ITbiglam | ITcase | ITlet | ITletrec | ITin | ITof
 169   | ITcoerce_in | ITcoerce_out
 170   | ITchar Char | ITstring FAST_STRING
 171   deriving Text -- debugging
 172 \end{code}
 173
 174 %************************************************************************
 175 %*                                                                      *
 176 \subsection{The lexical analyser}
 177 %*                                                                      *
 178 %************************************************************************
 179
 180 \begin{code}
 181 lexIface :: String -> [IfaceToken]
 182
 183 lexIface input
 184   = _scc_ "Lexer"
 185     case input of
 186       []    -> []
 187
 188       -- whitespace and comments
 189       ' '       : cs -> lexIface cs
 190       '\t'      : cs -> lexIface cs
 191       '\n'      : cs -> lexIface cs
 192       '-' : '-' : cs -> lex_comment cs
 193
 194 -- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake?
 195 --    '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
 196
 197       '(' : '.' : '.' : ')' : cs -> ITdotdot    : lexIface cs
 198       '{'                   : cs -> ITocurly    : lexIface cs
 199       '}'                   : cs -> ITccurly    : lexIface cs
 200       '(' : ','             : cs -> lex_tuple Nothing cs
 201       '(' : ')'             : cs -> ITconid SLIT("()")  : lexIface cs
 202       '('                   : cs -> IToparen    : lexIface cs
 203       ')'                   : cs -> ITcparen    : lexIface cs
 204       '[' : ']'             : cs -> ITconid SLIT("[]")  : lexIface cs
 205       '['                   : cs -> ITobrack    : lexIface cs
 206       ']'                   : cs -> ITcbrack    : lexIface cs
 207       ','                   : cs -> ITcomma     : lexIface cs
 208       ':' : ':'             : cs -> ITdcolon    : lexIface cs
 209       ';'                   : cs -> ITsemi      : lexIface cs
 210       '\"'                  : cs -> case read input of
 211                                         ((str, rest) : _) -> ITstring (_PK_ (str::String)) : lexIface rest
 212       '\''                  : cs -> case read input of
 213                                         ((ch, rest) : _) -> ITchar ch : lexIface rest
 214
 215       '_' : 'S' : '_'       : cs -> ITstrict    : lex_demand cs
 216       '_'                   : cs -> lex_keyword cs
 217
 218       c : cs | isDigit c         -> lex_num  input
 219              | otherwise         -> lex_id input
 220
 221       other -> error ("lexing:"++other)
 222   where
 223     lex_comment str
 224       = case (span ((/=) '\n') str) of { (junk, rest) ->
 225         lexIface rest }
 226
 227     ------------------
 228     lex_demand (c:cs) | isSpace c = lex_demand cs
 229                       | otherwise = case readList (c:cs) of
 230                                         ((demand,rest) : _) -> ITdemand demand : lexIface rest
 231     -----------
 232     lex_num str
 233       = case (span isDigit str) of { (num, rest) ->
 234         ITinteger (read num) : lexIface rest }
 235
 236     ------------
 237     lex_keyword str
 238       = case (span is_kwd_mod_char str)    of { (kw, rest) ->
 239         case (lookupFM ifaceKeywordsFM kw) of
 240           Nothing -> panic ("lex_keyword:"++str)
 241           Just xx -> xx : lexIface rest
 242         }
 243
 244     is_kwd_mod_char '_' = True
 245     is_kwd_mod_char c   = isAlphanum c
 246
 247     -----------
 248     lex_tuple module_dot orig_cs = go 2 orig_cs
 249                  where
 250                    go n (',':cs) = go (n+1) cs
 251                    go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs
 252                    go n other    = panic ("lex_tuple" ++ orig_cs)
 253
 254         -- NB: ':' isn't valid inside an identifier, only at the start.
 255         -- otherwise we get confused by a::t!
 256     is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
 257
 258     lex_id cs = go [] cs
 259         where
 260           go xs (f  :cs) | is_kwd_mod_char f = go (f : xs) cs
 261           go xs ('.':cs) | not (null xs)     = lex_id2 (Just (_PK_ (reverse xs))) [] cs
 262           go xs cs                           = lex_id2 Nothing                    xs cs
 263
 264         -- Dealt with the Module.part
 265     lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs
 266     lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs
 267     lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs
 268     lex_id2 module_dot [] (':' : cs)     = lex_id3 module_dot [':'] cs
 269     lex_id2 module_dot xs cs             = lex_id3 module_dot xs cs
 270
 271         -- Dealt with [], (), : special cases
 272     lex_id3 module_dot xs (f:cs) | is_id_char f = lex_id3 module_dot (f : xs) cs
 273
 274     lex_id3 Nothing xs rest = case lookupFM haskellKeywordsFM rxs of
 275                                        Just kwd_token -> kwd_token          : lexIface rest
 276                                        other          -> (mk_var_token rxs) : lexIface rest
 277                             where
 278                                rxs = reverse xs
 279
 280     lex_id3 (Just m) xs rest = end_lex_id (Just m) (mk_var_token (reverse xs)) rest
 281
 282     mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n
 283                           | f == ':'              = ITconsym n
 284                           | isAlpha f             = ITvarid n
 285                           | otherwise             = ITvarsym n
 286                 where
 287                       n = _PK_ xs
 288
 289     end_lex_id (Just m) (ITconid n)  cs = ITqconid (m,n) : lexIface cs
 290     end_lex_id (Just m) (ITvarid n)  cs = ITqvarid (m,n) : lexIface cs
 291     end_lex_id (Just m) (ITconsym n) cs = ITqconsym (m,n): lexIface cs
 292     end_lex_id (Just m) (ITvarsym n) cs = ITqvarsym (m,n): lexIface cs
 293     end_lex_id (Just m) ITbang       cs = ITqvarsym (m,SLIT("!")) : lexIface cs
 294     end_lex_id (Just m) token        cs = panic ("end_lex_id:" ++ show token)
 295     end_lex_id Nothing  token        cs = token : lexIface cs
 296
 297     ------------
 298     ifaceKeywordsFM :: FiniteMap String IfaceToken
 299     ifaceKeywordsFM = listToFM [
 300         ("interface_",          ITinterface)
 301        ,("usages_",             ITusages)
 302        ,("versions_",           ITversions)
 303        ,("exports_",            ITexports)
 304        ,("instance_modules_",   ITinstance_modules)
 305        ,("instances_",          ITinstances)
 306        ,("fixities_",           ITfixities)
 307        ,("declarations_",       ITdeclarations)
 308        ,("pragmas_",            ITpragmas)
 309        ,("forall_",             ITforall)
 310        ,("U_",                  ITunfold)
 311        ,("A_",                  ITarity)
 312        ,("coerce_in_",          ITcoerce_in)
 313        ,("coerce_out_",         ITcoerce_out)
 314        ,("A_",                  ITarity)
 315        ,("A_",                  ITarity)
 316        ,("!_",                  ITbottom)
 317
 318        ]
 319
 320     haskellKeywordsFM = listToFM [
 321         ("data",                ITdata)
 322        ,("type",                ITtype)
 323        ,("newtype",             ITnewtype)
 324        ,("class",               ITclass)
 325        ,("where",               ITwhere)
 326        ,("instance",            ITinstance)
 327        ,("infixl",              ITinfixl)
 328        ,("infixr",              ITinfixr)
 329        ,("infix",               ITinfix)
 330        ,("case",                ITcase)
 331        ,("of",                  ITof)
 332        ,("in",                  ITin)
 333        ,("let",                 ITlet)
 334        ,("letrec",              ITletrec)
 335        ,("deriving",            ITderiving)
 336
 337        ,("->",                  ITrarrow)
 338        ,("\\",                  ITlam)
 339        ,("/\\",                 ITbiglam)
 340        ,("|",                   ITvbar)
 341        ,("!",                   ITbang)
 342        ,("=>",                  ITdarrow)
 343        ,("=",                   ITequal)
 344        ]
 345 \end{code}
 346
 347
 348 %************************************************************************
 349 %*                                                                      *
 350 \subsection{Other utility functions
 351 %*                                                                      *
 352 %************************************************************************
 353
 354 \begin{code}
 355 type IfM a = MaybeErr a Error
 356
 357 returnIf   :: a -> IfM a
 358 thenIf     :: IfM a -> (a -> IfM b) -> IfM b
 359 happyError :: Int -> [IfaceToken] -> IfM a
 360
 361 returnIf a = Succeeded a
 362
 363 thenIf (Succeeded a) k = k a
 364 thenIf (Failed  err) _ = Failed err
 365
 366 happyError ln toks = Failed (ifaceParseErr ln toks)
 367
 368 -----------------------------------------------------------------
 369
 370 ifaceParseErr ln toks sty
 371   = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
 372 \end{code}