{-# 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


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