    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Language.Haskell.Exts.Annotated.Simplify
    -- Copyright   :  (c) Niklas Broberg 2009
    -- License     :  BSD-style (see the file LICENSE.txt)
    --
    -- Maintainer  :  Niklas Broberg, d00nibro@chalmers.se
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- This module contains code for translating from the annotated
    -- complex AST in Language.Haskell.Exts.Annotated.Syntax
    -- to the simpler, sparsely annotated AST in Language.Haskell.Exts.Syntax.
    --
    -- A function @sXYZ@ translates an annotated AST node of type @XYZ l@ into
    -- a simple AST node of type @XYZ@. I would have prefered to use a MPTC
    -- with an fd/type family to get a single exported function name, but
    -- I wish to stay Haskell 2010 compliant. Let's hope for Haskell 2011.
    --
    -----------------------------------------------------------------------------
    module Language.Haskell.Exts.Annotated.Simplify where

    import Language.Haskell.Exts.Annotated.Syntax
    import qualified Language.Haskell.Exts.Syntax as S

    import Language.Haskell.Exts.SrcLoc

    -- | Translate an annotated AST node representing a Haskell module, into
    --   a simpler version that retains (almost) only abstract information.
    --   In particular, XML and hybrid XML pages enabled by the XmlSyntax extension
    --   are translated into standard Haskell modules with a @page@ function.
    sModule :: SrcInfo loc => Module loc -> S.Module
    sModule md = case md of
        Module l mmh oss ids ds ->
            let (mn, mwt, mes) = sModuleHead mmh
             in S.Module (getPointLoc l) mn (map sModulePragma oss) mwt mes (map sImportDecl ids) (map sDecl ds)
        XmlPage l mn oss xn attrs mat es   ->
            let loc = getPointLoc l
             in S.Module loc (sModuleName mn) (map sModulePragma oss)
                          Nothing
                          (Just [S.EVar $ S.UnQual $ S.Ident "page"])
                            []
                            [pageFun loc $ S.XTag loc (sXName xn) (map sXAttr attrs) (fmap sExp mat) (map sExp es)]
        XmlHybrid l mmh oss ids ds xn attrs mat es  ->
            let loc1 = getPointLoc l
                loc2 = getPointLoc (ann xn)
                (mn, mwt, mes) = sModuleHead mmh
             in S.Module loc1 mn (map sModulePragma oss) mwt mes (map sImportDecl ids)
                    (map sDecl ds ++ [pageFun loc2 $ S.XTag loc2 (sXName xn) (map sXAttr attrs) (fmap sExp mat) (map sExp es)])
      where pageFun :: SrcLoc -> S.Exp -> S.Decl
            pageFun loc e = S.PatBind loc namePat Nothing rhs (S.BDecls [])
                where namePat = S.PVar $ S.Ident "page"
                      rhs = S.UnGuardedRhs e

    -- | Translate an annotated AST node representing a Haskell declaration
    --   into a simpler version. Note that in the simpler version, all declaration
    --   nodes are still annotated by 'SrcLoc's.
    sDecl :: SrcInfo loc => Decl loc -> S.Decl
    sDecl decl = case decl of
         TypeDecl     l dh t        ->
            let (n, tvs) = sDeclHead dh
             in S.TypeDecl (getPointLoc l) n tvs (sType t)
         TypeFamDecl  l dh mk       ->
            let (n, tvs) = sDeclHead dh
             in S.TypeFamDecl (getPointLoc l) n tvs (fmap sKind mk)
         DataDecl     l dn mctxt dh constrs mder    ->
            let (n, tvs) = sDeclHead dh
             in S.DataDecl (getPointLoc l) (sDataOrNew dn) (maybe [] sContext mctxt) n tvs (map sQualConDecl constrs) (maybe [] sDeriving mder)
         GDataDecl    l dn mctxt dh mk gds mder     ->
            let (n, tvs) = sDeclHead dh
             in S.GDataDecl (getPointLoc l) (sDataOrNew dn) (maybe [] sContext mctxt) n tvs (fmap sKind mk) (map sGadtDecl gds) (maybe [] sDeriving mder)
         DataFamDecl  l mctxt dh mk ->
            let (n, tvs) = sDeclHead dh
             in S.DataFamDecl (getPointLoc l) (maybe [] sContext mctxt) n tvs (fmap sKind mk)
         TypeInsDecl  l t1 t2       -> S.TypeInsDecl (getPointLoc l) (sType t1) (sType t2)
         DataInsDecl  l dn t constrs mder           ->
            S.DataInsDecl (getPointLoc l) (sDataOrNew dn) (sType t) (map sQualConDecl constrs) (maybe [] sDeriving mder)
         GDataInsDecl l dn t mk gds mder            ->
            S.GDataInsDecl (getPointLoc l) (sDataOrNew dn) (sType t) (fmap sKind mk) (map sGadtDecl gds) (maybe [] sDeriving mder)
         ClassDecl    l mctxt dh fds mcds           ->
            let (n, tvs) = sDeclHead dh
             in S.ClassDecl (getPointLoc l) (maybe [] sContext mctxt) n tvs (map sFunDep fds) (maybe [] (map sClassDecl) mcds)
         InstDecl     l mctxt ih mids               ->
            let (qn, ts) = sInstHead ih
             in S.InstDecl (getPointLoc l) (maybe [] sContext mctxt) qn ts (maybe [] (map sInstDecl) mids)
         DerivDecl    l mctxt ih    ->
            let (qn, ts) = sInstHead ih
             in S.DerivDecl (getPointLoc l) (maybe [] sContext mctxt) qn ts
         InfixDecl    l ass prec ops    -> S.InfixDecl (getPointLoc l) (sAssoc ass) (maybe 9 id prec) (map sOp ops)
         DefaultDecl  l ts          -> S.DefaultDecl (getPointLoc l) (map sType ts)
         SpliceDecl   l sp          -> S.SpliceDecl (getPointLoc l) (sExp sp)
         TypeSig      l ns t        -> S.TypeSig (getPointLoc l) (map sName ns) (sType t)
         FunBind      _ ms          -> S.FunBind (map sMatch ms)
         PatBind      l p mt rhs mbs    ->
            S.PatBind (getPointLoc l) (sPat p) (fmap sType mt) (sRhs rhs) (maybe (S.BDecls []) sBinds mbs)
         ForImp       l cc msaf mstr n t    ->
            S.ForImp (getPointLoc l) (sCallConv cc) (maybe (S.PlaySafe False) sSafety msaf) (maybe "" id mstr) (sName n) (sType t)
         ForExp       l cc      mstr n t    ->
            S.ForExp (getPointLoc l) (sCallConv cc) (maybe "" id mstr) (sName n) (sType t)
         RulePragmaDecl   l rs      -> S.RulePragmaDecl (getPointLoc l) (map sRule rs)
         DeprPragmaDecl   l nsstrs  -> S.DeprPragmaDecl (getPointLoc l) (map (\(ns, str) -> (map sName ns, str)) nsstrs)
         WarnPragmaDecl   l nsstrs  -> S.WarnPragmaDecl (getPointLoc l) (map (\(ns, str) -> (map sName ns, str)) nsstrs)
         InlineSig        l b mact qn   -> S.InlineSig (getPointLoc l) b (maybe S.AlwaysActive sActivation mact) (sQName qn)
         InlineConlikeSig l   mact qn   -> S.InlineConlikeSig (getPointLoc l) (maybe S.AlwaysActive sActivation mact) (sQName qn)
         SpecSig          l qn ts   -> S.SpecSig (getPointLoc l) (sQName qn) (map sType ts)
         SpecInlineSig    l b mact qn ts    ->
            S.SpecInlineSig (getPointLoc l) b (maybe S.AlwaysActive sActivation mact) (sQName qn) (map sType ts)
         InstSig          l mctxt ih    ->
            let (qn, ts) = sInstHead ih
             in S.InstSig (getPointLoc l) (maybe [] sContext mctxt) qn ts
         AnnPragma        l ann         ->
            S.AnnPragma (getPointLoc l) (sAnnotation ann)

    sAnnotation :: SrcInfo loc => Annotation loc -> S.Annotation
    sAnnotation ann = case ann of
        Ann       _ n e   -> S.Ann     (sName n) (sExp e)
        TypeAnn   _ n e   -> S.TypeAnn (sName n) (sExp e)
        ModuleAnn _   e   -> S.ModuleAnn         (sExp e)

    sModuleName :: ModuleName l -> S.ModuleName
    sModuleName (ModuleName _ str)  = S.ModuleName str

    sSpecialCon :: SpecialCon l -> S.SpecialCon
    sSpecialCon sc = case sc of
        UnitCon _           -> S.UnitCon
        ListCon _           -> S.ListCon
        FunCon  _           -> S.FunCon
        TupleCon _ b k      -> S.TupleCon b k
        Cons _              -> S.Cons
        UnboxedSingleCon _  -> S.UnboxedSingleCon

    sQName :: QName l -> S.QName
    sQName qn = case qn of
        Qual    _ mn n  -> S.Qual (sModuleName mn) (sName n)
        UnQual  _    n  -> S.UnQual (sName n)
        Special _ sc    -> S.Special (sSpecialCon sc)

    sName :: Name l -> S.Name
    sName (Ident _ str) = S.Ident str
    sName (Symbol _ str) = S.Symbol str

    sIPName :: IPName l -> S.IPName
    sIPName (IPDup _ str) = S.IPDup str
    sIPName (IPLin _ str) = S.IPLin str

    sQOp :: QOp l -> S.QOp
    sQOp (QVarOp _ qn) = S.QVarOp (sQName qn)
    sQOp (QConOp _ qn) = S.QConOp (sQName qn)

    sOp :: Op l -> S.Op
    sOp (VarOp _ n) = S.VarOp (sName n)
    sOp (ConOp _ n) = S.ConOp (sName n)

    sCName :: CName l -> S.CName
    sCName (VarName _ n) = S.VarName (sName n)
    sCName (ConName _ n) = S.ConName (sName n)

    sModuleHead :: Maybe (ModuleHead l) -> (S.ModuleName, Maybe (S.WarningText), Maybe [S.ExportSpec])
    sModuleHead mmh = case mmh of
        Nothing -> (S.main_mod, Nothing, Just [S.EVar (S.UnQual S.main_name)])
        Just (ModuleHead _ mn mwt mel) -> (sModuleName mn, fmap sWarningText mwt, fmap sExportSpecList mel)

    sExportSpecList :: ExportSpecList l -> [S.ExportSpec]
    sExportSpecList (ExportSpecList _ ess) = map sExportSpec ess

    sExportSpec :: ExportSpec l -> S.ExportSpec
    sExportSpec es = case es of
        EVar _ qn           -> S.EVar (sQName qn)
        EAbs _ qn           -> S.EAbs (sQName qn)
        EThingAll _ qn      -> S.EThingAll (sQName qn)
        EThingWith _ qn cns -> S.EThingWith (sQName qn) (map sCName cns)
        EModuleContents _ mn    -> S.EModuleContents (sModuleName mn)

    sImportDecl :: SrcInfo loc => ImportDecl loc -> S.ImportDecl
    sImportDecl (ImportDecl l mn qu src mpkg as misl) =
        S.ImportDecl (getPointLoc l) (sModuleName mn) qu src mpkg (fmap sModuleName as) (fmap sImportSpecList misl)

    sImportSpecList :: ImportSpecList l -> (Bool, [S.ImportSpec])
    sImportSpecList (ImportSpecList _ b iss) = (b, map sImportSpec iss)

    sImportSpec :: ImportSpec l -> S.ImportSpec
    sImportSpec is = case is of
        IVar _ n            -> S.IVar (sName n)
        IAbs _ n            -> S.IAbs (sName n)
        IThingAll _ n       -> S.IThingAll (sName n)
        IThingWith _ n cns  -> S.IThingWith (sName n) (map sCName cns)

    sAssoc :: Assoc l -> S.Assoc
    sAssoc a = case a of
        AssocNone  _ -> S.AssocNone
        AssocLeft  _ -> S.AssocLeft
        AssocRight _ -> S.AssocRight

    sDeclHead :: DeclHead l -> (S.Name, [S.TyVarBind])
    sDeclHead dh = case dh of
        DHead _ n tvs       -> (sName n, map sTyVarBind tvs)
        DHInfix _ tva n tvb -> (sName n, map sTyVarBind [tva,tvb])
        DHParen _ dh        -> sDeclHead dh

    sInstHead :: InstHead l -> (S.QName, [S.Type])
    sInstHead ih = case ih of
        IHead _ qn ts      -> (sQName qn, map sType ts)
        IHInfix _ ta qn tb -> (sQName qn, map sType [ta,tb])
        IHParen _ ih       -> sInstHead ih

    sDataOrNew :: DataOrNew l -> S.DataOrNew
    sDataOrNew (DataType _) = S.DataType
    sDataOrNew (NewType _) = S.NewType

    sDeriving :: (Deriving l) -> [(S.QName, [S.Type])]
    sDeriving (Deriving _ ihs) = map sInstHead ihs

    sBinds :: SrcInfo loc => Binds loc -> S.Binds
    sBinds bs = case bs of
        BDecls  _ decls     -> S.BDecls (map sDecl decls)
        IPBinds _ ipbds     -> S.IPBinds (map sIPBind ipbds)

    sIPBind :: SrcInfo loc => IPBind loc -> S.IPBind
    sIPBind (IPBind l ipn e) = S.IPBind (getPointLoc l) (sIPName ipn) (sExp e)

    sMatch :: SrcInfo loc => Match loc -> S.Match
    sMatch (Match l n ps rhs mwhere) =
        S.Match (getPointLoc l) (sName n) (map sPat ps) Nothing (sRhs rhs) (maybe (S.BDecls []) sBinds mwhere)
    sMatch (InfixMatch l pa n pbs rhs mwhere) =
        S.Match (getPointLoc l) (sName n) (map sPat (pa:pbs)) Nothing (sRhs rhs) (maybe (S.BDecls []) sBinds mwhere)

    sQualConDecl :: SrcInfo loc => QualConDecl loc -> S.QualConDecl
    sQualConDecl (QualConDecl l mtvs mctxt cd) =
        S.QualConDecl (getPointLoc l) (maybe [] (map sTyVarBind) mtvs) (maybe [] sContext mctxt) (sConDecl cd)

    sConDecl :: ConDecl l -> S.ConDecl
    sConDecl cd = case cd of
        ConDecl _ n bts     -> S.ConDecl (sName n) (map sBangType bts)
        InfixConDecl _ bta n btb -> S.InfixConDecl (sBangType bta) (sName n) (sBangType btb)
        RecDecl _ n fds -> S.RecDecl (sName n) (map sFieldDecl fds)

    sFieldDecl :: FieldDecl l -> ([S.Name], S.BangType)
    sFieldDecl (FieldDecl _ ns bt) = (map sName ns, sBangType bt)

    sGadtDecl :: SrcInfo loc => GadtDecl loc -> S.GadtDecl
    sGadtDecl (GadtDecl l n t) = S.GadtDecl (getPointLoc l) (sName n) (sType t)

    sClassDecl :: SrcInfo loc => ClassDecl loc -> S.ClassDecl
    sClassDecl cd = case cd of
        ClsDecl _ d  -> S.ClsDecl (sDecl d)
        ClsDataFam l mctxt dh mk    ->
            let (n, tvs) = sDeclHead dh
             in S.ClsDataFam (getPointLoc l) (maybe [] sContext mctxt) n tvs (fmap sKind mk)
        ClsTyFam l dh mk    ->
            let (n, tvs) = sDeclHead dh
             in S.ClsTyFam (getPointLoc l) n tvs (fmap sKind mk)
        ClsTyDef l t1 t2    ->
            S.ClsTyDef (getPointLoc l) (sType t1) (sType t2)

    sInstDecl :: SrcInfo loc => InstDecl loc -> S.InstDecl
    sInstDecl id = case id of
        InsDecl   _ d   -> S.InsDecl (sDecl d)
        InsType   l t1 t2   -> S.InsType (getPointLoc l) (sType t1) (sType t2)
        InsData   l dn t constrs mder   ->
            S.InsData (getPointLoc l) (sDataOrNew dn) (sType t) (map sQualConDecl constrs) (maybe [] sDeriving mder)
        InsGData  l dn t mk gds mder    ->
            S.InsGData (getPointLoc l) (sDataOrNew dn) (sType t) (fmap sKind mk) (map sGadtDecl gds) (maybe [] sDeriving mder)
    --    InsInline l b mact qn   -> S.InsInline (getPointLoc l) b (maybe S.AlwaysActive sActivation mact) (sQName qn)

    sBangType :: BangType l -> S.BangType
    sBangType bt = case bt of
        BangedTy   _ t  -> S.BangedTy (sType t)
        UnBangedTy _ t  -> S.UnBangedTy (sType t)
        UnpackedTy _ t  -> S.UnpackedTy (sType t)

    sRhs :: SrcInfo loc => Rhs loc -> S.Rhs
    sRhs (UnGuardedRhs _ e) = S.UnGuardedRhs (sExp e)
    sRhs (GuardedRhss _ grhss) = S.GuardedRhss (map sGuardedRhs grhss)

    sGuardedRhs :: SrcInfo loc => GuardedRhs loc -> S.GuardedRhs
    sGuardedRhs (GuardedRhs l ss e) = S.GuardedRhs (getPointLoc l) (map sStmt ss) (sExp e)

    sType :: Type l -> S.Type
    sType t = case t of
        TyForall _ mtvs mctxt t     -> S.TyForall (fmap (map sTyVarBind) mtvs) (maybe [] sContext mctxt) (sType t)
        TyFun _ t1 t2               -> S.TyFun (sType t1) (sType t2)
        TyTuple _ bx ts             -> S.TyTuple bx (map sType ts)
        TyList _ t                  -> S.TyList (sType t)
        TyApp _ t1 t2               -> S.TyApp (sType t1) (sType t2)
        TyVar _ n                   -> S.TyVar (sName n)
        TyCon _ qn                  -> S.TyCon (sQName qn)
        TyParen _ t                 -> S.TyParen (sType t)
        TyInfix _ ta qn tb          -> S.TyInfix (sType ta) (sQName qn) (sType tb)
        TyKind _ t k                -> S.TyKind (sType t) (sKind k)

    sTyVarBind :: TyVarBind l -> S.TyVarBind
    sTyVarBind (KindedVar _ n k) = S.KindedVar (sName n) (sKind k)
    sTyVarBind (UnkindedVar _ n) = S.UnkindedVar (sName n)

    sKind :: Kind l -> S.Kind
    sKind k = case k of
        KindStar  _     -> S.KindStar
        KindBang  _     -> S.KindBang
        KindFn _ k1 k2  -> S.KindFn (sKind k1) (sKind k2)
        KindParen _ k   -> S.KindParen (sKind k)
        KindVar _ n     -> S.KindVar (sName n)

    sFunDep :: FunDep l -> S.FunDep
    sFunDep (FunDep _ as bs) = S.FunDep (map sName as) (map sName bs)

    sContext :: Context l -> S.Context
    sContext ctxt = case ctxt of
        CxSingle _ asst     -> [sAsst asst]
        CxTuple  _ assts    -> map sAsst assts
        CxParen  _ ct       -> sContext ct
        CxEmpty  _          -> []

    sAsst :: Asst l -> S.Asst
    sAsst asst = case asst of
        ClassA _ qn ts      -> S.ClassA (sQName qn) (map sType ts)
        InfixA _ ta qn tb   -> S.InfixA (sType ta) (sQName qn) (sType tb)
        IParam _ ipn t      -> S.IParam (sIPName ipn) (sType t)
        EqualP _ t1 t2      -> S.EqualP (sType t1) (sType t2)

    sLiteral :: Literal l -> S.Literal
    sLiteral lit = case lit of
        Char       _ c _ -> S.Char c
        String     _ s _ -> S.String s
        Int        _ i _ -> S.Int i
        Frac       _ r _ -> S.Frac r
        PrimInt    _ i _ -> S.PrimInt i
        PrimWord   _ i _ -> S.PrimWord i
        PrimFloat  _ r _ -> S.PrimFloat r
        PrimDouble _ r _ -> S.PrimDouble r
        PrimChar   _ c _ -> S.PrimChar c
        PrimString _ s _ -> S.PrimString s

    sExp :: SrcInfo loc => Exp loc -> S.Exp
    sExp e = case e of
        Var _ qn            -> S.Var (sQName qn)
        IPVar _ ipn         -> S.IPVar (sIPName ipn)
        Con _ qn            -> S.Con (sQName qn)
        Lit _ lit           -> S.Lit (sLiteral lit)
        InfixApp _ e1 op e2 -> S.InfixApp (sExp e1) (sQOp op) (sExp e2)
        App _ e1 e2         -> S.App (sExp e1) (sExp e2)
        NegApp _ e          -> S.NegApp (sExp e)
        Lambda l ps e       -> S.Lambda (getPointLoc l) (map sPat ps) (sExp e)
        Let _ bs e          -> S.Let (sBinds bs) (sExp e)
        If _ e1 e2 e3       -> S.If (sExp e1) (sExp e2) (sExp e3)
        Case _ e alts       -> S.Case (sExp e) (map sAlt alts)
        Do _ ss             -> S.Do (map sStmt ss)
        MDo _ ss            -> S.MDo (map sStmt ss)
        Tuple _ es          -> S.Tuple (map sExp es)
        TupleSection _ mes  -> S.TupleSection (map (fmap sExp) mes)
        List _ es           -> S.List (map sExp es)
        Paren _ e           -> S.Paren (sExp e)
        LeftSection _ e op  -> S.LeftSection (sExp e) (sQOp op)
        RightSection _ op e -> S.RightSection (sQOp op) (sExp e)
        RecConstr _ qn fups -> S.RecConstr (sQName qn) (map sFieldUpdate fups)
        RecUpdate _ e fups  -> S.RecUpdate (sExp e) (map sFieldUpdate fups)
        EnumFrom _ e        -> S.EnumFrom (sExp e)
        EnumFromTo _ e1 e2  -> S.EnumFromTo (sExp e1) (sExp e2)
        EnumFromThen _ e1 e2    -> S.EnumFromThen (sExp e1) (sExp e2)
        EnumFromThenTo _ e1 e2 e3   -> S.EnumFromThenTo (sExp e1) (sExp e2) (sExp e3)
        ListComp _ e qss    -> S.ListComp (sExp e) (map sQualStmt qss)
        ParComp  _ e qsss   -> S.ParComp (sExp e) (map (map sQualStmt) qsss)
        ExpTypeSig l e t    -> S.ExpTypeSig (getPointLoc l) (sExp e) (sType t)
        VarQuote _ qn       -> S.VarQuote (sQName qn)
        TypQuote _ qn       -> S.TypQuote (sQName qn)
        BracketExp _ br     -> S.BracketExp (sBracket br)
        SpliceExp _ sp      -> S.SpliceExp (sSplice sp)
        QuasiQuote _ nm qt  -> S.QuasiQuote nm qt
        XTag l xn attrs mat es  -> S.XTag  (getPointLoc l) (sXName xn) (map sXAttr attrs) (fmap sExp mat) (map sExp es)
        XETag l xn attrs mat    -> S.XETag (getPointLoc l) (sXName xn) (map sXAttr attrs) (fmap sExp mat)
        XPcdata _ str       -> S.XPcdata str
        XExpTag _ e         -> S.XExpTag (sExp e)
        CorePragma _ str e  -> S.CorePragma str (sExp e)
        SCCPragma  _ str e  -> S.SCCPragma  str (sExp e)
        GenPragma  _ str i12 i34 e  -> S.GenPragma str i12 i34 (sExp e)
        Proc            l p  e  -> S.Proc (getPointLoc l) (sPat p) (sExp e)
        LeftArrApp      _ e1 e2 -> S.LeftArrApp (sExp e1) (sExp e2)
        RightArrApp     _ e1 e2 -> S.RightArrApp (sExp e1) (sExp e2)
        LeftArrHighApp  _ e1 e2 -> S.LeftArrHighApp (sExp e1) (sExp e2)
        RightArrHighApp _ e1 e2 -> S.RightArrHighApp (sExp e1) (sExp e2)

    sXName :: XName l -> S.XName
    sXName (XName _ str) = S.XName str
    sXName (XDomName _ dom str) = S.XDomName dom str

    sXAttr :: SrcInfo loc => XAttr loc -> S.XAttr
    sXAttr (XAttr _ xn e) = S.XAttr (sXName xn) (sExp e)

    sBracket:: SrcInfo loc => Bracket loc -> S.Bracket
    sBracket br = case br of
        ExpBracket _ e  -> S.ExpBracket (sExp e)
        PatBracket _ p  -> S.PatBracket (sPat p)
        TypeBracket _ t -> S.TypeBracket (sType t)
        DeclBracket _ ds -> S.DeclBracket (map sDecl ds)

    sSplice :: SrcInfo loc => Splice loc -> S.Splice
    sSplice (IdSplice _ str) = S.IdSplice str
    sSplice (ParenSplice _ e) = S.ParenSplice (sExp e)

    sSafety :: Safety l -> S.Safety
    sSafety (PlayRisky _) = S.PlayRisky
    sSafety (PlaySafe _ b) = S.PlaySafe b

    sCallConv :: CallConv l -> S.CallConv
    sCallConv (StdCall _) = S.StdCall
    sCallConv (CCall _)   = S.CCall

    sModulePragma :: SrcInfo loc => ModulePragma loc -> S.ModulePragma
    sModulePragma pr = case pr of
        LanguagePragma   l ns   -> S.LanguagePragma (getPointLoc l) (map sName ns)
        OptionsPragma    l mt str -> S.OptionsPragma (getPointLoc l) mt str
        AnnModulePragma  l ann -> S.AnnModulePragma (getPointLoc l) (sAnnotation ann)

    sActivation :: Activation l -> S.Activation
    sActivation act = case act of
        ActiveFrom   _ k    -> S.ActiveFrom k
        ActiveUntil  _ k    -> S.ActiveUntil k

    sRule :: SrcInfo loc => Rule loc -> S.Rule
    sRule (Rule _ str mact mrvs e1 e2) =
        S.Rule str (maybe S.AlwaysActive sActivation mact) (fmap (map sRuleVar) mrvs) (sExp e1) (sExp e2)

    sRuleVar :: RuleVar l -> S.RuleVar
    sRuleVar (RuleVar _ n) = S.RuleVar (sName n)
    sRuleVar (TypedRuleVar _ n t) = S.TypedRuleVar (sName n) (sType t)

    sWarningText :: WarningText l -> S.WarningText
    sWarningText (DeprText _ str) = S.DeprText str
    sWarningText (WarnText _ str) = S.WarnText str

    sPat :: SrcInfo loc => Pat loc -> S.Pat
    sPat pat = case pat of
        PVar _ n            -> S.PVar (sName n)
        PLit _ lit          -> S.PLit (sLiteral lit)
        PNeg _ p            -> S.PNeg (sPat p)
        PNPlusK _ n k       -> S.PNPlusK (sName n) k
        PInfixApp _ pa qn pb -> S.PInfixApp (sPat pa) (sQName qn) (sPat pb)
        PApp _ qn ps        -> S.PApp (sQName qn) (map sPat ps)
        PTuple _ ps         -> S.PTuple (map sPat ps)
        PList _ ps          -> S.PList (map sPat ps)
        PParen _ p          -> S.PParen (sPat p)
        PRec _ qn pfs       -> S.PRec (sQName qn) (map sPatField pfs)
        PAsPat _ n p        -> S.PAsPat (sName n) (sPat p)
        PWildCard _         -> S.PWildCard
        PIrrPat _ p         -> S.PIrrPat (sPat p)
        PatTypeSig l p t    -> S.PatTypeSig (getPointLoc l) (sPat p) (sType t)
        PViewPat _ e p      -> S.PViewPat (sExp e) (sPat p)
        PRPat _ rps         -> S.PRPat (map sRPat rps)
        PXTag l xn attrs mat ps -> S.PXTag (getPointLoc l) (sXName xn) (map sPXAttr attrs) (fmap sPat mat) (map sPat ps)
        PXETag l xn attrs mat   -> S.PXETag (getPointLoc l) (sXName xn) (map sPXAttr attrs) (fmap sPat mat)
        PXPcdata _ str      -> S.PXPcdata str
        PXPatTag _ p        -> S.PXPatTag (sPat p)
        PXRPats  _ rps      -> S.PXRPats (map sRPat rps)
        PExplTypeArg _ qn t -> S.PExplTypeArg (sQName qn) (sType t)
        PQuasiQuote _ nm qt -> S.PQuasiQuote nm qt
        PBangPat _ p        -> S.PBangPat (sPat p)

    sPXAttr :: SrcInfo loc => PXAttr loc -> S.PXAttr
    sPXAttr (PXAttr _ xn p) = S.PXAttr (sXName xn) (sPat p)

    sRPatOp :: RPatOp l -> S.RPatOp
    sRPatOp rpop = case rpop of
        RPStar  _ -> S.RPStar
        RPStarG _ -> S.RPStarG
        RPPlus  _ -> S.RPPlus
        RPPlusG _ -> S.RPPlusG
        RPOpt   _ -> S.RPOpt
        RPOptG  _ -> S.RPOptG

    sRPat :: SrcInfo loc => RPat loc -> S.RPat
    sRPat rp = case rp of
        RPOp _ rp rop       -> S.RPOp (sRPat rp) (sRPatOp rop)
        RPEither _ rp1 rp2  -> S.RPEither (sRPat rp1) (sRPat rp2)
        RPSeq _ rps         -> S.RPSeq (map sRPat rps)
        RPGuard _ p ss      -> S.RPGuard (sPat p) (map sStmt ss)
        RPCAs _ n rp        -> S.RPCAs (sName n) (sRPat rp)
        RPAs _ n rp         -> S.RPAs (sName n) (sRPat rp)
        RPParen _ rp        -> S.RPParen (sRPat rp)
        RPPat _ p           -> S.RPPat (sPat p)

    sPatField :: SrcInfo loc => PatField loc -> S.PatField
    sPatField pf = case pf of
        PFieldPat _ qn p    -> S.PFieldPat (sQName qn) (sPat p)
        PFieldPun _ n       -> S.PFieldPun (sName n)
        PFieldWildcard _    -> S.PFieldWildcard

    sStmt :: SrcInfo loc => Stmt loc -> S.Stmt
    sStmt stmt = case stmt of
        Generator l p e     -> S.Generator (getPointLoc l) (sPat p) (sExp e)
        Qualifier _ e       -> S.Qualifier (sExp e)
        LetStmt _ bs        -> S.LetStmt (sBinds bs)
        RecStmt _ ss        -> S.RecStmt (map sStmt ss)

    sQualStmt :: SrcInfo loc => QualStmt loc -> S.QualStmt
    sQualStmt qs = case qs of
        QualStmt     _ stmt     -> S.QualStmt (sStmt stmt)
        ThenTrans    _ e        -> S.ThenTrans (sExp e)
        ThenBy       _ e1 e2    -> S.ThenBy (sExp e1) (sExp e2)
        GroupBy      _ e        -> S.GroupBy (sExp e)
        GroupUsing   _ e        -> S.GroupUsing (sExp e)
        GroupByUsing _ e1 e2    -> S.GroupByUsing (sExp e1) (sExp e2)

    sFieldUpdate :: SrcInfo loc => FieldUpdate loc -> S.FieldUpdate
    sFieldUpdate fu = case fu of
        FieldUpdate _ qn e      -> S.FieldUpdate (sQName qn) (sExp e)
        FieldPun _ n            -> S.FieldPun (sName n)
        FieldWildcard _         -> S.FieldWildcard

    sAlt :: SrcInfo loc => Alt loc -> S.Alt
    sAlt (Alt l p galts mbs) = S.Alt (getPointLoc l) (sPat p) (sGuardedAlts galts) (maybe (S.BDecls []) sBinds mbs)

    sGuardedAlts :: SrcInfo loc => GuardedAlts loc -> S.GuardedAlts
    sGuardedAlts galts = case galts of
        UnGuardedAlt _ e    -> S.UnGuardedAlt (sExp e)
        GuardedAlts  _ gs   -> S.GuardedAlts (map sGuardedAlt gs)

    sGuardedAlt :: SrcInfo loc => GuardedAlt loc -> S.GuardedAlt
    sGuardedAlt (GuardedAlt l ss e) = S.GuardedAlt (getPointLoc l) (map sStmt ss) (sExp e)