-----------------------------------------------------------------------------
-- |
-- 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 hiding (loc)

import Data.Maybe (fromMaybe)

-- | 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 rhs Nothing
            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)
     ClosedTypeFamDecl  l dh mk eqs ->
        let (n, tvs) = sDeclHead dh
         in S.ClosedTypeFamDecl (getPointLoc l) n tvs (fmap sKind mk) (map sTypeEqn eqs)
     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 olp ih mids               ->
        let (tvs, cxt, (qn, ts)) = sInstRule ih
         in S.InstDecl (getPointLoc l) (fmap sOverlap olp) tvs cxt qn ts (maybe [] (map sInstDecl) mids)
     DerivDecl    l olp ih    ->
        let (tvs, cxt, (qn, ts)) = sInstRule ih
         in S.DerivDecl (getPointLoc l) (fmap sOverlap olp) tvs cxt qn ts
     InfixDecl    l ass prec ops    -> S.InfixDecl (getPointLoc l) (sAssoc ass) (fromMaybe 9 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)
     PatSynSig    l n mtvs c1 c2 t ->
        S.PatSynSig (getPointLoc l) (sName n) (fmap (map sTyVarBind) mtvs) (maybe [] sContext c1) (maybe [] sContext c2) (sType t)
     FunBind      _ ms          -> S.FunBind (map sMatch ms)
     PatBind      l p rhs mbs    ->
        S.PatBind (getPointLoc l) (sPat p) (sRhs rhs) (sBinds `fmap` mbs)
     ForImp       l cc msaf mstr n t    ->
        S.ForImp (getPointLoc l) (sCallConv cc) (maybe (S.PlaySafe False) sSafety msaf) (fromMaybe "" mstr) (sName n) (sType t)
     ForExp       l cc      mstr n t    ->
        S.ForExp (getPointLoc l) (sCallConv cc) (fromMaybe "" 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   mact qn ts   -> S.SpecSig (getPointLoc l) (maybe S.AlwaysActive sActivation mact) (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 ih    ->
        let (tvs, cxt, (qn, ts)) = sInstRule ih
         in S.InstSig (getPointLoc l) tvs cxt qn ts
     AnnPragma        l ann'        ->
        S.AnnPragma (getPointLoc l) (sAnnotation ann')
     MinimalPragma    l b           ->
        S.MinimalPragma (getPointLoc l) (fmap sBooleanFormula b)
     RoleAnnotDecl    l qn rs        ->
      S.RoleAnnotDecl (getPointLoc l) (sQName qn) (map sRole rs)
     PatSyn l p r t -> S.PatSyn (getPointLoc l) (sPat p) (sPat r) (sPatSyn t)

sPatSyn :: SrcInfo l => PatternSynDirection l -> S.PatternSynDirection
sPatSyn p = case p of
      Unidirectional             -> S.Unidirectional
      ImplicitBidirectional      -> S.ImplicitBidirectional
      ExplicitBidirectional _ ms -> S.ExplicitBidirectional (map sDecl ms)

sTypeEqn :: SrcInfo l => TypeEqn l -> S.TypeEqn
sTypeEqn (TypeEqn _ a b) = S.TypeEqn (sType a) (sType b)

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)

sBooleanFormula :: SrcInfo loc => BooleanFormula loc -> S.BooleanFormula
sBooleanFormula b' = case b' of
    VarFormula _ n   -> S.VarFormula (sName n)
    AndFormula _ ns  -> S.AndFormula $ map sBooleanFormula ns
    OrFormula _  ns  -> S.OrFormula $ map sBooleanFormula ns
    ParenFormula _ b -> S.ParenFormula (sBooleanFormula b)

sRole :: Role l -> S.Role
sRole r =
  case r of
    Nominal _          -> S.Nominal
    Representational _ -> S.Representational
    Phantom _          -> S.Phantom
    RoleWildcard _     -> S.RoleWildcard

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 _ n qn         -> S.EAbs (sNamespace n)(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 safe mpkg as misl) =
    S.ImportDecl (getPointLoc l) (sModuleName mn) qu src safe mpkg (fmap sModuleName as) (fmap sImportSpecList misl)

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

sNamespace :: Namespace l -> S.Namespace
sNamespace n = case n of
                NoNamespace _   -> S.NoNamespace
                TypeNamespace _ -> S.TypeNamespace
                PatternNamespace _ -> S.PatternNamespace

sImportSpec :: ImportSpec l -> S.ImportSpec
sImportSpec is = case is of
    IVar _ n            -> S.IVar (sName n)
    IAbs _ ns n         -> S.IAbs (sNamespace ns) (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 = go []
  where go ts dh' = case dh' of
                        DHead _ n           -> (sName n, ts)
                        DHInfix _ tva n     -> (sName n, sTyVarBind tva:ts)
                        DHParen _ dh        -> (n, ts1 ++ ts)
                          where (n, ts1) = sDeclHead dh
                        DHApp _ dh t        -> go (sTyVarBind t:ts) dh

sInstRule :: SrcInfo l => InstRule l -> ([S.TyVarBind], [S.Asst], (S.QName, [S.Type]))
sInstRule ih' = case ih' of
                    IRule _ mtvs mctxt qn   -> (tvs, cxt, sInstHead qn)
                        where cxt = maybe [] sContext mctxt
                              tvs = maybe [] (map sTyVarBind) mtvs
                    IParen _ ir             -> sInstRule ir

sInstHead :: SrcInfo l => InstHead l -> (S.QName, [S.Type])
sInstHead = go []
    where go ts' d' = case d' of
                        IHCon _ qn         -> (sQName qn, ts')
                        IHInfix _ ta qn    -> (sQName qn, sType ta:ts')
                        IHParen _ ih       -> (n, ts1 ++ ts')
                          where (n, ts1) = sInstHead ih
                        IHApp _ ih t       -> go (sType t:ts') ih

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

sDeriving :: SrcInfo l => Deriving l -> [(S.QName, [S.Type])]
sDeriving (Deriving _ irs) = map (\ir -> let (_, _, ret) = sInstRule ir in ret) irs

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) (sBinds `fmap` mwhere)
sMatch (InfixMatch l pa n pbs rhs mwhere) =
    S.Match (getPointLoc l) (sName n) (map sPat (pa:pbs)) Nothing (sRhs rhs) (sBinds `fmap` 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 :: SrcInfo l => ConDecl l -> S.ConDecl
sConDecl cd = case cd of
    ConDecl _ n bts     -> S.ConDecl (sName n) (map sType bts)
    InfixConDecl _ bta n btb -> S.InfixConDecl (sType bta) (sName n) (sType btb)
    RecDecl _ n fds -> S.RecDecl (sName n) (map sFieldDecl fds)

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

sGadtDecl :: SrcInfo loc => GadtDecl loc -> S.GadtDecl
sGadtDecl (GadtDecl l n mn t) = S.GadtDecl (getPointLoc l) (sName n) (maybe [] sRecFields mn) (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)
    ClsDefSig l n t ->
        S.ClsDefSig (getPointLoc l) (sName n) (sType t)

sRecFields :: SrcInfo l => [FieldDecl l] -> [([S.Name], S.Type)]
sRecFields = map sFieldDecl

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 :: SrcInfo l => BangType l -> S.BangType
sBangType bt = case bt of
    BangedTy   _  -> S.BangedTy
    UnpackedTy _  -> S.UnpackedTy

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 :: SrcInfo l => 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)
    TyParArray _ t              -> S.TyParArray (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)
    TyPromoted _ t              -> S.TyPromoted (sPromoted t)
    TyEquals _ t1 t2            -> S.TyEquals (sType t1) (sType t2)
    TySplice _ s                -> S.TySplice (sSplice s)
    TyBang _ b t                -> S.TyBang (sBangType b) (sType t)
    TyWildCard _ mn             -> S.TyWildCard (sName `fmap` mn)

sPromoted :: SrcInfo l => Promoted l -> S.Promoted
sPromoted p = case p of
    PromotedInteger _ n _ -> S.PromotedInteger n
    PromotedString _ s _ -> S.PromotedString s
    PromotedCon _ b qn -> S.PromotedCon b (sQName qn)
    PromotedList _ b ps -> S.PromotedList b (map sType ps)
    PromotedTuple _ ps -> S.PromotedTuple (map sType ps)
    PromotedUnit _ -> S.PromotedUnit


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
    KindFn _ k1 k2  -> S.KindFn (sKind k1) (sKind k2)
    KindParen _ k   -> S.KindParen (sKind k)
    KindVar _ n     -> S.KindVar (sQName n)
    KindApp _ k1 k2 -> S.KindApp (sKind k1) (sKind k2)
    KindTuple _ ks  -> S.KindTuple (map sKind ks)
    KindList  _ ks  -> S.KindList  (sKind ks)

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

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

sAsst :: SrcInfo l => Asst l -> S.Asst
sAsst asst = case asst of
    ClassA _ qn ts      -> S.ClassA (sQName qn) (map sType ts)
    AppA _ n ns         -> S.AppA (sName n) (map sType ns)
    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)
    ParenA _ a          -> S.ParenA (sAsst a)
    WildCardA _ mn      -> S.WildCardA (sName `fmap` mn)

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

sSign :: Sign l -> S.Sign
sSign sg = case sg of
    Signless _ -> S.Signless
    Negative _ -> S.Negative

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)
    MultiIf _ alts      -> S.MultiIf (map sGuardedRhs alts)
    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 _ bx es       -> S.Tuple bx (map sExp es)
    TupleSection _ bx mes -> S.TupleSection bx (map (fmap sExp) mes)
    List _ es           -> S.List (map sExp es)
    ParArray _ es       -> S.ParArray (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)
    ParArrayFromTo _ e1 e2 -> S.ParArrayFromTo (sExp e1) (sExp e2)
    ParArrayFromThenTo _ e1 e2 e3 -> S.ParArrayFromThenTo (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)
    ParArrayComp  _ e qsss -> S.ParArrayComp (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)
    XChildTag l es      -> S.XChildTag (getPointLoc l) (map sExp es)
    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)
    LCase _ alts -> S.LCase (map sAlt alts)
    ExprHole _              -> S.ExprHole


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
sSafety (PlayInterruptible _) = S.PlayInterruptible

sCallConv :: CallConv l -> S.CallConv
sCallConv (StdCall    _) = S.StdCall
sCallConv (CCall      _) = S.CCall
sCallConv (CPlusPlus  _) = S.CPlusPlus
sCallConv (DotNet     _) = S.DotNet
sCallConv (Jvm        _) = S.Jvm
sCallConv (Js         _) = S.Js
sCallConv (JavaScript _) = S.JavaScript
sCallConv (CApi       _) = S.CApi

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')

sOverlap :: SrcInfo loc => Overlap loc -> S.Overlap
sOverlap o' = case o' of
    NoOverlap _   -> S.NoOverlap
    Overlap _     -> S.Overlap
    Incoherent _  -> S.Incoherent

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 :: SrcInfo l => 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 _ sg lit       -> S.PLit (sSign sg) (sLiteral lit)
    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 _ bx ps      -> S.PTuple bx (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)
    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 _ qn      -> S.PFieldPun (sQName qn)
    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 _ qn           -> S.FieldPun (sQName qn)
    FieldWildcard _         -> S.FieldWildcard

sAlt :: SrcInfo loc => Alt loc -> S.Alt
sAlt (Alt l p galts mbs) = S.Alt (getPointLoc l) (sPat p) (sRhs galts) (sBinds `fmap` mbs)