Translate.hs

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

{- |
  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
) where

import Data.Char (ord, isUpper)
import Data.Typeable
import Data.List (foldl', nub, (\\))
import Language.Haskell.TH.Syntax
import qualified Language.Haskell.Exts.SrcLoc as Hs
import qualified Language.Haskell.Exts.Syntax as Hs

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


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

-- for error messages
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)]

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


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


instance ToPat Lit where
  toPat = LitP
instance (ToPat a) => ToPat [a] where
  toPat = ListP . fmap toPat
instance (ToPat a, ToPat b) => ToPat (a,b) where
  toPat (a,b) = TupP [toPat a, toPat b]
instance (ToPat a, ToPat b, ToPat c) => ToPat (a,b,c) where
  toPat (a,b,c) = 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) = TupP [toPat a, toPat b, toPat c, toPat d]


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


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


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


instance ToName String where
  toName = mkName

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

instance ToName (Hs.SpecialCon l) where
  toName (Hs.UnitCon _) = '()
  toName (Hs.ListCon _) = '[]
  toName (Hs.FunCon _)  = ''(->)
  toName (Hs.TupleCon _ _ n)
    | n<2 = '()
    | otherwise =
      let x = maybe [] (++".") (nameModule '(,))
      in mkName . concat $ x : ["(",replicate (n-1) ',',")"]
  toName (Hs.Cons _)    = '(:)


instance ToName (Hs.QName l) where
--  toName (Hs.Qual (Hs.Module []) n) = toName n
  toName (Hs.Qual _ (Hs.ModuleName _ []) n) = toName n
  toName (Hs.Qual _ (Hs.ModuleName _ m) n) =
    let m' = show . toName $ m
        n' = show . toName $ n
    in toName . concat $ [m',".",n']
  toName (Hs.UnQual _ n) = toName n
  toName (Hs.Special _ s) = toName s

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

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


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

-- * ToLit HsLiteral


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


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

-- * ToPat HsPat


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

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

-- * ToExp HsExp

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

toFieldExp :: Hs.FieldUpdate l -> FieldExp
toFieldExp (Hs.FieldUpdate _ n e) = (toName n, toExp e)




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


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

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

toGuard (Hs.GuardedRhs _ stmts e) = (g, toExp e)
  where
    g = case map toStmt stmts of
      [NoBindS x] -> NormalG x
      xs -> PatG xs

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

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

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

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

-- * ToLoc SrcLoc

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

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

-- * ToType HsType

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

instance ToName Name where
  toName = id

instance ToName TyVarBndr where
  toName (PlainTV n) = n
  toName (KindedTV n _) = n

toKind :: Hs.Kind l -> Kind
toKind = toType

toTyVar :: Hs.TyVarBind l -> TyVarBndr
toTyVar (Hs.KindedVar _ n k) = KindedTV (toName n) (toKind k)
toTyVar (Hs.UnkindedVar _ n) = PlainTV (toName n)

instance ToType (Hs.Type l) where
  toType (Hs.TyStar _) = StarT
  toType (Hs.TyForall _ tvbM cxt t) = ForallT (maybe [] (fmap toTyVar) tvbM) (toCxt cxt) (toType t)
  toType (Hs.TyFun _ a b) = toType a .->. toType b
  toType (Hs.TyList _ t) = ListT `AppT` toType t
  toType (Hs.TyTuple _ b ts) = foldAppT (tuple . length $ ts) (fmap toType ts)
   where
    tuple = case b of
      Hs.Boxed -> TupleT
      Hs.Unboxed -> UnboxedTupleT
  toType (Hs.TyApp _ a b) = AppT (toType a) (toType b)
  toType (Hs.TyVar _ n) = VarT (toName n)
  toType (Hs.TyCon _ qn) = ConT (toName qn)
  toType (Hs.TyParen _ t) = toType t
  -- XXX: need to wrap the name in parens!
  toType (Hs.TyInfix _ a o b) = AppT (AppT (ConT (toName o)) (toType a)) (toType b)
  toType (Hs.TyKind _ t k) = SigT (toType t) (toKind k)
  toType (Hs.TyPromoted _ p) =
      case p of
        Hs.PromotedInteger _ i _ -> LitT $ NumTyLit i
        Hs.PromotedString _ _ s -> LitT $ StrTyLit s
        Hs.PromotedCon _ _q n -> PromotedT (toName n)
        Hs.PromotedList _ _q ts -> foldr (\t pl -> PromotedConsT `AppT` toType t `AppT` pl) PromotedNilT ts
        Hs.PromotedTuple _ ts -> foldr (\t pt -> pt `AppT` toType t) (PromotedTupleT $ length ts) ts
        Hs.PromotedUnit _ -> PromotedT ''()
  toType (Hs.TyEquals _ t1 t2) = EqualityT `AppT` toType t1 `AppT` toType t2
  toType t@(Hs.TySplice _ _) = noTH "toType" t
  toType t@Hs.TyBang{} =
    nonsense "toType" "type cannot have strictness annotations in this context" t
  toType t@(Hs.TyWildCard _ _) = noTH "toType" t
  toType t = todo "toType" t

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


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

instance ToPred (Hs.Asst l) where
    toPred (Hs.ClassA _ n ts) = foldl' AppT (ConT (toName n)) (fmap toType ts)
    toPred (Hs.InfixA _ t1 n t2) = foldl' AppT (ConT (toName n)) (fmap toType [t1,t2])
    toPred (Hs.EqualP _ t1 t2) = foldl' AppT EqualityT (fmap toType [t1,t2])
    toPred (Hs.ParenA _ asst) = toPred asst
    toPred a@Hs.AppA{} = todo "toCxt" a
    toPred a@Hs.WildCardA{} = todo "toCxt" a
    toPred a@Hs.IParam{} = noTH "toCxt" a
    toPred p = todo "toPred" p

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 :: Type -> [Type] -> Type
foldAppT t ts = foldl' AppT t ts

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

-- * ToStmt HsStmt

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


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

-- * ToDec HsDecl

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

  toDec a@(Hs.DataDecl  _ dOrN cxt h qcds qns)
    = case dOrN of
        Hs.DataType _ -> DataD (toCxt cxt)
                             (toName h)
                             (toTyVars h)
                             Nothing
                             (fmap qualConDeclToCon qcds)
                             [] -- TODO (BvD): convert the deriving clause.
        Hs.NewType _  -> let qcd = case qcds of
                                     [x] -> x
                                     _   -> nonsense "toDec" ("newtype with " ++
                                                              "wrong number of constructors") a
                        in NewtypeD (toCxt cxt)
                                    (toName h)
                                    (toTyVars h)
                                    Nothing
                                    (qualConDeclToCon qcd)
                                    [] -- TODO (BvD): convert the deriving clause.

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

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

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

  toDec a@(Hs.FunBind _ mtchs)                           = hsMatchesToFunD mtchs
  toDec (Hs.PatBind _ p rhs bnds)                      = ValD (toPat p)
                                                              (hsRhsToBody rhs)
                                                              (toDecs bnds)

  toDec i@(Hs.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 (Hs.InstDecl _ Nothing irule ids) = InstanceD
    Nothing
    (toCxt irule)
    (toType irule)
    (toDecs ids)

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

  toDec x = todo "toDec" x

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

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

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

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

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

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

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

instance ToNames (Hs.Deriving l) where
#if MIN_VERSION_haskell_src_exts(1,20,1)
  toNames (Hs.Deriving _ _ irules) = concatMap toNames irules
#else
  toNames (Hs.Deriving _   irules) = concatMap toNames irules
#endif
instance ToNames (Hs.InstRule l) where
  toNames (Hs.IParen _ irule) = toNames irule
  toNames (Hs.IRule _ _mtvbs _mcxt mihd) = toNames mihd
instance ToNames (Hs.InstHead l) where
  toNames (Hs.IHCon _ n) = [toName n]
  toNames (Hs.IHInfix _ _ n) = [toName n]
  toNames (Hs.IHParen _ h) = toNames h
  toNames (Hs.IHApp _ h _) = toNames h

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

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

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

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

qualConDeclToCon :: Hs.QualConDecl l -> Con
qualConDeclToCon (Hs.QualConDecl _ Nothing Nothing cdecl) = conDeclToCon cdecl
qualConDeclToCon (Hs.QualConDecl _ ns cxt cdecl) = ForallC (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 (Hs.TyVarBind l) where
  toTyVars tvb = [toTyVar tvb]

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

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


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


hsMatchToClause :: Hs.Match l -> Clause
hsMatchToClause (Hs.Match _ _ ps rhs bnds) = Clause
                                                (fmap toPat ps)
                                                (hsRhsToBody rhs)
                                                (toDecs bnds)



hsRhsToBody :: Hs.Rhs l -> Body
hsRhsToBody (Hs.UnGuardedRhs _ e) = NormalB (toExp e)
hsRhsToBody (Hs.GuardedRhss _ hsgrhs) = let fromGuardedB (GuardedB a) = a
                                      in GuardedB . concat
                                          . fmap (fromGuardedB . hsGuardedRhsToBody)
                                              $ hsgrhs



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



hsStmtToGuard :: Hs.Stmt l -> Guard
hsStmtToGuard (Hs.Generator _ p e) = PatG [BindS (toPat p) (toExp e)]
hsStmtToGuard (Hs.Qualifier _ e)     = NormalG (toExp e)
hsStmtToGuard (Hs.LetStmt _ bs)      = PatG [LetS (toDecs bs)]


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

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

-- * ToDecs HsDecl HsBinds

instance ToDecs (Hs.Decl l) where
  toDecs a@(Hs.TypeSig _ ns t)
    = let xs = fmap (flip SigD (fixForall $ toType t) . toName) ns
       in xs

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

  toDecs a = [toDec a]

collectVars e = case e of
  VarT n -> [PlainTV n]
  AppT t1 t2 -> nub $ collectVars t1 ++ collectVars t2
  ForallT ns _ t -> collectVars t \\ ns
  _          -> []

fixForall t@(ForallT _ _ _) = t
fixForall t = case vs of
  [] -> t
  _  -> ForallT vs [] t
  where vs = collectVars t

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

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