QuasiQuoter.hs

{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
module Language.Java.Paragon.QuasiQuoter where
--import Language.Haskell.TH.Syntax 

--import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Lift
--import Language.Haskell.TH.Lib
import Language.Haskell.Meta.Parse

--import Data.Generics (extQ)
--import Data.Data

import Language.Java.Paragon.Parser
import Language.Java.Paragon.Syntax
import Language.Java.Paragon.Lexer

import Language.Java.Paragon.QuasiQuoter.Lift


import Prelude hiding(exp)

import Text.ParserCombinators.Parsec

--import qualified GHC.Enum as GE 

fromRight :: Either a b -> b
fromRight (Right res) = res
{-
instance Lift Double where
  lift d = let s = show d 
               cs = lift s
           in  [|(read $cs)::Double|]


-- Anti-quoting

antiQ :: Data b => b -> Maybe (TH.Q TH.Exp)
antiQ = const Nothing
        `extQ` antiCaseExp
        `extQ` antiCaseType
        `extQ` antiCaseName
        `extQ` antiCaseIdent
        

-- Idents
instance (Data a, Lift a) => Lift (Ident a) where
  lift = dataToExpQ antiQ

antiCaseIdent :: Ident a -> Maybe (TH.Q TH.Exp)
antiCaseIdent (AntiQIdent _ s) = Just $ TH.varE $ TH.mkName s
antiCaseIdent _ = Nothing

-- Names
instance (Data a, Lift a) => Lift (Name a) where
  lift = dataToExpQ antiQ

antiCaseName :: Name a -> Maybe (TH.Q TH.Exp)
antiCaseName (AntiQName _ s) = Just $ TH.varE $ TH.mkName s
antiCaseName _ = Nothing

-- Types
instance (Data a, Lift a) => Lift (Type a) where
  lift = dataToExpQ antiQ

antiCaseType :: Type a -> Maybe (TH.Q TH.Exp)
antiCaseType (AntiQType _ s) = Just $ TH.varE $ TH.mkName s
antiCaseType _ = Nothing

-- Exps
instance (Data a, Lift a) => Lift (Exp a) where
  lift = dataToExpQ antiQ

antiCaseExp :: Exp a -> Maybe (TH.Q TH.Exp)
antiCaseExp (AntiQExp _ s) = Just $ TH.varE $ TH.mkName s
antiCaseExp _ = Nothing

               
$(deriveLiftMany [''Literal,''ClassType,''TypeArgument,
       ''ClassBody,''ArrayInit,''MethodInvocation,''Op,       
       ''AssignOp,''PolicyExp,''Lhs,''RefType,
       ''ArrayIndex,''FieldAccess,''NonWildTypeArgument,
       ''WildcardBound,''Decl,''VarInit,
       ''Clause, ''LClause,
       ''PrimType,
       ''Atom,
       ''Actor,
       ''ActorName,
       ''Lock,
       ''Block,
       ''MemberDecl,
       ''MethodBody,
       ''FormalParam,
       ''ExceptionSpec,
       ''ConstructorBody,
       ''InterfaceDecl,
       ''BlockStmt,
       ''Modifier,
       ''LockProperties,
       ''ClassDecl,
       ''TypeParam,
       ''VarDecl,
       ''InterfaceBody,
       ''VarDeclId,
       ''ExplConstrInv,
       ''Stmt,
       ''EnumConstant, ''ForInit, ''SwitchBlock, ''Catch,
       ''SwitchLabel, ''EnumBody])

-}
--expToPat :: TS.Exp -> Pat 
--expToPat (LitE l) = [p|$l|]
--expToPat (VarE n) = [p|$n|]

parserQQ :: (Lift a,Show a) => GenParser (L Token) () a -> QuasiQuoter
parserQQ f = QuasiQuoter{ quoteExp=lift.fromRight.(parser f), 
                          quotePat=return.fromRight.parsePat.show.fromRight.(parser f)}       

nameQQ = parserQQ name
expQQ  = parserQQ exp
typeQQ = parserQQ ttype          
stmtQQ = parserQQ stmt
lhsQQ  = parserQQ lhs

varDeclQQ    = parserQQ varDecl
methodBodyQQ = parserQQ methodBody 
memberDeclQQ = parserQQ memberDecl
fieldDeclQQ  = parserQQ fieldDecl
methodDeclQQ = parserQQ methodDecl
modifiersQQ  = parserQQ (list modifier)
formalParamQQ = parserQQ formalParam
blockStmtQQ  = parserQQ blockStmt
classDeclQQ  = parserQQ classDecl