haskell-src-meta-0.0.0: src/Language/Haskell/Meta/Syntax/Translate.hs
{-# LANGUAGE TemplateHaskell #-}
{- |
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.Typeable
import Data.Generics
import Data.List (foldl')
import Language.Haskell.TH.Syntax
import Language.Haskell.Exts.Syntax
-----------------------------------------------------------------------------
class ToName a where toName :: 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 ToDec a where toDec :: a -> Dec
class ToStmt a where toStmt :: a -> Stmt
class ToLoc a where toLoc :: a -> Loc
errorMsg :: (Typeable a) => String -> a -> String
errorMsg fun a = concat
[ fun,": "
, show . typeRepTyCon . typeOf $ a
, " not (yet?) implemented"
]
-----------------------------------------------------------------------------
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 HsName where
toName (HsIdent s) = toName s
toName (HsSymbol s) = toName s
instance ToName Module where
toName (Module s) = toName s
instance ToName HsSpecialCon where
toName HsUnitCon = '()
toName HsListCon = '[]
toName HsFunCon = ''(->)
toName (HsTupleCon n)
| n<2 = '()
| otherwise =
let x = maybe [] (++".") (nameModule '())
in toName . concat $ x : ["(",replicate (n-1) ',',")"]
toName HsCons = '(:)
instance ToName HsQName where
toName (Qual (Module []) n) = toName n
toName (Qual m n) =
let m' = show . toName $ m
n' = show . toName $ n
in toName . concat $ [m',".",n']
toName (UnQual n) = toName n
toName (Special s) = toName s
-----------------------------------------------------------------------------
-- * ToLit HsLiteral
instance ToLit HsLiteral where
toLit (HsChar a) = CharL a
toLit (HsString a) = StringL a
toLit (HsInt a) = IntegerL a
toLit (HsFrac a) = RationalL a
toLit (HsCharPrim a) = CharL a -- XXX
toLit (HsStringPrim a) = StringL a -- XXX
toLit (HsIntPrim a) = IntPrimL a
toLit (HsFloatPrim a) = FloatPrimL a
toLit (HsDoublePrim a) = DoublePrimL a
-----------------------------------------------------------------------------
-- * ToPat HsPat
instance ToPat HsPat where
toPat (HsPVar n)
= VarP (toName n)
toPat (HsPLit l)
= LitP (toLit l)
{-
ghci> parseHsPat "-2"
Right (HsPParen (HsPNeg (HsPLit (HsInt 2))))
-}
toPat (HsPNeg p) = error "toPat: HsPNeg not supported"
toPat (HsPInfixApp p n q)= InfixP (toPat p) (toName n) (toPat q)
toPat (HsPApp n ps) = ConP (toName n) (fmap toPat ps)
toPat (HsPTuple ps) = TupP (fmap toPat ps)
toPat (HsPList ps) = ListP (fmap toPat ps)
toPat (HsPParen p) = toPat p
toPat (HsPRec n pfs) = let toFieldPat (HsPFieldPat n p) = (toName n, toPat p)
in RecP (toName n) (fmap toFieldPat pfs)
toPat (HsPAsPat n p) = AsP (toName n) (toPat p)
toPat (HsPWildCard) = WildP
toPat (HsPIrrPat p) = TildeP (toPat p)
toPat (HsPatTypeSig _ p t) = SigP (toPat p) (toType t)
toPat (HsPRPat rps) = error "toPat: HsRPat not supported"
toPat (HsPXTag _ _ _ pM p) = error "toPat: HsPXTag not supported"
toPat (HsPXETag _ _ _ pM) = error "toPat: HsPXETag not supported"
toPat (HsPXPcdata _) = error "toPat: HsPXPcdata not supported"
toPat (HsPXPatTag p) = error "toPat: HsPXPatTag not supported"
-----------------------------------------------------------------------------
-- * ToExp HsExp
instance ToExp HsQOp where
toExp (HsQVarOp n) = VarE (toName n)
toExp (HsQConOp n) = ConE (toName n)
toFieldExp :: HsFieldUpdate -> FieldExp
toFieldExp (HsFieldUpdate n e) = (toName n, toExp e)
instance ToExp HsExp where
{-
data HsExp
= HsVar HsQName
-}
-- | HsIPVar HsIPName
{-
| HsLet HsBinds HsExp
| HsDLet [HsIPBind] HsExp
| HsWith HsExp [HsIPBind]
| HsCase HsExp [HsAlt]
| HsDo [HsStmt]
-- use mfix somehow
| HsMDo [HsStmt]
-}
toExp (HsVar n) = VarE (toName n)
toExp (HsCon n) = ConE (toName n)
toExp (HsLit l) = LitE (toLit l)
toExp (HsInfixApp e o f) = InfixE (Just . toExp $ e) (toExp o) (Just . toExp $ f)
toExp (HsLeftSection e o) = InfixE (Just . toExp $ e) (toExp o) Nothing
toExp (HsRightSection o f) = InfixE Nothing (toExp o) (Just . toExp $ f)
toExp (HsApp e f) = AppE (toExp e) (toExp f)
toExp (HsNegApp e) = AppE (VarE 'negate) (toExp e)
toExp (HsLambda _ ps e) = LamE (fmap toPat ps) (toExp e)
toExp (HsLet bs e) = LetE (hsBindsToDecs bs) (toExp e)
-- toExp (HsWith e bs
toExp (HsIf a b c) = CondE (toExp a) (toExp b) (toExp c)
-- toExp (HsCase e xs)
-- toExp (HsDo ss)
-- toExp (HsMDo ss)
toExp (HsTuple xs) = TupE (fmap toExp xs)
toExp (HsList xs) = ListE (fmap toExp xs)
toExp (HsParen e) = toExp e
toExp (HsRecConstr n xs) = RecConE (toName n) (fmap toFieldExp xs)
toExp (HsRecUpdate e xs) = RecUpdE (toExp e) (fmap toFieldExp xs)
toExp (HsEnumFrom e) = ArithSeqE $ FromR (toExp e)
toExp (HsEnumFromTo e f) = ArithSeqE $ FromToR (toExp e) (toExp f)
toExp (HsEnumFromThen e f) = ArithSeqE $ FromThenR (toExp e) (toExp f)
toExp (HsEnumFromThenTo e f g) = ArithSeqE $ FromThenToR (toExp e) (toExp f) (toExp g)
toExp (HsExpTypeSig _ e t) = SigE (toExp e) (toType t)
-- HsListComp HsExp [HsStmt]
-- toExp (HsListComp e ss) = CompE
-- NEED: a way to go e -> Stmt
toExp a@(HsListComp e ss) = error $ errorMsg "toExp" a
{- HsVarQuote HsQName
| HsTypQuote HsQName
| HsBracketExp HsBracket
| HsSpliceExp HsSplice
data HsBracket
= HsExpBracket HsExp
| HsPatBracket HsPat
| HsTypeBracket HsType
| HsDeclBracket [HsDecl]
data HsSplice = HsIdSplice String | HsParenSplice HsExp -}
toExp (HsSpliceExp spl) = toExp spl
toExp e = error $ errorMsg "toExp" e
instance ToExp HsSplice where
toExp (HsIdSplice s) = VarE (toName s)
toExp (HsParenSplice e) = toExp e
-----------------------------------------------------------------------------
{-
class ToName a where toName :: 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 ToDec a where toDec :: a -> Dec
class ToStmt a where toStmt :: a -> Stmt
class ToLoc a where toLoc :: a -> Loc
-}
{-
TODO:
[]
PARTIAL:
* ToExp HsExp
* ToStmt HsStmt
* ToDec HsDecl
DONE:
* ToLit HsLiteral
* ToName {..}
* ToPat HsPat
* ToLoc SrcLoc
* ToType HsType
-}
-----------------------------------------------------------------------------
-- * ToLoc SrcLoc
instance ToLoc SrcLoc where
toLoc (SrcLoc fn l c) =
Loc fn [] [] (l,c) (-1,-1)
-----------------------------------------------------------------------------
-- * ToType HsType
instance ToName HsTyVarBind where
toName (HsKindedVar n _) = toName n
toName (HsUnkindedVar n) = toName n
{- |
TH does't handle
* unboxed tuples
* implicit params
* infix type constructors
* kind signatures
-}
instance ToType HsType where
toType (HsTyForall tvbM cxt t) = ForallT (maybe [] (fmap toName) tvbM) (fmap toType cxt) (toType t)
toType (HsTyFun a b) = toType a .->. toType b
toType (HsTyTuple _ ts) = foldAppT (TupleT . length $ ts) (fmap toType ts)
toType (HsTyApp a b) = AppT (toType a) (toType b)
toType (HsTyVar n) = VarT (toName n)
toType (HsTyCon qn) = ConT (toName qn)
toType a@(HsTyPred _) = error $ errorMsg "toType" a
-- XXX: need to wrap the name in parens!
toType (HsTyInfix a qn b) = foldAppT (ConT . toName $ qn) (fmap toType [a,b])
toType (HsTyKind t _) = toType t
(.->.) :: Type -> Type -> Type
a .->. b = AppT (AppT ArrowT a) b
{- |
TH doesn't handle:
* implicit params
* equality constraints
-}
instance ToType HsAsst where
toType (HsClassA n ts) = foldAppT (ConT . toName $ n) (fmap toType ts)
toType a@(HsIParam _ _) = error $ errorMsg "toType" a
toType a@(HsEqualP _ _) = error $ errorMsg "toType" a
foldAppT :: Type -> [Type] -> Type
foldAppT t ts = foldl' AppT t ts
-----------------------------------------------------------------------------
-- * ToStmt HsStmt
instance ToStmt HsStmt where
toStmt (HsGenerator _ p e) = BindS (toPat p) (toExp e)
toStmt (HsQualifier e) = NoBindS (toExp e)
toStmt a@(HsLetStmt bnds) = LetS (hsBindsToDecs bnds)
-----------------------------------------------------------------------------
-- * ToDec HsDecl
-- data HsBinds = HsBDecls [HsDecl] | HsIPBinds [HsIPBind]
hsBindsToDecs :: HsBinds -> [Dec]
hsBindsToDecs (HsBDecls ds) = fmap toDec ds
hsBindsToDecs a@(HsIPBinds ipbs) = error $ errorMsg "hsBindsToDecs" a
-- data HsIPBind = HsIPBind SrcLoc HsIPName HsExp
hsBangTypeToStrictType :: HsBangType -> (Strict, Type)
hsBangTypeToStrictType (HsBangedTy t) = (IsStrict, toType t)
hsBangTypeToStrictType (HsUnBangedTy t) = (NotStrict, toType t)
{-
data HsTyVarBind = HsKindedVar HsName HsKind | HsUnkindedVar HsName
data HsConDecl
= HsConDecl HsName [HsBangType]
| HsRecDecl HsName [([HsName], HsBangType)]
-}
{-
hsQualConDeclToCon :: HsQualConDecl -> Con
hsQualConDeclToCon (HsQualConDecl _ tvbs cxt condec) =
case condec of
HsConDecl n bangs ->
HsRecDecl n assocs ->
-}
instance ToDec HsDecl where
toDec (HsTypeDecl _ n ns t) = TySynD (toName n) (fmap toName ns) (toType t)
toDec a@(HsDataDecl _ dOrN cxt n ns qcds qns) = error $ errorMsg "toDec" a
{-
data HsQualConDecl
= HsQualConDecl SrcLoc
[HsTyVarBind] HsContext
HsConDecl
-}
{-
case dOrN of
DataType -> DataD
(fmap toType cxt)
(toName n)
(fmap toName ns)
NewType ->
-}
toDec a@(HsGDataDecl _ dOrN cxt n ns kM gadtDecs) = error $ errorMsg "toDec" a
toDec a@(HsTypeFamDecl _ n ns kM) = error $ errorMsg "toDec" a
toDec a@(HsDataFamDecl _ cxt n ns kM) = error $ errorMsg "toDec" a
toDec a@(HsTypeInsDecl _ ta tb) = error $ errorMsg "toDec" a
toDec a@(HsDataInsDecl _ dOrN t qcds qns) = error $ errorMsg "toDec" a
toDec a@(HsGDataInsDecl _ dOrN t kM gadtDecs) = error $ errorMsg "toDec" a
-- data HsOp = HsVarOp HsName | HsConOp HsName
toDec a@(HsInfixDecl _ asst i ops) = error $ errorMsg "toDec" a
toDec a@(HsClassDecl _ cxt n ns funDeps cDecs) = error $ errorMsg "toDec" a
toDec a@(HsInstDecl _ cxt qn ts instDecs) = error $ errorMsg "toDec" a
toDec a@(HsDerivDecl _ cxt qn ts) = error $ errorMsg "toDec" a
toDec a@(HsDefaultDecl _ ts) = error $ errorMsg "toDec" a
toDec a@(HsSpliceDecl _ s) = error $ errorMsg "toDec" a
toDec a@(HsTypeSig _ ns t) = error $ errorMsg "toDec" a
{- data HsDecl = ... | HsFunBind [HsMatch] | ...
data HsMatch = HsMatch SrcLoc HsName [HsPat] HsRhs HsBinds
data Dec = FunD Name [Clause] | ...
data Clause = Clause [Pat] Body [Dec] -}
toDec a@(HsFunBind mtchs) = hsMatchesToFunD mtchs
{- ghci> parseExp "let x = 2 in x"
LetE [ValD (VarP x) (NormalB (LitE (IntegerL 2))) []] (VarE x)
ghci> unQ[| let x = 2 in x |]
LetE [ValD (VarP x_0) (NormalB (LitE (IntegerL 2))) []] (VarE x_0) -}
toDec (HsPatBind _ p rhs bnds) = ValD (toPat p) (hsRhsToBody rhs) (hsBindsToDecs bnds)
toDec a@(HsForImp _ cconv safe str n t) = error $ errorMsg "toDec" a
toDec a@(HsForExp _ cconv str n t) = error $ errorMsg "toDec" a
hsMatchesToFunD :: [HsMatch] -> Dec
hsMatchesToFunD [] = FunD (mkName []) [] -- errorish
hsMatchesToFunD xs@(HsMatch _ n _ _ _:_) = FunD (toName n) (fmap hsMatchToClause xs)
hsMatchToClause :: HsMatch -> Clause
hsMatchToClause (HsMatch _ _ ps rhs bnds) = Clause
(fmap toPat ps)
(hsRhsToBody rhs)
(hsBindsToDecs bnds)
-- data HsRhs = HsUnGuardedRhs HsExp | HsGuardedRhs [HsGuardedRhs]
-- data HsGuardedRhs = HsGuardedRhs SrcLoc [HsStmt] HsExp
-- data Body = GuardedB [(Guard, Exp)] | NormalB Exp
-- data Guard = NormalG Exp | PatG [Stmt]
hsRhsToBody :: HsRhs -> Body
hsRhsToBody (HsUnGuardedRhs e) = NormalB (toExp e)
hsRhsToBody (HsGuardedRhss hsgrhs) = let fromGuardedB (GuardedB a) = a
in GuardedB . concat
. fmap (fromGuardedB . hsGuardedRhsToBody)
$ hsgrhs
hsGuardedRhsToBody :: HsGuardedRhs -> Body
hsGuardedRhsToBody (HsGuardedRhs _ [] e) = NormalB (toExp e)
hsGuardedRhsToBody (HsGuardedRhs _ [s] e) = GuardedB [(hsStmtToGuard s, toExp e)]
hsGuardedRhsToBody (HsGuardedRhs _ 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 :: HsStmt -> Guard
hsStmtToGuard (HsGenerator _ p e) = PatG [BindS (toPat p) (toExp e)]
hsStmtToGuard (HsQualifier e) = NormalG (toExp e)
hsStmtToGuard a@(HsLetStmt _) = error $ errorMsg "hsStmtToGuardExp" a
-----------------------------------------------------------------------------