haskell-src-meta-0.8.7: src/Language/Haskell/Meta/Syntax/Translate.hs
{-# 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
) 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 qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Syntax as TH
-----------------------------------------------------------------------------
#if MIN_VERSION_template_haskell(2,17,0)
type TyVarBndr_ flag = TH.TyVarBndr flag
#else
type TyVarBndr_ flag = TH.TyVarBndr
#endif
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
#if MIN_VERSION_template_haskell(2,11,0)
class ToInjectivityAnn a where toInjectivityAnn :: a -> TH.InjectivityAnn
#endif
#if MIN_VERSION_template_haskell(2,12,0)
type DerivClause = TH.DerivClause
#elif MIN_VERSION_template_haskell(2,11,0)
type DerivClause = TH.Pred
#else
type DerivClause = TH.Name
#endif
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) = TH.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)
toExp (Exts.InfixApp _ e o f) = TH.UInfixE (toExp e) (toExp o) (toExp f)
#if MIN_VERSION_template_haskell(2,12,0)
toExp (Exts.App _ e (Exts.TypeApp _ t)) = TH.AppTypeE (toExp e) (toType t)
#else
toExp (Exts.App _ _ e@Exts.TypeApp{}) = noTHyet "toExp" "2.12.0" e
#endif
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 (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 -> foldr (\t pt -> 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
#if MIN_VERSION_template_haskell(2,11,0)
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)
#else
-- TODO: what is this comment? Outdated?
-- TyBang l (BangType l) (Unpackedness l) (Type l)
-- data BangType l = BangedTy l | LazyTy l | NoStrictAnnot l
-- data Unpackedness l = Unpack l | NoUnpack l | NoUnpackPragma l
toStrictType (Exts.TyBang _ b u t) = (toStrict b u, toType t)
where
toStrict :: Exts.BangType l -> Exts.Unpackedness l -> TH.Strict
toStrict (Exts.BangedTy _) _ = TH.IsStrict
toStrict _ (Exts.Unpack _) = TH.Unpacked
toStrict _ _ = TH.NotStrict
toStrictType x = (TH.NotStrict, toType x)
#endif
(.->.) :: 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_template_haskell(2,12,0)
#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
#elif MIN_VERSION_template_haskell(2,11,0)
#if MIN_VERSION_haskell_src_exts(1,20,0)
toDerivClauses (Exts.Deriving _ _ irules) = map toType irules
#else
toDerivClauses (Exts.Deriving _ irules) = map toType irules
#endif
#else
-- template-haskell < 2.11
#if MIN_VERSION_haskell_src_exts(1,20,0)
toDerivClauses (Exts.Deriving _ _ irules) = concatMap toNames irules
#else
toDerivClauses (Exts.Deriving _ irules) = concatMap toNames irules
#endif
#endif
instance ToDerivClauses a => ToDerivClauses (Maybe a) where
toDerivClauses Nothing = []
toDerivClauses (Just a) = toDerivClauses a
instance ToDerivClauses a => ToDerivClauses [a] where
toDerivClauses = concatMap toDerivClauses
#if MIN_VERSION_template_haskell(2,12,0) && MIN_VERSION_haskell_src_exts(1,20,0)
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)
#if 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
#endif
#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)
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#endif
(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)
#if MIN_VERSION_template_haskell(2,11,0)
Nothing
#endif
(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
#if MIN_VERSION_template_haskell(2,11,0)
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)
#else
toDec (Exts.TypeFamDecl _ h sig inj)
= TH.FamilyD TH.TypeFam (toName h) (toTyVars h) (toMaybeKind sig)
toDec (Exts.DataFamDecl _ _ h sig)
= TH.FamilyD TH.DataFam (toName h) (toTyVars h) (toMaybeKind sig)
#endif
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.
#if MIN_VERSION_template_haskell(2,11,0)
toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD
Nothing
(toCxt irule)
(toType irule)
(toDecs ids)
#else
toDec (Exts.InstDecl _ Nothing irule ids) = TH.InstanceD
(toCxt irule)
(toType irule)
(toDecs ids)
#endif
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 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
#if MIN_VERSION_template_haskell(2,11,0)
instance ToInjectivityAnn (Exts.InjectivityInfo l) where
toInjectivityAnn (Exts.InjectivityInfo _ n ns) = TH.InjectivityAnn (toName n) (fmap toName ns)
#endif
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
-----------------------------------------------------------------------------