    {-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-}

    module Language.Haskell.Convert(Convert, convert) where

    import Language.Haskell as HS
    import Language.Haskell.TH.Syntax as TH
    import Control.Exception
    import Data.Typeable
    import System.IO.Unsafe
    import Data.Maybe

    class (Typeable a, Typeable b, Show a, Show b) => Convert a b where
        conv :: a -> b

    convert :: forall a b . Convert a b => a -> b
    convert a = unsafePerformIO $
            (return $! (conv a :: b)) `Control.Exception.catch` (\(e :: SomeException) -> error $ msg e)
        where
            msg e = "Could not convert " ++ show (typeOf a) ++ " to " ++
                    show (typeOf (undefined :: b)) ++ "\n" ++ show a ++
                    "\n" ++ show e

    appT = foldl AppT

    c mr = convert mr

    instance Convert a b => Convert [a] [b] where
        conv = map c

    instance Convert TH.Dec HS.Decl where
        conv x = case x of
            DataD cxt n vs con ds -> f DataType cxt n vs con ds
            NewtypeD cxt n vs con ds -> f NewType cxt n vs [con] ds
            where
                f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []

    instance Convert TH.Name HS.TyVarBind where
        conv = UnkindedVar . c

    instance Convert TH.Name HS.Name where
        conv x = name $ if '.' `elem` x2 then reverse $ takeWhile (/= '.') $ reverse x2 else x2
            where x2 = show x

    instance Convert TH.Name HS.QName where
        conv x = if x2 == Ident "[]" then Special ListCon else UnQual x2
            where x2 = c x

    instance Convert TH.Con HS.QualConDecl where
        conv (ForallC vs cxt x) = QualConDecl sl (c vs) (c cxt) (c x)
        conv x = QualConDecl sl [] [] (c x)

    instance Convert TH.Con HS.ConDecl where
        conv (NormalC n xs) = ConDecl (c n) (c xs)
        conv (RecC n xs) = RecDecl (c n) [([c x], c (y,z)) | (x,y,z) <- xs]
        conv (InfixC x n y) = InfixConDecl (c x) (c n) (c y)

    instance Convert TH.StrictType HS.BangType where
        conv (IsStrict, x) = BangedTy $ c x
        conv (NotStrict, x) = UnBangedTy $ c x
    #if __GLASGOW_HASKELL__ >= 704
        conv (Unpacked, x) = BangedTy $ c x
    #endif

    instance Convert TH.Type HS.Type where
        conv (ForallT xs cxt t) = TyForall (Just $ c xs) (c cxt) (c t)
        conv (VarT x) = TyVar $ c x
        conv (ConT x) | ',' `elem` show x = TyTuple Boxed []
                      | otherwise = TyCon $ c x
        conv (AppT (AppT ArrowT x) y) = TyFun (c x) (c y)
        conv (AppT ListT x) = TyList $ c x
        conv (TupleT _) = TyTuple Boxed []
        conv (AppT x y) = case c x of
            TyTuple b xs -> TyTuple b $ xs ++ [c y]
            x -> TyApp x $ c y

    instance Convert TH.Type HS.Asst where
        conv (ConT x) = ClassA (UnQual $ c x) []
        conv (AppT x y) = case c x of
            ClassA a b -> ClassA a (b ++ [c y])

    instance Convert HS.Decl TH.Dec where
        conv (InstDecl _ cxt nam typ ds) = InstanceD (c cxt) (c $ tyApp (TyCon nam) typ) [c d | InsDecl d <- ds]
        conv (FunBind ms@(HS.Match _ nam _ _ _ _:_)) = FunD (c nam) (c ms)
        conv (PatBind _ p _ bod ds) = ValD (c p) (c bod) (c ds)
        conv (TypeSig _ [nam] typ) = SigD (c nam) (c $ foralls typ)
        conv (DataDecl _ DataType ctx nam typ cs ds) =
          DataD (c ctx) (c nam) (c typ) (c cs) (c (map fst ds))
        conv (DataDecl _ NewType ctx nam typ [con] ds) =
          NewtypeD (c ctx) (c nam) (c typ) (c con) (c (map fst ds))

    instance Convert HS.QualConDecl TH.Con where
        conv (QualConDecl _ [] [] con) = c con
        conv (QualConDecl _ vs cx con) = ForallC (c vs) (c cx) (c con)

    instance Convert HS.ConDecl TH.Con where
        conv (ConDecl nam typ) = NormalC (c nam) (c typ)
        conv (InfixConDecl l nam r) = InfixC (c l) (c nam) (c r)
        conv (RecDecl nam fs) = RecC (c nam) (concatMap c fs)

    instance Convert HS.BangType TH.StrictType where
        conv (BangedTy t) = (IsStrict,c t)
        conv (UnBangedTy t) = (NotStrict,c t)

    instance Convert ([HS.Name],HS.BangType) [TH.VarStrictType] where
        conv (names,bt) = [(c name,s,t) | name <- names]
         where (s,t) = c bt

    instance Convert HS.Asst TH.Type where
        conv (InfixA x y z) = c $ ClassA y [x,z]
        conv (ClassA x y) = appT (ConT $ c x) (c y)

    instance Convert HS.Type TH.Type where
        conv (TyCon (Special ListCon)) = ListT
        conv (TyCon (Special UnitCon)) = TupleT 0
        conv (TyParen x) = c x
        conv (TyForall x y z) = ForallT (c $ fromMaybe [] x) (c y) (c z)
        conv (TyVar x) = VarT $ c x
        conv (TyCon x) = if x ~= "[]" then error "here" else ConT $ c x
        conv (TyFun x y) = AppT (AppT ArrowT (c x)) (c y)
        conv (TyList x) = AppT ListT (c x)
        conv (TyTuple _ x) = appT (TupleT (length x)) (c x)
        conv (TyApp x y) = AppT (c x) (c y)

    instance Convert HS.Name TH.Name where
        conv = mkName . filter (`notElem` "()") . prettyPrint

    instance Convert HS.Match TH.Clause where
        conv (HS.Match _ _ ps _ bod ds) = Clause (c ps) (c bod) (c ds)

    instance Convert HS.Rhs TH.Body where
        conv (UnGuardedRhs x) = NormalB (c x)
        conv (GuardedRhss x) = GuardedB (c x)

    instance Convert HS.Exp TH.Exp where
        conv (Con (Special UnitCon)) = TupE []
        conv (Var x) = VarE (c x)
        conv (Con x) = ConE (c x)
        conv (Lit x) = LitE (c x)
        conv (App x y) = AppE (c x) (c y)
        conv (Paren x) = c x
        conv (InfixApp x y z) = InfixE (Just $ c x) (c y) (Just $ c z)
        conv (LeftSection x y) = InfixE (Just $ c x) (c y) Nothing
        conv (RightSection y z) = InfixE Nothing (c y) (Just $ c z)
        conv (Lambda _ x y) = LamE (c x) (c y)
        conv (Tuple _ x) = TupE (c x)
        conv (If x y z) = CondE (c x) (c y) (c z)
        conv (Let x y) = LetE (c x) (c y)
        conv (Case x y) = CaseE (c x) (c y)
        conv (Do x) = DoE (c x)
        conv (EnumFrom x) = ArithSeqE $ FromR (c x)
        conv (EnumFromTo x y) = ArithSeqE $ FromToR (c x) (c y)
        conv (EnumFromThen x y) = ArithSeqE $ FromThenR (c x) (c y)
        conv (EnumFromThenTo x y z) = ArithSeqE $ FromThenToR (c x) (c y) (c z)
        conv (List x) = ListE (c x)
        conv (ExpTypeSig _ x y) = SigE (c x) (c y)
        conv (RecConstr x y) = RecConE (c x) (c y)
        conv (RecUpdate x y) = RecUpdE (c x) (c y)
        -- Work around bug 3395, convert to do notation instead
        conv (ListComp x y) = CompE $ c $ y ++ [QualStmt $ Qualifier x]

    instance Convert HS.GuardedRhs (TH.Guard, TH.Exp) where
        conv = undefined

    instance Convert HS.Binds [TH.Dec] where
        conv (BDecls x) = c x

    instance Convert HS.Pat TH.Pat where
        conv (PParen x) = c x
        conv (PLit x) = LitP (c x)
        conv (PTuple _ x) = TupP (c x)
        conv (PApp x y) = ConP (c x) (c y)
        conv (PVar x) = VarP (c x)
        conv (PInfixApp x y z) = InfixP (c x) (c y) (c z)
        conv (PIrrPat x) = TildeP (c x)
        conv (PAsPat x y) = AsP (c x) (c y)
        conv (PWildCard) = WildP
        conv (PRec x y) = RecP (c x) (c y)
        conv (PList x) = ListP (c x)
        conv (PatTypeSig _ x y) = SigP (c x) (c y)

    instance Convert HS.Literal TH.Lit where
        conv (Char x) = CharL x
        conv (String x) = StringL x
        conv (Int x) = IntegerL x
        conv (Frac x) = RationalL x
        conv (PrimInt x) = IntPrimL x
        conv (PrimWord x) = WordPrimL x
        conv (PrimFloat x) = FloatPrimL x
        conv (PrimDouble x) = DoublePrimL x

    instance Convert HS.QName TH.Name where
        conv (UnQual x) = c x
        conv (Qual m x) = c (Ident $ prettyPrint m ++ "." ++ prettyPrint x)
        conv (Special (TupleCon Boxed i)) = Name (mkOccName $ "(" ++ replicate (i-1) ',' ++ ")") NameS

    instance Convert HS.PatField TH.FieldPat where
        conv = undefined

    instance Convert HS.QOp TH.Exp where
        conv (QVarOp x) = c $ Var x
        conv (QConOp x) = c $ Con x

    instance Convert HS.Alt TH.Match where
        conv (Alt _ x y z) = TH.Match (c x) (c y) (c z)

    instance Convert HS.Stmt TH.Stmt where
        conv (Generator _ x y) = BindS (c x) (c y)
        conv (LetStmt x) = LetS (c x)
        conv (Qualifier x) = NoBindS (c x)

    instance Convert HS.QualStmt TH.Stmt where
        conv (QualStmt x) = c x

    instance Convert HS.FieldUpdate TH.FieldExp where
        conv (FieldUpdate x y) = (c x, c y)

    instance Convert HS.TyVarBind TH.Name where
        conv (UnkindedVar x) = c x

    instance Convert HS.GuardedAlts TH.Body where
        conv (UnGuardedAlt x) = NormalB (c x)
        conv (GuardedAlts x) = GuardedB (c x)

    instance Convert HS.GuardedAlt (TH.Guard, TH.Exp) where
        conv (GuardedAlt _ x y) = (PatG (c x), c y)

    #if __GLASGOW_HASKELL__ >= 612
    instance Convert TH.TyVarBndr HS.TyVarBind where
        conv (PlainTV x) = UnkindedVar $ c x
        conv (KindedTV x y) = KindedVar (c x) $ c y

    #if __GLASGOW_HASKELL__ < 706
    instance Convert TH.Kind HS.Kind where
        conv StarK = KindStar
        conv (ArrowK x y) = KindFn (c x) $ c y
    #else
    instance Convert TH.Kind HS.Kind where
        conv StarT = KindStar
        conv (AppT (AppT ArrowT x) y) = KindFn (c x) (c y)
    #endif

    instance Convert TH.Pred HS.Asst where
        conv (ClassP x y) = ClassA (UnQual $ c x) $ c y
        conv (TH.EqualP x y) = HS.EqualP (c x) $ c y

    instance Convert HS.Asst TH.Pred where
        conv (ClassA x y) = ClassP (c x) $ c y
        conv (HS.EqualP x y) = TH.EqualP (c x) $ c y

    instance Convert HS.TyVarBind TH.TyVarBndr where
        conv (UnkindedVar x) = PlainTV $ c x
        conv (KindedVar x y) = KindedTV (c x) $ c y

    #if __GLASGOW_HASKELL__ < 706
    instance Convert HS.Kind TH.Kind where
        conv KindStar = StarK
        conv (KindFn x y) = ArrowK (c x) $ c y
    #else
    instance Convert HS.Kind TH.Kind where
        conv KindStar = StarT
        conv (KindFn x y) = AppT (AppT ArrowT (c x)) (c y)
    #endif
    #endif