content: {-# OPTIONS_GHC -pgmF drift-ghc -F #-}
  module FrontEnd.HsSyn where
  
  import Data.Binary
  import Data.Generics
  
  import C.FFI
  import FrontEnd.SrcLoc
  import Name.Name
  import Name.Names
  import Options
  import StringTable.Atom
  import StringTable.Atom()
  
  instance HasLocation HsAlt where
      srcLoc (HsAlt sl _ _ _) = sl
  
  instance HasLocation HsExp where
      srcLoc (HsCase _ xs) = srcLoc xs
      srcLoc (HsExpTypeSig sl _ _) = sl
      srcLoc (HsLambda sl _ _) = sl
      srcLoc HsError { hsExpSrcLoc = sl } = sl
      srcLoc _ = bogusASrcLoc
  
  hsNameIdent_u f n = mapName (id,f) n
  hsIdentString_u f x = f x
  
  type HsName = Name
  
  instance Binary Module where
      get = do
          ps <- get
          return (Module $ fromAtom ps)
      put (Module n) = put (toAtom n)
  
  instance HasLocation HsModule where
      srcLoc x = hsModuleSrcLoc x
  
  data HsModule = HsModule {
      hsModuleName    :: Module,
      hsModuleSrcLoc  :: SrcLoc,
      hsModuleExports :: (Maybe [HsExportSpec]),
      hsModuleImports :: [HsImportDecl],
      hsModuleDecls   :: [HsDecl],
      hsModuleOptions :: [String],
      hsModuleOpt     :: Opt
      }
    {-! derive: update !-}
  
  -- Export/Import Specifications
  
  data HsExportSpec
      = HsEVar HsName                      -- variable
      | HsEAbs HsName                      -- T
      | HsEThingAll HsName                 -- T(..)
      | HsEThingWith HsName [HsName]       -- T(C_1,...,C_n)
      | HsEModuleContents Module           -- module M   (not for imports)
      | HsEQualified NameType HsExportSpec -- class Foo, type Bar, kind ANY
    deriving(Eq,Show)
  
  instance HasLocation HsImportDecl where
      srcLoc x = hsImportDeclSrcLoc x
  
  data HsImportDecl = HsImportDecl {
      hsImportDeclSrcLoc    :: SrcLoc,
      hsImportDeclModule    :: Module,
      hsImportDeclQualified :: !Bool,
      hsImportDeclAs        :: (Maybe Module),
      hsImportDeclSpec      :: (Maybe (Bool,[HsExportSpec]))
      }
    deriving(Eq,Show)
  
  data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight
    deriving(Eq,Show)
    {-! derive: Binary !-}
  
  instance HasLocation HsDecl where
      srcLoc HsTypeDecl	  { hsDeclSrcLoc = sl } = sl
      srcLoc HsTypeFamilyDecl { hsDeclSrcLoc = sl } = sl
      srcLoc HsDeclDeriving { hsDeclSrcLoc = sl } = sl
      srcLoc HsSpaceDecl    { hsDeclSrcLoc = sl } = sl
      srcLoc HsDataDecl	  { hsDeclSrcLoc = sl } = sl
      srcLoc HsInfixDecl    { hsDeclSrcLoc = sl } = sl
      srcLoc HsPragmaSpecialize { hsDeclSrcLoc = sl } = sl
      srcLoc (HsPragmaRules rs) = srcLoc rs
      srcLoc HsForeignDecl  { hsDeclSrcLoc = sl } = sl
      srcLoc HsActionDecl   { hsDeclSrcLoc = sl } = sl
      srcLoc (HsForeignExport sl _ _ _) = sl
      srcLoc (HsClassDecl	 sl _ _) = sl
      srcLoc HsClassAliasDecl { hsDeclSrcLoc = sl } = sl
      srcLoc (HsInstDecl	 sl _ _) = sl
      srcLoc (HsDefaultDecl sl _) = sl
      srcLoc (HsTypeSig	 sl _ _) = sl
      srcLoc (HsFunBind     ms) = srcLoc ms
      srcLoc (HsPatBind	 sl _ _ _) = sl
      srcLoc (HsPragmaProps sl _ _) = sl
  
  instance HasLocation HsRule where
      srcLoc HsRule { hsRuleSrcLoc = sl } = sl
  
  hsDataDecl = HsDataDecl {
      hsDeclDeclType = DeclTypeData,
      hsDeclSrcLoc = bogusASrcLoc,
      hsDeclContext = [],
      hsDeclName = error "hsDataDecl.hsDeclName",
      hsDeclArgs = [],
      hsDeclCons = [],
      hsDeclHasKind = Nothing,
      hsDeclCTYPE = Nothing,
      hsDeclDerives = []
      }
  
  hsNewTypeDecl = hsDataDecl {
      hsDeclDeclType = DeclTypeNewtype,
      hsDeclName = error "hsNewTypeDecl.hsDeclName"
      }
  
  data DeclType = DeclTypeData | DeclTypeNewtype | DeclTypeKind
      deriving(Eq,Show)
  
  data HsDecl
      = HsTypeFamilyDecl {
          hsDeclSrcLoc  :: SrcLoc,
          hsDeclData    :: !Bool,
          hsDeclName    :: HsName,
          hsDeclTArgs   :: [HsType],
          hsDeclHasKind :: Maybe HsKind
          }
      | HsTypeDecl	 {
          hsDeclSrcLoc :: SrcLoc,
          hsDeclName   :: HsName,
          hsDeclTArgs  :: [HsType],
          hsDeclType   :: HsType
          }
      | HsDataDecl	 {
          hsDeclDeclType :: !DeclType,
          hsDeclSrcLoc   :: SrcLoc,
          hsDeclContext  :: HsContext,
          hsDeclName     :: HsName,
          hsDeclArgs     :: [Name],
          hsDeclCons     :: [HsConDecl],
          hsDeclHasKind  :: Maybe HsKind,
          hsDeclCTYPE    :: Maybe String,
          {- deriving -} hsDeclDerives :: [HsName]
          }
      | HsInfixDecl   {
          hsDeclSrcLoc :: SrcLoc,
          hsDeclAssoc  :: HsAssoc,
          hsDeclInt    :: !Int,
          hsDeclNames  :: [HsName]
          }
      | HsClassDecl   {
          hsDeclSrcLoc    :: SrcLoc,
          hsDeclClassHead :: HsClassHead,
          hsDeclDecls     :: [HsDecl]
          }
      | HsClassAliasDecl {
          hsDeclSrcLoc   :: SrcLoc,
          hsDeclName     :: HsName,
          hsDeclTypeArgs :: [HsType],
          {- rhs -} hsDeclContext :: HsContext,
                    hsDeclClasses :: HsContext,
          hsDeclDecls :: [HsDecl]
          }
      | HsInstDecl    {
          hsDeclSrcLoc    :: SrcLoc,
          hsDeclClassHead :: HsClassHead,
          hsDeclDecls     :: [HsDecl]
          }
      | HsDefaultDecl SrcLoc HsType
      | HsTypeSig	 SrcLoc [HsName] HsQualType
      | HsFunBind  [HsMatch]
      | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]
      | HsActionDecl {
          hsDeclSrcLoc   :: SrcLoc,
          hsDeclPat      :: HsPat,
          hsDeclExp      :: HsExp
          }
      | HsSpaceDecl {
          hsDeclSrcLoc   :: SrcLoc,
          hsDeclName     :: HsName,
          hsDeclExp      :: HsExp,
          hsDeclCName    :: Maybe String,
          hsDeclCount    :: Int,
          hsDeclQualType :: HsQualType
          }
      | HsForeignDecl {
          hsDeclSrcLoc   :: SrcLoc,
          hsDeclForeign  :: FfiSpec,
          hsDeclName     :: HsName,
          hsDeclQualType :: HsQualType
          }
      | HsForeignExport {
          hsDeclSrcLoc :: SrcLoc,
          hsDeclFFIExport :: FfiExport,
          hsDeclName :: HsName,
          hsDeclQualType ::HsQualType
          }
      | HsPragmaProps SrcLoc String [HsName]
      | HsPragmaRules [HsRule]
      | HsPragmaSpecialize {
          hsDeclUniq   :: (Module,Int),
          hsDeclSrcLoc :: SrcLoc,
          hsDeclBool   :: Bool,
          hsDeclName   :: HsName,
          hsDeclType   :: HsType
          }
      | HsDeclDeriving {
          hsDeclSrcLoc    :: SrcLoc,
          hsDeclClassHead :: HsClassHead
          }
    deriving(Eq,Show)
    {-! derive: is !-}
  
  data HsRule = HsRule {
      hsRuleUniq      :: (Module,Int),
      hsRuleSrcLoc    :: SrcLoc,
      hsRuleIsMeta    :: Bool,
      hsRuleString    :: String,
      hsRuleFreeVars  :: [(HsName,Maybe HsType)],
      hsRuleLeftExpr  :: HsExp,
      hsRuleRightExpr :: HsExp
      }
    deriving(Eq,Show)
  
  data HsPragmaExp = HsPragmaExp String [HsExp]
  
  instance HasLocation HsMatch where
      srcLoc (HsMatch sl _ _ _ _) = sl
  
  data HsMatch = HsMatch {
      hsMatchSrcLoc :: SrcLoc,
      hsMatchName   :: HsName,
      hsMatchPats   :: [HsPat],
      hsMatchRhs    :: HsRhs,
      {-where-} hsMatchDecls :: [HsDecl]
      }
    deriving(Eq,Show)
  
  data HsConDecl
      = HsConDecl {
          hsConDeclSrcLoc :: SrcLoc,
          hsConDeclExists :: [HsTyVarBind],
          hsConDeclName   :: HsName,
          hsConDeclConArg :: [HsBangType]
          }
      | HsRecDecl {
          hsConDeclSrcLoc :: SrcLoc,
          hsConDeclExists :: [HsTyVarBind],
          hsConDeclName   :: HsName,
          hsConDeclRecArg :: [([HsName],HsBangType)]
          }
    deriving(Eq,Show)
    {-! derive: is, update !-}
  
  hsConDeclArgs HsConDecl { hsConDeclConArg = as } = as
  hsConDeclArgs HsRecDecl { hsConDeclRecArg = as } = concat [ replicate (length ns) t | (ns,t) <- as]
  
  data HsBangType
  	 = HsBangedTy   { hsBangType :: HsType }
  	 | HsUnBangedTy { hsBangType :: HsType }
    deriving(Eq,Show)
  
  data HsRhs
  	 = HsUnGuardedRhs HsExp
  	 | HsGuardedRhss  [HsGuardedRhs]
    deriving(Eq,Show)
  
  data HsGuardedRhs = HsGuardedRhs SrcLoc HsExp HsExp
    deriving(Eq,Show)
  
  data HsQualType = HsQualType {
      hsQualTypeContext :: HsContext,
      hsQualTypeType :: HsType
      } deriving(Data,Typeable,Eq,Ord,Show)
    {-! derive: Binary !-}
  
  type LHsType = Located HsType
  
  data HsType
      = HsTyFun HsType HsType
      | HsTyTuple [HsType]
      | HsTyUnboxedTuple [HsType]
      | HsTyApp HsType HsType
      | HsTyVar { hsTypeName :: HsName }
      | HsTyCon { hsTypeName :: HsName }
      | HsTyForall {
         hsTypeVars :: [HsTyVarBind],
         hsTypeType :: HsQualType }
      | HsTyExists {
         hsTypeVars :: [HsTyVarBind],
         hsTypeType :: HsQualType }
      | HsTyExpKind {
          hsTyLType :: LHsType,
          hsTyKind :: HsKind }
      | HsTyStrictType {
          hsTyStrict :: !Bool,
          hsTyLType :: LHsType
      }
      -- the following is used internally
      | HsTyAssoc
      | HsTyEq HsType HsType
    deriving(Data,Typeable,Eq,Ord,Show)
    {-! derive: Binary, is !-}
  
  data HsTyVarBind = HsTyVarBind {
      hsTyVarBindSrcLoc :: SrcLoc,
      hsTyVarBindName :: HsName,
      hsTyVarBindKind :: Maybe HsKind }
    deriving(Data,Typeable,Eq,Ord,Show)
    {-! derive: Binary, update !-}
  
  hsTyVarBind = HsTyVarBind {
      hsTyVarBindSrcLoc = bogusASrcLoc,
      hsTyVarBindName = undefined,
      hsTyVarBindKind = Nothing
      }
  
  instance HasLocation HsTyVarBind where
      srcLoc = hsTyVarBindSrcLoc
  
  type HsContext = [HsAsst]
  
  data HsAsst = HsAsst HsName [HsName] | HsAsstEq HsType HsType
    deriving(Data,Typeable,Eq,Ord, Show)
      {-! derive: Binary !-}
  
  data HsLiteral
  	= HsInt		!Integer
  	| HsChar	!Char
  	| HsString	String
  	| HsFrac	Rational
  	-- GHC unboxed literals:
  	| HsCharPrim	Char
  	| HsStringPrim	String
  	| HsIntPrim	Integer
  	| HsFloatPrim	Rational
  	| HsDoublePrim	Rational
  	-- GHC extension:
  	| HsLitLit	String
    deriving(Eq,Ord, Show)
      {-! derive: is !-}
  
  hsParen x@HsVar {} = x
  hsParen x@HsCon {} = x
  hsParen x@HsParen {} = x
  hsParen x@HsLit {} = x
  hsParen x@HsTuple {} = x
  hsParen x@HsUnboxedTuple {} = x
  hsParen x = HsParen x
  
  data HsErrorType
      = HsErrorPatternFailure
      | HsErrorSource
      | HsErrorFieldSelect
      | HsErrorUnderscore
      | HsErrorUninitializedField
      | HsErrorRecordUpdate
   deriving(Eq,Show)
  
  type LHsExp = Located HsExp
  
  data HsExp
  	= HsVar { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName }
  	| HsCon { {-hsExpSrcSpan :: SrcSpan,-} hsExpName :: HsName }
  	| HsLit HsLiteral
  	| HsInfixApp HsExp HsExp HsExp
  	| HsApp HsExp HsExp
  	| HsNegApp HsExp
  	| HsLambda SrcLoc [HsPat] HsExp
  	| HsLet [HsDecl] HsExp
  	| HsIf HsExp HsExp HsExp
  	| HsCase HsExp [HsAlt]
  	| HsDo { hsExpStatements :: [HsStmt] }
  	| HsTuple [HsExp]
  	| HsUnboxedTuple [HsExp]
  	| HsList [HsExp]
  	| HsParen HsExp
  	| HsLeftSection HsExp HsExp
  	| HsRightSection HsExp HsExp
  	| HsRecConstr HsName [HsFieldUpdate]
  	| HsRecUpdate HsExp [HsFieldUpdate]
  	| HsEnumFrom HsExp
  	| HsEnumFromTo HsExp HsExp
  	| HsEnumFromThen HsExp HsExp
  	| HsEnumFromThenTo HsExp HsExp HsExp
  	| HsListComp HsExp [HsStmt]
  	| HsExpTypeSig SrcLoc HsExp HsQualType
  	| HsAsPat { hsExpName :: HsName, hsExpExp :: HsExp }
          | HsError { hsExpSrcLoc :: SrcLoc, hsExpErrorType :: HsErrorType, hsExpString :: String }
  	| HsWildCard SrcLoc
  	| HsIrrPat { hsExpLExp :: LHsExp }
  	| HsBangPat { hsExpLExp :: LHsExp }
          | HsLocatedExp LHsExp
   deriving(Eq,Show)
      {-! derive: is, update !-}
  
  data HsClassHead = HsClassHead {
      hsClassHeadContext :: HsContext,
      hsClassHead :: HsName,
      hsClassHeadArgs :: [HsType] }
   deriving(Eq,Show)
      {-! derive: update !-}
  
  type LHsPat = Located HsPat
  
  data HsPat
  	= HsPVar { hsPatName :: HsName }
  	| HsPLit { hsPatLit :: HsLiteral }
  	| HsPNeg HsPat
  	| HsPInfixApp HsPat HsName HsPat
  	| HsPApp { hsPatName :: HsName, hsPatPats :: [HsPat] }
  	| HsPTuple [HsPat]
  	| HsPUnboxedTuple [HsPat]
  	| HsPList [HsPat]
  	| HsPParen HsPat
  	| HsPRec HsName [HsPatField]
  	| HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat }
  	| HsPWildCard
  	| HsPIrrPat { hsPatLPat :: LHsPat }
  	| HsPBangPat { hsPatLPat :: LHsPat }
  	| HsPTypeSig SrcLoc HsPat HsQualType  -- scoped type variable extension
   deriving(Eq,Ord,Show)
   {-! derive: is !-}
  
  data HsPatField = HsPFieldPat HsName HsPat
      deriving(Eq,Ord,Show)
  
  data HsStmt
  	= HsGenerator SrcLoc HsPat HsExp       -- srcloc added by bernie
  	| HsQualifier HsExp
  	| HsLetStmt [HsDecl]
   deriving(Eq,Show)
  
  data HsFieldUpdate = HsFieldUpdate HsName HsExp
    deriving(Eq,Show)
  
  data HsAlt = HsAlt SrcLoc HsPat HsRhs [HsDecl]
    deriving(Eq,Show)
  
  data HsKind = HsKind HsName | HsKindFn HsKind HsKind
    deriving(Data,Typeable,Eq,Ord,Show)
    {-! derive: Binary !-}
  
  hsKindStar = HsKind s_Star
  hsKindHash = HsKind s_Hash
  hsKindBang = HsKind s_Bang
  hsKindQuest = HsKind s_Quest
  hsKindQuestQuest = HsKind s_QuestQuest
  hsKindStarBang = HsKind s_StarBang
  