{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Ivory.Language.Syntax.Concrete.QQ.BindExp
( fromExp
, fromArea
, fromExpStmt
, fromAreaStmt
) where
import Prelude hiding (exp)
import Language.Haskell.TH hiding (Exp, Stmt,
Type)
import qualified Language.Haskell.TH as T
import qualified Ivory.Language.Proc as I
import qualified Ivory.Language.Ref as I
import Ivory.Language.Syntax.Concrete.ParseAST
import Ivory.Language.Syntax.Concrete.QQ.Common
import Ivory.Language.Syntax.Concrete.QQ.ExprQQ
fromExp :: Insert a -> Exp -> QStM a T.Exp
fromExp f exp = do
env <- (mkBinds f) exp
return (toExp env exp)
mkBinds :: Insert a -> Exp -> QStM a VarEnv
mkBinds f exp = do
envs <- mapM (insertBind f) (collectBindExps exp)
return (concat envs)
insertBind :: Insert a -> Key -> QStM a VarEnv
insertBind f key = do
b <- fromBind f key
i@(_, nm) <- fresh
f key nm b
return [i]
where
fresh = do nm <- liftQ (freshVar key)
return (key, nm)
fromBind :: Insert a -> Key -> QStM a T.Exp
fromBind f key
| isArea key
= fromArea f (keyToArea key)
| isCall key
= fromCall f (keyToCall key)
| otherwise
= error "impossible in fromBind"
fromCall :: Insert a -> Call -> QStM a T.Exp
fromCall f (Call sym args) = do
es <- mapM (fromExp f) args
let call = AppE (VarE 'I.call) (mkVar sym)
return $ callit call es
callToVar :: Call -> String
callToVar (Call sym _) = sym
areaToVar :: Area -> String
areaToVar area = case area of
AreaVar v -> map (\c -> if c == '.' then '_' else c) v
AddrOf v -> areaToVar v
ArrayArea area' _ -> areaToVar area'
StructArea area0 area1 -> areaToVar area0 ++ ('_': areaToVar area1)
fromArea :: Insert a -> Area -> QStM a T.Exp
fromArea f area = case area of
AreaVar v
-> return (mkVar v)
AddrOf area'
-> do a <- (fromArea f) area'
return $ toAddrOf a
ArrayArea area' ixExp
-> do ix <- (fromExp f) ixExp
a <- (fromArea f) area'
return $ toArray a ix
StructArea area0 area1
-> do a0 <- (fromArea f) area0
a1 <- (fromArea f) area1
return $ toStruct a0 a1
freshVar :: Key -> Q Name
freshVar key
| isArea key
= newName $ "deref_" ++ areaToVar (keyToArea key)
| isCall key
= newName $ "call_" ++ callToVar (keyToCall key)
| otherwise
= error "Impossible in freshVar"
insertStmt :: Insert T.Stmt
insertStmt key nm exp
| isArea key
= insert $ BindS (VarP nm) (AppE (VarE 'I.deref) exp)
| isCall key
= insert $ BindS (VarP nm) exp
| otherwise
= error "Impossible in insertStmt"
fromExpStmt :: Exp -> QStM T.Stmt T.Exp
fromExpStmt = fromExp insertStmt
fromAreaStmt :: Area -> QStM T.Stmt T.Exp
fromAreaStmt = fromArea insertStmt