{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Jikka.Core.Language.QuasiRules
( r,
module Jikka.Core.Language.Expr,
alphaExpr,
makeRewriteRule,
genVarName',
)
where
import Control.Arrow
import Control.Monad.State.Strict
import Data.Data
import Data.Maybe
import Jikka.Common.Alpha
import Jikka.Common.Error
import Jikka.Common.Format.Error
import qualified Jikka.Core.Convert.Alpha as Alpha
import qualified Jikka.Core.Convert.TypeInfer as TypeInfer
import Jikka.Core.Language.Expr
import Jikka.Core.Language.RewriteRules
import Jikka.Core.Language.Util
import Jikka.Core.Parse (parseRule)
import Language.Haskell.TH (Exp (..), Lit (..), Pat (..), Q, Stmt (..))
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as TH
import qualified Language.Haskell.TH.Syntax as TH
liftError :: ExceptT Error Q a -> Q a
liftError :: ExceptT Error Q a -> Q a
liftError ExceptT Error Q a
f = do
Either Error a
x <- ExceptT Error Q a -> Q (Either Error a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT Error Q a
f
case Either Error a
x of
Left Error
err -> String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q a) -> String -> Q a
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.liftError: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (Error -> [String]
prettyError' Error
err)
Right a
y -> a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
fromVarName :: VarName -> Q TH.Name
fromVarName :: VarName -> Q Name
fromVarName (VarName OccName
x NameFlavour
_) = do
String -> Q Name
TH.newName (String -> OccName -> String
forall a. a -> Maybe a -> a
fromMaybe String
"x" OccName
x)
fromTypeName :: TypeName -> Q TH.Name
fromTypeName :: TypeName -> Q Name
fromTypeName (TypeName OccName
x NameFlavour
_) = do
String -> Q Name
TH.newName (String -> OccName -> String
forall a. a -> Maybe a -> a
fromMaybe String
"t" OccName
x)
liftDataP :: Data a => a -> Q Pat
liftDataP :: a -> Q Pat
liftDataP = (forall b. Data b => b -> Maybe (Q Pat)) -> a -> Q Pat
forall a.
Data a =>
(forall b. Data b => b -> Maybe (Q Pat)) -> a -> Q Pat
TH.dataToPatQ (Maybe (Q Pat) -> b -> Maybe (Q Pat)
forall a b. a -> b -> a
const Maybe (Q Pat)
forall a. Maybe a
Nothing)
type ExprExp = Exp
data RenamedVarName
= DeclaredAtForall
| RenamedVar ExprExp
| RenamedPatLam TH.Name ExprExp
| RenamedExpLam ExprExp
| RenamedPatLet TH.Name ExprExp
| RenamedExpLet ExprExp
deriving (RenamedVarName -> RenamedVarName -> Bool
(RenamedVarName -> RenamedVarName -> Bool)
-> (RenamedVarName -> RenamedVarName -> Bool) -> Eq RenamedVarName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RenamedVarName -> RenamedVarName -> Bool
$c/= :: RenamedVarName -> RenamedVarName -> Bool
== :: RenamedVarName -> RenamedVarName -> Bool
$c== :: RenamedVarName -> RenamedVarName -> Bool
Eq, Eq RenamedVarName
Eq RenamedVarName
-> (RenamedVarName -> RenamedVarName -> Ordering)
-> (RenamedVarName -> RenamedVarName -> Bool)
-> (RenamedVarName -> RenamedVarName -> Bool)
-> (RenamedVarName -> RenamedVarName -> Bool)
-> (RenamedVarName -> RenamedVarName -> Bool)
-> (RenamedVarName -> RenamedVarName -> RenamedVarName)
-> (RenamedVarName -> RenamedVarName -> RenamedVarName)
-> Ord RenamedVarName
RenamedVarName -> RenamedVarName -> Bool
RenamedVarName -> RenamedVarName -> Ordering
RenamedVarName -> RenamedVarName -> RenamedVarName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RenamedVarName -> RenamedVarName -> RenamedVarName
$cmin :: RenamedVarName -> RenamedVarName -> RenamedVarName
max :: RenamedVarName -> RenamedVarName -> RenamedVarName
$cmax :: RenamedVarName -> RenamedVarName -> RenamedVarName
>= :: RenamedVarName -> RenamedVarName -> Bool
$c>= :: RenamedVarName -> RenamedVarName -> Bool
> :: RenamedVarName -> RenamedVarName -> Bool
$c> :: RenamedVarName -> RenamedVarName -> Bool
<= :: RenamedVarName -> RenamedVarName -> Bool
$c<= :: RenamedVarName -> RenamedVarName -> Bool
< :: RenamedVarName -> RenamedVarName -> Bool
$c< :: RenamedVarName -> RenamedVarName -> Bool
compare :: RenamedVarName -> RenamedVarName -> Ordering
$ccompare :: RenamedVarName -> RenamedVarName -> Ordering
$cp1Ord :: Eq RenamedVarName
Ord, Int -> RenamedVarName -> String -> String
[RenamedVarName] -> String -> String
RenamedVarName -> String
(Int -> RenamedVarName -> String -> String)
-> (RenamedVarName -> String)
-> ([RenamedVarName] -> String -> String)
-> Show RenamedVarName
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [RenamedVarName] -> String -> String
$cshowList :: [RenamedVarName] -> String -> String
show :: RenamedVarName -> String
$cshow :: RenamedVarName -> String
showsPrec :: Int -> RenamedVarName -> String -> String
$cshowsPrec :: Int -> RenamedVarName -> String -> String
Show)
expFromRenamedVarName :: RenamedVarName -> Maybe ExprExp
expFromRenamedVarName :: RenamedVarName -> Maybe ExprExp
expFromRenamedVarName = \case
RenamedVarName
DeclaredAtForall -> Maybe ExprExp
forall a. Maybe a
Nothing
RenamedVar ExprExp
e -> ExprExp -> Maybe ExprExp
forall a. a -> Maybe a
Just ExprExp
e
RenamedPatLam Name
_ ExprExp
e -> ExprExp -> Maybe ExprExp
forall a. a -> Maybe a
Just ExprExp
e
RenamedExpLam ExprExp
e -> ExprExp -> Maybe ExprExp
forall a. a -> Maybe a
Just ExprExp
e
RenamedPatLet Name
_ ExprExp
e -> ExprExp -> Maybe ExprExp
forall a. a -> Maybe a
Just ExprExp
e
RenamedExpLet ExprExp
e -> ExprExp -> Maybe ExprExp
forall a. a -> Maybe a
Just ExprExp
e
data Env = Env
{ Env -> [(VarName, RenamedVarName)]
vars :: [(VarName, RenamedVarName)],
Env -> [(TypeName, Name)]
typeVars :: [(TypeName, TH.Name)]
}
toPatT :: Type -> StateT Env Q Pat
toPatT :: Type -> StateT Env Q Pat
toPatT = \case
VarTy TypeName
x -> do
[(TypeName, Name)]
env <- (Env -> [(TypeName, Name)]) -> StateT Env Q [(TypeName, Name)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env -> [(TypeName, Name)]
typeVars
case TypeName -> [(TypeName, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TypeName
x [(TypeName, Name)]
env of
Just Name
y -> do
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|((==) $(pure (VarE y)) -> True)|]
Maybe Name
Nothing -> do
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ TypeName -> Q Name
fromTypeName TypeName
x
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {typeVars :: [(TypeName, Name)]
typeVars = (TypeName
x, Name
y) (TypeName, Name) -> [(TypeName, Name)] -> [(TypeName, Name)]
forall a. a -> [a] -> [a]
: Env -> [(TypeName, Name)]
typeVars Env
env})
Pat -> StateT Env Q Pat
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> StateT Env Q Pat) -> Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
y
Type
IntTy -> Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> StateT Env Q Pat) -> Q Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Type -> Q Pat
forall a. Data a => a -> Q Pat
liftDataP Type
IntTy
Type
BoolTy -> Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> StateT Env Q Pat) -> Q Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Type -> Q Pat
forall a. Data a => a -> Q Pat
liftDataP Type
IntTy
ListTy Type
t -> do
Pat
t <- Type -> StateT Env Q Pat
toPatT Type
t
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|ListTy $(pure t)|]
TupleTy [Type]
ts -> do
[Pat]
ts <- (Type -> StateT Env Q Pat) -> [Type] -> StateT Env Q [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> StateT Env Q Pat
toPatT [Type]
ts
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|TupleTy $(pure (ListP ts))|]
FunTy Type
t1 Type
t2 -> do
Pat
t1 <- Type -> StateT Env Q Pat
toPatT Type
t1
Pat
t2 <- Type -> StateT Env Q Pat
toPatT Type
t2
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|FunTy $(pure t1) $(pure t2)|]
DataStructureTy DataStructure
ds -> do
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|DataStructureTy $(liftDataP ds)|]
toPatL :: Literal -> StateT Env Q Pat
toPatL :: Literal -> StateT Env Q Pat
toPatL = \case
LitBuiltin Builtin
builtin [Type]
ts -> do
[Pat]
ts <- (Type -> StateT Env Q Pat) -> [Type] -> StateT Env Q [Pat]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> StateT Env Q Pat
toPatT [Type]
ts
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|LitBuiltin $(liftDataP builtin) $(pure (ListP ts))|]
lit :: Literal
lit@(LitInt Integer
_) -> Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> StateT Env Q Pat) -> Q Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Literal -> Q Pat
forall a. Data a => a -> Q Pat
liftDataP Literal
lit
lit :: Literal
lit@(LitBool Bool
_) -> Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Pat -> StateT Env Q Pat) -> Q Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Literal -> Q Pat
forall a. Data a => a -> Q Pat
liftDataP Literal
lit
LitNil Type
t -> do
Pat
t <- Type -> StateT Env Q Pat
toPatT Type
t
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|LitNil $(pure t)|]
LitBottom Type
t String
msg -> do
Pat
t <- Type -> StateT Env Q Pat
toPatT Type
t
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|LitBottom $(pure t) $(liftDataP msg)|]
toPatE :: Expr -> StateT Env Q Pat
toPatE :: Expr -> StateT Env Q Pat
toPatE = \case
Var VarName
x ->
if VarName
x VarName -> VarName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName -> NameFlavour -> VarName
VarName OccName
forall a. Maybe a
Nothing NameFlavour
forall a. Maybe a
Nothing
then Pat -> StateT Env Q Pat
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
WildP
else do
[(VarName, RenamedVarName)]
env <- (Env -> [(VarName, RenamedVarName)])
-> StateT Env Q [(VarName, RenamedVarName)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env -> [(VarName, RenamedVarName)]
vars
case RenamedVarName -> Maybe ExprExp
expFromRenamedVarName (RenamedVarName -> Maybe ExprExp)
-> Maybe RenamedVarName -> Maybe (Maybe ExprExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarName -> [(VarName, RenamedVarName)] -> Maybe RenamedVarName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarName
x [(VarName, RenamedVarName)]
env of
Just (Just ExprExp
y) -> do
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|((== $(pure y)) -> True)|]
Just Maybe ExprExp
Nothing -> do
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ VarName -> Q Name
fromVarName VarName
x
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {vars :: [(VarName, RenamedVarName)]
vars = (VarName
x, ExprExp -> RenamedVarName
RenamedVar (Name -> ExprExp
VarE Name
y)) (VarName, RenamedVarName)
-> [(VarName, RenamedVarName)] -> [(VarName, RenamedVarName)]
forall a. a -> [a] -> [a]
: Env -> [(VarName, RenamedVarName)]
vars Env
env})
Pat -> StateT Env Q Pat
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> StateT Env Q Pat) -> Pat -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Pat
VarP Name
y
Maybe (Maybe ExprExp)
Nothing -> String -> StateT Env Q Pat
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Env Q Pat) -> String -> StateT Env Q Pat
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.toPatE: undefined variable (forall is required): " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
formatVarName VarName
x
Lit Literal
lit -> do
Pat
lit <- Literal -> StateT Env Q Pat
toPatL Literal
lit
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|Lit $(pure lit)|]
App Expr
e1 Expr
e2 -> do
Pat
e1 <- Expr -> StateT Env Q Pat
toPatE Expr
e1
Pat
e2 <- Expr -> StateT Env Q Pat
toPatE Expr
e2
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|App $(pure e1) $(pure e2)|]
Lam VarName
x Type
t Expr
e -> do
Pat
t <- Type -> StateT Env Q Pat
toPatT Type
t
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ VarName -> Q Name
fromVarName VarName
x
ExprExp
y' <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Var $(pure (VarE y))|]
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {vars :: [(VarName, RenamedVarName)]
vars = (VarName
x, Name -> ExprExp -> RenamedVarName
RenamedPatLam Name
y ExprExp
y') (VarName, RenamedVarName)
-> [(VarName, RenamedVarName)] -> [(VarName, RenamedVarName)]
forall a. a -> [a] -> [a]
: Env -> [(VarName, RenamedVarName)]
vars Env
env})
Pat
e <- Expr -> StateT Env Q Pat
toPatE Expr
e
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|Lam $(pure (VarP y)) $(pure t) $(pure e)|]
Let VarName
x Type
t Expr
e1 Expr
e2 -> do
Pat
t <- Type -> StateT Env Q Pat
toPatT Type
t
Pat
e1 <- Expr -> StateT Env Q Pat
toPatE Expr
e1
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ VarName -> Q Name
fromVarName VarName
x
ExprExp
y' <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Var $(pure (VarE y))|]
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {vars :: [(VarName, RenamedVarName)]
vars = (VarName
x, Name -> ExprExp -> RenamedVarName
RenamedPatLet Name
y ExprExp
y') (VarName, RenamedVarName)
-> [(VarName, RenamedVarName)] -> [(VarName, RenamedVarName)]
forall a. a -> [a] -> [a]
: Env -> [(VarName, RenamedVarName)]
vars Env
env})
Pat
e2 <- Expr -> StateT Env Q Pat
toPatE Expr
e2
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|Let $(pure (VarP y)) $(pure t) $(pure e1) $(pure e2)|]
Assert Expr
e1 Expr
e2 -> do
Pat
e1 <- Expr -> StateT Env Q Pat
toPatE Expr
e1
Pat
e2 <- Expr -> StateT Env Q Pat
toPatE Expr
e2
Q Pat -> StateT Env Q Pat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [p|Assert $(pure e1) $(pure e2)|]
toExpT :: Type -> StateT Env Q Exp
toExpT :: Type -> StateT Env Q ExprExp
toExpT = \case
VarTy TypeName
x -> do
[(TypeName, Name)]
env <- (Env -> [(TypeName, Name)]) -> StateT Env Q [(TypeName, Name)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env -> [(TypeName, Name)]
typeVars
case TypeName -> [(TypeName, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TypeName
x [(TypeName, Name)]
env of
Just Name
y -> ExprExp -> StateT Env Q ExprExp
forall (m :: * -> *) a. Monad m => a -> m a
return (ExprExp -> StateT Env Q ExprExp)
-> ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Name -> ExprExp
VarE Name
y
Maybe Name
Nothing -> String -> StateT Env Q ExprExp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Env Q ExprExp) -> String -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.toExpT: undefined type variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TypeName -> String
formatTypeName TypeName
x
Type
IntTy -> do
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ExprExp -> StateT Env Q ExprExp)
-> Q ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Type -> Q ExprExp
forall a. Data a => a -> Q ExprExp
TH.liftData Type
IntTy
Type
BoolTy -> do
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ExprExp -> StateT Env Q ExprExp)
-> Q ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Type -> Q ExprExp
forall a. Data a => a -> Q ExprExp
TH.liftData Type
BoolTy
ListTy Type
t -> do
ExprExp
t <- Type -> StateT Env Q ExprExp
toExpT Type
t
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|ListTy $(pure t)|]
TupleTy [Type]
ts -> do
[ExprExp]
ts <- (Type -> StateT Env Q ExprExp) -> [Type] -> StateT Env Q [ExprExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> StateT Env Q ExprExp
toExpT [Type]
ts
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|TupleTy $(pure (ListE ts))|]
FunTy Type
t1 Type
t2 -> do
ExprExp
t1 <- Type -> StateT Env Q ExprExp
toExpT Type
t1
ExprExp
t2 <- Type -> StateT Env Q ExprExp
toExpT Type
t2
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|FunTy $(pure t1) $(pure t2)|]
DataStructureTy DataStructure
ds -> do
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ExprExp -> StateT Env Q ExprExp)
-> Q ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Type -> Q ExprExp
forall a. Data a => a -> Q ExprExp
TH.liftData (DataStructure -> Type
DataStructureTy DataStructure
ds)
toExpL :: Literal -> StateT Env Q Exp
toExpL :: Literal -> StateT Env Q ExprExp
toExpL = \case
LitBuiltin Builtin
builtin [Type]
ts -> do
[ExprExp]
ts <- (Type -> StateT Env Q ExprExp) -> [Type] -> StateT Env Q [ExprExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> StateT Env Q ExprExp
toExpT [Type]
ts
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|LitBuiltin $(TH.liftData builtin) $(pure (ListE ts))|]
lit :: Literal
lit@(LitInt Integer
_) -> Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ExprExp -> StateT Env Q ExprExp)
-> Q ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Literal -> Q ExprExp
forall a. Data a => a -> Q ExprExp
TH.liftData Literal
lit
lit :: Literal
lit@(LitBool Bool
_) -> Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q ExprExp -> StateT Env Q ExprExp)
-> Q ExprExp -> StateT Env Q ExprExp
forall a b. (a -> b) -> a -> b
$ Literal -> Q ExprExp
forall a. Data a => a -> Q ExprExp
TH.liftData Literal
lit
LitNil Type
t -> do
ExprExp
t <- Type -> StateT Env Q ExprExp
toExpT Type
t
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|LitNil $(pure t)|]
LitBottom Type
t String
msg -> do
ExprExp
t <- Type -> StateT Env Q ExprExp
toExpT Type
t
Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|LitBottom $(pure t) $(TH.liftData msg)|]
toExpE :: Expr -> StateT Env Q ([Stmt], Exp)
toExpE :: Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e = do
ExprExp
var <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Var|]
ExprExp
genVarName <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|genVarName'|]
case Expr
e of
Var VarName
x -> do
[(VarName, RenamedVarName)]
env <- (Env -> [(VarName, RenamedVarName)])
-> StateT Env Q [(VarName, RenamedVarName)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Env -> [(VarName, RenamedVarName)]
vars
case RenamedVarName -> Maybe ExprExp
expFromRenamedVarName (RenamedVarName -> Maybe ExprExp)
-> Maybe RenamedVarName -> Maybe (Maybe ExprExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VarName -> [(VarName, RenamedVarName)] -> Maybe RenamedVarName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarName
x [(VarName, RenamedVarName)]
env of
Just (Just ExprExp
y) -> ([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ExprExp
y)
Maybe (Maybe ExprExp)
_ -> String -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Env Q ([Stmt], ExprExp))
-> String -> StateT Env Q ([Stmt], ExprExp)
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.toExpE: undefined variable: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
formatVarName VarName
x
Lit Literal
lit -> do
ExprExp
lit <- Literal -> StateT Env Q ExprExp
toExpL Literal
lit
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Lit $(pure lit)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], ExprExp
e)
App Expr
e1 Expr
e2 -> do
([Stmt]
stmts, ExprExp
e1) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e1
([Stmt]
stmts', ExprExp
e2) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e2
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|App $(pure e1) $(pure e2)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
stmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
stmts', ExprExp
e)
Lam VarName
x Type
t Expr
e -> do
ExprExp
t <- Type -> StateT Env Q ExprExp
toExpT Type
t
Maybe RenamedVarName
y <- (Env -> Maybe RenamedVarName)
-> StateT Env Q (Maybe RenamedVarName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (VarName -> [(VarName, RenamedVarName)] -> Maybe RenamedVarName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarName
x ([(VarName, RenamedVarName)] -> Maybe RenamedVarName)
-> (Env -> [(VarName, RenamedVarName)])
-> Env
-> Maybe RenamedVarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> [(VarName, RenamedVarName)]
vars)
case Maybe RenamedVarName
y of
Just (RenamedPatLam Name
y ExprExp
_) -> do
([Stmt]
stmts, ExprExp
e) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Lam $(pure (VarE y)) $(pure t) $(pure e)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
stmts, ExprExp
e)
Maybe RenamedVarName
Nothing -> do
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ VarName -> Q Name
fromVarName VarName
x
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {vars :: [(VarName, RenamedVarName)]
vars = (VarName
x, ExprExp -> RenamedVarName
RenamedExpLam (ExprExp -> ExprExp -> ExprExp
AppE ExprExp
var (Name -> ExprExp
VarE Name
y))) (VarName, RenamedVarName)
-> [(VarName, RenamedVarName)] -> [(VarName, RenamedVarName)]
forall a. a -> [a] -> [a]
: Env -> [(VarName, RenamedVarName)]
vars Env
env})
([Stmt]
stmts, ExprExp
e) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Lam $(pure (VarE y)) $(pure t) $(pure e)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat -> ExprExp -> Stmt
BindS (Name -> Pat
VarP Name
y) ExprExp
genVarName Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts, ExprExp
e)
Maybe RenamedVarName
_ -> String -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Env Q ([Stmt], ExprExp))
-> String -> StateT Env Q ([Stmt], ExprExp)
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
formatVarName VarName
x
Let VarName
x Type
t Expr
e1 Expr
e2 -> do
ExprExp
t <- Type -> StateT Env Q ExprExp
toExpT Type
t
([Stmt]
stmts, ExprExp
e1) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e1
Maybe RenamedVarName
y <- (Env -> Maybe RenamedVarName)
-> StateT Env Q (Maybe RenamedVarName)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (VarName -> [(VarName, RenamedVarName)] -> Maybe RenamedVarName
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup VarName
x ([(VarName, RenamedVarName)] -> Maybe RenamedVarName)
-> (Env -> [(VarName, RenamedVarName)])
-> Env
-> Maybe RenamedVarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> [(VarName, RenamedVarName)]
vars)
case Maybe RenamedVarName
y of
Just (RenamedPatLet Name
y ExprExp
_) -> do
([Stmt]
stmts', ExprExp
e2) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e2
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Let $(pure (VarE y)) $(pure t) $(pure e1) $(pure e2)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
stmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
stmts', ExprExp
e)
Maybe RenamedVarName
Nothing -> do
Name
y <- Q Name -> StateT Env Q Name
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Q Name -> StateT Env Q Name) -> Q Name -> StateT Env Q Name
forall a b. (a -> b) -> a -> b
$ VarName -> Q Name
fromVarName VarName
x
(Env -> Env) -> StateT Env Q ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Env
env -> Env
env {vars :: [(VarName, RenamedVarName)]
vars = (VarName
x, ExprExp -> RenamedVarName
RenamedExpLet (ExprExp -> ExprExp -> ExprExp
AppE ExprExp
var (Name -> ExprExp
VarE Name
y))) (VarName, RenamedVarName)
-> [(VarName, RenamedVarName)] -> [(VarName, RenamedVarName)]
forall a. a -> [a] -> [a]
: Env -> [(VarName, RenamedVarName)]
vars Env
env})
([Stmt]
stmts', ExprExp
e2) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e2
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Let $(pure (VarE y)) $(pure t) $(pure e1) $(pure e2)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
stmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Pat -> ExprExp -> Stmt
BindS (Name -> Pat
VarP Name
y) ExprExp
genVarName Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmts', ExprExp
e)
Maybe RenamedVarName
_ -> String -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT Env Q ([Stmt], ExprExp))
-> String -> StateT Env Q ([Stmt], ExprExp)
forall a b. (a -> b) -> a -> b
$ String
"Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ VarName -> String
formatVarName VarName
x
Assert Expr
e1 Expr
e2 -> do
([Stmt]
stmts1, ExprExp
e1) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e1
([Stmt]
stmts2, ExprExp
e2) <- Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e2
ExprExp
e <- Q ExprExp -> StateT Env Q ExprExp
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift [e|Assert $(pure e1) $(pure e2)|]
([Stmt], ExprExp) -> StateT Env Q ([Stmt], ExprExp)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Stmt]
stmts1 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
stmts2, ExprExp
e)
alphaExpr :: (MonadAlpha m, MonadError Error m) => [(VarName, Type)] -> Expr -> m Expr
alphaExpr :: [(VarName, Type)] -> Expr -> m Expr
alphaExpr = [(VarName, Type)] -> Expr -> m Expr
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
[(VarName, Type)] -> Expr -> m Expr
Alpha.runExpr
ruleExp :: String -> Q Exp
ruleExp :: String -> Q ExprExp
ruleExp String
s = do
(String
name, [(VarName, Type)]
args, Expr
e1, Expr
e2) <- ExceptT Error Q (String, [(VarName, Type)], Expr, Expr)
-> Q (String, [(VarName, Type)], Expr, Expr)
forall a. ExceptT Error Q a -> Q a
liftError (ExceptT Error Q (String, [(VarName, Type)], Expr, Expr)
-> Q (String, [(VarName, Type)], Expr, Expr))
-> ExceptT Error Q (String, [(VarName, Type)], Expr, Expr)
-> Q (String, [(VarName, Type)], Expr, Expr)
forall a b. (a -> b) -> a -> b
$ String -> ExceptT Error Q (String, [(VarName, Type)], Expr, Expr)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
String -> m (String, [(VarName, Type)], Expr, Expr)
parseRule String
s
([(VarName, Type)]
args, Expr
e1, Expr
e2) <- ExceptT Error Q ([(VarName, Type)], Expr, Expr)
-> Q ([(VarName, Type)], Expr, Expr)
forall a. ExceptT Error Q a -> Q a
liftError (ExceptT Error Q ([(VarName, Type)], Expr, Expr)
-> Q ([(VarName, Type)], Expr, Expr))
-> ExceptT Error Q ([(VarName, Type)], Expr, Expr)
-> Q ([(VarName, Type)], Expr, Expr)
forall a b. (a -> b) -> a -> b
$ [(VarName, Type)]
-> Expr -> Expr -> ExceptT Error Q ([(VarName, Type)], Expr, Expr)
forall (m :: * -> *).
(MonadAlpha m, MonadError Error m) =>
[(VarName, Type)]
-> Expr -> Expr -> m ([(VarName, Type)], Expr, Expr)
TypeInfer.runRule [(VarName, Type)]
args Expr
e1 Expr
e2
Env
env <-
Env -> Q Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> Q Env) -> Env -> Q Env
forall a b. (a -> b) -> a -> b
$
Env :: [(VarName, RenamedVarName)] -> [(TypeName, Name)] -> Env
Env
{ vars :: [(VarName, RenamedVarName)]
vars = ((VarName, Type) -> (VarName, RenamedVarName))
-> [(VarName, Type)] -> [(VarName, RenamedVarName)]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> RenamedVarName)
-> (VarName, Type) -> (VarName, RenamedVarName)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (RenamedVarName -> Type -> RenamedVarName
forall a b. a -> b -> a
const RenamedVarName
DeclaredAtForall)) [(VarName, Type)]
args,
typeVars :: [(TypeName, Name)]
typeVars = []
}
(Pat
pat, Env
env) <- StateT Env Q Pat -> Env -> Q (Pat, Env)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Expr -> StateT Env Q Pat
toPatE Expr
e1) Env
env
[Stmt]
supressUnusedMatchesWarnings <- ([[Stmt]] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Stmt]] -> [Stmt]) -> Q [[Stmt]] -> Q [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q [[Stmt]] -> Q [Stmt])
-> (((VarName, RenamedVarName) -> Q [Stmt]) -> Q [[Stmt]])
-> ((VarName, RenamedVarName) -> Q [Stmt])
-> Q [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(VarName, RenamedVarName)]
-> ((VarName, RenamedVarName) -> Q [Stmt]) -> Q [[Stmt]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Env -> [(VarName, RenamedVarName)]
vars Env
env) (((VarName, RenamedVarName) -> Q [Stmt]) -> Q [Stmt])
-> ((VarName, RenamedVarName) -> Q [Stmt]) -> Q [Stmt]
forall a b. (a -> b) -> a -> b
$ \case
(VarName
_, RenamedVarName -> Maybe ExprExp
expFromRenamedVarName -> Just ExprExp
e) -> do
ExprExp
e <- [e|return $(pure e)|]
[Stmt] -> Q [Stmt]
forall (m :: * -> *) a. Monad m => a -> m a
return [ExprExp -> Stmt
NoBindS ExprExp
e]
(VarName, RenamedVarName)
_ -> [Stmt] -> Q [Stmt]
forall (m :: * -> *) a. Monad m => a -> m a
return []
[Stmt]
supressUnusedMatchesWarnings' <- [(TypeName, Name)] -> ((TypeName, Name) -> Q Stmt) -> Q [Stmt]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Env -> [(TypeName, Name)]
typeVars Env
env) (((TypeName, Name) -> Q Stmt) -> Q [Stmt])
-> ((TypeName, Name) -> Q Stmt) -> Q [Stmt]
forall a b. (a -> b) -> a -> b
$ \(TypeName
_, Name
y) -> do
ExprExp -> Stmt
NoBindS (ExprExp -> Stmt) -> Q ExprExp -> Q Stmt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [e|return $(pure (VarE y))|]
(([Stmt]
stmts, ExprExp
exp), Env
_) <- StateT Env Q ([Stmt], ExprExp) -> Env -> Q (([Stmt], ExprExp), Env)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Expr -> StateT Env Q ([Stmt], ExprExp)
toExpE Expr
e2) Env
env
ExprExp
nop <- [e|return ()|]
ExprExp
exp' <- [e|return $(pure exp)|]
[e|
makeRewriteRule $(pure (LitE (StringL name))) $ \env e -> case e of
$(pure pat) -> do
$(pure (DoE (supressUnusedMatchesWarnings ++ [NoBindS nop])))
$(pure (DoE (supressUnusedMatchesWarnings' ++ [NoBindS nop])))
e <- $(pure (DoE (stmts ++ [NoBindS exp'])))
Just <$> alphaExpr (typeEnv env) e
_ -> return Nothing
|]
r :: TH.QuasiQuoter
r :: QuasiQuoter
r =
QuasiQuoter :: (String -> Q ExprExp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
TH.QuasiQuoter
{ quoteExp :: String -> Q ExprExp
TH.quoteExp = String -> Q ExprExp
ruleExp,
quotePat :: String -> Q Pat
TH.quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined,
quoteType :: String -> Q Type
TH.quoteType = String -> Q Type
forall a. HasCallStack => a
undefined,
quoteDec :: String -> Q [Dec]
TH.quoteDec = String -> Q [Dec]
forall a. HasCallStack => a
undefined
}