From e644281795b864f3ce86849ce38332d0ec156334 Mon Sep 17 00:00:00 2001 From: Kimiyuki Onaka Date: Tue, 3 Aug 2021 02:46:44 +0900 Subject: [PATCH] feat(core): Add the quasi quote for rewrite rules --- Jikka.cabal | 9 +- package.yaml | 2 +- src/Jikka/Core/Convert/ShortCutFusion.hs | 46 ++---- src/Jikka/Core/Language/QuasiRules.hs | 195 +++++++++++++++++++++++ 4 files changed, 216 insertions(+), 36 deletions(-) create mode 100644 src/Jikka/Core/Language/QuasiRules.hs diff --git a/Jikka.cabal b/Jikka.cabal index 7c88b8cf..bd7e2ee9 100644 --- a/Jikka.cabal +++ b/Jikka.cabal @@ -97,6 +97,7 @@ library Jikka.Core.Language.FreeVars Jikka.Core.Language.LambdaPatterns Jikka.Core.Language.Lint + Jikka.Core.Language.QuasiRules Jikka.Core.Language.RewriteRules Jikka.Core.Language.Runtime Jikka.Core.Language.TypeCheck @@ -166,7 +167,7 @@ library , deepseq >=1.4.4 && <1.5 , directory >=1.3.3 && <1.4 , mtl >=2.2.2 && <2.3 - , template-haskell >=2.14.0 && <2.17 + , template-haskell >=2.16.0 && <2.17 , text >=1.2.3 && <1.3 , transformers >=0.5.6 && <0.6 , vector >=0.12.3 && <0.13 @@ -190,7 +191,7 @@ executable jikka , deepseq >=1.4.4 && <1.5 , directory >=1.3.3 && <1.4 , mtl >=2.2.2 && <2.3 - , template-haskell >=2.14.0 && <2.17 + , template-haskell >=2.16.0 && <2.17 , text >=1.2.3 && <1.3 , transformers >=0.5.6 && <0.6 , vector >=0.12.3 && <0.13 @@ -214,7 +215,7 @@ test-suite jikka-doctest , directory >=1.3.3 && <1.4 , doctest , mtl >=2.2.2 && <2.3 - , template-haskell >=2.14.0 && <2.17 + , template-haskell >=2.16.0 && <2.17 , text >=1.2.3 && <1.3 , transformers >=0.5.6 && <0.6 , vector >=0.12.3 && <0.13 @@ -287,7 +288,7 @@ test-suite jikka-test , hspec , mtl >=2.2.2 && <2.3 , ormolu - , template-haskell >=2.14.0 && <2.17 + , template-haskell >=2.16.0 && <2.17 , text >=1.2.3 && <1.3 , transformers >=0.5.6 && <0.6 , vector >=0.12.3 && <0.13 diff --git a/package.yaml b/package.yaml index 86860ae7..f97bfac3 100644 --- a/package.yaml +++ b/package.yaml @@ -30,7 +30,7 @@ dependencies: - deepseq >= 1.4.4 && < 1.5 - directory >= 1.3.3 && < 1.4 - mtl >= 2.2.2 && < 2.3 - - template-haskell >= 2.14.0 && < 2.17 + - template-haskell >= 2.16.0 && < 2.17 - text >= 1.2.3 && < 1.3 - transformers >= 0.5.6 && < 0.6 - vector >= 0.12.3 && < 0.13 diff --git a/src/Jikka/Core/Convert/ShortCutFusion.hs b/src/Jikka/Core/Convert/ShortCutFusion.hs index 4992bfe5..a9754dfa 100644 --- a/src/Jikka/Core/Convert/ShortCutFusion.hs +++ b/src/Jikka/Core/Convert/ShortCutFusion.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} -- | -- Module : Jikka.Core.Convert.ShortCutFusion @@ -38,6 +39,7 @@ import Jikka.Core.Language.Expr import Jikka.Core.Language.FreeVars import Jikka.Core.Language.LambdaPatterns import Jikka.Core.Language.Lint +import Jikka.Core.Language.QuasiRules import Jikka.Core.Language.RewriteRules import Jikka.Core.Language.Util @@ -48,40 +50,22 @@ import Jikka.Core.Language.Util -- * `Nil` and `Cons` are kept as is. reduceBuild :: MonadAlpha m => RewriteRule m reduceBuild = - let return' = return . Just - in RewriteRule $ \_ -> \case - Range2' l r -> do - let n = Minus' r l - x <- genVarName' - let f = Lam x IntTy (Plus' l (Var x)) - return' $ Map' IntTy IntTy f (Range1' n) - Range3' l r step -> do - let n = CeilDiv' (Minus' r l) step - x <- genVarName' - let f = Lam x IntTy (Plus' l (Mult' step (Var x))) - return' $ Map' IntTy IntTy f (Range1' n) - _ -> return Nothing + mconcat + [ [r| "range2" forall l r. range2 l r = map? (fun i -> l + i) (range (r - l)) |], + [r| "range3" forall l r step. range3 l r step = map? (fun i -> l + i * step) (range ((r - l) /^ step)) |] + ] reduceMapBuild :: MonadAlpha m => RewriteRule m reduceMapBuild = - let return' = return . Just - in RewriteRule $ \_ -> \case - -- reduce `Sorted` - Sorted' _ (Nil' t) -> return' $ Nil' t - Sorted' _ (Range1' n) -> return' $ Range1' n - -- reduce `Reversed` - Reversed' _ (Nil' t) -> return' $ Nil' t - Reversed' _ (Range1' n) -> do - x <- genVarName' - let f = Lam x IntTy (Minus' (Minus' n (Var x)) (LitInt' 1)) - return' $ Map' IntTy IntTy f n - -- reduce `Filter` - Filter' _ _ (Nil' t) -> return' $ Nil' t - -- reduce `Map` - Map' _ _ _ (Nil' t) -> return' $ Nil' t - Map' t1 t2 f (Cons' _ x xs) -> return' $ Cons' t2 (App f x) (Map' t1 t2 f xs) - -- others - _ -> return Nothing + mconcat + [ [r| "sorted/nil" sorted? nil? = nil? |], + [r| "sorted/range" forall n. sorted? (range n) = range n |], + [r| "reversed/nil" reversed? nil? = nil? |], + [r| "reversed/range" forall n. reversed? (range n) = map? (fun i -> n - i - 1) (range n) |], + [r| "filter/nil" filter? _ nil? = nil? |], + [r| "map/nil" map? _ nil? = nil? |], + [r| "map/cons" forall f x xs. map? f (cons? x xs) = cons? (f x) (map? f xs) |] + ] reduceMap :: Monad m => RewriteRule m reduceMap = diff --git a/src/Jikka/Core/Language/QuasiRules.hs b/src/Jikka/Core/Language/QuasiRules.hs new file mode 100644 index 00000000..f35db363 --- /dev/null +++ b/src/Jikka/Core/Language/QuasiRules.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +module Jikka.Core.Language.QuasiRules where + +import Control.Arrow +import Control.Monad.State.Strict +import Data.Data +import Jikka.Common.Error +import Jikka.Common.Format.Error +import qualified Jikka.Core.Convert.TypeInfer as TypeInfer +import Jikka.Core.Language.Expr +import Jikka.Core.Language.RewriteRules +import Jikka.Core.Parse (parseRule) +import Language.Haskell.TH (Body (..), Exp (..), Match (..), 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 f = do + x <- runExceptT f + case x of + Left err -> fail $ "Jikka.Core.Language.QuasiRules.liftError: " ++ unlines (prettyError' err) + Right y -> return y + +lookupValueName :: (MonadTrans t, Monad (t Q), MonadFail (t Q)) => String -> t Q TH.Name +lookupValueName x = do + y <- lift $ TH.lookupValueName x + case y of + Nothing -> fail $ "Jikka.Core.Language.QuasiRules.lookupValueName: undefined symbol: " ++ x + Just y -> return y + +liftDataQ :: Data a => a -> Q Pat +liftDataQ = TH.dataToPatQ (const Nothing) + +data Env = Env + { vars :: [(VarName, Maybe Exp)], + typeVars :: [(TypeName, TH.Name)] + } + +toPatT :: Type -> StateT Env Q Pat +toPatT = \case + VarTy x -> do + env <- gets typeVars + case lookup x env of + Just y -> do + lift [p|((==) $(pure (VarE y)) -> True)|] + Nothing -> do + y <- lift $ TH.newName (unTypeName x) + modify' (\env -> env {typeVars = (x, y) : typeVars env}) + return $ VarP y + IntTy -> lift $ liftDataQ IntTy + BoolTy -> lift $ liftDataQ IntTy + ListTy t -> do + t <- toPatT t + lift [p|ListTy $(pure t)|] + TupleTy ts -> do + ts <- mapM toPatT ts + lift [p|TupleTy $(pure (ListP ts))|] + FunTy t1 t2 -> do + t1 <- toPatT t1 + t2 <- toPatT t2 + lift [p|FunTy $(pure t1) $(pure t2)|] + DataStructureTy ds -> do + lift [p|DataStructureTy $(liftDataQ ds)|] + +toPatE :: Expr -> StateT Env Q Pat +toPatE = \case + Var x -> + if x == VarName "_" + then return WildP + else do + env <- gets vars + case lookup x env of + Just (Just y) -> do + lift [p|((== $(pure y)) -> True)|] + Just Nothing -> do + y <- lift $ TH.newName (unVarName x) + modify' (\env -> env {vars = (x, Just (VarE y)) : vars env}) + return $ VarP y + Nothing -> fail $ "Jikka.Core.Language.QuasiRules.toPatE: undefined variable: " ++ unVarName x + Lit lit -> do + lift [p|Lit $(liftDataQ lit)|] + App e1 e2 -> do + e1 <- toPatE e1 + e2 <- toPatE e2 + lift [p|App $(pure e1) $(pure e2)|] + Lam x t e -> do + t <- toPatT t + y <- lift $ TH.newName (unVarName x) + modify' (\env -> env {vars = (x, Just (VarE y)) : vars env}) + e <- toPatE e + lift [p|Lam $(pure (VarP y)) $(pure t) $(pure e)|] + Let x t e1 e2 -> do + t <- toPatT t + e1 <- toPatE e1 + y <- lift $ TH.newName (unVarName x) + modify' (\env -> env {vars = (x, Just (VarE y)) : vars env}) + e2 <- toPatE e2 + lift [p|Let $(pure (VarP y)) $(pure t) $(pure e1) $(pure e2)|] + +toExpT :: Type -> StateT Env Q Exp +toExpT = \case + VarTy x -> do + env <- gets typeVars + case lookup x env of + Just y -> return $ VarE y + Nothing -> fail $ "Jikka.Core.Language.QuasiRules.toExpT: undefined type variable: " ++ unTypeName x + IntTy -> do + lift $ TH.liftData IntTy + BoolTy -> do + lift $ TH.liftData BoolTy + ListTy t -> do + t <- toExpT t + lift [e|ListTy $(pure t)|] + TupleTy ts -> do + ts <- mapM toExpT ts + lift [e|TupleTy $(pure (ListE ts))|] + FunTy t1 t2 -> do + t1 <- toExpT t1 + t2 <- toExpT t2 + lift [e|FunTy $(pure t1) $(pure t2)|] + DataStructureTy ds -> do + lift $ TH.liftData (DataStructureTy ds) + +toExpE :: Expr -> StateT Env Q ([Stmt], Exp) +toExpE e = do + var <- lookupValueName "Var" + genVarName <- lookupValueName "Jikka.Core.Language.Util.genVarName'" + case e of + Var x -> do + env <- gets vars + case lookup x env of + Just (Just y) -> return ([], y) + _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: undefined variable: " ++ unVarName x + Lit lit -> do + e <- lift [e|Lit $(TH.liftData lit)|] + return ([], e) + App e1 e2 -> do + (stmts, e1) <- toExpE e1 + (stmts', e2) <- toExpE e2 + e <- lift [e|App $(pure e1) $(pure e2)|] + return (stmts ++ stmts', e) + Lam x t e -> do + t <- toExpT t + y <- lift $ TH.newName (unVarName x) + modify' (\env -> env {vars = (x, Just (AppE (ConE var) (VarE y))) : vars env}) + (stmts, e) <- toExpE e + e <- lift [e|Lam $(pure (VarE y)) $(pure t) $(pure e)|] + return (BindS (VarP y) (VarE genVarName) : stmts, e) + Let x t e1 e2 -> do + t <- toExpT t + (stmts, e1) <- toExpE e1 + y <- lift $ TH.newName (unVarName x) + modify' (\env -> env {vars = (x, Just (AppE (ConE var) (VarE y))) : vars env}) + (stmts', e2) <- toExpE e2 + e <- lift [e|Let $(pure (VarE y)) $(pure t) $(pure e1) $(pure e2)|] + return (stmts ++ BindS (VarP y) (VarE genVarName) : stmts', e) + +ruleExp :: String -> Q Exp +ruleExp s = do + (_, args, e1, e2) <- liftError $ parseRule s + (args, e1, e2) <- liftError $ TypeInfer.runRule args e1 e2 + env <- + return $ + Env + { vars = map (second (const Nothing)) args, + typeVars = [] + } + (pat, env) <- runStateT (toPatE e1) env + ((stmts, exp), _) <- runStateT (toExpE e2) env + rewriteRule' <- [e|RewriteRule|] + return' <- [e|return|] + just <- [e|Just|] + nothing <- [e|Nothing|] + return $ + AppE rewriteRule' $ + LamE [WildP] $ + LamCaseE + [ Match pat (NormalB (DoE (stmts ++ [NoBindS (AppE return' (AppE just exp))]))) [], + Match WildP (NormalB (AppE return' nothing)) [] + ] + +r :: TH.QuasiQuoter +r = + TH.QuasiQuoter + { TH.quoteExp = ruleExp, + TH.quotePat = undefined, + TH.quoteType = undefined, + TH.quoteDec = undefined + }