+{
+#include "HsVersions.h"
+
+module ParseIface (
+ parseIface,
+
+ ParsedIface(..), RdrIfaceDecl(..),
+
+ ExportsMap(..), LocalDefsMap(..), LocalPragmasMap(..),
+ LocalVersionsMap(..), PragmaStuff(..)
+
+ ) where
+
+import Ubiq{-uitous-}
+
+import HsSyn ( ClassDecl, InstDecl, TyDecl, PolyType, InPat, Fake )
+import RdrHsSyn ( RdrNameTyDecl(..), RdrNameClassDecl(..),
+ RdrNamePolyType(..), RdrNameInstDecl(..)
+ )
+import FiniteMap ( emptyFM, listToFM, fmToList, lookupFM, keysFM, FiniteMap )
+import Name ( ExportFlag(..) )
+import Util ( startsWith )
+-----------------------------------------------------------------
+
+parseIface = parseIToks . lexIface
+
+type LocalVersionsMap = FiniteMap FAST_STRING Version
+type ExportsMap = FiniteMap FAST_STRING (RdrName, ExportFlag)
+type LocalDefsMap = FiniteMap FAST_STRING RdrIfaceDecl
+type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
+
+type PragmaStuff = String
+
+data ParsedIface
+ = ParsedIface
+ Module -- Module name
+ Version -- Module version number
+ (Maybe Version) -- Source version number
+ LocalVersionsMap -- Local version numbers
+ ExportsMap -- Exported names
+ [Module] -- Special instance modules
+ LocalDefsMap -- Local names defined
+ [RdrIfaceDecl] -- Local instance declarations
+ LocalPragmasMap -- Pragmas for local names
+
+{-
+instance Text ParsedIface where
+ showsPrec _ (ParsedIface m v mv lcm exm ims ldm lids ldp)
+ = showString "interface "
+ . showString (_UNPK_ m)
+ . showChar ' '
+ . showInt v
+ . showString "\n__versions__\n"
+ . showList (fmToList lcm)
+ . showString "\n__exports__\n"
+ . showList (fmToList exm)
+ . showString "\n__instance_modules__\n"
+ . showList (map _UNPK_ ims)
+ . showString "\n__declarations__\n"
+ . showList (map _UNPK_ (keysFM ldm))
+ . showString "\n__instances__\n"
+ . showList lids
+ . showString "\n__pragmas__\n"
+ . showList (map _UNPK_ (keysFM ldp))
+-}
+
+-----------------------------------------------------------------
+
+data RdrIfaceDecl
+ = TypeSig RdrName Bool SrcLoc RdrNameTyDecl
+ | NewTypeSig RdrName RdrName Bool SrcLoc RdrNameTyDecl
+ | DataSig RdrName [RdrName] Bool SrcLoc RdrNameTyDecl
+ | ClassSig RdrName [RdrName] Bool SrcLoc RdrNameClassDecl
+ | ValSig RdrName Bool SrcLoc RdrNamePolyType
+ | InstSig RdrName RdrName Bool SrcLoc RdrNameInstDecl
+ -- True => Source Iface decl
+-----------
+type Version = Int
+
+-----------------------------------------------------------------
+}
+
+%name parseIToks
+%tokentype { IfaceToken }
+
+%token
+ interface { ITinterface }
+ versions_part { ITversions }
+ exports_part { ITexports }
+ instance_modules_part { ITinstance_modules }
+ instances_part { ITinstances }
+ declarations_part { ITdeclarations }
+ pragmas_part { ITpragmas }
+ data { ITdata }
+ type { ITtype }
+ newtype { ITnewtype }
+ class { ITclass }
+ where { ITwhere }
+ instance { ITinstance }
+ bar { ITbar }
+ colons { ITcolons }
+ comma { ITcomma }
+ dblrarrow { ITdblrarrow }
+ dot { ITdot }
+ dotdot { ITdotdot }
+ equal { ITequal }
+ lbrace { ITlbrace }
+ lbrack { ITlbrack }
+ lparen { ITlparen }
+ rarrow { ITrarrow }
+ rbrace { ITrbrace }
+ rbrack { ITrbrack }
+ rparen { ITrparen }
+ semicolon { ITsemicolon }
+ num { ITnum $$ }
+ name { ITname $$ }
+%%
+
+Iface :: { ParsedIface }
+Iface : interface name num
+ VersionsPart ExportsPart InstanceModulesPart
+ DeclsPart InstancesPart PragmasPart
+ { ParsedIface $2 (fromInteger $3) Nothing{-src version-}
+ $4 -- local versions
+ $5 -- exports map
+ $6 -- instance modules
+ $7 -- decls map
+ $8 -- local instances
+ $9 -- pragmas map
+ }
+
+VersionsPart :: { LocalVersionsMap }
+VersionsPart : versions_part NameVersionPairs
+ { listToFM $2 }
+
+NameVersionPairs :: { [(FAST_STRING, Int)] }
+NameVersionPairs : NameVersionPairs name lparen num rparen
+ { ($2, fromInteger $4) : $1 }
+ | { [] }
+
+ExportsPart :: { ExportsMap }
+ExportsPart : exports_part ExportItems
+ { listToFM $2 }
+
+ExportItems :: { [(FAST_STRING, (RdrName, ExportFlag))] }
+ExportItems : ExportItems name dot name MaybeDotDot
+ { ($4, (Qual $2 $4, $5)) : $1 }
+ | { [] }
+
+MaybeDotDot :: { ExportFlag }
+MaybeDotDot : dotdot { ExportAll }
+ | { ExportAbs }
+
+InstanceModulesPart :: { [Module] }
+InstanceModulesPart : instance_modules_part ModList
+ { $2 }
+
+ModList :: { [Module] }
+ModList : ModList name { $2 : $1 }
+ | { [] }
+
+DeclsPart :: { LocalDefsMap }
+DeclsPart : declarations_part
+ { emptyFM }
+
+InstancesPart :: { [RdrIfaceDecl] }
+InstancesPart : instances_part
+ { [] }
+
+PragmasPart :: { LocalPragmasMap }
+PragmasPart : pragmas_part
+ { emptyFM }
+{
+-----------------------------------------------------------------
+happyError :: Int -> [IfaceToken] -> a
+happyError i _ = error ("Parse error in line " ++ show i ++ "\n")
+
+-----------------------------------------------------------------
+data IfaceToken
+ = ITinterface -- keywords
+ | ITversions
+ | ITexports
+ | ITinstance_modules
+ | ITinstances
+ | ITdeclarations
+ | ITpragmas
+ | ITdata
+ | ITtype
+ | ITnewtype
+ | ITclass
+ | ITwhere
+ | ITinstance
+ | ITbar -- magic symbols
+ | ITcolons
+ | ITcomma
+ | ITdblrarrow
+ | ITdot
+ | ITdotdot
+ | ITequal
+ | ITlbrace
+ | ITlbrack
+ | ITlparen
+ | ITrarrow
+ | ITrbrace
+ | ITrbrack
+ | ITrparen
+ | ITsemicolon
+ | ITnum Integer -- numbers and names
+ | ITname FAST_STRING
+
+-----------------------------------------------------------------
+lexIface :: String -> [IfaceToken]
+
+lexIface str
+ = case str of
+ [] -> []
+
+ -- whitespace and comments
+ ' ' : cs -> lexIface cs
+ '\t' : cs -> lexIface cs
+ '\n' : cs -> lexIface cs
+ '-' : '-' : cs -> lex_comment cs
+ '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
+
+ '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
+ '(' : cs -> ITlparen : lexIface cs
+ ')' : cs -> ITrparen : lexIface cs
+ '[' : cs -> ITlbrack : lexIface cs
+ ']' : cs -> ITrbrack : lexIface cs
+ '{' : cs -> ITlbrace : lexIface cs
+ '}' : cs -> ITrbrace : lexIface cs
+ '-' : '>' : cs -> ITrarrow : lexIface cs
+ '.' : cs -> ITdot : lexIface cs
+ '|' : cs -> ITbar : lexIface cs
+ ':' : ':' : cs -> ITcolons : lexIface cs
+ '=' : '>' : cs -> ITdblrarrow : lexIface cs
+ '=' : cs -> ITequal : lexIface cs
+ ',' : cs -> ITcomma : lexIface cs
+ ';' : cs -> ITsemicolon : lexIface cs
+
+ '_' : cs -> lex_word str
+ c : cs | isDigit c -> lex_num str
+ | isAlpha c -> lex_word str
+
+ other -> error ("lexing:"++other)
+ where
+ lex_comment str
+ = case (span ((/=) '\n') str) of { (junk, rest) ->
+ lexIface rest }
+
+ lex_nested_comment lvl [] = error "EOF in nested comment in interface"
+ lex_nested_comment lvl str
+ = case str of
+ '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
+ '-' : '}' : xs -> if lvl == 1
+ then lexIface xs
+ else lex_nested_comment (lvl-1) xs
+ _ : xs -> lex_nested_comment lvl xs
+
+ lex_num str
+ = case (span isDigit str) of { (num, rest) ->
+ ITnum (read num) : lexIface rest }
+
+ lex_word str
+ = case (span is_word_sym str) of { (word, rest) ->
+ case (lookupFM keywordsFM word) of {
+ Nothing -> ITname (_PK_ word) : lexIface rest ;
+ Just xx -> xx : lexIface rest
+ }}
+ where
+ is_word_sym '_' = True
+ is_word_sym c = isAlphanum c
+
+ keywordsFM :: FiniteMap String IfaceToken
+ keywordsFM = listToFM [
+ ("interface", ITinterface)
+
+ ,("__versions__", ITversions)
+ ,("__exports__", ITexports)
+ ,("__instance_modules__", ITinstance_modules)
+ ,("__instances__", ITinstances)
+ ,("__declarations__", ITdeclarations)
+ ,("__pragmas__", ITpragmas)
+
+ ,("data", ITdata)
+ ,("class", ITclass)
+ ,("where", ITwhere)
+ ,("instance", ITinstance)
+ ]
+}