{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE CPP #-}
module Ivory.Language.Syntax.Concrete.QQ.ProcQQ where
import Prelude hiding (exp, init)
import Language.Haskell.TH hiding (Stmt, Exp, Type)
import Language.Haskell.TH.Quote()
import qualified Ivory.Language.Proc as I
import Ivory.Language.Syntax.Concrete.ParseAST
#if __GLASGOW_HASKELL__ >= 709
import Ivory.Language.Syntax.Concrete.QQ.Common
#endif
import Ivory.Language.Syntax.Concrete.QQ.CondQQ
import Ivory.Language.Syntax.Concrete.QQ.StmtQQ
import Ivory.Language.Syntax.Concrete.QQ.TypeQQ
fromProc :: ProcDef -> Q [Dec]
fromProc pd = case pd of
#if __GLASGOW_HASKELL__ >= 709
ProcDef retTy procName args body prePosts srcloc -> do
ty <- fromProcType retTy procName args
pb <- procBody
let imp = ValD (VarP $ mkName procName)
(NormalB pb)
[]
lnPrag <- lnPragma srcloc
return (lnPrag ++ [ty, imp])
#else
ProcDef retTy procName args body prePosts _srcloc -> do
ty <- fromProcType retTy procName args
pb <- procBody
let imp = ValD (VarP $ mkName procName)
(NormalB pb)
[]
return [ty, imp]
#endif
where
args' = snd (unzip args)
procBody = do
let vars = map mkName args'
let lams = map VarP vars
prog <- fromProgram body
let bd = AppE (VarE 'I.body) prog
full <- mkPrePostConds prePosts bd
let nm = AppE (VarE 'I.proc) (LitE $ StringL procName)
return (AppE nm (LamE lams full))
fromInclProc :: IncludeProc -> Q [Dec]
fromInclProc pd = case pd of
#if __GLASGOW_HASKELL__ >= 709
IncludeProc retTy procName args (file, sym) srcloc -> do
ty <- fromProcType retTy procName args
lnPrag <- lnPragma srcloc
pb <- procDef
let imp = ValD (VarP $ mkName procName)
(NormalB pb)
[]
return (lnPrag ++ [ty, imp])
#else
IncludeProc retTy procName args (file, sym) _srcloc -> do
ty <- fromProcType retTy procName args
pb <- procDef
let imp = ValD (VarP $ mkName procName)
(NormalB pb)
[]
return [ty, imp]
#endif
where
procDef = do
let nm = AppE (VarE 'I.importProc) (LitE $ StringL sym)
return (AppE nm (LitE $ StringL file))