{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}

module Jikka.Core.Language.QuasiRules
  ( r,

    -- * Things which `r` uses.
    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)

-- | `Exp` with type `Expr`.
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
          -- Use the same variable name
          ([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
          -- Introduce a new name
          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
          -- Use the same variable name
          ([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
          -- Introduce a new name
          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
    }