module Language.Haskell.Convert(Convert, convert) where
import Language.Haskell as HS
import Language.Haskell.TH.Syntax as TH
import Language.Haskell.TH.Compat
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 :: TH.Type -> [TH.Type] -> TH.Type
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
#if __GLASGOW_HASKELL__ >= 800
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 :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> unused -> HS.Decl
f t cxt n vs con _ = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
#else
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 :: DataOrNew -> Cxt -> TH.Name -> [TyVarBndr] -> [Con] -> [TH.Name] -> HS.Decl
f t cxt n vs con ds = DataDecl sl t (c cxt) (c n) (c vs) (c con) []
#endif
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.Type where
#if __GLASGOW_HASKELL__ >= 800
conv (Bang SourceUnpack SourceStrict, x) = TyBang UnpackedTy $ TyBang BangedTy $ c x
conv (Bang SourceUnpack _, x) = TyBang UnpackedTy $ c x
conv (Bang _ SourceStrict, x) = TyBang BangedTy $ c x
conv (Bang _ _, x) = c x
#else
conv (IsStrict, x) = TyBang BangedTy $ c x
conv (NotStrict, x) = c x
#if __GLASGOW_HASKELL__ >= 704
conv (Unpacked, x) = TyBang UnpackedTy $ c x
#endif
#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 (ArrowT) = TyCon $ Special FunCon
conv (AppT ListT x) = TyList $ c x
conv (ListT) = TyCon $ Special ListCon
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)
#if __GLASGOW_HASKELL__ >= 800
conv (DataDecl _ DataType ctx nam typ cs ds) =
DataD (c ctx) (c nam) (c typ) Nothing (c cs) []
conv (DataDecl _ NewType ctx nam typ [con] ds) =
NewtypeD (c ctx) (c nam) (c typ) Nothing (c con) []
#else
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))
#endif
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.Type TH.StrictType where
#if __GLASGOW_HASKELL__ >= 800
conv (TyBang BangedTy t) = (Bang NoSourceUnpackedness SourceStrict, c t)
#else
conv (TyBang BangedTy t) = (IsStrict, c t)
#if __GLASGOW_HASKELL__ >= 704
conv (TyBang UnpackedTy t) = (Unpacked, c t)
#else
conv (TyBang UnpackedTy t) = (IsStrict, c t)
#endif
#endif
#if __GLASGOW_HASKELL__ >= 800
conv t = (Bang NoSourceUnpackedness NoSourceStrictness, c t)
#else
conv t = (NotStrict, c t)
#endif
instance Convert ([HS.Name],HS.Type) [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)
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 (Maybe HS.Binds) [TH.Dec] where
conv Nothing = []
conv (Just x) = c x
instance Convert HS.Pat TH.Pat where
conv (PParen x) = c x
conv (PLit Signless 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 (i1) ',' ++ ")") 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
#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
#if __GLASGOW_HASKELL__ < 709
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
#endif
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