content: {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE CPP #-}
  
  --
  -- Ivory procedure quasiquoter.
  --
  -- Copyright (C) 2014, Galois, Inc.
  -- All rights reserved.
  --
  
  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
  
  --------------------------------------------------------------------------------
  
  -- | Turn our proc AST value into a Haskell type declaration and definition.
  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))
  
  -- | Turn our importProc AST value into a Haskell type declaration and
  -- definition.
  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))
  
  