{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeSynonymInstances #-}

{- |
  Module      :  Language.Haskell.Meta.Syntax.Translate
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3
  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  experimental
  Portability :  portable (template-haskell)
-}

module Language.Haskell.Meta.Syntax.Translate (
    module Language.Haskell.Meta.Syntax.Translate
  , TyVarBndr_
) where

import qualified Data.Char                      as Char
import qualified Data.List                      as List
import qualified Language.Haskell.Exts.SrcLoc   as Exts.SrcLoc
import qualified Language.Haskell.Exts.Syntax   as Exts
import           Language.Haskell.Meta.THCompat (TyVarBndr_)
import qualified Language.Haskell.Meta.THCompat as Compat
import qualified Language.Haskell.TH.Lib        as TH
import qualified Language.Haskell.TH.Syntax     as TH

-----------------------------------------------------------------------------

class ToName a where toName :: a -> TH.Name
class ToNames a where toNames :: a -> [TH.Name]
class ToLit  a where toLit  :: a -> TH.Lit
class ToType a where toType :: a -> TH.Type
class ToPat  a where toPat  :: a -> TH.Pat
class ToExp  a where toExp  :: a -> TH.Exp
class ToDecs a where toDecs :: a -> [TH.Dec]
class ToDec  a where toDec  :: a -> TH.Dec
class ToStmt a where toStmt :: a -> TH.Stmt
class ToLoc  a where toLoc  :: a -> TH.Loc
class ToCxt  a where toCxt  :: a -> TH.Cxt
class ToPred a where toPred :: a -> TH.Pred
class ToTyVars a where toTyVars :: a -> [TyVarBndr_ ()]
class ToMaybeKind a where toMaybeKind :: a -> Maybe TH.Kind
class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn

type DerivClause = TH.DerivClause

class ToDerivClauses a where toDerivClauses :: a -> [DerivClause]

-- for error messages
moduleName :: String
moduleName = "Language.Haskell.Meta.Syntax.Translate"

-- When to use each of these isn't always clear: prefer 'todo' if unsure.
noTH :: (Functor f, Show (f ())) => String -> f e -> a
noTH fun thing = error . concat $ [moduleName, ".", fun,
  ": template-haskell has no representation for: ", show (fmap (const ()) thing)]

noTHyet :: (Functor f, Show (f ())) => String -> String -> f e -> a
noTHyet fun minVersion thing = error . concat $ [moduleName, ".", fun,
  ": template-haskell-", VERSION_template_haskell, " (< ", minVersion, ")",
  " has no representation for: ", show (fmap (const ()) thing)]

todo :: (Functor f, Show (f ())) => String -> f e -> a
todo fun thing = error . concat $ [moduleName, ".", fun,
  ": not implemented: ", show (fmap (const ()) thing)]

nonsense :: (Functor f, Show (f ())) => String -> String -> f e -> a
nonsense fun inparticular thing = error . concat $ [moduleName, ".", fun,
  ": nonsensical: ", inparticular, ": ", show (fmap (const ()) thing)]

#if MIN_VERSION_template_haskell(2,16,0)
toTupEl :: ToExp a => a -> Maybe TH.Exp
toTupEl = Just . toExp
#else
toTupEl :: ToExp a => a -> TH.Exp
toTupEl = toExp
#endif

-----------------------------------------------------------------------------


instance ToExp TH.Lit where
  toExp = TH.LitE
instance (ToExp a) => ToExp [a] where
  toExp = TH.ListE . fmap toExp
instance (ToExp a, ToExp b) => ToExp (a,b) where
  toExp (a,b) = TH.TupE [toTupEl a, toTupEl b]
instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
  toExp (a,b,c) = TH.TupE [toTupEl a, toTupEl b, toTupEl c]
instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
  toExp (a,b,c,d) = TH.TupE [toTupEl a, toTupEl b, toTupEl c, toTupEl d]


instance ToPat TH.Lit where
  toPat = TH.LitP
instance (ToPat a) => ToPat [a] where
  toPat = TH.ListP . fmap toPat
instance (ToPat a, ToPat b) => ToPat (a,b) where
  toPat (a,b) = TH.TupP [toPat a, toPat b]
instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
  toPat (a,b,c) = TH.TupP [toPat a, toPat b, toPat c]
instance (ToPat a, ToPat b, ToPat c, ToPat d) => ToPat (a,b,c,d) where
  toPat (a,b,c,d) = TH.TupP [toPat a, toPat b, toPat c, toPat d]


instance ToLit Char where
  toLit = TH.CharL
instance ToLit String where
  toLit = TH.StringL
instance ToLit Integer where
  toLit = TH.IntegerL
instance ToLit Int where
  toLit = TH.IntegerL . toInteger
instance ToLit Float where
  toLit = TH.RationalL . toRational
instance ToLit Double where
  toLit = TH.RationalL . toRational


-----------------------------------------------------------------------------


-- * ToName {String,HsName,Module,HsSpecialCon,HsQName}


instance ToName String where
  toName = TH.mkName

instance ToName (Exts.Name l) where
  toName (Exts.Ident _ s)  = toName s
  toName (Exts.Symbol _ s) = toName s

instance ToName (Exts.SpecialCon l) where
  toName (Exts.UnitCon _) = TH.mkName "()" -- TODO LumiGuide: '()
  toName (Exts.ListCon _) = ''[] -- Parser only uses this in types -- TODO LumiGuide: '[]
  toName (Exts.FunCon _)  = ''(->)
  toName (Exts.TupleCon _ _ n) =
    TH.mkName $ concat ["(",replicate (n-1) ',',")"]
    -- TODO LumiGuide:
    -- .
    -- .| n<2 = '()
    -- .| otherwise =
    -- .  let x = maybe [] (++".") (nameModule '(,))
    -- .  in TH.mkName . concat $ x : ["(",replicate (n-1) ',',")"]
  toName (Exts.Cons _)    = '(:)
  toName h = todo "toName not implemented" h
  -- TODO
  -- toName (Exts.UnboxedSingleCon _) = ''
  -- toName (Exts.ExprHole _) = ''_


instance ToName (Exts.QName l) where
-- TODO: why is this commented out?
--  toName (Exts.Qual (Exts.Module []) n) = toName n
  toName (Exts.Qual _ (Exts.ModuleName _ []) n) = toName n
  toName (Exts.Qual _ (Exts.ModuleName _ m) n) =
    let m' = show . toName $ m
        n' = show . toName $ n
    in toName . concat $ [m',".",n']
  toName (Exts.UnQual _ n) = toName n
  toName (Exts.Special _ s) = toName s

#if MIN_VERSION_haskell_src_exts(1,20,1)
instance ToName (Exts.MaybePromotedName l) where
  toName (Exts.PromotedName   _ qn) = toName qn
  toName (Exts.UnpromotedName _ qn) = toName qn
#endif

instance ToName (Exts.Op l) where
  toName (Exts.VarOp _ n) = toName n
  toName (Exts.ConOp _ n) = toName n


-----------------------------------------------------------------------------

-- * ToLit HsLiteral


instance ToLit (Exts.Literal l) where
  toLit (Exts.Char _ a _) = TH.CharL a
  toLit (Exts.String _ a _) = TH.StringL a
  toLit (Exts.Int _ a _) = TH.IntegerL a
  toLit (Exts.Frac _ a _) = TH.RationalL a
  toLit l@Exts.PrimChar{} = noTH "toLit" l
  toLit (Exts.PrimString _ a _) = TH.StringPrimL (map toWord8 a)
   where
    toWord8 = fromIntegral . Char.ord
  toLit (Exts.PrimInt _ a _) = TH.IntPrimL a
  toLit (Exts.PrimFloat _ a _) = TH.FloatPrimL a
  toLit (Exts.PrimDouble _ a _) = TH.DoublePrimL a
  toLit (Exts.PrimWord _ a _) = TH.WordPrimL a


-----------------------------------------------------------------------------

-- * ToPat HsPat

instance ToPat (Exts.Pat l) where
  toPat (Exts.PVar _ n)
    = TH.VarP (toName n)
  toPat (Exts.PLit _ (Exts.Signless _) l)
    = TH.LitP (toLit l)
  toPat (Exts.PLit _ (Exts.Negative _) l) = TH.LitP $ case toLit l of
    TH.IntegerL z      -> TH.IntegerL (negate z)
    TH.RationalL q     -> TH.RationalL (negate q)
    TH.IntPrimL z'     -> TH.IntPrimL (negate z')
    TH.FloatPrimL r'   -> TH.FloatPrimL (negate r')
    TH.DoublePrimL r'' -> TH.DoublePrimL (negate r'')
    _                  -> nonsense "toPat" "negating wrong kind of literal" l
  toPat (Exts.PInfixApp _ p n q) = TH.UInfixP (toPat p) (toName n) (toPat q)
  toPat (Exts.PApp _ n ps) = Compat.conP (toName n) (fmap toPat ps)
  toPat (Exts.PTuple _ Exts.Boxed ps) = TH.TupP (fmap toPat ps)
  toPat (Exts.PTuple _ Exts.Unboxed ps) = TH.UnboxedTupP (fmap toPat ps)
  toPat (Exts.PList _ ps) = TH.ListP (fmap toPat ps)
  toPat (Exts.PParen _ p) = TH.ParensP (toPat p)
  -- TODO: move toFieldPat to top level defn
  toPat (Exts.PRec _ n pfs) = let toFieldPat (Exts.PFieldPat _ n' p) = (toName n', toPat p)
                                  toFieldPat h = todo "toFieldPat" h
                            in TH.RecP (toName n) (fmap toFieldPat pfs)
  toPat (Exts.PAsPat _ n p) = TH.AsP (toName n) (toPat p)
  toPat (Exts.PWildCard _) = TH.WildP
  toPat (Exts.PIrrPat _ p) = TH.TildeP (toPat p)
  toPat (Exts.PatTypeSig _ p t) = TH.SigP (toPat p) (toType t)
  toPat (Exts.PViewPat _ e p) = TH.ViewP (toExp e) (toPat p)
  -- regular pattern
  toPat p@Exts.PRPat{} = noTH "toPat" p
  -- XML stuff
  toPat p@Exts.PXTag{} = noTH "toPat" p
  toPat p@Exts.PXETag{} = noTH "toPat" p
  toPat p@Exts.PXPcdata{} = noTH "toPat" p
  toPat p@Exts.PXPatTag{} = noTH "toPat" p
  toPat (Exts.PBangPat _ p) = TH.BangP (toPat p)
  toPat p = todo "toPat" p
  -- TODO
            -- (Exts.PNPlusK _ _ _)
            -- (Exts.PUnboxedSum _ _ _ _)
            -- (Exts.PXRPats _ _)
            -- (Exts.PSplice _ _)
            -- ...

-----------------------------------------------------------------------------

-- * ToExp HsExp

instance ToExp (Exts.QOp l) where
  toExp (Exts.QVarOp _ n) = TH.VarE (toName n)
  toExp (Exts.QConOp _ n) = TH.ConE (toName n)

toFieldExp :: Exts.FieldUpdate l -> TH.FieldExp
toFieldExp (Exts.FieldUpdate _ n e) = (toName n, toExp e)
toFieldExp h                        = todo "toFieldExp" h




instance ToExp (Exts.Exp l) where
  toExp (Exts.Var _ n)                 = TH.VarE (toName n)
  toExp e@Exts.IPVar{}                 = noTH "toExp" e
  toExp (Exts.Con _ n)                 = TH.ConE (toName n)
  toExp (Exts.Lit _ l)                 = TH.LitE (toLit l)
#if MIN_VERSION_template_haskell(2,13,0)
  toExp (Exts.OverloadedLabel _ s)     = TH.LabelE s
#endif
  toExp (Exts.InfixApp _ e o f)        = TH.UInfixE (toExp e) (toExp o) (toExp f)
  toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t)
  toExp (Exts.App _ e f)               = TH.AppE (toExp e) (toExp f)
  toExp (Exts.NegApp _ e)              = TH.AppE (TH.VarE 'negate) (toExp e)
  toExp (Exts.Lambda _ ps e)           = TH.LamE (fmap toPat ps) (toExp e)
  toExp (Exts.Let _ bs e)              = TH.LetE (toDecs bs) (toExp e)
  toExp (Exts.If _ a b c)              = TH.CondE (toExp a) (toExp b) (toExp c)
  toExp (Exts.MultiIf _ ifs)           = TH.MultiIfE (map toGuard ifs)
  toExp (Exts.Case _ e alts)           = TH.CaseE (toExp e) (map toMatch alts)
#if MIN_VERSION_template_haskell(2,17,0)
  toExp (Exts.Do _ ss)                 = TH.DoE Nothing (map toStmt ss)
#else
  toExp (Exts.Do _ ss)                 = TH.DoE (map toStmt ss)
#endif
  toExp e@Exts.MDo{}                   = noTH "toExp" e
  toExp (Exts.Tuple _ Exts.Boxed xs)   = TH.TupE (fmap toTupEl xs)
  toExp (Exts.Tuple _ Exts.Unboxed xs) = TH.UnboxedTupE (fmap toTupEl xs)
  toExp e@Exts.TupleSection{}          = noTH "toExp" e
  toExp (Exts.List _ xs)               = TH.ListE (fmap toExp xs)
  toExp (Exts.Paren _ e)               = TH.ParensE (toExp e)
  toExp (Exts.LeftSection _ e o)       = TH.InfixE (Just . toExp $ e) (toExp o) Nothing
  toExp (Exts.RightSection _ o f)      = TH.InfixE Nothing (toExp o) (Just . toExp $ f)
  toExp (Exts.RecConstr _ n xs)        = TH.RecConE (toName n) (fmap toFieldExp xs)
  toExp (Exts.RecUpdate _ e xs)        = TH.RecUpdE (toExp e) (fmap toFieldExp xs)
  toExp (Exts.EnumFrom _ e)            = TH.ArithSeqE $ TH.FromR (toExp e)
  toExp (Exts.EnumFromTo _ e f)        = TH.ArithSeqE $ TH.FromToR (toExp e) (toExp f)
  toExp (Exts.EnumFromThen _ e f)      = TH.ArithSeqE $ TH.FromThenR (toExp e) (toExp f)
  toExp (Exts.EnumFromThenTo _ e f g)  = TH.ArithSeqE $ TH.FromThenToR (toExp e) (toExp f) (toExp g)
  toExp (Exts.ListComp _ e ss)         = TH.CompE $ map convert ss ++ [TH.NoBindS (toExp e)]
   where
    convert (Exts.QualStmt _ st) = toStmt st
    convert s                    = noTH "toExp ListComp" s
  toExp (Exts.ExpTypeSig _ e t)      = TH.SigE (toExp e) (toType t)
  toExp e = todo "toExp" e


toMatch :: Exts.Alt l -> TH.Match
toMatch (Exts.Alt _ p rhs ds) = TH.Match (toPat p) (toBody rhs) (toDecs ds)

toBody :: Exts.Rhs l -> TH.Body
toBody (Exts.UnGuardedRhs _ e)   = TH.NormalB $ toExp e
toBody (Exts.GuardedRhss _ rhss) = TH.GuardedB $ map toGuard rhss

toGuard :: Exts.GuardedRhs l -> (TH.Guard, TH.Exp)
toGuard (Exts.GuardedRhs _ stmts e) = (g, toExp e)
  where
    g = case map toStmt stmts of
      [TH.NoBindS x] -> TH.NormalG x
      xs             -> TH.PatG xs

instance ToDecs a => ToDecs (Maybe a) where
    toDecs Nothing  = []
    toDecs (Just a) = toDecs a

instance ToDecs (Exts.Binds l) where
  toDecs (Exts.BDecls _ ds)  = toDecs ds
  toDecs a@(Exts.IPBinds {}) = noTH "ToDecs Exts.Binds" a

instance ToDecs (Exts.ClassDecl l) where
  toDecs (Exts.ClsDecl _ d) = toDecs d
  toDecs x                  = todo "classDecl" x

-----------------------------------------------------------------------------

-- * ToLoc SrcLoc

instance ToLoc Exts.SrcLoc.SrcLoc where
  toLoc (Exts.SrcLoc.SrcLoc fn l c) =
    TH.Loc fn [] [] (l,c) (-1,-1)

-----------------------------------------------------------------------------

-- * ToType HsType

instance ToName (Exts.TyVarBind l) where
  toName (Exts.KindedVar _ n _) = toName n
  toName (Exts.UnkindedVar _ n) = toName n

instance ToName TH.Name where
  toName = id

instance ToName (Compat.TyVarBndr_ flag) where
#if MIN_VERSION_template_haskell(2,17,0)
  toName (TH.PlainTV n _)    = n
  toName (TH.KindedTV n _ _) = n
#else
  toName (TH.PlainTV n)      = n
  toName (TH.KindedTV n _)   = n
#endif

#if !MIN_VERSION_haskell_src_exts(1,21,0)
instance ToType (Exts.Kind l) where
  toType (Exts.KindStar _)     = TH.StarT
  toType (Exts.KindFn _ k1 k2) = toType k1 .->. toType k2
  toType (Exts.KindParen _ kp) = toType kp
  toType (Exts.KindVar _ n)    = TH.VarT (toName n)
  -- TODO LumiGuide:
  -- toType (Hs.KindVar _ n)
  --    | isCon (nameBase th_n) = ConT th_n
  --    | otherwise             = VarT th_n
  --  where
  --    th_n = toName n
  --
  --    isCon :: String -> Bool
  --    isCon (c:_) = isUpper c || c == ':'
  --    isCon _ = nonsense "toType" "empty kind variable name" n
  toType (Exts.KindApp _ k1 k2) = toType k1 `TH.AppT` toType k2
  toType (Exts.KindTuple _ ks) = foldr (\k pt -> pt `TH.AppT` toType k) (TH.TupleT $ length ks) ks
  toType (Exts.KindList _ k) = TH.ListT `TH.AppT` toType k
#endif

toKind :: Exts.Kind l -> TH.Kind
toKind = toType

toTyVar :: Exts.TyVarBind l -> TyVarBndr_ ()
#if MIN_VERSION_template_haskell(2,17,0)
toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) () (toKind k)
toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n) ()
#else
toTyVar (Exts.KindedVar _ n k) = TH.KindedTV (toName n) (toKind k)
toTyVar (Exts.UnkindedVar _ n) = TH.PlainTV (toName n)
#endif

#if MIN_VERSION_template_haskell(2,17,0)
toTyVarSpec :: TyVarBndr_ () -> TH.TyVarBndrSpec
toTyVarSpec (TH.KindedTV n () k) = TH.KindedTV n TH.SpecifiedSpec k
toTyVarSpec (TH.PlainTV n ())    = TH.PlainTV n TH.SpecifiedSpec
#else
toTyVarSpec :: TyVarBndr_ flag -> TyVarBndr_ flag
toTyVarSpec = id
#endif

instance ToType (Exts.Type l) where
  toType (Exts.TyForall _ tvbM cxt t) = TH.ForallT (maybe [] (fmap (toTyVarSpec . toTyVar)) tvbM) (toCxt cxt) (toType t)
  toType (Exts.TyFun _ a b) = toType a .->. toType b
  toType (Exts.TyList _ t) = TH.ListT `TH.AppT` toType t
  toType (Exts.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)
   where
    tuple = case b of
      Exts.Boxed   -> TH.TupleT
      Exts.Unboxed -> TH.UnboxedTupleT
  toType (Exts.TyApp _ a b) = TH.AppT (toType a) (toType b)
  toType (Exts.TyVar _ n) = TH.VarT (toName n)
  toType (Exts.TyCon _ qn) = TH.ConT (toName qn)
  toType (Exts.TyParen _ t) = toType t
  -- XXX: need to wrap the name in parens!
#if MIN_VERSION_haskell_src_exts(1,20,0)
  -- TODO: why does this branch exist?
  -- Why fail toType if this is a promoted name?
  toType (Exts.TyInfix _ a (Exts.UnpromotedName _ o) b) =
    TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)
#else
  toType (Exts.TyInfix _ a o b) =
    TH.AppT (TH.AppT (TH.ConT (toName o)) (toType a)) (toType b)
#endif
  toType (Exts.TyKind _ t k) = TH.SigT (toType t) (toKind k)
  toType (Exts.TyPromoted _ p) = case p of
    Exts.PromotedInteger _ i _ -> TH.LitT $ TH.NumTyLit i
    Exts.PromotedString _ _ s -> TH.LitT $ TH.StrTyLit s
    Exts.PromotedCon _ _q n -> TH.PromotedT $ toName n
    Exts.PromotedList _ _q ts -> foldr (\t pl -> TH.PromotedConsT `TH.AppT` toType t `TH.AppT` pl) TH.PromotedNilT ts
    Exts.PromotedTuple _ ts -> foldl (\pt t -> pt `TH.AppT` toType t) (TH.PromotedTupleT $ length ts) ts
    Exts.PromotedUnit _ -> TH.PromotedT ''()
  toType (Exts.TyEquals _ t1 t2) = TH.EqualityT `TH.AppT` toType t1 `TH.AppT` toType t2
  toType t@Exts.TySplice{} = noTH "toType" t
  toType t@Exts.TyBang{} =
    nonsense "toType" "type cannot have strictness annotations in this context" t
  toType t@Exts.TyWildCard{} = noTH "toType" t
  toType t = todo "toType" t
  -- TODO
  -- toType (Exts.TyUnboxedSum _ _)
  -- toType (Exts.TyParArray _ _)
  -- toType (Exts.TyInfix _ _ (Exts.PromotedName _ _) _)

toStrictType :: Exts.Type l -> TH.StrictType
toStrictType (Exts.TyBang _ s u t) = (TH.Bang (toUnpack u) (toStrict s), toType t)
    where
      toStrict (Exts.LazyTy _)        = TH.SourceLazy
      toStrict (Exts.BangedTy _)      = TH.SourceStrict
      toStrict (Exts.NoStrictAnnot _) = TH.NoSourceStrictness
      toUnpack (Exts.Unpack _)         = TH.SourceUnpack
      toUnpack (Exts.NoUnpack _)       = TH.SourceNoUnpack
      toUnpack (Exts.NoUnpackPragma _) = TH.NoSourceUnpackedness
toStrictType x = (TH.Bang TH.NoSourceUnpackedness TH.NoSourceStrictness, toType x)

(.->.) :: TH.Type -> TH.Type -> TH.Type
a .->. b = TH.AppT (TH.AppT TH.ArrowT a) b

instance ToPred (Exts.Asst l) where
#if MIN_VERSION_haskell_src_exts(1,22,0)
    toPred (Exts.TypeA _ t) = toType t
#else
    toPred (Exts.ClassA _ n ts) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType ts)
    toPred (Exts.InfixA _ t1 n t2) = List.foldl' TH.AppT (TH.ConT (toName n)) (fmap toType [t1,t2])
    toPred (Exts.EqualP _ t1 t2) = List.foldl' TH.AppT TH.EqualityT (fmap toType [t1,t2])
    toPred a@Exts.AppA{} = todo "toPred" a
    toPred a@Exts.WildCardA{} = todo "toPred" a
#endif
    toPred (Exts.ParenA _ asst) = toPred asst
    toPred a@Exts.IParam{} = noTH "toPred" a
    -- Pattern match is redundant.
    -- TODO: Is there a way to turn off this warn for catch-alls?
    -- would make the code more future-compat
    -- toPred p = todo "toPred" p

instance ToDerivClauses (Exts.Deriving l) where
#if MIN_VERSION_haskell_src_exts(1,20,0)
  toDerivClauses (Exts.Deriving _ strat irules) = [TH.DerivClause (fmap toDerivStrategy strat) (map toType irules)]
#else
  toDerivClauses (Exts.Deriving _ irules) = [TH.DerivClause Nothing (map toType irules)]
#endif

instance ToDerivClauses a => ToDerivClauses (Maybe a) where
  toDerivClauses Nothing  = []
  toDerivClauses (Just a) = toDerivClauses a

instance ToDerivClauses a => ToDerivClauses [a] where
  toDerivClauses = concatMap toDerivClauses


toDerivStrategy :: (Exts.DerivStrategy l) -> TH.DerivStrategy
toDerivStrategy (Exts.DerivStock _)    = TH.StockStrategy
toDerivStrategy (Exts.DerivAnyclass _) = TH.AnyclassStrategy
toDerivStrategy (Exts.DerivNewtype _)  = TH.NewtypeStrategy
#if MIN_VERSION_haskell_src_exts(1,21,0) && MIN_VERSION_template_haskell(2,14,0)
toDerivStrategy (Exts.DerivVia _ t)    = TH.ViaStrategy (toType t)
#else
toDerivStrategy d@Exts.DerivVia{}      = noTHyet "toDerivStrategy" "2.14" d
#endif


-- TODO LumiGuide
-- instance ToCxt (Hs.Deriving l) where
-- #if MIN_VERSION_haskell_src_exts(1,20,1)
--   toCxt (Hs.Deriving _ _ rule) = toCxt rule
-- #else
--   toCxt (Hs.Deriving _   rule) = toCxt rule
-- #endif

-- instance ToCxt [Hs.InstRule l] where
--   toCxt = concatMap toCxt

-- instance ToCxt a => ToCxt (Maybe a) where
--     toCxt Nothing = []
--     toCxt (Just a) = toCxt a


foldAppT :: TH.Type -> [TH.Type] -> TH.Type
foldAppT t ts = List.foldl' TH.AppT t ts

-----------------------------------------------------------------------------

-- * ToStmt HsStmt

instance ToStmt (Exts.Stmt l) where
  toStmt (Exts.Generator _ p e)   = TH.BindS (toPat p) (toExp e)
  toStmt (Exts.Qualifier _ e)     = TH.NoBindS (toExp e)
  toStmt _a@(Exts.LetStmt _ bnds) = TH.LetS (toDecs bnds)
  toStmt s@Exts.RecStmt{}         = noTH "toStmt" s


-----------------------------------------------------------------------------

-- * ToDec HsDecl

instance ToDec (Exts.Decl l) where
  toDec (Exts.TypeDecl _ h t)
    = TH.TySynD (toName h) (toTyVars h) (toType t)

  toDec a@(Exts.DataDecl  _ dOrN cxt h qcds qns)
    = case dOrN of
        Exts.DataType _ -> TH.DataD (toCxt cxt)
                             (toName h)
                             (toTyVars h)
                             Nothing
                             (fmap qualConDeclToCon qcds)
                             (toDerivClauses qns)
        Exts.NewType _  -> let qcd = case qcds of
                                     [x] -> x
                                     _   -> nonsense "toDec" ("newtype with " ++
                                                              "wrong number of constructors") a
                        in TH.NewtypeD (toCxt cxt)
                                    (toName h)
                                    (toTyVars h)
                                    Nothing
                                    (qualConDeclToCon qcd)
                                    (toDerivClauses qns)

  -- This type-signature conversion is just wrong.
  -- Type variables need to be dealt with. /Jonas
  toDec _a@(Exts.TypeSig _ ns t)
    -- XXXXXXXXXXXXXX: oh crap, we can't return a [Dec] from this class!
    = let xs = fmap (flip TH.SigD (toType t) . toName) ns
      in case xs of x:_ -> x; [] -> error "toDec: malformed TypeSig!"

  toDec (Exts.InlineConlikeSig _ act qn) = TH.PragmaD $
    TH.InlineP (toName qn) TH.Inline TH.ConLike (transAct act)
  toDec (Exts.InlineSig _ b act qn) = TH.PragmaD $
    TH.InlineP (toName qn) inline TH.FunLike (transAct act)
   where
    inline | b = TH.Inline | otherwise = TH.NoInline

  toDec (Exts.TypeFamDecl _ h sig inj)
    = TH.OpenTypeFamilyD $ TH.TypeFamilyHead (toName h)
                                       (toTyVars h)
                                       (maybe TH.NoSig TH.KindSig . toMaybeKind $ sig)
                                       (fmap toInjectivityAnn inj)
  toDec (Exts.DataFamDecl _ _ h sig)
    = TH.DataFamilyD (toName h) (toTyVars h) (toMaybeKind sig)

  toDec _a@(Exts.FunBind _ mtchs)                           = hsMatchesToFunD mtchs
  toDec (Exts.PatBind _ p rhs bnds)                      = TH.ValD (toPat p)
                                                              (hsRhsToBody rhs)
                                                              (toDecs bnds)

  toDec i@(Exts.InstDecl _ (Just overlap) _ _) =
    noTH "toDec" (fmap (const ()) overlap, i)

  -- the 'vars' bit seems to be for: instance forall a. C (T a) where ...
  -- TH's own parser seems to flat-out ignore them, and honestly I can't see
  -- that it's obviously wrong to do so.
  toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD
    Nothing
    (toCxt irule)
    (toType irule)
    (toDecs ids)

  toDec (Exts.ClassDecl _ cxt h fds decls) = TH.ClassD
    (toCxt cxt)
    (toName h)
    (toTyVars h)
    (fmap toFunDep fds)
    (toDecs decls)
   where
    toFunDep (Exts.FunDep _ ls rs) = TH.FunDep (fmap toName ls) (fmap toName rs)

  toDec (Exts.AnnPragma _ ann) = TH.PragmaD (TH.AnnP (target ann) (expann ann))
    where
      target (Exts.Ann _ n _)     = TH.ValueAnnotation (toName n)
      target (Exts.TypeAnn _ n _) = TH.TypeAnnotation (toName n)
      target (Exts.ModuleAnn _ _) = TH.ModuleAnnotation
      expann (Exts.Ann _ _ e)     = toExp e
      expann (Exts.TypeAnn _ _ e) = toExp e
      expann (Exts.ModuleAnn _ e) = toExp e

  toDec x = todo "toDec" x

instance ToMaybeKind (Exts.ResultSig l) where
    toMaybeKind (Exts.KindSig _ k)  = Just $ toKind k
    toMaybeKind (Exts.TyVarSig _ _) = Nothing

instance ToMaybeKind a => ToMaybeKind (Maybe a) where
    toMaybeKind Nothing  = Nothing
    toMaybeKind (Just a) = toMaybeKind a

instance ToInjectivityAnn (Exts.InjectivityInfo l) where
  toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns)

transAct :: Maybe (Exts.Activation l) -> TH.Phases
transAct Nothing                       = TH.AllPhases
transAct (Just (Exts.ActiveFrom _ n))  = TH.FromPhase n
transAct (Just (Exts.ActiveUntil _ n)) = TH.BeforePhase n

instance ToName (Exts.DeclHead l) where
  toName (Exts.DHead _ n)     = toName n
  toName (Exts.DHInfix _ _ n) = toName n
  toName (Exts.DHParen _ h)   = toName h
  toName (Exts.DHApp _ h _)   = toName h

instance ToTyVars (Exts.DeclHead l) where
  toTyVars (Exts.DHead _ _)       = []
  toTyVars (Exts.DHParen _ h)     = toTyVars h
  toTyVars (Exts.DHInfix _ tvb _) = [toTyVar tvb]
  toTyVars (Exts.DHApp _ h tvb)   = toTyVars h ++ [toTyVar tvb]

instance ToNames a => ToNames (Maybe a) where
  toNames Nothing  = []
  toNames (Just a) = toNames a

instance ToNames (Exts.Deriving l) where
#if MIN_VERSION_haskell_src_exts(1,20,0)
  toNames (Exts.Deriving _ _ irules) = concatMap toNames irules
#else
  toNames (Exts.Deriving _ irules)   = concatMap toNames irules
#endif

instance ToNames (Exts.InstRule l) where
  toNames (Exts.IParen _ irule)            = toNames irule
  toNames (Exts.IRule _ _mtvbs _mcxt mihd) = toNames mihd
instance ToNames (Exts.InstHead l) where
  toNames (Exts.IHCon _ n)     = [toName n]
  toNames (Exts.IHInfix _ _ n) = [toName n]
  toNames (Exts.IHParen _ h)   = toNames h
  toNames (Exts.IHApp _ h _)   = toNames h

instance ToCxt (Exts.InstRule l) where
  toCxt (Exts.IRule _ _ cxt _) = toCxt cxt
  toCxt (Exts.IParen _ irule)  = toCxt irule

instance ToCxt (Exts.Context l) where
  toCxt x = case x of
              Exts.CxEmpty _     -> []
              Exts.CxSingle _ x' -> [toPred x']
              Exts.CxTuple _ xs  -> fmap toPred xs

instance ToCxt a => ToCxt (Maybe a) where
    toCxt Nothing  = []
    toCxt (Just a) = toCxt a

instance ToType (Exts.InstRule l) where
    toType (Exts.IRule _ _ _ h)  = toType h
    toType (Exts.IParen _ irule) = toType irule

instance ToType (Exts.InstHead l) where
    toType (Exts.IHCon _ qn)       = toType qn
    toType (Exts.IHInfix _ typ qn) = TH.AppT (toType typ) (toType qn)
    toType (Exts.IHParen _ hd)     = toType hd
    toType (Exts.IHApp _ hd typ)   = TH.AppT (toType hd) (toType typ)

qualConDeclToCon :: Exts.QualConDecl l -> TH.Con
qualConDeclToCon (Exts.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl
qualConDeclToCon (Exts.QualConDecl _ ns cxt cdecl) = TH.ForallC (toTyVarSpec <$> toTyVars ns)
                                                    (toCxt cxt)
                                                    (conDeclToCon cdecl)

instance ToTyVars a => ToTyVars (Maybe a) where
  toTyVars Nothing  = []
  toTyVars (Just a) = toTyVars a

instance ToTyVars a => ToTyVars [a] where
  toTyVars = concatMap toTyVars

instance ToTyVars (Exts.TyVarBind l) where
  toTyVars tvb = [toTyVar tvb]

instance ToType (Exts.QName l) where
    toType = TH.ConT . toName

conDeclToCon :: Exts.ConDecl l -> TH.Con
conDeclToCon (Exts.ConDecl _ n tys)
  = TH.NormalC (toName n) (map toStrictType tys)
conDeclToCon (Exts.RecDecl _ n fieldDecls)
  = TH.RecC (toName n) (concatMap convField fieldDecls)
  where
    convField :: Exts.FieldDecl l -> [TH.VarStrictType]
    convField (Exts.FieldDecl _ ns t) =
      let (strict, ty) = toStrictType t
      in map (\n' -> (toName n', strict, ty)) ns
conDeclToCon h = todo "conDeclToCon" h
-- TODO
-- (Exts.InfixConDecl _ _ _ _)


hsMatchesToFunD :: [Exts.Match l] -> TH.Dec
hsMatchesToFunD [] = TH.FunD (TH.mkName []) []   -- errorish
hsMatchesToFunD xs@(Exts.Match _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)
hsMatchesToFunD xs@(Exts.InfixMatch _ _ n _ _ _ : _) = TH.FunD (toName n) (fmap hsMatchToClause xs)


hsMatchToClause :: Exts.Match l -> TH.Clause
hsMatchToClause (Exts.Match _ _ ps rhs bnds) = TH.Clause
                                                (fmap toPat ps)
                                                (hsRhsToBody rhs)
                                                (toDecs bnds)
hsMatchToClause (Exts.InfixMatch _ p _ ps rhs bnds) = TH.Clause
                                                        (fmap toPat (p:ps))
                                                        (hsRhsToBody rhs)
                                                        (toDecs bnds)



hsRhsToBody :: Exts.Rhs l -> TH.Body
hsRhsToBody (Exts.UnGuardedRhs _ e) = TH.NormalB (toExp e)
hsRhsToBody (Exts.GuardedRhss _ hsgrhs) =
  let fromGuardedB (TH.GuardedB a) = a
      fromGuardedB h               = todo "fromGuardedB" [h]
      -- TODO: (NormalB _)
  in TH.GuardedB . concat
     . fmap (fromGuardedB . hsGuardedRhsToBody)
     $ hsgrhs


hsGuardedRhsToBody :: Exts.GuardedRhs l -> TH.Body
hsGuardedRhsToBody (Exts.GuardedRhs _ [] e)  = TH.NormalB (toExp e)
hsGuardedRhsToBody (Exts.GuardedRhs _ [s] e) = TH.GuardedB [(hsStmtToGuard s, toExp e)]
hsGuardedRhsToBody (Exts.GuardedRhs _ ss e)  = let ss' = fmap hsStmtToGuard ss
                                                   (pgs,ngs) = unzip [(p,n)
                                                                     | (TH.PatG p) <- ss'
                                                                     , n@(TH.NormalG _) <- ss']
                                                   e' = toExp e
                                                   patg = TH.PatG (concat pgs)
                                               in TH.GuardedB $ (patg,e') : zip ngs (repeat e')



hsStmtToGuard :: Exts.Stmt l -> TH.Guard
hsStmtToGuard (Exts.Generator _ p e) = TH.PatG [TH.BindS (toPat p) (toExp e)]
hsStmtToGuard (Exts.Qualifier _ e)   = TH.NormalG (toExp e)
hsStmtToGuard (Exts.LetStmt _ bs)    = TH.PatG [TH.LetS (toDecs bs)]
hsStmtToGuard h                      = todo "hsStmtToGuard" h
-- TODO
-- (Exts.RecStmt _ _)


-----------------------------------------------------------------------------

-- * ToDecs InstDecl
instance ToDecs (Exts.InstDecl l) where
  toDecs (Exts.InsDecl _ decl) = toDecs decl
  toDecs d                     = todo "toDec" d

-- * ToDecs HsDecl HsBinds

instance ToDecs (Exts.Decl l) where
  toDecs _a@(Exts.TypeSig _ ns t)
    -- TODO: fixforall as before?
    -- = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns
    = let xs = fmap (flip TH.SigD (toType t) . toName) ns
       in xs

  toDecs (Exts.InfixDecl l assoc Nothing ops) =
      toDecs (Exts.InfixDecl l assoc (Just 9) ops)
  toDecs (Exts.InfixDecl _ assoc (Just fixity) ops) =
    map (\op -> TH.InfixD (TH.Fixity fixity dir) (toName op)) ops
   where
    dir = case assoc of
      Exts.AssocNone _  -> TH.InfixN
      Exts.AssocLeft _  -> TH.InfixL
      Exts.AssocRight _ -> TH.InfixR

  toDecs a = [toDec a]


-- TODO: see aboe re: fixforall
-- fixForall t@(TH.ForallT _ _ _) = t
-- fixForall t = case vs of
--   [] -> t
--   _  -> TH.ForallT vs [] t
--   where vs = collectVars t
-- collectVars e = case e of
--   VarT n -> [PlainTV n]
--   AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2
--   TH.ForallT ns _ t -> collectVars t \\ ns
--   _          -> []

instance ToDecs a => ToDecs [a] where
  toDecs a = concatMap toDecs a
