diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,15 +1,25 @@
# Changelog for Jikka
+## 2021-09-25: v5.6.0.0
+
+Feature:
+
+- Use readable names for variables in generated C++ code ([#232](https://github.com/kmyk/Jikka/pull/232), [#238](https://github.com/kmyk/Jikka/pull/238) by [@kmyk](https://github.com/kmyk))
+
+Bug Fix:
+
+- Fix type errors of `map`, `zip`, and `enumerate` ([#237](https://github.com/kmyk/Jikka/pull/237) by [@zer0-star](https://github.com/zer0-star))
+
## 2021-09-04: v5.5.0.0
Features:
- Now Jikka is available on Web:
-- Solve some formulae in the form of `∑ᵢ ∑ⱼ |aᵢ−aⱼ|` [#210](https://github.com/kmyk/Jikka/pull/210) by [@kmyk](https://github.com/kmyk)
+- Solve some formulae in the form of `∑ᵢ ∑ⱼ |aᵢ−aⱼ|` ([#210](https://github.com/kmyk/Jikka/pull/210) by [@kmyk](https://github.com/kmyk))
Bug Fix:
-- Fix a bug about `std::accumulate` ([#205](https://github.com/kmyk/Jikka/pull/205) by [@riantkb](https://github.com/riantkb)
+- Fix a bug about `std::accumulate` ([#205](https://github.com/kmyk/Jikka/pull/205) by [@riantkb](https://github.com/riantkb))
## 2021-08-24: v5.4.0.0
diff --git a/Jikka.cabal b/Jikka.cabal
--- a/Jikka.cabal
+++ b/Jikka.cabal
@@ -5,7 +5,7 @@
-- see: https://github.com/sol/hpack
name: Jikka
-version: 5.5.0.0
+version: 5.6.0.0
synopsis: A transpiler from Python to C++ for competitive programming
description: Please see the README on GitHub at
category: Compilers/Interpreters
@@ -58,6 +58,7 @@
Jikka.Common.Location
Jikka.Common.Matrix
Jikka.Common.ModInt
+ Jikka.Common.Name
Jikka.Common.Parse.JoinLines
Jikka.Common.Parse.OffsideRule
Jikka.Common.Parse.Read
@@ -95,6 +96,7 @@
Jikka.Core.Language.AssertedHint
Jikka.Core.Language.Beta
Jikka.Core.Language.BuiltinPatterns
+ Jikka.Core.Language.Eta
Jikka.Core.Language.Expr
Jikka.Core.Language.FreeVars
Jikka.Core.Language.LambdaPatterns
@@ -114,6 +116,8 @@
Jikka.CPlusPlus.Convert
Jikka.CPlusPlus.Convert.AddMain
Jikka.CPlusPlus.Convert.BundleRuntime
+ Jikka.CPlusPlus.Convert.BurnFlavouredNames
+ Jikka.CPlusPlus.Convert.EmbedOriginalCode
Jikka.CPlusPlus.Convert.FromCore
Jikka.CPlusPlus.Convert.InlineSetAt
Jikka.CPlusPlus.Convert.MoveSemantics
@@ -262,6 +266,7 @@
Jikka.Core.Language.ArithmeticExprSpec
Jikka.Core.Language.AssertedHintSpec
Jikka.Core.Language.BetaSpec
+ Jikka.Core.Language.EtaSpec
Jikka.Core.ParseSpec
Jikka.CPlusPlus.Convert.FromCoreSpec
Jikka.CPlusPlus.Convert.MoveSemanticsSpec
@@ -299,10 +304,8 @@
, containers >=0.6.0 && <0.7
, deepseq >=1.4.4 && <1.5
, directory >=1.3.3 && <1.4
- , hlint
, hspec
, mtl >=2.2.2 && <2.3
- , ormolu
, template-haskell >=2.15.0 && <2.17
, text >=1.2.3 && <1.3
, transformers >=0.5.6 && <0.6
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -56,10 +56,8 @@
For users:
- [docs/language.md](https://github.com/kmyk/Jikka/blob/master/docs/language.md)
- - [docs/language.ja.md](https://github.com/kmyk/Jikka/blob/master/docs/language.ja.md) (Japanese translation)
- The language specification of our restricted Python / Jikka で使われる制限された Python の言語仕様
- [docs/optimization.md](https://github.com/kmyk/Jikka/blob/master/docs/optimization.md)
- - [docs/optimization.ja.md](https://github.com/kmyk/Jikka/blob/master/docs/optimization.ja.md) (Japanese translation)
- A list of optimizations which Jikka does / Jikka が行なってくれる最適化の一覧
- [examples/](https://github.com/kmyk/Jikka/blob/master/examples)
- [gallery](https://kmyk.github.io/Jikka/gallery)
@@ -69,18 +67,16 @@
For developpers:
- [CONTRIBUTING.md](https://github.com/kmyk/Jikka/blob/master/CONTRIBUTING.md)
- - [CONTRIBUTING.ja.md](https://github.com/kmyk/Jikka/blob/master/CONTRIBUTING.ja.md) (Japanese translation)
- My blog article [競技プログラミングの問題を自動で解きたい - うさぎ小屋](https://kimiyuki.net/blog/2020/12/09/automated-solvers-of-competitive-programming/) (Japanese)
- - 競技プログラミングの問題を自動で解くとはどういうことなのかについて
+ - On what it means to automatically solve problems of competitive programming / 競技プログラミングの問題を自動で解くとはどういうことなのかについて
- [docs/how-it-works.pdf](https://github.com/kmyk/Jikka/blob/master/docs/how-it-works.pdf) (Japanese)
- - 動作原理や関連する理論について
-- [docs/DESIGN.md](https://github.com/kmyk/Jikka/blob/master/docs/DESIGN.md) (Japanese)
- - 実装方針について
-- [docs/internal.ja.md](https://github.com/kmyk/Jikka/blob/master/docs/internal.ja.md) (Japanese)
- - 具体的な処理の流れについて
+ - How it works and related theories / 動作原理や関連する理論
+- [docs/DESIGN.md](https://github.com/kmyk/Jikka/blob/master/docs/DESIGN.md)
+ - The policy of designs / 実装方針
+- [docs/internal.md](https://github.com/kmyk/Jikka/blob/master/docs/internal.md)
+ - The overview of internal processes / 内部の処理の流れ
- [docs/core.md](https://github.com/kmyk/Jikka/blob/master/docs/core.md)
- - [docs/core.ja.md](https://github.com/kmyk/Jikka/blob/master/docs/core.ja.md) (Japanese)
- - core 言語の説明
+ - The specification of core language / core 言語の仕様
- [Haddock](https://hackage.haskell.org/package/Jikka)
- [Haddock (master)](https://kmyk.github.io/Jikka/haddock)
diff --git a/src/Jikka/CPlusPlus/Convert/AddMain.hs b/src/Jikka/CPlusPlus/Convert/AddMain.hs
--- a/src/Jikka/CPlusPlus/Convert/AddMain.hs
+++ b/src/Jikka/CPlusPlus/Convert/AddMain.hs
@@ -23,6 +23,7 @@
import Jikka.Common.Alpha
import Jikka.Common.Error
import qualified Jikka.Common.IOFormat as F
+import Jikka.Common.Name
lookup' :: (MonadState (M.Map String VarName) m, MonadError Error m) => String -> m VarName
lookup' x = do
@@ -38,7 +39,7 @@
F.At e i -> at <$> runFormatExpr e <*> (Var <$> lookup' i)
F.Len e -> do
e <- runFormatExpr e
- return $ cast TyInt32 (Call MethodSize [e])
+ return $ cast TyInt32 (Call' MethodSize [e])
runMainDeclare :: (MonadState (M.Map String VarName) m, MonadAlpha m, MonadError Error m) => F.IOFormat -> m [(S.Set VarName, Statement)]
runMainDeclare format = go M.empty (F.inputTree format)
@@ -46,7 +47,7 @@
go sizes = \case
F.Exp e -> do
(x, indices) <- F.unpackSubscriptedVar e
- y <- renameVarName LocalNameKind x
+ y <- renameVarName' LocalNameHint x
modify' $ M.insert x y
let lookupSize i = case M.lookup i sizes of
Just e -> return e
@@ -78,7 +79,7 @@
(stmts', initialized) <- go initialized (F.Seq formats)
return (stmts ++ stmts', initialized)
F.Loop i n body -> do
- j <- renameVarName LoopCounterNameKind i
+ j <- renameVarName' LoopCounterNameHint i
modify' $ M.insert i j
n <- runFormatExpr n
(body, initialized) <- go initialized body
@@ -90,14 +91,14 @@
runMainSolve :: (MonadState (M.Map String VarName) m, MonadAlpha m, MonadError Error m) => F.IOFormat -> m Statement
runMainSolve format = do
args <- mapM lookup' (F.inputVariables format)
- let solve = Call (Function "solve" []) (map Var args)
+ let solve = Call' (Function "solve" []) (map Var args)
case F.outputVariables format of
Left x -> do
- y <- renameVarName LocalNameKind x
+ y <- renameVarName' LocalNameHint x
modify' $ M.insert x y
return $ Declare TyAuto y (DeclareCopy solve)
Right xs -> do
- ys <- mapM (renameVarName LocalNameKind) xs
+ ys <- mapM (renameVarName' LocalNameHint) xs
modify' $ \env -> foldl (\env (x, y) -> M.insert x y env) env (zip xs ys)
return $ DeclareDestructure ys solve
@@ -111,7 +112,7 @@
F.Newline -> return [coutStatement (Lit (LitChar '\n'))]
F.Seq formats -> concat <$> mapM go formats
F.Loop i n body -> do
- j <- renameVarName LoopCounterNameKind i
+ j <- renameVarName' LoopCounterNameHint i
modify' $ M.insert i j
n <- runFormatExpr n
body <- go body
diff --git a/src/Jikka/CPlusPlus/Convert/BurnFlavouredNames.hs b/src/Jikka/CPlusPlus/Convert/BurnFlavouredNames.hs
new file mode 100644
--- /dev/null
+++ b/src/Jikka/CPlusPlus/Convert/BurnFlavouredNames.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- |
+-- Module : Jikka.CPlusPlus.Convert.BurnFlavouredNames
+-- Description : remove unique numbers from names as a preprocess to emit the result source code. / 結果のソースコードを出力する前処理として、名前に付けられた一意な整数を解決します。
+-- Copyright : (c) Kimiyuki Onaka, 2020
+-- License : Apache License 2.0
+-- Maintainer : kimiyuki95@gmail.com
+-- Stability : experimental
+-- Portability : portable
+module Jikka.CPlusPlus.Convert.BurnFlavouredNames
+ ( run,
+ )
+where
+
+import Control.Monad.State.Strict
+import qualified Data.Map as M
+import Data.Maybe
+import qualified Data.Set as S
+import Jikka.CPlusPlus.Language.Expr
+import Jikka.CPlusPlus.Language.Util
+import Jikka.Common.Alpha
+import Jikka.Common.Error
+import Jikka.Common.Name
+
+data Env = Env
+ { renameMapping :: M.Map VarName VarName,
+ usedVars :: S.Set String
+ }
+ deriving (Eq, Ord, Read, Show)
+
+emptyEnv :: Env
+emptyEnv =
+ Env
+ { renameMapping = M.empty,
+ usedVars = S.empty
+ }
+
+fromNameHint :: Maybe NameHint -> String
+fromNameHint = \case
+ Nothing -> "u"
+ Just LocalNameHint -> "x"
+ Just LocalArgumentNameHint -> "b"
+ Just LoopCounterNameHint -> "i"
+ Just ConstantNameHint -> "c"
+ Just FunctionNameHint -> "f"
+ Just ArgumentNameHint -> "a"
+ Just (AdHocNameHint hint) -> hint
+
+chooseOccName :: S.Set String -> VarName -> String
+chooseOccName used (VarName occ _ kind) =
+ let occ_workaround = (\s -> if '$' `elem` s then Nothing else Just s) =<< occ -- TODO: Remove this after Python stops using variables with `$`.
+ base = fromMaybe (fromNameHint kind) occ_workaround
+ occs = base : map (\i -> base ++ show i) [2 ..]
+ occ' = head $ filter (`S.notMember` used) occs
+ in occ'
+
+rename :: MonadState Env m => VarName -> m VarName
+rename x = do
+ y <- gets $ M.lookup x . renameMapping
+ case y of
+ Just y -> return y
+ Nothing -> do
+ y' <- flip chooseOccName x <$> gets usedVars
+ let y = VarName (Just y') Nothing Nothing
+ modify $ \env ->
+ env
+ { renameMapping = M.insert x y (renameMapping env),
+ usedVars = S.insert y' (usedVars env)
+ }
+ return y
+
+runProgram :: MonadState Env m => Program -> m Program
+runProgram = mapVarNameProgramM rename
+
+run :: (MonadAlpha m, MonadError Error m) => Program -> m Program
+run prog = wrapError' "Jikka.CPlusPlus.Convert.BurnFlavouredNames" $ do
+ evalStateT (runProgram prog) emptyEnv
diff --git a/src/Jikka/CPlusPlus/Convert/EmbedOriginalCode.hs b/src/Jikka/CPlusPlus/Convert/EmbedOriginalCode.hs
new file mode 100644
--- /dev/null
+++ b/src/Jikka/CPlusPlus/Convert/EmbedOriginalCode.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Jikka.CPlusPlus.Convert.EmbedOriginalCode where
+
+import qualified Data.Text as T
+import Data.Version (showVersion)
+import Paths_Jikka (version)
+
+run' :: T.Text -> T.Text
+run' input =
+ let headers =
+ [ "// This C++ code is transpiled using Jikka transpiler v" <> T.pack (showVersion version) <> " https://github.com/kmyk/Jikka",
+ "// The original Python code:"
+ ]
+ in T.unlines (headers ++ map ("// " <>) (T.lines input))
+
+run :: T.Text -> T.Text -> T.Text
+run input output = run' input <> output
diff --git a/src/Jikka/CPlusPlus/Convert/FromCore.hs b/src/Jikka/CPlusPlus/Convert/FromCore.hs
--- a/src/Jikka/CPlusPlus/Convert/FromCore.hs
+++ b/src/Jikka/CPlusPlus/Convert/FromCore.hs
@@ -23,8 +23,10 @@
import qualified Jikka.CPlusPlus.Language.Util as Y
import Jikka.Common.Alpha
import Jikka.Common.Error
+import Jikka.Common.Name
import qualified Jikka.Core.Format as X (formatBuiltinIsolated, formatType)
import qualified Jikka.Core.Language.BuiltinPatterns as X
+import qualified Jikka.Core.Language.Eta as X
import qualified Jikka.Core.Language.Expr as X
import qualified Jikka.Core.Language.LambdaPatterns as X
import qualified Jikka.Core.Language.TypeCheck as X
@@ -33,19 +35,68 @@
--------------------------------------------------------------------------------
-- monad
-renameVarName' :: MonadAlpha m => Y.NameKind -> X.VarName -> m Y.VarName
-renameVarName' kind x = Y.renameVarName kind (X.unVarName x)
+renameVarName' :: MonadAlpha m => NameHint -> X.VarName -> m Y.VarName
+renameVarName' kind (X.VarName occ _) = case occ of
+ Nothing -> Y.newFreshName kind
+ Just occ -> Y.renameVarName' kind occ
-type Env = [(X.VarName, X.Type, Y.VarName)]
+renameFunName' :: MonadError Error m => X.VarName -> m Y.FunName
+renameFunName' = \case
+ X.VarName (Just occ) _ -> return $ Y.FunName occ
+ _ -> throwInternalError "annonymous toplevel-let is not allowed"
+newFreshNameWithAdHocHintFromExpr :: MonadAlpha m => String -> Y.Expr -> m Y.VarName
+newFreshNameWithAdHocHintFromExpr prefix e = case e of
+ Y.Var (Y.VarName (Just occ) _ _) -> Y.newFreshName (AdHocNameHint (prefix ++ "_" ++ occ))
+ _ -> Y.newFreshName (AdHocNameHint prefix)
+
+newFreshNameWithAdHocHintFromExpr' :: MonadAlpha m => String -> X.Expr -> m Y.VarName
+newFreshNameWithAdHocHintFromExpr' prefix e = case e of
+ X.Var (X.VarName (Just occ) _) -> Y.newFreshName (AdHocNameHint (prefix ++ "_" ++ occ))
+ _ -> Y.newFreshName (AdHocNameHint prefix)
+
+data Env = Env
+ { typeEnv :: [(X.VarName, X.Type)],
+ varMapping :: [(X.VarName, Y.VarName)],
+ funMapping :: [(X.VarName, Y.FunName)]
+ }
+ deriving (Eq, Ord, Show, Read)
+
+emptyEnv :: Env
+emptyEnv =
+ Env
+ { typeEnv = [],
+ varMapping = [],
+ funMapping = []
+ }
+
+pushVar :: X.VarName -> X.Type -> Y.VarName -> Env -> Env
+pushVar x t y env =
+ env
+ { typeEnv = (x, t) : typeEnv env,
+ varMapping = (x, y) : varMapping env
+ }
+
+pushFun :: X.VarName -> X.Type -> Y.FunName -> Env -> Env
+pushFun x t y env =
+ env
+ { typeEnv = (x, t) : typeEnv env,
+ funMapping = (x, y) : funMapping env
+ }
+
typecheckExpr :: MonadError Error m => Env -> X.Expr -> m X.Type
-typecheckExpr env = X.typecheckExpr (map (\(x, t, _) -> (x, t)) env)
+typecheckExpr env = X.typecheckExpr (typeEnv env)
lookupVarName :: MonadError Error m => Env -> X.VarName -> m Y.VarName
-lookupVarName env x = case lookup x (map (\(x, _, y) -> (x, y)) env) of
+lookupVarName env x = case lookup x (varMapping env) of
Just y -> return y
- Nothing -> throwInternalError $ "undefined variable: " ++ X.unVarName x
+ Nothing -> throwInternalError $ "undefined variable: " ++ X.formatVarName x
+lookupFunName :: MonadError Error m => Env -> X.VarName -> m Y.FunName
+lookupFunName env x = case lookup x (funMapping env) of
+ Just y -> return y
+ Nothing -> throwInternalError $ "undefined function: " ++ X.formatVarName x
+
class Monad m => MonadStatements m where
useStatement :: Y.Statement -> m ()
@@ -104,7 +155,7 @@
return $ Y.vecCtor t []
X.LitBottom t err -> do
t <- runType t
- return $ Y.Call (Y.Function "jikka::error" [t]) [Y.Lit (Y.LitString err)]
+ return $ Y.Call' (Y.Function "jikka::error" [t]) [Y.Lit (Y.LitString err)]
arityOfBuiltin :: MonadError Error m => X.Builtin -> [X.Type] -> m Int
arityOfBuiltin builtin ts = case builtin of
@@ -123,8 +174,8 @@
t <- runType t
n <- runExpr env n
x <- runExpr env x
- y <- Y.newFreshName Y.LocalNameKind
- i <- Y.newFreshName Y.LoopCounterNameKind
+ y <- Y.newFreshName LocalNameHint
+ i <- Y.newFreshName LoopCounterNameHint
(stmtsF, body, f) <- runExprFunction env f (Y.Var y)
useStatement $ Y.Declare t y (Y.DeclareCopy x)
useStatements stmtsF
@@ -142,7 +193,7 @@
return $ Y.Cond e1' e2' e3'
_ -> do
t <- runType t
- phi <- Y.newFreshName Y.LocalNameKind
+ phi <- Y.newFreshName LocalNameHint
let assign = Y.Assign . Y.AssignExpr Y.SimpleAssign (Y.LeftVar phi)
useStatement $ Y.Declare t phi Y.DeclareDefault
useStatement $ Y.If e1' (stmts2 ++ [assign e2']) (Just (stmts3 ++ [assign e3']))
@@ -154,8 +205,8 @@
xs <- runExpr env xs
t1 <- runType t1
t2 <- runType t2
- y <- Y.newFreshName Y.LocalNameKind
- x <- Y.newFreshName Y.LocalNameKind
+ y <- Y.newFreshName LocalNameHint
+ x <- Y.newFreshName LocalNameHint
(stmtsF, body, f) <- runExprFunction2 env f (Y.Var y) (Y.Var x)
useStatement $ Y.Declare t2 y (Y.DeclareCopy init)
useStatements stmtsF
@@ -164,7 +215,7 @@
runMap :: (MonadStatements m, MonadAlpha m, MonadError Error m) => Env -> X.Type -> X.Type -> X.Expr -> X.Expr -> m Y.Expr
runMap env _ t2 f xs = do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- newFreshNameWithAdHocHintFromExpr' "mapped" xs
t2 <- runType t2
case (f, xs) of
-- optimize @map (const e) xs@
@@ -176,7 +227,7 @@
-- other cases
_ -> do
xs <- runExpr env xs
- i <- Y.newFreshName Y.LoopCounterNameKind
+ i <- Y.newFreshName LoopCounterNameHint
(stmtsF, body, f) <- runExprFunction env f (Y.at xs (Y.Var i))
useStatement $ Y.Declare (Y.TyVector t2) ys (Y.DeclareCopy (Y.vecCtor t2 [Y.size xs]))
useStatements stmtsF
@@ -264,18 +315,18 @@
X.Plus -> go02 $ \e1 e2 -> Y.BinOp Y.Add e1 e2
X.Minus -> go02 $ \e1 e2 -> Y.BinOp Y.Sub e1 e2
X.Mult -> go02 $ \e1 e2 -> Y.BinOp Y.Mul e1 e2
- X.FloorDiv -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::floordiv" []) [e1, e2]
- X.FloorMod -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::floormod" []) [e1, e2]
- X.CeilDiv -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::ceildiv" []) [e1, e2]
- X.CeilMod -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::ceilmod" []) [e1, e2]
- X.JustDiv -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::justdiv" []) [e1, e2]
- X.Pow -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::notmod::pow" []) [e1, e2]
+ X.FloorDiv -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::floordiv" []) [e1, e2]
+ X.FloorMod -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::floormod" []) [e1, e2]
+ X.CeilDiv -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::ceildiv" []) [e1, e2]
+ X.CeilMod -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::ceilmod" []) [e1, e2]
+ X.JustDiv -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::justdiv" []) [e1, e2]
+ X.Pow -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::notmod::pow" []) [e1, e2]
-- advanced arithmetical functions
- X.Abs -> go01 $ \e -> Y.Call (Y.Function "std::abs" []) [e]
- X.Gcd -> go02 $ \e1 e2 -> Y.Call (Y.Function "std::gcd" []) [e1, e2]
- X.Lcm -> go02 $ \e1 e2 -> Y.Call (Y.Function "std::lcm" []) [e1, e2]
- X.Min2 -> go12 $ \t e1 e2 -> Y.Call (Y.Function "std::min" [t]) [e1, e2]
- X.Max2 -> go12 $ \t e1 e2 -> Y.Call (Y.Function "std::max" [t]) [e1, e2]
+ X.Abs -> go01 $ \e -> Y.Call' (Y.Function "std::abs" []) [e]
+ X.Gcd -> go02 $ \e1 e2 -> Y.Call' (Y.Function "std::gcd" []) [e1, e2]
+ X.Lcm -> go02 $ \e1 e2 -> Y.Call' (Y.Function "std::lcm" []) [e1, e2]
+ X.Min2 -> go12 $ \t e1 e2 -> Y.Call' (Y.Function "std::min" [t]) [e1, e2]
+ X.Max2 -> go12 $ \t e1 e2 -> Y.Call' (Y.Function "std::max" [t]) [e1, e2]
X.Iterate -> go13'' $ runIterate env
-- logical functions
X.Not -> go01 $ \e -> Y.UnOp Y.Not e
@@ -291,34 +342,34 @@
X.BitLeftShift -> go02 $ \e1 e2 -> Y.BinOp Y.BitLeftShift e1 e2
X.BitRightShift -> go02 $ \e1 e2 -> Y.BinOp Y.BitRightShift e1 e2
-- matrix functions
- X.MatAp h w -> go02 $ \f x -> Y.Call (Y.Function "jikka::mat::ap" [Y.TyIntValue h, Y.TyIntValue w]) [f, x]
- X.MatZero h w -> go00 $ Y.Call (Y.Function "jikka::mat::zero" [Y.TyIntValue h, Y.TyIntValue w]) []
- X.MatOne n -> go00 $ Y.Call (Y.Function "jikka::mat::one" [Y.TyIntValue n]) []
- X.MatAdd h w -> go02 $ \f g -> Y.Call (Y.Function "jikka::mat::add" [Y.TyIntValue h, Y.TyIntValue w]) [f, g]
- X.MatMul h n w -> go02 $ \f g -> Y.Call (Y.Function "jikka::mat::mul" [Y.TyIntValue h, Y.TyIntValue n, Y.TyIntValue w]) [f, g]
- X.MatPow n -> go02 $ \f k -> Y.Call (Y.Function "jikka::mat::pow" [Y.TyIntValue n]) [f, k]
- X.VecFloorMod n -> go02 $ \x m -> Y.Call (Y.Function "jikka::modmat::floormod" [Y.TyIntValue n]) [x, m]
- X.MatFloorMod h w -> go02 $ \f m -> Y.Call (Y.Function "jikka::modmat::floormod" [Y.TyIntValue h, Y.TyIntValue w]) [f, m]
+ X.MatAp h w -> go02 $ \f x -> Y.Call' (Y.Function "jikka::mat::ap" [Y.TyIntValue h, Y.TyIntValue w]) [f, x]
+ X.MatZero h w -> go00 $ Y.Call' (Y.Function "jikka::mat::zero" [Y.TyIntValue h, Y.TyIntValue w]) []
+ X.MatOne n -> go00 $ Y.Call' (Y.Function "jikka::mat::one" [Y.TyIntValue n]) []
+ X.MatAdd h w -> go02 $ \f g -> Y.Call' (Y.Function "jikka::mat::add" [Y.TyIntValue h, Y.TyIntValue w]) [f, g]
+ X.MatMul h n w -> go02 $ \f g -> Y.Call' (Y.Function "jikka::mat::mul" [Y.TyIntValue h, Y.TyIntValue n, Y.TyIntValue w]) [f, g]
+ X.MatPow n -> go02 $ \f k -> Y.Call' (Y.Function "jikka::mat::pow" [Y.TyIntValue n]) [f, k]
+ X.VecFloorMod n -> go02 $ \x m -> Y.Call' (Y.Function "jikka::modmat::floormod" [Y.TyIntValue n]) [x, m]
+ X.MatFloorMod h w -> go02 $ \f m -> Y.Call' (Y.Function "jikka::modmat::floormod" [Y.TyIntValue h, Y.TyIntValue w]) [f, m]
-- modular functions
- X.ModNegate -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::mod::negate" []) [e1, e2]
- X.ModPlus -> go03 $ \e1 e2 e3 -> Y.Call (Y.Function "jikka::mod::plus" []) [e1, e2, e3]
- X.ModMinus -> go03 $ \e1 e2 e3 -> Y.Call (Y.Function "jikka::mod::minus" []) [e1, e2, e3]
- X.ModMult -> go03 $ \e1 e2 e3 -> Y.Call (Y.Function "jikka::mod::mult" []) [e1, e2, e3]
- X.ModInv -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::mod::inv" []) [e1, e2]
- X.ModPow -> go03 $ \e1 e2 e3 -> Y.Call (Y.Function "jikka::mod::pow" []) [e1, e2, e3]
- X.ModMatAp h w -> go03 $ \f x m -> Y.Call (Y.Function "jikka::modmat::ap" [Y.TyIntValue h, Y.TyIntValue w]) [f, x, m]
- X.ModMatAdd h w -> go03 $ \f g m -> Y.Call (Y.Function "jikka::modmat::add" [Y.TyIntValue h, Y.TyIntValue w]) [f, g, m]
- X.ModMatMul h n w -> go03 $ \f g m -> Y.Call (Y.Function "jikka::modmat::mul" [Y.TyIntValue h, Y.TyIntValue n, Y.TyIntValue w]) [f, g, m]
- X.ModMatPow n -> go03 $ \f k m -> Y.Call (Y.Function "jikka::modmat::pow" [Y.TyIntValue n]) [f, k, m]
+ X.ModNegate -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::mod::negate" []) [e1, e2]
+ X.ModPlus -> go03 $ \e1 e2 e3 -> Y.Call' (Y.Function "jikka::mod::plus" []) [e1, e2, e3]
+ X.ModMinus -> go03 $ \e1 e2 e3 -> Y.Call' (Y.Function "jikka::mod::minus" []) [e1, e2, e3]
+ X.ModMult -> go03 $ \e1 e2 e3 -> Y.Call' (Y.Function "jikka::mod::mult" []) [e1, e2, e3]
+ X.ModInv -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::mod::inv" []) [e1, e2]
+ X.ModPow -> go03 $ \e1 e2 e3 -> Y.Call' (Y.Function "jikka::mod::pow" []) [e1, e2, e3]
+ X.ModMatAp h w -> go03 $ \f x m -> Y.Call' (Y.Function "jikka::modmat::ap" [Y.TyIntValue h, Y.TyIntValue w]) [f, x, m]
+ X.ModMatAdd h w -> go03 $ \f g m -> Y.Call' (Y.Function "jikka::modmat::add" [Y.TyIntValue h, Y.TyIntValue w]) [f, g, m]
+ X.ModMatMul h n w -> go03 $ \f g m -> Y.Call' (Y.Function "jikka::modmat::mul" [Y.TyIntValue h, Y.TyIntValue n, Y.TyIntValue w]) [f, g, m]
+ X.ModMatPow n -> go03 $ \f k m -> Y.Call' (Y.Function "jikka::modmat::pow" [Y.TyIntValue n]) [f, k, m]
-- list functions
X.Cons -> go12' $ \t x xs -> do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare (Y.TyVector t) ys Y.DeclareDefault
useStatement $ Y.callMethod' (Y.Var ys) "push_back" [x]
useStatement $ Y.callMethod' (Y.Var ys) "insert" [Y.end (Y.Var ys), Y.begin xs, Y.end xs]
return $ Y.Var ys
X.Snoc -> go12' $ \t xs x -> do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare (Y.TyVector t) ys (Y.DeclareCopy xs)
useStatement $ Y.callMethod' (Y.Var ys) "push_back" [x]
return $ Y.Var ys
@@ -327,8 +378,8 @@
init <- runExpr env init
xs <- runExpr env xs
t2 <- runType t2
- ys <- Y.newFreshName Y.LocalNameKind
- i <- Y.newFreshName Y.LoopCounterNameKind
+ ys <- Y.newFreshName LocalNameHint
+ i <- Y.newFreshName LoopCounterNameHint
(stmtsF, body, f) <- runExprFunction2 env f (Y.at (Y.Var ys) (Y.Var i)) (Y.at xs (Y.Var i))
useStatement $ Y.Declare (Y.TyVector t2) ys (Y.DeclareCopy (Y.vecCtor t2 [Y.incrExpr (Y.size xs)]))
useStatement $ Y.assignAt ys (Y.litInt32 0) init
@@ -339,8 +390,8 @@
xs <- runExpr env xs
n <- runExpr env n
t <- runType t
- ys <- Y.newFreshName Y.LocalNameKind
- i <- Y.newFreshName Y.LoopCounterNameKind
+ ys <- Y.newFreshName LocalNameHint
+ i <- Y.newFreshName LoopCounterNameHint
(stmtsF, body, f) <- runExprFunction env f (Y.Var ys)
useStatement $ Y.Declare (Y.TyVector t) ys (Y.DeclareCopy xs)
useStatements stmtsF
@@ -351,104 +402,108 @@
X.Filter -> go12'' $ \t f xs -> do
xs <- runExpr env xs
t <- runType t
- ys <- Y.newFreshName Y.LocalNameKind
- x <- Y.newFreshName Y.LocalNameKind
+ ys <- newFreshNameWithAdHocHintFromExpr "filtered" xs
+ x <- Y.newFreshName LocalNameHint
(stmtsF, body, f) <- runExprFunction env f (Y.Var x)
useStatement $ Y.Declare (Y.TyVector t) ys Y.DeclareDefault
useStatements stmtsF
useStatement $ Y.ForEach t x xs (body ++ [Y.If f [Y.callMethod' (Y.Var ys) "push_back" [Y.Var x]] Nothing])
return $ Y.Var ys
X.At -> go12 $ \_ e1 e2 -> Y.at e1 e2
- X.SetAt -> go13 $ \t xs i x -> Y.Call (Y.SetAt t) [xs, i, x]
+ X.SetAt -> go13 $ \t xs i x -> Y.Call' (Y.SetAt t) [xs, i, x]
X.Elem -> go12' $ \_ xs x -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare Y.TyBool y (Y.DeclareCopy (Y.BinOp Y.NotEqual (Y.callFunction "std::find" [] [Y.begin xs, Y.end xs, x]) (Y.end xs)))
return $ Y.Var y
X.Sum -> go01' $ \xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "sum" xs
useStatement $ Y.Declare Y.TyInt64 y (Y.DeclareCopy (Y.callFunction "std::accumulate" [] [Y.begin xs, Y.end xs, Y.litInt64 0]))
return $ Y.Var y
X.ModSum -> go02' $ \xs m -> do
- y <- Y.newFreshName Y.LocalNameKind
- x <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "sum" xs
+ x <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare Y.TyInt64 y (Y.DeclareCopy (Y.litInt64 0))
useStatement $ Y.ForEach Y.TyInt64 x xs [Y.Assign (Y.AssignExpr Y.AddAssign (Y.LeftVar y) (Y.callFunction "jikka::floormod" [] [Y.Var x, m]))]
return $ Y.callFunction "jikka::floormod" [] [Y.Var y, m]
X.Product -> go01' $ \xs -> do
- y <- Y.newFreshName Y.LocalNameKind
- x <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "prod" xs
+ x <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare Y.TyInt64 y (Y.DeclareCopy (Y.litInt64 1))
useStatement $ Y.ForEach Y.TyInt64 x xs [Y.Assign (Y.AssignExpr Y.MulAssign (Y.LeftVar y) (Y.Var x))]
return $ Y.Var y
X.ModProduct -> go02' $ \xs m -> do
- y <- Y.newFreshName Y.LocalNameKind
- x <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "prod" xs
+ x <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare Y.TyInt64 y (Y.DeclareCopy (Y.litInt64 1))
useStatement $ Y.ForEach Y.TyInt64 x xs [Y.Assign (Y.AssignExpr Y.SimpleAssign (Y.LeftVar y) (Y.callFunction "jikka::mod::mult" [] [Y.Var y, Y.Var x, m]))]
return $ Y.Var y
X.Min1 -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "min" xs
useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::min_element" [] [Y.begin xs, Y.end xs])))
return $ Y.Var y
X.Max1 -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "max" xs
useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::max_element" [] [Y.begin xs, Y.end xs])))
return $ Y.Var y
X.ArgMin -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "argmin" xs
useStatement $ Y.Declare t y (Y.DeclareCopy (Y.BinOp Y.Sub (Y.callFunction "std::min_element" [] [Y.begin xs, Y.end xs]) (Y.begin xs)))
return $ Y.Var y
X.ArgMax -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "argmax" xs
useStatement $ Y.Declare t y (Y.DeclareCopy (Y.BinOp Y.Sub (Y.callFunction "std::max_element" [] [Y.begin xs, Y.end xs]) (Y.begin xs)))
return $ Y.Var y
X.Gcd1 -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
- useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::accumulate" [] [Y.begin xs, Y.end xs, Y.litInt64 0, Y.Lam [(Y.TyAuto, Y.VarName "a"), (Y.TyAuto, Y.VarName "b")] Y.TyAuto [Y.Return $ Y.callFunction "std::gcd" [] [Y.Var $ Y.VarName "a", Y.Var $ Y.VarName "b"]]])))
+ y <- newFreshNameWithAdHocHintFromExpr "gcd" xs
+ a <- Y.newFreshName LocalArgumentNameHint
+ b <- Y.newFreshName LocalArgumentNameHint
+ useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::accumulate" [] [Y.begin xs, Y.end xs, Y.litInt64 0, Y.Lam [(Y.TyAuto, a), (Y.TyAuto, b)] Y.TyAuto [Y.Return $ Y.callFunction "std::gcd" [] [Y.Var a, Y.Var b]]])))
return $ Y.Var y
X.Lcm1 -> go11' $ \t xs -> do
- y <- Y.newFreshName Y.LocalNameKind
- useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::accumulate" [] [Y.begin xs, Y.end xs, Y.litInt64 1, Y.Lam [(Y.TyAuto, Y.VarName "a"), (Y.TyAuto, Y.VarName "b")] Y.TyAuto [Y.Return $ Y.callFunction "std::lcm" [] [Y.Var $ Y.VarName "a", Y.Var $ Y.VarName "b"]]])))
+ y <- newFreshNameWithAdHocHintFromExpr "lcm" xs
+ a <- Y.newFreshName LocalArgumentNameHint
+ b <- Y.newFreshName LocalArgumentNameHint
+ useStatement $ Y.Declare t y (Y.DeclareCopy (Y.UnOp Y.Deref (Y.callFunction "std::accumulate" [] [Y.begin xs, Y.end xs, Y.litInt64 1, Y.Lam [(Y.TyAuto, a), (Y.TyAuto, b)] Y.TyAuto [Y.Return $ Y.callFunction "std::lcm" [] [Y.Var a, Y.Var b]]])))
return $ Y.Var y
X.All -> go01' $ \xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "all" xs
useStatement $ Y.Declare Y.TyBool y (Y.DeclareCopy (Y.BinOp Y.Equal (Y.callFunction "std::find" [] [Y.begin xs, Y.end xs, Y.Lit (Y.LitBool False)]) (Y.end xs)))
return $ Y.Var y
X.Any -> go01' $ \xs -> do
- y <- Y.newFreshName Y.LocalNameKind
+ y <- newFreshNameWithAdHocHintFromExpr "any" xs
useStatement $ Y.Declare Y.TyBool y (Y.DeclareCopy (Y.BinOp Y.NotEqual (Y.callFunction "std::find" [] [Y.begin xs, Y.end xs, Y.Lit (Y.LitBool True)]) (Y.end xs)))
return $ Y.Var y
X.Sorted -> go11' $ \t xs -> do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- newFreshNameWithAdHocHintFromExpr "sorted" xs
useStatement $ Y.Declare (Y.TyVector t) ys (Y.DeclareCopy xs)
useStatement $ Y.callFunction' "std::sort" [] [Y.begin (Y.Var ys), Y.end (Y.Var ys)]
return $ Y.Var ys
X.Reversed -> go11' $ \t xs -> do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- newFreshNameWithAdHocHintFromExpr "reversed" xs
useStatement $ Y.Declare (Y.TyVector t) ys (Y.DeclareCopy xs)
useStatement $ Y.callFunction' "std::reverse" [] [Y.begin (Y.Var ys), Y.end (Y.Var ys)]
return $ Y.Var ys
- X.Range1 -> go01 $ \n -> Y.Call Y.Range [n]
+ X.Range1 -> go01 $ \n -> Y.Call' Y.Range [n]
X.Range2 -> go02' $ \from to -> do
- ys <- Y.newFreshName Y.LocalNameKind
+ ys <- Y.newFreshName LocalNameHint
useStatement $ Y.Declare (Y.TyVector Y.TyInt64) ys (Y.DeclareCopy (Y.vecCtor Y.TyInt64 [Y.BinOp Y.Sub to from]))
useStatement $ Y.callFunction' "std::iota" [] [Y.begin (Y.Var ys), Y.end (Y.Var ys), from]
return $ Y.Var ys
X.Range3 -> go03' $ \from to step -> do
- ys <- Y.newFreshName Y.LocalNameKind
- i <- Y.newFreshName Y.LoopCounterNameKind
+ ys <- Y.newFreshName LocalNameHint
+ i <- Y.newFreshName LoopCounterNameHint
useStatement $ Y.Declare (Y.TyVector Y.TyInt64) ys Y.DeclareDefault
useStatement $ Y.For Y.TyInt32 i from (Y.BinOp Y.LessThan (Y.Var i) to) (Y.AssignExpr Y.AddAssign (Y.LeftVar i) step) [Y.callMethod' (Y.Var ys) "push_back" [Y.Var i]]
return $ Y.Var ys
-- tuple functions
X.Tuple -> goNN $ \ts es ->
if Y.shouldBeArray ts
- then Y.Call (Y.ArrayExt (head ts)) es
- else Y.Call (Y.StdTuple ts) es
+ then Y.Call' (Y.ArrayExt (head ts)) es
+ else Y.Call' (Y.StdTuple ts) es
X.Proj n -> goN1 $ \ts e ->
if Y.shouldBeArray ts
then Y.at e (Y.Lit (Y.LitInt32 n))
- else Y.Call (Y.StdGet (toInteger n)) [e]
+ else Y.Call' (Y.StdGet (toInteger n)) [e]
-- comparison
X.LessThan -> go12 $ \_ e1 e2 -> Y.BinOp Y.LessThan e1 e2
X.LessEqual -> go12 $ \_ e1 e2 -> Y.BinOp Y.LessEqual e1 e2
@@ -457,49 +512,49 @@
X.Equal -> go12 $ \_ e1 e2 -> Y.BinOp Y.Equal e1 e2
X.NotEqual -> go12 $ \_ e1 e2 -> Y.BinOp Y.NotEqual e1 e2
-- combinational functions
- X.Fact -> go01 $ \e -> Y.Call (Y.Function "jikka::notmod::fact" []) [e]
- X.Choose -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::notmod::choose" []) [e1, e2]
- X.Permute -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::notmod::permute" []) [e1, e2]
- X.MultiChoose -> go02 $ \e1 e2 -> Y.Call (Y.Function "jikka::notmod::multichoose" []) [e1, e2]
+ X.Fact -> go01 $ \e -> Y.Call' (Y.Function "jikka::notmod::fact" []) [e]
+ X.Choose -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::notmod::choose" []) [e1, e2]
+ X.Permute -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::notmod::permute" []) [e1, e2]
+ X.MultiChoose -> go02 $ \e1 e2 -> Y.Call' (Y.Function "jikka::notmod::multichoose" []) [e1, e2]
-- data structures
- X.ConvexHullTrickInit -> go00 $ Y.Call Y.ConvexHullTrickCtor []
- X.ConvexHullTrickGetMin -> go02 $ \cht x -> Y.Call (Y.Method "get_min") [cht, x]
- X.ConvexHullTrickInsert -> go03 $ \cht a b -> Y.Call Y.ConvexHullTrickCopyAddLine [cht, a, b]
- X.SegmentTreeInitList semigrp -> go01 $ \a -> Y.Call (Y.SegmentTreeCtor (runSemigroup semigrp)) [a]
- X.SegmentTreeGetRange _ -> go03 $ \segtree l r -> Y.Call (Y.Method "prod") [segtree, l, r]
- X.SegmentTreeSetPoint semigrp -> go03 $ \segtree i a -> Y.Call (Y.SegmentTreeCopySetPoint (runSemigroup semigrp)) [segtree, i, a]
+ X.ConvexHullTrickInit -> go00 $ Y.Call' Y.ConvexHullTrickCtor []
+ X.ConvexHullTrickGetMin -> go02 $ \cht x -> Y.Call' (Y.Method "get_min") [cht, x]
+ X.ConvexHullTrickInsert -> go03 $ \cht a b -> Y.Call' Y.ConvexHullTrickCopyAddLine [cht, a, b]
+ X.SegmentTreeInitList semigrp -> go01 $ \a -> Y.Call' (Y.SegmentTreeCtor (runSemigroup semigrp)) [a]
+ X.SegmentTreeGetRange _ -> go03 $ \segtree l r -> Y.Call' (Y.Method "prod") [segtree, l, r]
+ X.SegmentTreeSetPoint semigrp -> go03 $ \segtree i a -> Y.Call' (Y.SegmentTreeCopySetPoint (runSemigroup semigrp)) [segtree, i, a]
runExprFunction :: (MonadAlpha m, MonadError Error m) => Env -> X.Expr -> Y.Expr -> m ([Y.Statement], [Y.Statement], Y.Expr)
runExprFunction env f e = case f of
X.Lam x t body -> do
- y <- renameVarName' Y.LocalArgumentNameKind x
- (stmts, body) <- runStatementsT $ runExpr ((x, t, y) : env) body
+ y <- renameVarName' LocalArgumentNameHint x
+ (stmts, body) <- runStatementsT $ runExpr (pushVar x t y env) body
let stmts' = map (Y.replaceStatement y e) stmts
let body' = Y.replaceExpr y e body
return ([], stmts', body')
f -> do
(stmts, f) <- runStatementsT $ runExpr env f
- return (stmts, [], Y.CallExpr f [e])
+ return (stmts, [], Y.Call f [e])
runExprFunction2 :: (MonadAlpha m, MonadError Error m) => Env -> X.Expr -> Y.Expr -> Y.Expr -> m ([Y.Statement], [Y.Statement], Y.Expr)
runExprFunction2 env f e1 e2 = case f of
X.Lam2 x1 t1 x2 t2 body -> do
- y1 <- renameVarName' Y.LocalArgumentNameKind x1
- y2 <- renameVarName' Y.LocalArgumentNameKind x2
- (stmts, body) <- runStatementsT $ runExpr ((x2, t2, y2) : (x1, t1, y1) : env) body
+ y1 <- renameVarName' LocalArgumentNameHint x1
+ y2 <- renameVarName' LocalArgumentNameHint x2
+ (stmts, body) <- runStatementsT $ runExpr (pushVar x2 t2 y2 (pushVar x1 t1 y1 env)) body
let stmts' = map (Y.replaceStatement y2 e2 . Y.replaceStatement y1 e1) stmts
let body' = Y.replaceExpr y2 e2 $ Y.replaceExpr y1 e1 body
return ([], stmts', body')
f -> do
(stmts, f) <- runStatementsT $ runExpr env f
- return (stmts, [], Y.CallExpr (Y.CallExpr f [e1]) [e2])
+ return (stmts, [], Y.Call (Y.Call f [e1]) [e2])
runAssert :: (MonadStatements m, MonadAlpha m, MonadError Error m) => Env -> X.Expr -> m ()
runAssert env = \case
-- optimize @assert all(...)@
X.All' (X.Map' t _ f xs) -> do
t <- runType t
- y <- Y.newFreshName Y.LocalNameKind
+ y <- Y.newFreshName LocalNameHint
xs <- runExpr env xs
(stmtsF, body, e) <- runExprFunction env f (Y.Var y)
useStatements stmtsF
@@ -512,8 +567,11 @@
runExpr :: (MonadStatements m, MonadAlpha m, MonadError Error m) => Env -> X.Expr -> m Y.Expr
runExpr env = \case
X.Var x -> do
- y <- lookupVarName env x
- return $ Y.Var y
+ case lookupVarName env x of
+ Right y -> return $ Y.Var y
+ Left _ -> case lookupFunName env x of
+ Right f -> return $ Y.Callable (Y.Function f [])
+ Left _ -> throwInternalError $ "undefined variable: " ++ X.formatVarName x
X.Lit lit -> do
runLiteral env lit
e@(X.App _ _) -> do
@@ -527,7 +585,7 @@
ts <- mapM runType ts
ret <- runType ret
xs <- replicateM (arity - length args) X.genVarName'
- ys <- mapM (renameVarName' Y.LocalArgumentNameKind) xs
+ ys <- mapM (renameVarName' LocalArgumentNameHint) xs
e <- runAppBuiltin env builtin bts (args ++ map X.Var xs)
let (_, e') = foldr (\(t, y) (ret, e) -> (Y.TyFunction ret [t], Y.Lam [(t, y)] ret [Y.Return e])) (ret, e) (zip (drop (length args) ts) ys)
return e'
@@ -538,37 +596,37 @@
else do
args' <- mapM (runExpr env) (drop arity args)
e <- runAppBuiltin env builtin bts (take arity args)
- return $ Y.CallExpr e args'
+ return $ Y.Call e args'
_ -> do
f <- runExpr env f
args <- mapM (runExpr env) args
- return $ Y.CallExpr f args
+ return $ Y.Call f args
e@(X.Lam _ _ _) -> do
let (args, body) = X.uncurryLam e
- ys <- mapM (renameVarName' Y.LocalArgumentNameKind . fst) args
- let env' = reverse (zipWith (\(x, t) y -> (x, t, y)) args ys) ++ env
+ ys <- mapM (renameVarName' LocalArgumentNameHint . fst) args
+ let env' = foldl (\env ((x, t), y) -> pushVar x t y env) env (zip args ys)
ret <- runType =<< typecheckExpr env' body
(stmts, body) <- runStatementsT $ runExpr env' body
ts <- mapM (runType . snd) args
let (_, [Y.Return e]) = foldr (\(t, y) (ret, body) -> (Y.TyFunction ret [t], [Y.Return (Y.Lam [(t, y)] ret body)])) (ret, stmts ++ [Y.Return body]) (zip ts ys)
return e
X.Let x t e1 e2 -> do
- y <- renameVarName' Y.LocalNameKind x
+ y <- renameVarName' LocalNameHint x
t' <- runType t
e1 <- runExpr env e1
useStatement $ Y.Declare t' y (Y.DeclareCopy e1)
- runExpr ((x, t, y) : env) e2
+ runExpr (pushVar x t y env) e2
X.Assert e1 e2 -> do
runAssert env e1
runExpr env e2
-runToplevelFunDef :: (MonadAlpha m, MonadError Error m) => Env -> Y.VarName -> [(X.VarName, X.Type)] -> X.Type -> X.Expr -> m [Y.ToplevelStatement]
+runToplevelFunDef :: (MonadAlpha m, MonadError Error m) => Env -> Y.FunName -> [(X.VarName, X.Type)] -> X.Type -> X.Expr -> m [Y.ToplevelStatement]
runToplevelFunDef env f args ret body = do
ret <- runType ret
args <- forM args $ \(x, t) -> do
- y <- renameVarName' Y.ArgumentNameKind x
+ y <- renameVarName' ArgumentNameHint x
return (x, t, y)
- (stmts, result) <- runStatementsT $ runExpr (reverse args ++ env) body
+ (stmts, result) <- runStatementsT $ runExpr (foldl (\env (x, t, y) -> pushVar x t y env) env args) body
args <- forM args $ \(_, t, y) -> do
t <- runType t
return (t, y)
@@ -580,41 +638,35 @@
(stmts, e) <- runStatementsT $ runExpr env e
case stmts of
[] -> return [Y.VarDef t x e]
- _ -> return [Y.VarDef t x (Y.CallExpr (Y.Lam [] t (stmts ++ [Y.Return e])) [])]
+ _ -> return [Y.VarDef t x (Y.Call (Y.Lam [] t (stmts ++ [Y.Return e])) [])]
runToplevelExpr :: (MonadAlpha m, MonadError Error m) => Env -> X.ToplevelExpr -> m [Y.ToplevelStatement]
runToplevelExpr env = \case
X.ResultExpr e -> do
t <- typecheckExpr env e
- case X.uncurryFunTy t of
- (ts@(_ : _), ret) -> do
- let f = Y.VarName "solve"
- (args, body) <- case X.uncurryLam e of
- (args, body) | length args == length ts -> do
- -- merge two sets of arguments which introduced by @FunTy@ and @Lam@
- args <- forM args $ \(x, t) -> do
- y <- renameVarName' Y.ArgumentNameKind x
- return (x, t, y)
- (stmts, e) <- runStatementsT $ runExpr (reverse args ++ env) body
- let body = stmts ++ [Y.Return e]
- args' <- forM args $ \(_, t, y) -> do
- t <- runType t
- return (t, y)
- return (args', body)
- _ -> do
- args <- forM ts $ \t -> do
- t <- runType t
- y <- Y.newFreshName Y.ArgumentNameKind
- return (t, y)
- (stmts, e) <- runStatementsT $ runExpr env e
- let body = stmts ++ [Y.Return (Y.CallExpr e (map (Y.Var . snd) args))]
- return (args, body)
- ret <- runType ret
- return [Y.FunDef ret f args body]
+ (ts, ret) <- case X.uncurryFunTy t of
+ (ts@(_ : _), ret) -> return (ts, ret)
_ -> throwInternalError "solve function must be a function" -- TODO: add check in restricted Python
+ ret <- runType ret
+ -- do eta-expansion to define it as a function.
+ e <- X.etaExpand (typeEnv env) e
+ (args, body) <- case X.uncurryLam e of
+ (args, body) | length args == length ts -> return (args, body)
+ _ -> throwInternalError "the result expr must be eta-converted"
+ -- merge two sets of arguments which introduced by @FunTy@ and @Lam@
+ args <- forM args $ \(x, t) -> do
+ y <- renameVarName' ArgumentNameHint x
+ return (x, t, y)
+ (stmts, e) <- runStatementsT $ runExpr (foldl (\env (x, t, y) -> pushVar x t y env) env args) body
+ let body = stmts ++ [Y.Return e]
+ args' <- forM args $ \(_, t, y) -> do
+ t <- runType t
+ return (t, y)
+ let f = Y.FunName "solve"
+ return [Y.FunDef ret f args' body]
X.ToplevelLet x t e cont -> case (X.uncurryLam e, X.uncurryFunTy t) of
((args@(_ : _), body), (ts@(_ : _), ret)) -> do
- g <- renameVarName' Y.FunctionNameKind x
+ g <- renameFunName' x
(args, body) <-
if length args < length ts
then do
@@ -623,28 +675,28 @@
let body' = X.uncurryApp body (map X.Var xs)
return (args', body')
else return (args, body)
- stmt <- runToplevelFunDef ((x, t, g) : env) g args ret body
- cont <- runToplevelExpr ((x, t, g) : env) cont
+ stmt <- runToplevelFunDef (pushFun x t g env) g args ret body
+ cont <- runToplevelExpr (pushFun x t g env) cont
return $ stmt ++ cont
_ -> do
- y <- renameVarName' Y.ConstantNameKind x
+ y <- renameVarName' ConstantNameHint x
stmt <- runToplevelVarDef env y t e
- cont <- runToplevelExpr ((x, t, y) : env) cont
+ cont <- runToplevelExpr (pushVar x t y env) cont
return $ stmt ++ cont
X.ToplevelLetRec f args ret body cont -> do
- g <- renameVarName' Y.FunctionNameKind f
+ g <- renameFunName' f
let t = X.curryFunTy (map snd args) ret
- stmt <- runToplevelFunDef ((f, t, g) : env) g args ret body
- cont <- runToplevelExpr ((f, t, g) : env) cont
+ stmt <- runToplevelFunDef (pushFun f t g env) g args ret body
+ cont <- runToplevelExpr (pushFun f t g env) cont
return $ stmt ++ cont
X.ToplevelAssert e cont -> do
(stmts, e) <- runStatementsT $ runExpr env e
- let stmt = Y.StaticAssert (Y.CallExpr (Y.Lam [] Y.TyBool (stmts ++ [Y.Return e])) []) ""
+ let stmt = Y.StaticAssert (Y.Call (Y.Lam [] Y.TyBool (stmts ++ [Y.Return e])) []) ""
cont <- runToplevelExpr env cont
return $ stmt : cont
runProgram :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program
-runProgram prog = Y.Program <$> runToplevelExpr [] prog
+runProgram prog = Y.Program <$> runToplevelExpr emptyEnv prog
run :: (MonadAlpha m, MonadError Error m) => X.Program -> m Y.Program
run prog = wrapError' "Jikka.CPlusPlus.Convert.FromCore" $ do
diff --git a/src/Jikka/CPlusPlus/Convert/InlineSetAt.hs b/src/Jikka/CPlusPlus/Convert/InlineSetAt.hs
--- a/src/Jikka/CPlusPlus/Convert/InlineSetAt.hs
+++ b/src/Jikka/CPlusPlus/Convert/InlineSetAt.hs
@@ -19,13 +19,14 @@
import Jikka.CPlusPlus.Language.Util
import Jikka.Common.Alpha
import Jikka.Common.Error
+import Jikka.Common.Name
runExpr :: (MonadAlpha m, MonadWriter [Statement] m) => Expr -> m Expr
runExpr = \case
- Call (SetAt t) [xs, i, x] -> do
+ Call' (SetAt t) [xs, i, x] -> do
y <- case xs of
- Var (VarName xs) -> renameVarName LocalNameKind xs
- _ -> newFreshName LocalNameKind
+ Var xs -> renameVarName LocalNameHint xs
+ _ -> newFreshName LocalNameHint
tell
[ Declare (TyVector t) y (DeclareCopy xs),
Assign (AssignExpr SimpleAssign (LeftAt (LeftVar y) i) x)
diff --git a/src/Jikka/CPlusPlus/Convert/MoveSemantics.hs b/src/Jikka/CPlusPlus/Convert/MoveSemantics.hs
--- a/src/Jikka/CPlusPlus/Convert/MoveSemantics.hs
+++ b/src/Jikka/CPlusPlus/Convert/MoveSemantics.hs
@@ -34,8 +34,8 @@
BinOp op e1 e2 -> BinOp op <$> runExpr e1 <*> runExpr e2
Cond e1 e2 e3 -> Cond <$> runExpr e1 <*> runExpr e2 <*> runExpr e3
Lam args ret body -> Lam args ret <$> runStatements body []
- Call f args -> Call f <$> mapM runExpr args
- CallExpr f args -> CallExpr <$> runExpr f <*> mapM runExpr args
+ Call f args -> Call <$> runExpr f <*> mapM runExpr args
+ Callable f -> return $ Callable f
runLeftExpr :: MonadState (M.Map VarName VarName) m => LeftExpr -> m LeftExpr
runLeftExpr = \case
@@ -120,16 +120,16 @@
DeclareCopy (Var x) | (x `isMovableTo` y) SimpleCopy env cont -> do
modify' (M.insert y x)
return []
- DeclareCopy (Call (SetAt _) [Var x, i, xi])
+ DeclareCopy (Call' (SetAt _) [Var x, i, xi])
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
return [Assign (AssignExpr SimpleAssign (LeftAt (LeftVar x) i) xi)]
- DeclareCopy (Call ConvexHullTrickCtor []) -> return [Declare t y DeclareDefault]
- DeclareCopy (Call ConvexHullTrickCopyAddLine [Var x, a, b])
+ DeclareCopy (Call' ConvexHullTrickCtor []) -> return [Declare t y DeclareDefault]
+ DeclareCopy (Call' ConvexHullTrickCopyAddLine [Var x, a, b])
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
return [callMethod' (Var x) "add_line" [a, b]]
- DeclareCopy (Call (SegmentTreeCopySetPoint _) [Var x, i, a])
+ DeclareCopy (Call' (SegmentTreeCopySetPoint _) [Var x, i, a])
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
return [callMethod' (Var x) "set" [i, a]]
@@ -143,19 +143,19 @@
env <- get
case e of
AssignExpr SimpleAssign (LeftVar y) (Var x) | x == y -> return []
- AssignExpr SimpleAssign (LeftVar y) (Call (SetAt _) [Var x, i, xi])
+ AssignExpr SimpleAssign (LeftVar y) (Call' (SetAt _) [Var x, i, xi])
| x == y -> return [Assign (AssignExpr SimpleAssign (LeftAt (LeftVar x) i) xi)]
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
return [Assign (AssignExpr SimpleAssign (LeftAt (LeftVar x) i) xi)]
| otherwise -> return [Assign e]
- AssignExpr SimpleAssign (LeftVar y) (Call ConvexHullTrickCopyAddLine [Var x, a, b])
+ AssignExpr SimpleAssign (LeftVar y) (Call' ConvexHullTrickCopyAddLine [Var x, a, b])
| x == y -> return [callMethod' (Var x) "add_line" [a, b]]
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
return [callMethod' (Var x) "add_line" [a, b]]
| otherwise -> return [Assign e]
- AssignExpr SimpleAssign (LeftVar y) (Call (SegmentTreeCopySetPoint _) [Var x, i, a])
+ AssignExpr SimpleAssign (LeftVar y) (Call' (SegmentTreeCopySetPoint _) [Var x, i, a])
| x == y -> return [callMethod' (Var x) "set" [i, a]]
| (x `isMovableTo` y) UpdatedCopy env cont -> do
modify' (M.insert y x)
diff --git a/src/Jikka/CPlusPlus/Convert/OptimizeRange.hs b/src/Jikka/CPlusPlus/Convert/OptimizeRange.hs
--- a/src/Jikka/CPlusPlus/Convert/OptimizeRange.hs
+++ b/src/Jikka/CPlusPlus/Convert/OptimizeRange.hs
@@ -16,20 +16,25 @@
import Jikka.CPlusPlus.Language.Expr
import Jikka.CPlusPlus.Language.Util
+import Jikka.Common.Alpha
import Jikka.Common.Error
+import Jikka.Common.Name
runExpr :: Monad m => Expr -> m Expr
runExpr = \case
- Call At [Call Range [_], i] -> return i
- Call MethodSize [Call Range [n]] -> return n
+ Call' At [Call' Range [_], i] -> return i
+ Call' MethodSize [Call' Range [n]] -> return n
e -> return e
-runStatement :: Monad m => Statement -> m Statement
+runStatement :: MonadAlpha m => Statement -> m Statement
runStatement = \case
- ForEach _ x (Call Range [n]) body -> return $ repStatement x n body -- TODO: check n is not updated in body
+ ForEach _ x (Call' Range [n]) body -> do
+ y <- renameVarName LoopCounterNameHint x
+ let body' = map (renameVarNameStatement x y) body
+ return $ repStatement y n body' -- TODO: check n is not updated in body
stmt -> return stmt
-runProgram :: Monad m => Program -> m Program
+runProgram :: MonadAlpha m => Program -> m Program
runProgram = mapExprStatementProgramM runExpr (((: []) <$>) . runStatement)
-- | `run` replaces superfluous copying.
@@ -55,6 +60,6 @@
-- > for (int i = 0; i < n; ++ i) {
-- > ...
-- > }
-run :: MonadError Error m => Program -> m Program
+run :: (MonadAlpha m, MonadError Error m) => Program -> m Program
run prog = wrapError' "Jikka.CPlusPlus.Convert.OptimizeRange" $ do
runProgram prog
diff --git a/src/Jikka/CPlusPlus/Convert/UnpackTuples.hs b/src/Jikka/CPlusPlus/Convert/UnpackTuples.hs
--- a/src/Jikka/CPlusPlus/Convert/UnpackTuples.hs
+++ b/src/Jikka/CPlusPlus/Convert/UnpackTuples.hs
@@ -21,6 +21,7 @@
import Jikka.CPlusPlus.Language.Util
import Jikka.Common.Alpha
import Jikka.Common.Error
+import Jikka.Common.Name
-- | `runExpr` replaces variables using the @mapping :: M.Map VarName [(Type, VarName)]@.
runExpr :: (MonadAlpha m, MonadError Error m, MonadState (M.Map VarName [(Type, VarName)]) m) => Expr -> m Expr
@@ -34,17 +35,19 @@
in if shouldBeArray (map fst ys)
then
let t = fst (head ys)
- in Call (ArrayExt t) es
+ in Call' (ArrayExt t) es
else
let ts = map fst ys
- in Call (StdTuple ts) es
+ in Call' (StdTuple ts) es
Lit lit -> return $ Lit lit
UnOp op e -> UnOp op <$> runExpr e
BinOp op e1 e2 -> BinOp op <$> runExpr e1 <*> runExpr e2
Cond e1 e2 e3 -> Cond <$> runExpr e1 <*> runExpr e2 <*> runExpr e3
Lam args ret body -> Lam args ret <$> runStatements body []
- Call f args -> runCall f args
- CallExpr e args -> CallExpr <$> runExpr e <*> mapM runExpr args
+ Call f args -> case f of
+ Callable f -> runCall f args
+ _ -> Call <$> runExpr f <*> mapM runExpr args
+ Callable f -> return $ Callable f
-- | `runCall` does the same thing to `runExpr` and also reduces `std::get(e)` and `e[i]`.
runCall :: (MonadAlpha m, MonadError Error m, MonadState (M.Map VarName [(Type, VarName)]) m) => Function -> [Expr] -> m Expr
@@ -60,9 +63,9 @@
when (n < 0 || toInteger (length ys) <= n) $ do
throwInternalError "index out of range"
return $ es !! fromInteger n
- Nothing -> return $ Call f args
+ Nothing -> return $ Call' f args
-- std::get(std::tuple(e1, e2, ...))
- (StdGet n, [Call (StdTuple _) es]) -> do
+ (StdGet n, [Call' (StdTuple _) es]) -> do
when (n < 0 || toInteger (length es) <= n) $ do
throwInternalError "index out of range"
return $ es !! fromInteger n
@@ -81,10 +84,10 @@
when (n < 0 || toInteger (length ys) <= n) $ do
throwInternalError "index out of range"
return (es !! fromInteger n)
- Nothing -> return $ Call f args
- Nothing -> return $ Call f args
+ Nothing -> return $ Call' f args
+ Nothing -> return $ Call' f args
-- (std::array{e1, e2, ...})[i]
- (At, [Call (ArrayExt _) es, e2]) -> do
+ (At, [Call' (ArrayExt _) es, e2]) -> do
let n = case e2 of
Lit (LitInt32 n) -> Just n
Lit (LitInt64 n) -> Just n
@@ -94,8 +97,8 @@
when (n < 0 || toInteger (length es) <= n) $ do
throwInternalError "index out of range"
return (es !! fromInteger n)
- Nothing -> return $ Call f args
- _ -> return $ Call f args
+ Nothing -> return $ Call' f args
+ _ -> return $ Call' f args
runLeftExpr :: (MonadAlpha m, MonadError Error m, MonadState (M.Map VarName [(Type, VarName)]) m) => LeftExpr -> m LeftExpr
runLeftExpr = \case
@@ -143,14 +146,14 @@
DeclareInitialize es -> DeclareInitialize <$> mapM runExpr es
case init of
-- std::tuple x = std::tuple<...>(e1, e2, ...);
- DeclareCopy (Call (StdTuple ts) es) -> do
- ys <- replicateM (length es) (renameVarName LocalNameKind (unVarName x))
+ DeclareCopy (Call' (StdTuple ts) es) -> do
+ ys <- replicateM (length es) (renameVarName LocalNameHint x)
modify' (M.insert x (zip ts ys))
return $ zipWith3 (\t y e -> Declare t y (DeclareCopy e)) ts ys es
-- std::array x = std::array{e1, e2, ...};
- DeclareCopy (Call (ArrayExt t) es) -> do
+ DeclareCopy (Call' (ArrayExt t) es) -> do
let ts = replicate (length es) t
- ys <- replicateM (length es) (renameVarName LocalNameKind (unVarName x))
+ ys <- replicateM (length es) (renameVarName LocalNameHint x)
modify' (M.insert x (zip ts ys))
return $ zipWith3 (\t y e -> Declare t y (DeclareCopy e)) ts ys es
_ -> do
@@ -169,20 +172,20 @@
let ts = map fst ys
let n = toInteger (length ts)
let es = case e of
- Call (StdTuple _) es -> es
- Call (ArrayExt _) es -> es
+ Call' (StdTuple _) es -> es
+ Call' (ArrayExt _) es -> es
_ ->
if shouldBeArray ts
- then map (\i -> Call At [e, litInt32 i]) [0 .. n - 1]
- else map (\i -> Call (StdGet i) [e]) [0 .. n - 1]
- tmpys <- replicateM (length ts) (newFreshName LocalNameKind)
+ then map (\i -> Call' At [e, litInt32 i]) [0 .. n - 1]
+ else map (\i -> Call' (StdGet i) [e]) [0 .. n - 1]
+ tmpys <- replicateM (length ts) (newFreshName LocalNameHint)
return $ zipWith3 (\t y e -> Declare t y (DeclareCopy e)) ts tmpys es ++ zipWith (\y e -> Assign (AssignExpr SimpleAssign (LeftVar y) (Var e))) (map snd ys) tmpys
Nothing -> return [Assign (AssignExpr SimpleAssign (LeftVar x) e)]
_ -> do
forM_ (S.toList (freeVarsAssignExpr e)) $ \x -> do
ys <- gets (M.lookup x)
case ys of
- Just _ -> throwInternalError $ "wrong assignment to a tuple: " ++ unVarName x
+ Just _ -> throwInternalError $ "wrong assignment to a tuple: " ++ formatVarName x
Nothing -> return ()
return [Assign e]
Assert e -> do
diff --git a/src/Jikka/CPlusPlus/Convert/UseInitialization.hs b/src/Jikka/CPlusPlus/Convert/UseInitialization.hs
--- a/src/Jikka/CPlusPlus/Convert/UseInitialization.hs
+++ b/src/Jikka/CPlusPlus/Convert/UseInitialization.hs
@@ -22,10 +22,10 @@
runStatement :: Statement -> Statement
runStatement = \case
Declare t x init -> case (t, init) of
- (TyVector _, DeclareCopy (Call (VecCtor _) [])) -> Declare t x DeclareDefault
- (TyVector _, DeclareCopy (Call (VecCtor _) es)) -> Declare t x (DeclareInitialize es)
- (TyConvexHullTrick, DeclareCopy (Call ConvexHullTrickCtor es)) -> Declare t x (DeclareInitialize es)
- (TySegmentTree _, DeclareCopy (Call (SegmentTreeCtor _) es)) -> Declare t x (DeclareInitialize es)
+ (TyVector _, DeclareCopy (Call' (VecCtor _) [])) -> Declare t x DeclareDefault
+ (TyVector _, DeclareCopy (Call' (VecCtor _) es)) -> Declare t x (DeclareInitialize es)
+ (TyConvexHullTrick, DeclareCopy (Call' ConvexHullTrickCtor es)) -> Declare t x (DeclareInitialize es)
+ (TySegmentTree _, DeclareCopy (Call' (SegmentTreeCtor _) es)) -> Declare t x (DeclareInitialize es)
(_, _) -> Declare t x init
stmt -> stmt
diff --git a/src/Jikka/CPlusPlus/Format.hs b/src/Jikka/CPlusPlus/Format.hs
--- a/src/Jikka/CPlusPlus/Format.hs
+++ b/src/Jikka/CPlusPlus/Format.hs
@@ -204,9 +204,45 @@
formatExpr' :: Prec -> Expr -> Code
formatExpr' prec = resolvePrec prec . formatExpr
+formatFunction :: Function -> Maybe [Expr] -> (Code, Prec)
+formatFunction f args =
+ let args' = intercalate ", " (maybe [] (map (formatExpr' CommaPrec)) args)
+ call f = case args of
+ Nothing -> (f, IdentPrec)
+ Just _ -> (f ++ "(" ++ args' ++ ")", FunCallPrec)
+ method f = case args of
+ Just (e : args) -> (formatExpr' FunCallPrec e ++ "." ++ f ++ "(" ++ intercalate ", " (map (formatExpr' CommaPrec) args) ++ ")", FunCallPrec)
+ _ -> error $ "Jikka.CPlusPlus.Language.Format.formatExpr: no receiver for method: " ++ f
+ in case f of
+ Function f ts -> call $ formatFunName f ++ (if null ts then "" else "<" ++ intercalate ", " (map formatType ts) ++ ">")
+ Method f -> method $ formatFunName f
+ At -> case args of
+ Just [e1, e2] ->
+ let e1' = formatExpr' FunCallPrec e1
+ e2' = formatExpr' ParenPrec e2
+ in (e1' ++ "[" ++ e2' ++ "]", FunCallPrec)
+ _ -> error $ "Jikka.CPlusPlus.Language.Format.formatExpr: wrong number of arguments for subscription: " ++ show (length args)
+ SetAt t -> call $ "jikka::set_at<" ++ formatType t ++ ">"
+ Cast t -> call $ formatType t
+ StdTuple ts -> call $ "std::tuple<" ++ intercalate ", " (map formatType ts) ++ ">"
+ StdGet n -> call $ "std::get<" ++ show n ++ ">"
+ ArrayExt t -> case args of
+ Nothing -> error "cannot use array extensional notation without any application"
+ Just args -> ("std::array<" ++ formatType t ++ ", " ++ show (length args) ++ ">{" ++ args' ++ "}", IdentPrec)
+ VecExt t -> case args of
+ Nothing -> error "cannot use vector extensional notation without any application"
+ Just _ -> ("std::vector<" ++ formatType t ++ ">{" ++ args' ++ "}", IdentPrec)
+ VecCtor t -> call $ "std::vector<" ++ formatType t ++ ">"
+ Range -> call "jikka::range"
+ MethodSize -> method "size"
+ ConvexHullTrickCtor -> call "jikka::convex_hull_trick"
+ ConvexHullTrickCopyAddLine -> call "jikka::convex_hull_trick::add_line"
+ SegmentTreeCtor mon -> call (formatType (TySegmentTree mon))
+ SegmentTreeCopySetPoint _ -> call "jikka::segment_tree_set"
+
formatExpr :: Expr -> (Code, Prec)
formatExpr = \case
- Var x -> (unVarName x, IdentPrec)
+ Var x -> (formatVarName x, IdentPrec)
Lit lit -> (formatLiteral lit, IdentPrec)
UnOp op e ->
let (op', prec) = formatUnaryOp op
@@ -218,42 +254,17 @@
e2' = resolvePrecRight prec (formatExpr e2)
in (e1' ++ " " ++ op' ++ " " ++ e2', prec)
Lam args ret body ->
- let args' = map (\(t, x) -> formatType t ++ " " ++ unVarName x) args
+ let args' = map (\(t, x) -> formatType t ++ " " ++ formatVarName x) args
ret' = formatType ret
body' = concatMap formatStatement body
in ("[=](" ++ intercalate ", " args' ++ ") -> " ++ ret' ++ "{ " ++ unwords body' ++ " }", FunCallPrec)
- Call f args ->
- let args' = intercalate ", " (map (formatExpr' CommaPrec) args)
- call f = (f ++ "(" ++ args' ++ ")", FunCallPrec)
- method f = case args of
- [] -> error $ "Jikka.CPlusPlus.Language.Format.formatExpr: no receiver for method: " ++ f
- e : args -> (formatExpr' FunCallPrec e ++ "." ++ f ++ "(" ++ intercalate ", " (map (formatExpr' CommaPrec) args) ++ ")", FunCallPrec)
- in case f of
- Function f ts -> call $ unFunName f ++ (if null ts then "" else "<" ++ intercalate ", " (map formatType ts) ++ ">")
- Method f -> method $ unFunName f
- At -> case args of
- [e1, e2] ->
- let e1' = formatExpr' FunCallPrec e1
- e2' = formatExpr' ParenPrec e2
- in (e1' ++ "[" ++ e2' ++ "]", FunCallPrec)
- _ -> error $ "Jikka.CPlusPlus.Language.Format.formatExpr: wrong number of arguments for subscription: " ++ show (length args)
- SetAt t -> call $ "jikka::set_at<" ++ formatType t ++ ">"
- Cast t -> call $ formatType t
- StdTuple ts -> call $ "std::tuple<" ++ intercalate ", " (map formatType ts) ++ ">"
- StdGet n -> call $ "std::get<" ++ show n ++ ">"
- ArrayExt t -> ("std::array<" ++ formatType t ++ ", " ++ show (length args) ++ ">{" ++ args' ++ "}", IdentPrec)
- VecExt t -> ("std::vector<" ++ formatType t ++ ">{" ++ args' ++ "}", IdentPrec)
- VecCtor t -> call $ "std::vector<" ++ formatType t ++ ">"
- Range -> call "jikka::range"
- MethodSize -> method "size"
- ConvexHullTrickCtor -> call "jikka::convex_hull_trick"
- ConvexHullTrickCopyAddLine -> call "jikka::convex_hull_trick::add_line"
- SegmentTreeCtor mon -> call (formatType (TySegmentTree mon))
- SegmentTreeCopySetPoint _ -> call "jikka::segment_tree_set"
- CallExpr f args ->
- let f' = formatExpr' FunCallPrec f
- args' = intercalate ", " (map (formatExpr' CommaPrec) args)
- in (f' ++ "(" ++ args' ++ ")", FunCallPrec)
+ Call f args -> case f of
+ Callable f -> formatFunction f (Just args)
+ _ -> do
+ let f' = formatExpr' FunCallPrec f
+ args' = intercalate ", " (map (formatExpr' CommaPrec) args)
+ in (f' ++ "(" ++ args' ++ ")", FunCallPrec)
+ Callable f -> formatFunction f Nothing
Cond e1 e2 e3 ->
let e1' = resolvePrecLeft CondPrec (formatExpr e1)
e2' = resolvePrec CondPrec (formatExpr e2)
@@ -291,12 +302,12 @@
cond' = formatExpr' ParenPrec cond
incr' = resolvePrec ParenPrec $ formatAssignExpr incr
body' = concatMap formatStatement body
- in ["for (" ++ t' ++ " " ++ unVarName x ++ " = " ++ init' ++ "; " ++ cond' ++ "; " ++ incr' ++ ") {"] ++ body' ++ ["}"]
+ in ["for (" ++ t' ++ " " ++ formatVarName x ++ " = " ++ init' ++ "; " ++ cond' ++ "; " ++ incr' ++ ") {"] ++ body' ++ ["}"]
ForEach t x xs body ->
let t' = formatType t
xs' = formatExpr' ParenPrec xs
body' = concatMap formatStatement body
- in ["for (" ++ t' ++ " " ++ unVarName x ++ " : " ++ xs' ++ ") {"] ++ body' ++ ["}"]
+ in ["for (" ++ t' ++ " " ++ formatVarName x ++ " : " ++ xs' ++ ") {"] ++ body' ++ ["}"]
While cond body ->
let cond' = formatExpr' ParenPrec cond
body' = concatMap formatStatement body
@@ -307,20 +318,20 @@
DeclareDefault -> ""
DeclareCopy e -> " = " ++ resolvePrecRight AssignPrec (formatExpr e)
DeclareInitialize es -> "(" ++ intercalate ", " (map (formatExpr' CommaPrec) es) ++ ")"
- in [t' ++ " " ++ unVarName x ++ init' ++ ";"]
- DeclareDestructure xs e -> ["auto [" ++ intercalate ", " (map unVarName xs) ++ "] = " ++ resolvePrecRight AssignPrec (formatExpr e) ++ ";"]
+ in [t' ++ " " ++ formatVarName x ++ init' ++ ";"]
+ DeclareDestructure xs e -> ["auto [" ++ intercalate ", " (map formatVarName xs) ++ "] = " ++ resolvePrecRight AssignPrec (formatExpr e) ++ ";"]
Assign e -> [resolvePrec ParenPrec (formatAssignExpr e) ++ ";"]
Assert e -> ["assert (" ++ formatExpr' ParenPrec e ++ ");"]
Return e -> ["return " ++ formatExpr' ParenPrec e ++ ";"]
formatToplevelStatement :: ToplevelStatement -> [Code]
formatToplevelStatement = \case
- VarDef t x e -> [formatType t ++ " " ++ unVarName x ++ " = " ++ resolvePrecRight AssignPrec (formatExpr e) ++ ";"]
+ VarDef t x e -> [formatType t ++ " " ++ formatVarName x ++ " = " ++ resolvePrecRight AssignPrec (formatExpr e) ++ ";"]
FunDef ret f args body ->
let ret' = formatType ret
- args' = intercalate ", " $ map (\(t, x) -> formatType t ++ " " ++ unVarName x) args
+ args' = intercalate ", " $ map (\(t, x) -> formatType t ++ " " ++ formatVarName x) args
body' = concatMap formatStatement body
- in [ret' ++ " " ++ unVarName f ++ "(" ++ args' ++ ") {"] ++ body' ++ ["}"]
+ in [ret' ++ " " ++ formatFunName f ++ "(" ++ args' ++ ") {"] ++ body' ++ ["}"]
StaticAssert e msg ->
["static_assert (" ++ resolvePrec CommaPrec (formatExpr e) ++ ", " ++ formatLiteral (LitString msg) ++ ");"]
diff --git a/src/Jikka/CPlusPlus/Language/Expr.hs b/src/Jikka/CPlusPlus/Language/Expr.hs
--- a/src/Jikka/CPlusPlus/Language/Expr.hs
+++ b/src/Jikka/CPlusPlus/Language/Expr.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-- |
-- Module : Jikka.CPlusPlus.Language.Expr
-- Description : contains data types of C++ language. / C++ のためのデータ型を含みます。
@@ -13,12 +11,27 @@
-- The data types are intended to use for the code generation.
module Jikka.CPlusPlus.Language.Expr where
-import Data.String (IsString)
+import Data.String
+import Jikka.Common.Name
-newtype VarName = VarName {unVarName :: String} deriving (Eq, Ord, Show, Read, IsString)
+data VarName = VarName OccName NameFlavour (Maybe NameHint) deriving (Eq, Ord, Show, Read)
-newtype FunName = FunName {unFunName :: String} deriving (Eq, Ord, Show, Read, IsString)
+instance IsString VarName where
+ fromString s =
+ let (occ, flavour) = toFlavouredName s
+ in VarName occ flavour Nothing
+formatVarName :: VarName -> String
+formatVarName (VarName occ flavour _) = formatFlavouredName occ flavour
+
+newtype FunName = FunName String deriving (Eq, Ord, Show, Read)
+
+instance IsString FunName where
+ fromString = FunName
+
+formatFunName :: FunName -> String
+formatFunName (FunName occ) = occ
+
data Type
= -- | @auto@
TyAuto
@@ -192,10 +205,9 @@
Cond Expr Expr Expr
| -- | lambda expression @[=](T1 x1, T2 x2, ...) -> Tr { stmt1; stmt2; ... }@
Lam [(Type, VarName)] Type [Statement]
- | -- | @f(e1, e2, ...)@ for a fixed function @f@
- Call Function [Expr]
- | -- | @e(e1, e2, ...)@ for an callable expr @e@
- CallExpr Expr [Expr]
+ | -- | @f(e1, e2, ...)@ for a callable @f@
+ Call Expr [Expr]
+ | Callable Function
deriving (Eq, Ord, Show, Read)
data LeftExpr
@@ -254,7 +266,7 @@
= -- | @const T x = e;@
VarDef Type VarName Expr
| -- | @T f(T1 x1, T2 x2, ...) { stmt1; stmt2; ... }@
- FunDef Type VarName [(Type, VarName)] [Statement]
+ FunDef Type FunName [(Type, VarName)] [Statement]
| -- | @static_assert(e, msg);@
StaticAssert Expr String
deriving (Eq, Ord, Show, Read)
diff --git a/src/Jikka/CPlusPlus/Language/Util.hs b/src/Jikka/CPlusPlus/Language/Util.hs
--- a/src/Jikka/CPlusPlus/Language/Util.hs
+++ b/src/Jikka/CPlusPlus/Language/Util.hs
@@ -1,49 +1,37 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
module Jikka.CPlusPlus.Language.Util where
import Control.Monad.Identity
-import Data.Char (isAlphaNum, isNumber)
import qualified Data.Set as S
import Jikka.CPlusPlus.Language.Expr
import Jikka.Common.Alpha
+import Jikka.Common.Name
fromLeftExpr :: LeftExpr -> Expr
fromLeftExpr = \case
LeftVar x -> Var x
- LeftAt x e -> Call At [fromLeftExpr x, e]
- LeftGet n e -> Call (Function "std::get" [TyIntValue n]) [fromLeftExpr e]
-
-data NameKind
- = LocalNameKind
- | LocalArgumentNameKind
- | LoopCounterNameKind
- | ConstantNameKind
- | FunctionNameKind
- | ArgumentNameKind
- deriving (Eq, Ord, Show, Read)
+ LeftAt x e -> Call' At [fromLeftExpr x, e]
+ LeftGet n e -> Call' (Function "std::get" [TyIntValue n]) [fromLeftExpr e]
-fromNameKind :: NameKind -> String
-fromNameKind = \case
- LocalNameKind -> "x"
- LocalArgumentNameKind -> "b"
- LoopCounterNameKind -> "i"
- ConstantNameKind -> "c"
- FunctionNameKind -> "f"
- ArgumentNameKind -> "a"
+newFreshName :: MonadAlpha m => NameHint -> m VarName
+newFreshName kind = do
+ i <- nextCounter
+ return (VarName Nothing (Just i) (Just kind))
-newFreshName :: MonadAlpha m => NameKind -> m VarName
-newFreshName kind = renameVarName kind ""
+renameVarName :: MonadAlpha m => NameHint -> VarName -> m VarName
+renameVarName kind (VarName occ _ _) = case occ of
+ Nothing -> newFreshName kind
+ Just occ -> renameVarName' kind occ
-renameVarName :: MonadAlpha m => NameKind -> String -> m VarName
-renameVarName kind hint = do
+renameVarName' :: MonadAlpha m => NameHint -> String -> m VarName
+renameVarName' kind occ = do
i <- nextCounter
- let f = reverse . dropWhile (\c -> isNumber c || c == '_') . reverse . takeWhile (\c -> isAlphaNum c || c == '_')
- let prefix = case f hint of
- "" -> fromNameKind kind
- hint' -> hint' ++ "_"
- return (VarName (prefix ++ show i))
+ return (VarName (Just occ) (Just i) (Just kind))
freeVars :: Expr -> S.Set VarName
freeVars = \case
@@ -53,8 +41,8 @@
BinOp _ e1 e2 -> freeVars e1 <> freeVars e2
Cond e1 e2 e3 -> freeVars e1 <> freeVars e2 <> freeVars e3
Lam args _ body -> freeVarsStatements body S.\\ S.fromList (map snd args)
- Call _ args -> mconcat (map freeVars args)
- CallExpr f args -> freeVars f <> mconcat (map freeVars args)
+ Call f args -> freeVars f <> mconcat (map freeVars args)
+ Callable _ -> S.empty
freeVarsStatements :: [Statement] -> S.Set VarName
freeVarsStatements = mconcat . map freeVarsStatement
@@ -112,14 +100,17 @@
incrExpr :: Expr -> Expr
incrExpr e = BinOp Add e (Lit (LitInt32 1))
+pattern Call' :: Function -> [Expr] -> Expr
+pattern Call' f args = Call (Callable f) args
+
size :: Expr -> Expr
-size e = Call MethodSize [e]
+size e = Call' MethodSize [e]
at :: Expr -> Expr -> Expr
-at e i = Call At [e, i]
+at e i = Call' At [e, i]
cast :: Type -> Expr -> Expr
-cast t e = Call (Cast t) [e]
+cast t e = Call' (Cast t) [e]
assignSimple :: VarName -> Expr -> Statement
assignSimple x e = Assign (AssignExpr SimpleAssign (LeftVar x) e)
@@ -128,25 +119,25 @@
assignAt xs i e = Assign (AssignExpr SimpleAssign (LeftAt (LeftVar xs) i) e)
callFunction :: FunName -> [Type] -> [Expr] -> Expr
-callFunction f ts args = Call (Function f ts) args
+callFunction f ts args = Call' (Function f ts) args
callFunction' :: FunName -> [Type] -> [Expr] -> Statement
callFunction' = ((ExprStatement .) .) . callFunction
callMethod :: Expr -> FunName -> [Expr] -> Expr
-callMethod e f args = Call (Method f) (e : args)
+callMethod e f args = Call' (Method f) (e : args)
callMethod' :: Expr -> FunName -> [Expr] -> Statement
callMethod' = ((ExprStatement .) .) . callMethod
vecCtor :: Type -> [Expr] -> Expr
-vecCtor t es = Call (VecCtor t) es
+vecCtor t es = Call' (VecCtor t) es
begin :: Expr -> Expr
-begin e = Call (Method "begin") [e]
+begin e = Call' (Method "begin") [e]
end :: Expr -> Expr
-end e = Call (Method "end") [e]
+end e = Call' (Method "end") [e]
mapExprStatementExprM :: Monad m => (Expr -> m Expr) -> (Statement -> m [Statement]) -> Expr -> m Expr
mapExprStatementExprM f g = go
@@ -158,8 +149,8 @@
BinOp op e1 e2 -> f =<< (BinOp op <$> go e1 <*> go e2)
Cond e1 e2 e3 -> f =<< (Cond <$> go e1 <*> go e2 <*> go e3)
Lam args ret body -> f . Lam args ret . concat =<< mapM (mapExprStatementStatementM f g) body
- Call g args -> f . Call g =<< mapM go args
- CallExpr g args -> f =<< (CallExpr <$> go g <*> mapM go args)
+ Call g args -> f =<< (Call <$> go g <*> mapM go args)
+ Callable g -> f $ Callable g
mapExprStatementLeftExprM :: Monad m => (Expr -> m Expr) -> (Statement -> m [Statement]) -> LeftExpr -> m LeftExpr
mapExprStatementLeftExprM f g = \case
@@ -208,6 +199,9 @@
mapExprStatementProgram :: (Expr -> Expr) -> (Statement -> [Statement]) -> Program -> Program
mapExprStatementProgram f g = runIdentity . mapExprStatementProgramM (return . f) (return . g)
+mapExprStatementExpr :: (Expr -> Expr) -> (Statement -> [Statement]) -> Expr -> Expr
+mapExprStatementExpr goE goS = runIdentity . mapExprStatementExprM (return . goE) (return . goS)
+
mapSubExprM :: Monad m => (Expr -> m Expr) -> Expr -> m Expr
mapSubExprM f e = mapExprStatementExprM f (return . (: [])) e
@@ -243,11 +237,11 @@
LeftGet i e -> LeftGet i <$> mapDirectExprLeftExprM f e
replaceExpr :: VarName -> Expr -> Expr -> Expr
-replaceExpr x e = runIdentity . mapExprStatementExprM go (return . (: []))
+replaceExpr x e = mapExprStatementExpr go (: [])
where
go = \case
- Var y | y == x -> return e
- e' -> return e'
+ Var y | y == x -> e
+ e' -> e'
replaceStatement :: VarName -> Expr -> Statement -> Statement
replaceStatement x e = head . runIdentity . mapExprStatementStatementM go (return . (: []))
@@ -255,3 +249,53 @@
go = \case
Var y | y == x -> return e
e' -> return e'
+
+mapToplevelStatementProgramM :: Monad m => (ToplevelStatement -> m [ToplevelStatement]) -> Program -> m Program
+mapToplevelStatementProgramM f prog = Program . concat <$> mapM f (decls prog)
+
+mapLeftExprAssignExprM :: Applicative m => (LeftExpr -> m LeftExpr) -> AssignExpr -> m AssignExpr
+mapLeftExprAssignExprM f = \case
+ AssignExpr op e1 e2 -> AssignExpr op <$> f e1 <*> pure e2
+ AssignIncr e -> AssignIncr <$> f e
+ AssignDecr e -> AssignDecr <$> f e
+
+mapLeftExprAssignExpr :: (LeftExpr -> LeftExpr) -> AssignExpr -> AssignExpr
+mapLeftExprAssignExpr f = runIdentity . mapLeftExprAssignExprM (return . f)
+
+mapVarNameExprStatementGenericM :: forall m a. Monad m => ((Expr -> m Expr) -> (Statement -> m [Statement]) -> a) -> (VarName -> m VarName) -> a
+mapVarNameExprStatementGenericM mapExprStatementM f = mapExprStatementM goE (fmap (: []) . goS)
+ where
+ goE = \case
+ Var x -> Var <$> f x
+ Lam args ret body -> Lam <$> mapM (\(t, x) -> (t,) <$> f x) args <*> pure ret <*> pure body
+ e -> return e
+ goS :: Statement -> m Statement
+ goS = \case
+ Assign e -> Assign <$> goAssignExpr e
+ Declare t x init -> Declare t <$> f x <*> pure init
+ DeclareDestructure xs e -> DeclareDestructure <$> mapM f xs <*> pure e
+ For t x init pred incr body -> For t <$> f x <*> pure init <*> pure pred <*> goAssignExpr incr <*> pure body
+ ForEach t x e body -> ForEach t <$> f x <*> pure e <*> pure body
+ stmt -> return stmt
+ goAssignExpr = mapLeftExprAssignExprM goLeftExpr
+ goLeftExpr = \case
+ LeftVar x -> LeftVar <$> f x
+ LeftAt e1 e2 -> LeftAt <$> goLeftExpr e1 <*> pure e2
+ LeftGet n e -> LeftGet n <$> goLeftExpr e
+
+mapVarNameStatementM :: Monad m => (VarName -> m VarName) -> Statement -> m Statement
+mapVarNameStatementM f stmt = head <$> mapVarNameExprStatementGenericM mapExprStatementStatementM f stmt
+
+mapVarNameToplevelStatementM :: Monad m => (VarName -> m VarName) -> ToplevelStatement -> m ToplevelStatement
+mapVarNameToplevelStatementM f stmt = do
+ stmt <- case stmt of
+ VarDef t x e -> VarDef t <$> f x <*> pure e
+ FunDef ret g args body -> FunDef ret g <$> mapM (\(t, x) -> (t,) <$> f x) args <*> pure body
+ _ -> return stmt
+ mapVarNameExprStatementGenericM mapExprStatementToplevelStatementM f stmt
+
+mapVarNameProgramM :: Monad m => (VarName -> m VarName) -> Program -> m Program
+mapVarNameProgramM f = mapToplevelStatementProgramM (fmap (: []) . mapVarNameToplevelStatementM f)
+
+renameVarNameStatement :: VarName -> VarName -> Statement -> Statement
+renameVarNameStatement x y = runIdentity . mapVarNameStatementM (\z -> return $ if z == x then y else z)
diff --git a/src/Jikka/CPlusPlus/Language/VariableAnalysis.hs b/src/Jikka/CPlusPlus/Language/VariableAnalysis.hs
--- a/src/Jikka/CPlusPlus/Language/VariableAnalysis.hs
+++ b/src/Jikka/CPlusPlus/Language/VariableAnalysis.hs
@@ -34,8 +34,8 @@
let ReadWriteList rs ws = analyzeStatements body
args' = S.fromList (map snd args)
in ReadWriteList (rs `S.difference` args') (ws `S.difference` args')
- Call _ args -> mconcat (map analyzeExpr args)
- CallExpr f args -> mconcat (map analyzeExpr (f : args))
+ Call f args -> mconcat (map analyzeExpr (f : args))
+ Callable _ -> mempty
analyzeLeftExpr :: LeftExpr -> ReadWriteList
analyzeLeftExpr = \case
diff --git a/src/Jikka/Common/Name.hs b/src/Jikka/Common/Name.hs
new file mode 100644
--- /dev/null
+++ b/src/Jikka/Common/Name.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Jikka.Common.Name where
+
+import Data.List
+import Data.Maybe
+import Text.Read
+
+type OccName = Maybe String
+
+type NameFlavour = Maybe Int
+
+toFlavouredName :: String -> (OccName, NameFlavour)
+toFlavouredName = \case
+ "_" -> (Nothing, Nothing)
+ s -> case elemIndex '$' s of
+ Nothing -> (Just s, Nothing)
+ Just i ->
+ let (occ, flavour) = splitAt i s
+ occ' = if occ == "" then Nothing else Just occ
+ flavour' = case readMaybe (tail flavour) of
+ Nothing -> error $ "Jikka.Common.Name.toFlavouredName: invalid flavoured name: " ++ s
+ Just i -> i
+ in (occ', Just flavour')
+
+formatFlavouredName :: OccName -> NameFlavour -> String
+formatFlavouredName occ flavour = case (occ, flavour) of
+ (Nothing, Nothing) -> "_"
+ _ -> fromMaybe "" occ ++ maybe "" (('$' :) . show) flavour
+
+data NameHint
+ = LocalNameHint
+ | LocalArgumentNameHint
+ | LoopCounterNameHint
+ | ConstantNameHint
+ | FunctionNameHint
+ | ArgumentNameHint
+ | AdHocNameHint String
+ deriving (Eq, Ord, Show, Read)
diff --git a/src/Jikka/Core/Convert/Alpha.hs b/src/Jikka/Core/Convert/Alpha.hs
--- a/src/Jikka/Core/Convert/Alpha.hs
+++ b/src/Jikka/Core/Convert/Alpha.hs
@@ -35,16 +35,15 @@
if x `notElem` used
then return x
else do
- let base = takeWhile (/= '$') (unVarName x)
- i <- nextCounter
- return $ VarName (base ++ "$" ++ show i)
+ let base = takeWhile (/= '$') (formatVarName x)
+ VarName (Just base) . Just <$> nextCounter
put $ y : used
return y
runExpr' :: (MonadState UsedVars m, MonadAlpha m, MonadError Error m) => RenameMapping -> Expr -> m Expr
runExpr' env = \case
Var x -> case lookup x env of
- Nothing -> throwInternalError $ "undefined variable: " ++ unVarName x
+ Nothing -> throwInternalError $ "undefined variable: " ++ formatVarName x
Just y -> return $ Var y
Lit lit -> return $ Lit lit
App f e -> App <$> runExpr' env f <*> runExpr' env e
diff --git a/src/Jikka/Core/Convert/Eta.hs b/src/Jikka/Core/Convert/Eta.hs
--- a/src/Jikka/Core/Convert/Eta.hs
+++ b/src/Jikka/Core/Convert/Eta.hs
@@ -17,39 +17,26 @@
)
where
-import Data.Maybe
import Jikka.Common.Alpha
import Jikka.Common.Error
import Jikka.Core.Language.BuiltinPatterns
+import Jikka.Core.Language.Eta
import Jikka.Core.Language.Expr
import Jikka.Core.Language.Lint
import Jikka.Core.Language.RewriteRules
-import Jikka.Core.Language.Util
-expandExpr :: MonadAlpha m => Type -> Expr -> m (Maybe Expr)
-expandExpr t e = case (t, e) of
- (FunTy t1 t2, Lam x _ body) -> do
- body <- expandExpr t2 body
- return $ Lam x t1 <$> body
- (FunTy t1 t2, e) -> do
- x <- genVarName'
- let e' = App e (Var x)
- e'' <- expandExpr t2 e'
- return . Just $ Lam x t1 (fromMaybe e' e'')
- _ -> return Nothing
-
-rule :: MonadAlpha m => RewriteRule m
+rule :: (MonadAlpha m, MonadError Error m) => RewriteRule m
rule =
- let go :: MonadAlpha m => Expr -> Type -> (Expr -> Expr) -> m (Maybe Expr)
- go e t f = (f <$>) <$> expandExpr t e
- in makeRewriteRule "eta-reduction" $ \_ -> \case
- Let x t e1 e2 -> go e1 t (\e1 -> Let x t e1 e2)
- Iterate' t k f x -> go f (FunTy t t) (\f -> Iterate' t k f x)
- Foldl' t1 t2 f init xs -> go f (FunTy t2 (FunTy t1 t1)) (\f -> Foldl' t1 t2 f init xs)
- Scanl' t1 t2 f init xs -> go f (FunTy t2 (FunTy t1 t1)) (\f -> Scanl' t1 t2 f init xs)
- Build' t f xs n -> go f (FunTy (ListTy t) t) (\f -> Build' t f xs n)
- Map' t1 t2 f xs -> go f (FunTy t1 t2) (\f -> Map' t1 t2 f xs)
- Filter' t f xs -> go f (FunTy t BoolTy) (\f -> Filter' t f xs)
+ let go :: (MonadAlpha m, MonadError Error m) => RewriteEnvironment -> Expr -> (Expr -> Expr) -> m (Maybe Expr)
+ go env e f = (f <$>) <$> etaExpand' (typeEnv env) e
+ in makeRewriteRule "eta-expansion" $ \env -> \case
+ Let x t e1 e2 -> go env e1 (\e1 -> Let x t e1 e2)
+ Iterate' t k f x -> go env f (\f -> Iterate' t k f x)
+ Foldl' t1 t2 f init xs -> go env f (\f -> Foldl' t1 t2 f init xs)
+ Scanl' t1 t2 f init xs -> go env f (\f -> Scanl' t1 t2 f init xs)
+ Build' t f xs n -> go env f (\f -> Build' t f xs n)
+ Map' t1 t2 f xs -> go env f (\f -> Map' t1 t2 f xs)
+ Filter' t f xs -> go env f (\f -> Filter' t f xs)
_ -> return Nothing
runProgram :: (MonadAlpha m, MonadError Error m) => Program -> m Program
diff --git a/src/Jikka/Core/Convert/SegmentTree.hs b/src/Jikka/Core/Convert/SegmentTree.hs
--- a/src/Jikka/Core/Convert/SegmentTree.hs
+++ b/src/Jikka/Core/Convert/SegmentTree.hs
@@ -52,8 +52,8 @@
)
where
CumulativeSum t f e es =
- let x1 = findUnusedVarName (VarName "y") f
- x2 = findUnusedVarName (VarName "x") f
+ let x1 = findUnusedVarName' f
+ x2 = findUnusedVarName' f
in Scanl' t t (Lam2 x1 t x2 t (App (App f (Var x1)) (Var x2))) e es
pattern CumulativeSumFlip t f e es <-
@@ -65,8 +65,8 @@
)
where
CumulativeSumFlip t f e es =
- let x1 = findUnusedVarName (VarName "y") f
- x2 = findUnusedVarName (VarName "x") f
+ let x1 = findUnusedVarName' f
+ x2 = findUnusedVarName' f
in Scanl' t t (Lam2 x1 t x2 t (App (App f (Var x2)) (Var x1))) e es
builtinToSemigroup :: Builtin -> [Type] -> Maybe Semigroup'
diff --git a/src/Jikka/Core/Convert/TypeInfer.hs b/src/Jikka/Core/Convert/TypeInfer.hs
--- a/src/Jikka/Core/Convert/TypeInfer.hs
+++ b/src/Jikka/Core/Convert/TypeInfer.hs
@@ -66,7 +66,7 @@
wrapErrorFromHint :: MonadError Error m => Hint -> m a -> m a
wrapErrorFromHint = \case
- VarHint x -> wrapError' $ "around variable " ++ unVarName x
+ VarHint x -> wrapError' $ "around variable " ++ formatVarName x
ExprHint e -> wrapError' $ "around expr " ++ summarize (formatExpr e)
ToplevelExprHint e -> wrapError' $ "around toplevel expr " ++ summarize (formatToplevelExpr e)
where
@@ -170,7 +170,7 @@
unifyTyVar :: (MonadState Subst m, MonadError Error m) => TypeName -> Type -> m ()
unifyTyVar x t =
if x `elem` freeTyVars t
- then throwInternalError $ "looped type equation " ++ unTypeName x ++ " = " ++ formatType t
+ then throwInternalError $ "looped type equation " ++ formatTypeName x ++ " = " ++ formatType t
else do
modify' (Subst . M.insert x t . unSubst) -- This doesn't introduce the loop.
diff --git a/src/Jikka/Core/Evaluate.hs b/src/Jikka/Core/Evaluate.hs
--- a/src/Jikka/Core/Evaluate.hs
+++ b/src/Jikka/Core/Evaluate.hs
@@ -259,10 +259,10 @@
SegmentTreeSetPoint _ -> go3' valueToList valueToInt pure ValList setAtEither
callLambda :: MonadError Error m => Maybe VarName -> Env -> VarName -> Type -> Expr -> [Value] -> m Value
-callLambda = \name env x t body args -> wrapError' ("while calling lambda " ++ maybe "(anonymous)" unVarName name) $ go Nothing env x t body args
+callLambda = \name env x t body args -> wrapError' ("while calling lambda " ++ maybe "(anonymous)" formatVarName name) $ go Nothing env x t body args
where
go name env x t body [] = return $ ValLambda name env x t body
- go name env x _ body (e : args) = maybe id (\name -> wrapError' $ "while calling lambda " ++ unVarName name) name $ do
+ go name env x _ body (e : args) = maybe id (\name -> wrapError' $ "while calling lambda " ++ formatVarName name) name $ do
body <- evaluateExpr ((x, e) : env) body
case body of
ValLambda name env x t body -> go name env x t body args
@@ -278,7 +278,7 @@
evaluateExpr :: MonadError Error m => Env -> Expr -> m Value
evaluateExpr env = \case
Var x -> case lookup x env of
- Nothing -> throwInternalError $ "undefined variable: " ++ unVarName x
+ Nothing -> throwInternalError $ "undefined variable: " ++ formatVarName x
Just val -> return val
Lit lit -> case lit of
LitBuiltin ConvexHullTrickInit ts -> callBuiltin ConvexHullTrickInit ts []
diff --git a/src/Jikka/Core/Format.hs b/src/Jikka/Core/Format.hs
--- a/src/Jikka/Core/Format.hs
+++ b/src/Jikka/Core/Format.hs
@@ -109,7 +109,7 @@
formatType' :: Type -> (String, Prec)
formatType' = \case
- VarTy (TypeName a) -> (a, identPrec)
+ VarTy a -> (formatTypeName a, identPrec)
IntTy -> ("int", identPrec)
BoolTy -> ("bool", identPrec)
ListTy t -> (resolvePrec funCallPrec (formatType' t) ++ " list", funCallPrec)
@@ -306,16 +306,16 @@
LitBottom _ msg -> "bottom<" ++ show msg ++ ">"
formatFormalArgs :: [(VarName, Type)] -> String
-formatFormalArgs args = unwords $ map (\(x, t) -> paren (unVarName x ++ ": " ++ formatType t)) args
+formatFormalArgs args = unwords $ map (\(x, t) -> paren (formatVarName x ++ ": " ++ formatType t)) args
formatExpr' :: Expr -> (String, Prec)
formatExpr' = \case
- Var x -> (unVarName x, identPrec)
+ Var x -> (formatVarName x, identPrec)
Lit lit -> (formatLiteral lit, identPrec)
e@(App _ _) ->
let (f, args) = curryApp e
in case f of
- Var x -> formatFunCall (unVarName x, identPrec) args
+ Var x -> formatFunCall (formatVarName x, identPrec) args
Lit (LitBuiltin builtin ts) -> formatBuiltin' builtin ts args
_ -> formatFunCall (formatExpr' f) args
LamId _ -> ("id", identPrec)
@@ -323,7 +323,7 @@
e@(Lam _ _ _) ->
let (args, body) = uncurryLam e
in ("fun " ++ formatFormalArgs args ++ " ->\n" ++ indent ++ "\n" ++ resolvePrec parenPrec (formatExpr' body) ++ "\n" ++ dedent ++ "\n", lambdaPrec)
- Let x t e1 e2 -> ("let " ++ unVarName x ++ ": " ++ formatType t ++ " = " ++ resolvePrec parenPrec (formatExpr' e1) ++ "\nin " ++ resolvePrec lambdaPrec (formatExpr' e2), lambdaPrec)
+ Let x t e1 e2 -> ("let " ++ formatVarName x ++ ": " ++ formatType t ++ " = " ++ resolvePrec parenPrec (formatExpr' e1) ++ "\nin " ++ resolvePrec lambdaPrec (formatExpr' e2), lambdaPrec)
Assert e1 e2 -> ("assert " ++ resolvePrec parenPrec (formatExpr' e1) ++ " in\n" ++ resolvePrec lambdaPrec (formatExpr' e2), lambdaPrec)
formatExpr :: Expr -> String
@@ -332,8 +332,8 @@
formatToplevelExpr' :: ToplevelExpr -> [String]
formatToplevelExpr' = \case
ResultExpr e -> lines (resolvePrec lambdaPrec (formatExpr' e))
- ToplevelLet x t e cont -> let' (unVarName x) t e cont
- ToplevelLetRec f args ret e cont -> let' ("rec " ++ unVarName f ++ " " ++ formatFormalArgs args) ret e cont
+ ToplevelLet x t e cont -> let' (formatVarName x) t e cont
+ ToplevelLetRec f args ret e cont -> let' ("rec " ++ formatVarName f ++ " " ++ formatFormalArgs args) ret e cont
ToplevelAssert e cont -> ["assert " ++ resolvePrec parenPrec (formatExpr' e), "in"] ++ formatToplevelExpr' cont
where
let' s t e cont =
diff --git a/src/Jikka/Core/Language/Beta.hs b/src/Jikka/Core/Language/Beta.hs
--- a/src/Jikka/Core/Language/Beta.hs
+++ b/src/Jikka/Core/Language/Beta.hs
@@ -57,14 +57,14 @@
then return $ ToplevelLet y t e' cont
else do
when (y `isFreeVar` e) $ do
- throwInternalError $ "Jikka.Core.Language.Beta.substituteToplevelExpr: toplevel name conflicts: " ++ unVarName y
+ throwInternalError $ "Jikka.Core.Language.Beta.substituteToplevelExpr: toplevel name conflicts: " ++ formatVarName y
ToplevelLet y t e' <$> substituteToplevelExpr x e cont
ToplevelLetRec f args ret body cont -> do
if f == x
then return $ ToplevelLetRec f args ret body cont
else do
when (f `isFreeVar` e) $ do
- throwInternalError $ "Jikka.Core.Language.Beta.substituteToplevelExpr: toplevel name conflicts: " ++ unVarName f
+ throwInternalError $ "Jikka.Core.Language.Beta.substituteToplevelExpr: toplevel name conflicts: " ++ formatVarName f
(args, body) <-
if x `elem` map fst args
then return (args, body)
diff --git a/src/Jikka/Core/Language/Eta.hs b/src/Jikka/Core/Language/Eta.hs
new file mode 100644
--- /dev/null
+++ b/src/Jikka/Core/Language/Eta.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+-- |
+-- Module : Jikka.Core.Language.Eta
+-- Description : does eta-reductions and eta-expansions. / eta 簡約および eta 展開を行います。
+-- Copyright : (c) Kimiyuki Onaka, 2021
+-- License : Apache License 2.0
+-- Maintainer : kimiyuki95@gmail.com
+-- Stability : experimental
+-- Portability : portable
+module Jikka.Core.Language.Eta
+ ( etaExpand,
+ etaExpand',
+ etaReduce,
+ etaReduce',
+ )
+where
+
+import Control.Monad.Trans.Maybe
+import Data.Maybe
+import Jikka.Common.Alpha
+import Jikka.Common.Error
+import Jikka.Core.Language.Expr
+import Jikka.Core.Language.FreeVars
+import Jikka.Core.Language.TypeCheck
+import Jikka.Core.Language.Util
+
+etaExpand' :: (MonadAlpha m, MonadError Error m) => [(VarName, Type)] -> Expr -> m (Maybe Expr)
+etaExpand' env e = runMaybeT $ do
+ t <- lift $ typecheckExpr env e
+ ts <- case uncurryFunTy t of
+ (ts@(_ : _), _) -> return ts
+ _ -> hoistMaybe Nothing
+ let (args, body) = uncurryLam e
+ guard $ length args /= length ts -- otherwise, it's already eta-expanded
+ args' <- forM (drop (length args) ts) $ \t -> do
+ x <- lift genVarName'
+ return (x, t)
+ return $ curryLam (args ++ args') (uncurryApp body (map (Var . fst) args'))
+
+-- `etaExpand` does an eta-expansion.
+--
+-- == Examples
+--
+-- Before:
+--
+-- > map
+--
+-- After:
+--
+-- > fun f xs -> map f xs
+--
+-- Before:
+--
+-- > let f x y = x + y in f
+--
+-- After:
+--
+-- > fun x y -> (let f x y = x + y in f) x y
+etaExpand :: (MonadAlpha m, MonadError Error m) => [(VarName, Type)] -> Expr -> m Expr
+etaExpand env e = fromMaybe e <$> etaExpand' env e
+
+etaReduce' :: Expr -> Maybe Expr
+etaReduce' e = do
+ let (args, body) = uncurryLam e
+ let (f, args') = curryApp body
+ guard $ length args <= length args'
+ let k = length args' - length args
+ let f' = uncurryApp f (take k args')
+ let args'' = drop k args'
+ guard $ args'' == map (Var . fst) args
+ guard $ all (\(x, _) -> x `isUnusedVar` f') args
+ return f'
+
+-- `etaReduce` does an eta-reduce in the result expr.
+--
+-- == Examples
+--
+-- Before:
+--
+-- > fun f xs -> map f xs
+--
+-- After:
+--
+-- > map
+--
+-- Before:
+--
+-- > fun x y -> (let f x y = x + y in f) x y
+--
+-- After:
+--
+-- > let f x y = x + y in f
+etaReduce :: Expr -> Expr
+etaReduce e = fromMaybe e (etaReduce' e)
diff --git a/src/Jikka/Core/Language/Expr.hs b/src/Jikka/Core/Language/Expr.hs
--- a/src/Jikka/Core/Language/Expr.hs
+++ b/src/Jikka/Core/Language/Expr.hs
@@ -1,5 +1,4 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
@@ -18,17 +17,25 @@
module Jikka.Core.Language.Expr where
import Data.Data
-import Data.String (IsString)
+import Data.String
+import Jikka.Common.Name
-newtype VarName = VarName String deriving (Eq, Ord, Show, Read, Data, Typeable, IsString)
+-- NOTE: @VarName occ flavour == VarName occ' flavour'@ is defined as @occ == occ' && flavour == flavour'@ but we assume that this is equivalent to @flavour == flavour'@ unless they are @Nothing@.
+data VarName = VarName OccName NameFlavour deriving (Eq, Ord, Show, Read, Data, Typeable)
-unVarName :: VarName -> String
-unVarName (VarName name) = name
+instance IsString VarName where
+ fromString = uncurry VarName . toFlavouredName
-newtype TypeName = TypeName String deriving (Eq, Ord, Show, Read, Data, Typeable, IsString)
+formatVarName :: VarName -> String
+formatVarName (VarName occ flavour) = formatFlavouredName occ flavour
-unTypeName :: TypeName -> String
-unTypeName (TypeName name) = name
+data TypeName = TypeName OccName NameFlavour deriving (Eq, Ord, Show, Read, Data, Typeable)
+
+instance IsString TypeName where
+ fromString = uncurry TypeName . toFlavouredName
+
+formatTypeName :: TypeName -> String
+formatTypeName (TypeName occ flavour) = formatFlavouredName occ flavour
-- | `Type` represents the types of our core language. This is similar to the `Type` of GHC Core.
-- See also [commentary/compiler/type-type](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/type-type).
diff --git a/src/Jikka/Core/Language/FreeVars.hs b/src/Jikka/Core/Language/FreeVars.hs
--- a/src/Jikka/Core/Language/FreeVars.hs
+++ b/src/Jikka/Core/Language/FreeVars.hs
@@ -10,8 +10,19 @@
-- Portability : portable
module Jikka.Core.Language.FreeVars where
+import Data.Maybe
+import qualified Data.Set as S
import Jikka.Core.Language.Expr
+freeVars :: Expr -> S.Set VarName
+freeVars = \case
+ Var x -> S.singleton x
+ Lit _ -> S.empty
+ App f e -> freeVars f <> freeVars e
+ Lam x _ e -> S.delete x (freeVars e)
+ Let x _ e1 e2 -> freeVars e1 <> S.delete x (freeVars e2)
+ Assert e1 e2 -> freeVars e1 <> freeVars e2
+
-- | `isFreeVar` checks if the given variable occurs in the tiven expr. This considers contexts.
--
-- >>> VarName "x" `isFreeVar` Lam (VarName "y") IntTy (Var (VarName "x"))
@@ -58,7 +69,10 @@
DataStructureTy _ -> []
findUnusedVarName :: VarName -> Expr -> VarName
-findUnusedVarName (VarName x) e = head . filter (`isUnusedVar` e) $ map (\i -> VarName (x ++ show i)) [0 ..]
+findUnusedVarName (VarName x _) e =
+ let xs = S.fromList (concatMap (\(VarName _ i) -> maybeToList i) (S.toList (freeVars e)))
+ flavour = head $ filter (`S.notMember` xs) [0 ..]
+ in VarName x (Just flavour)
findUnusedVarName' :: Expr -> VarName
-findUnusedVarName' = findUnusedVarName (VarName "x")
+findUnusedVarName' = findUnusedVarName (VarName Nothing Nothing)
diff --git a/src/Jikka/Core/Language/NameCheck.hs b/src/Jikka/Core/Language/NameCheck.hs
--- a/src/Jikka/Core/Language/NameCheck.hs
+++ b/src/Jikka/Core/Language/NameCheck.hs
@@ -26,7 +26,7 @@
define x t = do
env <- get
case lookup x env of
- Just t' -> throwInternalError $ "name conflict: " ++ unVarName x ++ ": " ++ formatType t ++ " and " ++ unVarName x ++ ": " ++ formatType t'
+ Just t' -> throwInternalError $ "name conflict: " ++ formatVarName x ++ ": " ++ formatType t ++ " and " ++ formatVarName x ++ ": " ++ formatType t'
Nothing -> put $ (x, t) : env
namecheckExpr' :: (MonadState [(VarName, Type)] m, MonadError Error m) => Expr -> m ()
@@ -34,7 +34,7 @@
Var x -> do
env <- get
case lookup x env of
- Nothing -> throwInternalError $ "undefined variable: " ++ unVarName x
+ Nothing -> throwInternalError $ "undefined variable: " ++ formatVarName x
Just _ -> return ()
Lit _ -> return ()
App f e -> do
diff --git a/src/Jikka/Core/Language/QuasiRules.hs b/src/Jikka/Core/Language/QuasiRules.hs
--- a/src/Jikka/Core/Language/QuasiRules.hs
+++ b/src/Jikka/Core/Language/QuasiRules.hs
@@ -18,6 +18,7 @@
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
@@ -40,14 +41,12 @@
Right y -> return y
fromVarName :: VarName -> Q TH.Name
-fromVarName (VarName x) = do
- let base = takeWhile (/= '$') x
- TH.newName (if null base then "x" else base)
+fromVarName (VarName x _) = do
+ TH.newName (fromMaybe "x" x)
fromTypeName :: TypeName -> Q TH.Name
-fromTypeName (TypeName x) = do
- let base = takeWhile (/= '$') x
- TH.newName (if null base then "t" else base)
+fromTypeName (TypeName x _) = do
+ TH.newName (fromMaybe "t" x)
liftDataP :: Data a => a -> Q Pat
liftDataP = TH.dataToPatQ (const Nothing)
@@ -121,7 +120,7 @@
toPatE :: Expr -> StateT Env Q Pat
toPatE = \case
Var x ->
- if x == VarName "_"
+ if x == VarName Nothing Nothing
then return WildP
else do
env <- gets vars
@@ -132,7 +131,7 @@
y <- lift $ fromVarName x
modify' (\env -> env {vars = (x, RenamedVar (VarE y)) : vars env})
return $ VarP y
- Nothing -> fail $ "Jikka.Core.Language.QuasiRules.toPatE: undefined variable (forall is required): " ++ unVarName x
+ Nothing -> fail $ "Jikka.Core.Language.QuasiRules.toPatE: undefined variable (forall is required): " ++ formatVarName x
Lit lit -> do
lit <- toPatL lit
lift [p|Lit $(pure lit)|]
@@ -166,7 +165,7 @@
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
+ Nothing -> fail $ "Jikka.Core.Language.QuasiRules.toExpT: undefined type variable: " ++ formatTypeName x
IntTy -> do
lift $ TH.liftData IntTy
BoolTy -> do
@@ -207,7 +206,7 @@
env <- gets vars
case expFromRenamedVarName <$> lookup x env of
Just (Just y) -> return ([], y)
- _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: undefined variable: " ++ unVarName x
+ _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: undefined variable: " ++ formatVarName x
Lit lit -> do
lit <- toExpL lit
e <- lift [e|Lit $(pure lit)|]
@@ -233,7 +232,7 @@
(stmts, e) <- toExpE e
e <- lift [e|Lam $(pure (VarE y)) $(pure t) $(pure e)|]
return (BindS (VarP y) genVarName : stmts, e)
- _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " ++ unVarName x
+ _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " ++ formatVarName x
Let x t e1 e2 -> do
t <- toExpT t
(stmts, e1) <- toExpE e1
@@ -251,7 +250,7 @@
(stmts', e2) <- toExpE e2
e <- lift [e|Let $(pure (VarE y)) $(pure t) $(pure e1) $(pure e2)|]
return (stmts ++ BindS (VarP y) genVarName : stmts', e)
- _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " ++ unVarName x
+ _ -> fail $ "Jikka.Core.Language.QuasiRules.toExpE: variable conflicts: " ++ formatVarName x
Assert e1 e2 -> do
(stmts1, e1) <- toExpE e1
(stmts2, e2) <- toExpE e2
diff --git a/src/Jikka/Core/Language/TypeCheck.hs b/src/Jikka/Core/Language/TypeCheck.hs
--- a/src/Jikka/Core/Language/TypeCheck.hs
+++ b/src/Jikka/Core/Language/TypeCheck.hs
@@ -166,7 +166,7 @@
typecheckExpr :: MonadError Error m => TypeEnv -> Expr -> m Type
typecheckExpr env = \case
Var x -> case lookup x env of
- Nothing -> throwInternalError $ "undefined variable: " ++ unVarName x
+ Nothing -> throwInternalError $ "undefined variable: " ++ formatVarName x
Just t -> return t
Lit lit -> literalToType lit
App f e -> do
@@ -176,13 +176,13 @@
FunTy te' ret | te' == te -> return ret
_ -> throwInternalError $ "wrong type funcall: function = " ++ formatExpr f ++ " and argument = " ++ formatExpr e ++ ", function's type = " ++ formatType tf ++ ", but argument's type = " ++ formatType te
Lam x t e ->
- let env' = if x == VarName "_" then env else (x, t) : env
+ let env' = if x == VarName Nothing Nothing then env else (x, t) : env
in FunTy t <$> typecheckExpr env' e
Let x t e1 e2 -> do
t' <- typecheckExpr env e1
when (t /= t') $ do
throwInternalError $ "wrong type binding: " ++ formatExpr (Let x t e1 e2)
- let env' = if x == VarName "_" then env else (x, t) : env
+ let env' = if x == VarName Nothing Nothing then env else (x, t) : env
typecheckExpr env' e2
Assert e1 e2 -> do
t <- typecheckExpr env e1
@@ -196,13 +196,13 @@
ToplevelLet x t e cont -> do
t' <- typecheckExpr env e
when (t' /= t) $ do
- throwInternalError $ "assigned type is not correct: context = (let " ++ unVarName x ++ ": " ++ formatType t ++ " = " ++ formatExpr e ++ " in ...), expected type = " ++ formatType t ++ ", actual type = " ++ formatType t'
+ throwInternalError $ "assigned type is not correct: context = (let " ++ formatVarName x ++ ": " ++ formatType t ++ " = " ++ formatExpr e ++ " in ...), expected type = " ++ formatType t ++ ", actual type = " ++ formatType t'
typecheckToplevelExpr ((x, t) : env) cont
ToplevelLetRec f args ret body cont -> do
let t = curryFunTy (map snd args) ret
ret' <- typecheckExpr (reverse args ++ (f, t) : env) body
when (ret' /= ret) $ do
- throwInternalError $ "returned type is not correct: context = (let rec " ++ unVarName f ++ " " ++ unwords (map (\(x, t) -> unVarName x ++ ": " ++ formatType t) args) ++ ": " ++ formatType ret ++ " = " ++ formatExpr body ++ " in ...), expected type = " ++ formatType ret ++ ", actual type = " ++ formatType ret'
+ throwInternalError $ "returned type is not correct: context = (let rec " ++ formatVarName f ++ " " ++ unwords (map (\(x, t) -> formatVarName x ++ ": " ++ formatType t) args) ++ ": " ++ formatType ret ++ " = " ++ formatExpr body ++ " in ...), expected type = " ++ formatType ret ++ ", actual type = " ++ formatType ret'
typecheckToplevelExpr ((f, t) : env) cont
ToplevelAssert e1 e2 -> do
t <- typecheckExpr env e1
diff --git a/src/Jikka/Core/Language/Util.hs b/src/Jikka/Core/Language/Util.hs
--- a/src/Jikka/Core/Language/Util.hs
+++ b/src/Jikka/Core/Language/Util.hs
@@ -17,18 +17,13 @@
import Jikka.Core.Language.Expr
genType :: MonadAlpha m => m Type
-genType = do
- i <- nextCounter
- return $ VarTy (TypeName ('$' : show i))
+genType = VarTy . TypeName Nothing . Just <$> nextCounter
genVarName :: MonadAlpha m => VarName -> m VarName
-genVarName x = do
- i <- nextCounter
- let base = if unVarName x == "_" then "" else takeWhile (/= '$') (unVarName x)
- return $ VarName (base ++ '$' : show i)
+genVarName (VarName x _) = VarName x . Just <$> nextCounter
genVarName' :: MonadAlpha m => m VarName
-genVarName' = genVarName (VarName "_")
+genVarName' = genVarName (VarName Nothing Nothing)
genVarName'' :: MonadAlpha m => Expr -> m VarName
genVarName'' = \case
diff --git a/src/Jikka/Core/Parse/Happy.y b/src/Jikka/Core/Parse/Happy.y
--- a/src/Jikka/Core/Parse/Happy.y
+++ b/src/Jikka/Core/Parse/Happy.y
@@ -22,6 +22,7 @@
, runRule
) where
+import Data.String (fromString)
import Data.List (intercalate)
import Jikka.Common.Alpha
import Jikka.Common.Error
@@ -232,7 +233,7 @@
-- Types
atom_type :: { Type }
- : IDENT { let (L.Ident x) = value $1 in VarTy (TypeName x) }
+ : IDENT { let (L.Ident x) = value $1 in VarTy (fromString x) }
| "int" { IntTy }
| "bool" { BoolTy }
| atom_type "list" { ListTy $1 }
@@ -276,8 +277,8 @@
| builtin { Lit (uncurry LitBuiltin $1) }
identifier :: { VarName }
- : IDENT { let (L.Ident x) = value $1 in VarName x }
- | "_" { VarName "_" }
+ : IDENT { let (L.Ident x) = value $1 in fromString x }
+ | "_" { VarName Nothing Nothing }
integer :: { Integer }
: INTEGER { let (L.Int n) = value $1 in n }
@@ -528,7 +529,7 @@
(<@>) = (<$>)
underscoreTy :: Type
-underscoreTy = VarTy (TypeName "_")
+underscoreTy = VarTy (TypeName Nothing Nothing)
makeTuple :: MonadError Error m => [Expr] -> Type -> m Expr
makeTuple es t = case t of
@@ -544,13 +545,13 @@
replaceUnderscoresT :: MonadAlpha m => Type -> m Type
replaceUnderscoresT = mapSubTypesM go where
go = \case
- VarTy (TypeName "_") -> genType
+ VarTy (TypeName Nothing Nothing) -> genType
t -> return t
replaceUnderscoresE :: (MonadAlpha m, MonadError Error m) => [(VarName, Type)] -> Expr -> m Expr
replaceUnderscoresE env = mapSubExprM go env where
go _ = \case
- Var (VarName "_") -> Var <$> genVarName'
+ Var (VarName Nothing Nothing) -> Var <$> genVarName'
e@(Proj' [] i (Var x)) -> case lookup x env of
Just (TupleTy ts) -> return $ Proj' ts i (Var x) -- Fix types of projections if it's easily possible.
_ -> return e -- Some cases are impossible. You need to use Jikka.Core.Convert.TypeInfer.
diff --git a/src/Jikka/Main.hs b/src/Jikka/Main.hs
--- a/src/Jikka/Main.hs
+++ b/src/Jikka/Main.hs
@@ -11,10 +11,10 @@
module Jikka.Main where
import Data.Maybe (fromMaybe)
-import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version (showVersion)
import qualified Jikka.CPlusPlus.Convert.BundleRuntime as BundleRuntime
+import qualified Jikka.CPlusPlus.Convert.EmbedOriginalCode as EmbedOriginalCode
import Jikka.Common.Error
import Jikka.Common.Format.Error (hPrintError, hPrintErrorWithText)
import qualified Jikka.Main.Subcommand.Convert as Convert
@@ -134,9 +134,7 @@
output <-
return $
if target' == CPlusPlusTarget && embedOriginalCode opts
- then
- let headers = ["// This C++ code is transpiled using Jikka transpiler v" <> T.pack (showVersion version) <> " https://github.com/kmyk/Jikka", "// The original Python code:"]
- in T.unlines (headers ++ map ("// " <>) (T.lines input)) <> output
+ then EmbedOriginalCode.run input output
else output
liftIO $ T.putStr output
"debug" -> Debug.run path -- TODO: make this subcommand convenient
diff --git a/src/Jikka/Main/Subcommand/Convert.hs b/src/Jikka/Main/Subcommand/Convert.hs
--- a/src/Jikka/Main/Subcommand/Convert.hs
+++ b/src/Jikka/Main/Subcommand/Convert.hs
@@ -13,6 +13,7 @@
import Data.Text (Text, pack)
import qualified Jikka.CPlusPlus.Convert as FromCore
+import qualified Jikka.CPlusPlus.Convert.BurnFlavouredNames as BurnFlavouredNamesCPlusPlus
import qualified Jikka.CPlusPlus.Format as FormatCPlusPlus
import qualified Jikka.CPlusPlus.Language.Expr as CPlusPlus
import Jikka.Common.Alpha
@@ -72,7 +73,9 @@
PythonProgram prog -> return . pack $ show prog -- TODO
RestrictedPythonProgram prog -> FormatRestrictedPython.run prog
CoreProgram prog -> FormatCore.run prog
- CPlusPlusProgram prog -> FormatCPlusPlus.run prog
+ CPlusPlusProgram prog -> do
+ prog <- BurnFlavouredNamesCPlusPlus.run prog
+ FormatCPlusPlus.run prog
run :: Target -> Target -> FilePath -> Text -> Either Error Text
run source target path input = flip evalAlphaT 0 $ do
diff --git a/src/Jikka/Python/Convert/ToRestrictedPython.hs b/src/Jikka/Python/Convert/ToRestrictedPython.hs
--- a/src/Jikka/Python/Convert/ToRestrictedPython.hs
+++ b/src/Jikka/Python/Convert/ToRestrictedPython.hs
@@ -26,7 +26,9 @@
-- convert AST
runIdent :: X.Ident' -> Y.VarName'
-runIdent (WithLoc loc (X.Ident x)) = WithLoc' (Just loc) (Y.VarName x)
+runIdent (WithLoc loc (X.Ident x)) =
+ let occ = if x == "_" then Nothing else Just x
+ in WithLoc' (Just loc) (Y.VarName occ Nothing Nothing)
runAttribute :: X.Ident' -> Y.Attribute'
runAttribute (WithLoc loc (X.Ident x)) = WithLoc' (Just loc) (Y.UnresolvedAttribute (Y.AttributeName x))
diff --git a/src/Jikka/RestrictedPython/Convert/Alpha.hs b/src/Jikka/RestrictedPython/Convert/Alpha.hs
--- a/src/Jikka/RestrictedPython/Convert/Alpha.hs
+++ b/src/Jikka/RestrictedPython/Convert/Alpha.hs
@@ -69,7 +69,7 @@
Just y -> return y
Nothing -> do
y <- genVarName x
- when (unVarName (value' x) /= "_") $ do
+ when (value' x /= underscoreVarName) $ do
put $
env
{ currentMapping = (value' x, value' y) : currentMapping env
@@ -92,7 +92,7 @@
renameLocalCompletelyNew x = do
env <- get
case lookupLocalName x env of
- Just _ -> throwSemanticErrorAt' (loc' x) $ "cannot redefine variable: " ++ unVarName (value' x)
+ Just _ -> throwSemanticErrorAt' (loc' x) $ "cannot redefine variable: " ++ formatVarName (value' x)
Nothing -> renameLocalNew x
-- | `renameToplevel` records given variables to the `Env` without actual renaming.
@@ -103,11 +103,11 @@
Just _ -> do
let msg =
if value' x `S.member` builtinNames
- then "cannot assign to builtin function: " ++ unVarName (value' x)
- else "cannot redefine variable in toplevel: " ++ unVarName (value' x)
+ then "cannot assign to builtin function: " ++ formatVarName (value' x)
+ else "cannot redefine variable in toplevel: " ++ formatVarName (value' x)
throwSemanticErrorAt' (loc' x) msg
Nothing -> do
- when (unVarName (value' x) /= "_") $ do
+ when (formatVarName (value' x) /= "_") $ do
put $
env
{ currentMapping = (value' x, value' x) : currentMapping env
@@ -120,7 +120,7 @@
popRename :: (MonadState Env m, MonadError Error m) => VarName' -> m ()
popRename x =
- when (unVarName (value' x) /= "_") $ do
+ when (formatVarName (value' x) /= "_") $ do
y <- lookupName' x
modify' $ \env -> env {currentMapping = delete (value' x, value' y) (currentMapping env)}
@@ -142,7 +142,7 @@
env <- get
case lookupName x env of
Just y -> return y
- Nothing -> throwSymbolErrorAt' (loc' x) $ "undefined identifier: " ++ unVarName (value' x)
+ Nothing -> throwSymbolErrorAt' (loc' x) $ "undefined identifier: " ++ formatVarName (value' x)
-- | `runAnnTarget` renames targets of annotated assignments.
runAnnTarget :: (MonadState Env m, MonadAlpha m, MonadError Error m) => Target' -> m Target'
diff --git a/src/Jikka/RestrictedPython/Convert/DefaultMain.hs b/src/Jikka/RestrictedPython/Convert/DefaultMain.hs
--- a/src/Jikka/RestrictedPython/Convert/DefaultMain.hs
+++ b/src/Jikka/RestrictedPython/Convert/DefaultMain.hs
@@ -28,18 +28,18 @@
[] -> throwSymbolError "solve function is not defined"
ToplevelAnnAssign _ _ _ : stmts -> lookupSolve stmts
ToplevelFunctionDef f args ret body : stmts -> case value' f of
- VarName "solve" -> return (loc' f, args, ret, body)
+ VarName (Just "solve") Nothing Nothing -> return (loc' f, args, ret, body)
_ -> lookupSolve stmts
ToplevelAssert _ : stmts -> lookupSolve stmts
makeInputFormatFromType :: (MonadAlpha m, MonadError Error m) => Type -> m (FormatTree, String)
makeInputFormatFromType = \case
IntTy -> do
- x <- unVarName . value' <$> genVarName'
+ x <- formatVarName . value' <$> genVarName'
return (Exp (Var x), x)
ListTy t -> do
- n <- unVarName . value' <$> genVarName'
- i <- unVarName . value' <$> genVarName'
+ n <- formatVarName . value' <$> genVarName'
+ i <- formatVarName . value' <$> genVarName'
(body, x) <- makeInputFormatFromType t
body <- (`mapFormatTreeM` body) $ \case
Exp e -> return $ Exp (At e i)
@@ -50,10 +50,10 @@
makeOutputFormatFromType' :: (MonadAlpha m, MonadError Error m) => Type -> m (FormatTree, String)
makeOutputFormatFromType' = \case
IntTy -> do
- x <- unVarName . value' <$> genVarName'
+ x <- formatVarName . value' <$> genVarName'
return (Exp (Var x), x)
ListTy t -> do
- i <- unVarName . value' <$> genVarName'
+ i <- formatVarName . value' <$> genVarName'
(body, x) <- makeOutputFormatFromType' t
body <- (`mapFormatTreeM` body) $ \case
Exp e -> return $ Exp (At e i)
diff --git a/src/Jikka/RestrictedPython/Convert/ParseMain.hs b/src/Jikka/RestrictedPython/Convert/ParseMain.hs
--- a/src/Jikka/RestrictedPython/Convert/ParseMain.hs
+++ b/src/Jikka/RestrictedPython/Convert/ParseMain.hs
@@ -29,7 +29,7 @@
splitMain :: Program -> (Maybe MainFunction, Program)
splitMain = \case
[] -> (Nothing, [])
- ToplevelFunctionDef (WithLoc' loc (VarName "main")) args ret body : stmts -> (Just (loc, args, ret, body), stmts)
+ ToplevelFunctionDef (WithLoc' loc (VarName (Just "main") Nothing Nothing)) args ret body : stmts -> (Just (loc, args, ret, body), stmts)
stmt : stmts -> second (stmt :) $ splitMain stmts
checkMainType :: MonadError Error m => MainFunction -> m ()
@@ -78,21 +78,21 @@
parseAnnAssign :: (MonadAlpha m, MonadError Error m) => Target' -> Type -> Expr' -> [Statement] -> m (FormatTree, Maybe ([String], Either String [String]), [Statement])
parseAnnAssign x _ e cont = do
let subscriptTrg x = case value' x of
- NameTrg x -> return (unVarName (value' x), [])
- SubscriptTrg x (WithLoc' _ (Name i)) -> second (++ [unVarName (value' i)]) <$> subscriptTrg x
+ NameTrg x -> return (formatVarName (value' x), [])
+ SubscriptTrg x (WithLoc' _ (Name i)) -> second (++ [formatVarName (value' i)]) <$> subscriptTrg x
_ -> throwSemanticErrorAt' (loc' x) $ "name target or subscript target is expected, but got: " ++ formatTarget x
let subscriptTupleTrg x = case value' x of
TupleTrg xs -> mapM subscriptTrg xs
_ -> throwSemanticErrorAt' (loc' x) $ "tuple target is expected, but got: " ++ formatTarget x
let nameTrg x = case value' x of
- NameTrg x -> return $ unVarName (value' x)
+ NameTrg x -> return $ formatVarName (value' x)
_ -> throwSemanticErrorAt' (loc' x) $ "name target is expected, but got: " ++ formatTarget x
let nameOrTupleTrg x = case value' x of
- NameTrg x -> return . Left $ unVarName (value' x)
+ NameTrg x -> return . Left $ formatVarName (value' x)
TupleTrg xs -> Right <$> mapM nameTrg xs
_ -> throwSemanticErrorAt' (loc' x) $ "name target or tuple target is expected, but got: " ++ formatTarget x
let nameExpr e = case value' e of
- Name x -> return $ unVarName (value' x)
+ Name x -> return $ formatVarName (value' x)
_ -> throwSemanticErrorAt' (loc' e) $ "variable is expected, but got: " ++ formatExpr e
case e of
-- int(input())
@@ -107,8 +107,8 @@
ListMapIntInputSplit -> do
(x, indices) <- subscriptTrg x
case cont of
- Assert (WithLoc' _ (Compare (CallBuiltin (BuiltinLen _) [WithLoc' _ (Name x')]) (CmpOp' Eq' _) n)) : cont | unVarName (value' x') == x -> do
- i <- unVarName . value' <$> genVarName'
+ Assert (WithLoc' _ (Compare (CallBuiltin (BuiltinLen _) [WithLoc' _ (Name x')]) (CmpOp' Eq' _) n)) : cont | formatVarName (value' x') == x -> do
+ i <- formatVarName . value' <$> genVarName'
n <- nameExpr n
return (Seq [Loop i (Var n) (Exp (At (packSubscriptedVar x indices) i)), Newline], Nothing, cont)
_ -> throwSemanticErrorAt' (loc' e) "after `xs = list(map(int, input().split()))', we need to write `assert len(xs) == n`"
@@ -122,7 +122,7 @@
For _ (CallBuiltin BuiltinRange1 [WithLoc' _ (Name n')]) _ : _ | value' n' == n -> return (Seq [], Nothing, cont) -- TODO: add more strict checks
_ -> throwSemanticErrorAt' (loc' e) "after some repetition of `xs = list(range(n))', we need to write `for i in range(n):`"
-- solve(...)
- WithLoc' _ (Call (WithLoc' _ (Name (WithLoc' _ (VarName "solve")))) args) -> do
+ WithLoc' _ (Call (WithLoc' _ (Name (WithLoc' _ (VarName (Just "solve") Nothing Nothing)))) args) -> do
inputs <- mapM nameExpr args
output <- nameOrTupleTrg x
return (Seq [], Just (inputs, output), cont)
@@ -144,20 +144,20 @@
_ -> throwSemanticErrorAt' (loc' n) $ "for loops in main function must use `range(x)', `range(x + k)', `range(x - k)', `range(len(xs))`: " ++ formatExpr n
n <- return $ case n of
Right (n, k) ->
- let n' = Var (unVarName (value' n))
+ let n' = Var (formatVarName (value' n))
in if k == 0 then n' else Plus n' k
- Left xs -> Len (Var (unVarName (value' xs)))
+ Left xs -> Len (Var (formatVarName (value' xs)))
(input, solve, output) <- go body
when (isJust solve) $ do
throwSemanticError "cannot call `solve(...)' in for loop"
- let x' = unVarName (value' x)
+ let x' = formatVarName (value' x)
return (Loop x' n input, Loop x' n output)
parseExprStatement :: (MonadAlpha m, MonadError Error m) => Expr' -> m FormatTree
parseExprStatement e = do
let subscriptExpr e = case value' e of
- Name x -> return (unVarName (value' x), [])
- Subscript e (WithLoc' _ (Name i)) -> second (++ [unVarName (value' i)]) <$> subscriptExpr e
+ Name x -> return (formatVarName (value' x), [])
+ Subscript e (WithLoc' _ (Name i)) -> second (++ [formatVarName (value' i)]) <$> subscriptExpr e
_ -> throwSemanticErrorAt' (loc' e) $ "subscripted variable is expected, but got: " ++ formatExpr e
let starredExpr e = do
(e, starred) <- return $ case value' e of
@@ -169,7 +169,7 @@
| not starred = return $ packSubscriptedVar' x indices
| otherwise = do
let xs = packSubscriptedVar x indices
- i <- unVarName . value' <$> genVarName'
+ i <- formatVarName . value' <$> genVarName'
return $ Loop i (Len xs) (packSubscriptedVar' x (indices ++ [i]))
case e of
CallBuiltin (BuiltinPrint _) args -> do
diff --git a/src/Jikka/RestrictedPython/Convert/ToCore.hs b/src/Jikka/RestrictedPython/Convert/ToCore.hs
--- a/src/Jikka/RestrictedPython/Convert/ToCore.hs
+++ b/src/Jikka/RestrictedPython/Convert/ToCore.hs
@@ -47,11 +47,11 @@
return x
runVarName :: X.VarName' -> Y.VarName
-runVarName (X.WithLoc' _ (X.VarName x)) = Y.VarName x
+runVarName (X.WithLoc' _ (X.VarName occ flavour _)) = Y.VarName occ flavour
runType :: MonadError Error m => X.Type -> m Y.Type
runType = \case
- X.VarTy (X.TypeName x) -> return $ Y.VarTy (Y.TypeName x)
+ X.VarTy (X.TypeName occ flavour) -> return $ Y.VarTy (Y.TypeName occ flavour)
X.IntTy -> return Y.IntTy
X.BoolTy -> return Y.BoolTy
X.ListTy t -> Y.ListTy <$> runType t
@@ -60,14 +60,14 @@
X.StringTy -> throwSemanticError "cannot use `str' type out of main function"
X.SideEffectTy -> throwSemanticError "side-effect type must be used only as expr-statement" -- TODO: check in Jikka.RestrictedPython.Language.Lint
-runConstant :: MonadError Error m => X.Constant -> m Y.Expr
+runConstant :: (MonadAlpha m, MonadError Error m) => X.Constant -> m Y.Expr
runConstant = \case
X.ConstNone -> return $ Y.Tuple' []
X.ConstInt n -> return $ Y.Lit (Y.LitInt n)
X.ConstBool p -> return $ Y.Lit (Y.LitBool p)
X.ConstBuiltin builtin -> runBuiltin builtin
-runBuiltin :: MonadError Error m => X.Builtin -> m Y.Expr
+runBuiltin :: (MonadAlpha m, MonadError Error m) => X.Builtin -> m Y.Expr
runBuiltin builtin = do
let go0 builtin = do
return $ Y.Lit (Y.LitBuiltin builtin [])
@@ -109,24 +109,24 @@
_ -> do
ts <- mapM runType ts
ret <- runType ret
- let var i = Y.VarName ("xs" ++ show i)
- let lam body = Y.Lam "go0" (Y.curryFunTy ts ret) (foldr (\(i, t) -> Y.Lam (var i) (Y.ListTy t)) body (zip [0 ..] ts))
- let len = Y.Min1' Y.IntTy (foldr (Y.Cons' Y.IntTy) (Y.Nil' Y.IntTy) (zipWith (\i t -> Y.Len' t (Y.Var (var i))) [0 ..] ts))
- let body = Y.Map' Y.IntTy ret (Y.Lam "i" Y.IntTy (Y.uncurryApp (Y.Var "go0") (map (Y.Var . var) [0 .. length ts - 1]))) (Y.Range1' len)
+ xs <- replicateM (length ts) Y.genVarName'
+ let lam body = Y.Lam "go0" (Y.curryFunTy ts ret) (foldr (\(i, t) -> Y.Lam (xs !! i) (Y.ListTy t)) body (zip [0 ..] ts))
+ let len = Y.Min1' Y.IntTy (foldr (Y.Cons' Y.IntTy) (Y.Nil' Y.IntTy) (zipWith (\i t -> Y.Len' t (Y.Var (xs !! i))) [0 ..] ts))
+ let body = Y.Map' Y.IntTy ret (Y.Lam "i" Y.IntTy (Y.uncurryApp (Y.Var "go0") (zipWith (\i t -> Y.At' t (Y.Var (xs !! i)) (Y.Var "i")) [0 ..] ts))) (Y.Range1' len)
return $ lam body
X.BuiltinSorted t -> go1 Y.Sorted t
X.BuiltinReversed t -> go1 Y.Reversed t
X.BuiltinEnumerate t -> do
t <- runType t
let body = Y.Lam "i" Y.IntTy (Y.uncurryApp (Y.Tuple' [Y.IntTy, t]) [Y.Var "i", Y.At' t (Y.Var "xs") (Y.Var "i")])
- return $ Y.Lam "xs" (Y.ListTy t) (Y.Map' (Y.ListTy t) (Y.ListTy (Y.TupleTy [Y.IntTy, t])) body (Y.Range1' (Y.Len' t (Y.Var "xs"))))
+ return $ Y.Lam "xs" (Y.ListTy t) (Y.Map' Y.IntTy (Y.TupleTy [Y.IntTy, t]) body (Y.Range1' (Y.Len' t (Y.Var "xs"))))
X.BuiltinFilter t -> go1 Y.Filter t
X.BuiltinZip ts -> do
ts <- mapM runType ts
- let var i = Y.VarName ("xs" ++ show i)
- let lam body = foldr (\(i, t) -> Y.Lam (var i) (Y.ListTy t)) body (zip [0 ..] ts)
- let len = Y.Min1' Y.IntTy (foldr (Y.Cons' Y.IntTy) (Y.Nil' Y.IntTy) (zipWith (\i t -> Y.Len' t (Y.Var (var i))) [0 ..] ts))
- let body = Y.Map' Y.IntTy (Y.TupleTy ts) (Y.Lam "i" Y.IntTy (Y.uncurryApp (Y.Tuple' ts) (map (Y.Var . var) [0 .. length ts - 1]))) (Y.Range1' len)
+ xs <- replicateM (length ts) Y.genVarName'
+ let lam body = foldr (\(i, t) -> Y.Lam (xs !! i) (Y.ListTy t)) body (zip [0 ..] ts)
+ let len = Y.Min1' Y.IntTy (foldr (Y.Cons' Y.IntTy) (Y.Nil' Y.IntTy) (zipWith (\i t -> Y.Len' t (Y.Var (xs !! i))) [0 ..] ts))
+ let body = Y.Map' Y.IntTy (Y.TupleTy ts) (Y.Lam "i" Y.IntTy (Y.uncurryApp (Y.Tuple' ts) (zipWith (\i t -> Y.At' t (Y.Var (xs !! i)) (Y.Var "i")) [0 ..] ts))) (Y.Range1' len)
return $ lam body
X.BuiltinAll -> go0 Y.All
X.BuiltinAny -> go0 Y.Any
@@ -140,14 +140,14 @@
when (n < 2) $ do
throwTypeError $ "max expected 2 or more arguments, got " ++ show n
t <- runType t
- let args = map (\i -> Y.VarName ('x' : show i)) [0 .. n -1]
+ args <- replicateM n Y.genVarName'
return $ Y.curryLam (map (,t) args) (foldr1 (Y.Max2' t) (map Y.Var args))
X.BuiltinMin1 t -> go1 Y.Min1 t
X.BuiltinMin t n -> do
when (n < 2) $ do
throwTypeError $ "max min 2 or more arguments, got " ++ show n
t <- runType t
- let args = map (\i -> Y.VarName ('x' : show i)) [0 .. n -1]
+ args <- replicateM n Y.genVarName'
return $ Y.curryLam (map (,t) args) (foldr1 (Y.Min2' t) (map Y.Var args))
X.BuiltinArgMax t -> go1 Y.ArgMax t
X.BuiltinArgMin t -> go1 Y.ArgMin t
diff --git a/src/Jikka/RestrictedPython/Evaluate.hs b/src/Jikka/RestrictedPython/Evaluate.hs
--- a/src/Jikka/RestrictedPython/Evaluate.hs
+++ b/src/Jikka/RestrictedPython/Evaluate.hs
@@ -45,7 +45,7 @@
local <- get
case M.lookup (value' x) (unLocal local) of
Just v -> return v
- Nothing -> throwInternalErrorAt' (loc' x) $ "undefined variable: " ++ unVarName (value' x)
+ Nothing -> throwInternalErrorAt' (loc' x) $ "undefined variable: " ++ formatVarName (value' x)
assignSubscriptedTarget :: (MonadReader Global m, MonadState Local m, MonadError Error m) => Target' -> Expr' -> Value -> m ()
assignSubscriptedTarget f index v = wrapAt' (loc' f) $ do
@@ -270,7 +270,7 @@
global <- ask
case M.lookup (value' x) (unGlobal global) of
Just v -> return v
- Nothing -> throwInternalError $ "undefined variable: " ++ unVarName (value' x)
+ Nothing -> throwInternalError $ "undefined variable: " ++ formatVarName (value' x)
List _ es -> ListVal . V.fromList <$> mapM evalExpr es
Tuple es -> TupleVal <$> mapM evalExpr es
SubscriptSlice e from to step -> do
@@ -528,7 +528,7 @@
lookupGlobal x global =
case M.lookup (value' x) (unGlobal global) of
Just y -> return y
- Nothing -> throwSymbolErrorAt' (loc' x) $ "undefined variable: " ++ unVarName (value' x)
+ Nothing -> throwSymbolErrorAt' (loc' x) $ "undefined variable: " ++ formatVarName (value' x)
runWithGlobal :: MonadError Error m => Global -> Expr' -> m Value
runWithGlobal global e = do
@@ -548,7 +548,7 @@
run :: MonadError Error m => Program -> [Value] -> m Value
run prog args = wrapError' "Jikka.RestrictedPython.Evaluate" $ do
global <- makeGlobal prog
- solve <- lookupGlobal (withoutLoc (VarName "solve")) global
+ solve <- lookupGlobal (withoutLoc solveVarName) global
runWithGlobal' global solve args
evalBinOp :: MonadError Error m => Value -> Operator -> Value -> m Value
diff --git a/src/Jikka/RestrictedPython/Format.hs b/src/Jikka/RestrictedPython/Format.hs
--- a/src/Jikka/RestrictedPython/Format.hs
+++ b/src/Jikka/RestrictedPython/Format.hs
@@ -30,7 +30,7 @@
formatType :: Type -> String
formatType t = case t of
- VarTy x -> unTypeName x
+ VarTy x -> formatTypeName x
IntTy -> "int"
BoolTy -> "bool"
ListTy t -> "List[" ++ formatType t ++ "]"
@@ -104,7 +104,7 @@
formatTarget :: Target' -> String
formatTarget (WithLoc' _ x) = case x of
SubscriptTrg x e -> formatTarget x ++ "[" ++ formatExpr e ++ "]"
- NameTrg x -> unVarName (value' x)
+ NameTrg x -> formatVarName (value' x)
TupleTrg xs -> case xs of
[] -> "()"
[x] -> "(" ++ formatTarget x ++ ",)"
@@ -117,7 +117,7 @@
UnaryOp op e -> formatUnaryOp op ++ " " ++ formatExpr e
Lambda args body -> case args of
[] -> "lambda: " ++ formatExpr body
- _ -> "lambda " ++ intercalate ", " (map (unVarName . value' . fst) args) ++ ": " ++ formatExpr body
+ _ -> "lambda " ++ intercalate ", " (map (formatVarName . value' . fst) args) ++ ": " ++ formatExpr body
IfExp e1 e2 e3 -> formatExpr e2 ++ " if " ++ formatExpr e1 ++ " else " ++ formatExpr e3
ListComp e comp -> "[" ++ formatExpr e ++ " " ++ formatComprehension comp ++ "]"
Compare e1 op e2 -> formatExpr e1 ++ " " ++ formatCmpOp op ++ " " ++ formatExpr e2
@@ -128,7 +128,7 @@
Attribute e (WithLoc' _ x) -> formatExpr e ++ "." ++ formatAttribute x
Subscript e1 e2 -> formatExpr e1 ++ "[" ++ formatExpr e2 ++ "]"
Starred e -> "*" ++ formatExpr e
- Name x -> unVarName (value' x)
+ Name x -> formatVarName (value' x)
List _ es -> "[" ++ intercalate ", " (map formatExpr es) ++ "]"
Tuple es -> case es of
[] -> "()"
@@ -157,8 +157,8 @@
formatToplevelStatement :: ToplevelStatement -> [String]
formatToplevelStatement = \case
- ToplevelAnnAssign x t e -> [unVarName (value' x) ++ ": " ++ formatType t ++ " = " ++ formatExpr e]
- ToplevelFunctionDef f args ret body -> ["def " ++ unVarName (value' f) ++ "(" ++ intercalate ", " (map (\(x, t) -> unVarName (value' x) ++ ": " ++ formatType t) args) ++ ") -> " ++ formatType ret ++ ":", indent] ++ concatMap formatStatement body ++ [dedent]
+ ToplevelAnnAssign x t e -> [formatVarName (value' x) ++ ": " ++ formatType t ++ " = " ++ formatExpr e]
+ ToplevelFunctionDef f args ret body -> ["def " ++ formatVarName (value' f) ++ "(" ++ intercalate ", " (map (\(x, t) -> formatVarName (value' x) ++ ": " ++ formatType t) args) ++ ") -> " ++ formatType ret ++ ":", indent] ++ concatMap formatStatement body ++ [dedent]
ToplevelAssert e -> ["assert " ++ formatExpr e]
formatProgram :: Program -> [String]
diff --git a/src/Jikka/RestrictedPython/Language/Builtin.hs b/src/Jikka/RestrictedPython/Language/Builtin.hs
--- a/src/Jikka/RestrictedPython/Language/Builtin.hs
+++ b/src/Jikka/RestrictedPython/Language/Builtin.hs
@@ -126,7 +126,7 @@
e <- resolveUniqueBuiltin x
case value' e of
Constant (ConstBuiltin _) -> return e
- _ -> throwInternalError $ "not exhaustive: " ++ unVarName (value' x)
+ _ -> throwInternalError $ "not exhaustive: " ++ formatVarName (value' x)
formatBuiltin :: Builtin -> String
formatBuiltin = \case
@@ -294,7 +294,7 @@
_ -> return $ Attribute e x
resolveAttribute e@(WithLoc' _ (Name (WithLoc' _ "jikka"))) x = wrapAt' (loc' x) $ case value' x of
UnresolvedAttribute x' ->
- let x'' = VarName (unAttributeName x')
+ let x'' = VarName (Just (unAttributeName x')) Nothing Nothing
in if x'' `S.notMember` additionalBuiltinNames
then throwSymbolError $ "unknown attribute: " ++ unAttributeName x'
else value' <$> resolveUniqueBuiltin (x $> x'')
diff --git a/src/Jikka/RestrictedPython/Language/Expr.hs b/src/Jikka/RestrictedPython/Language/Expr.hs
--- a/src/Jikka/RestrictedPython/Language/Expr.hs
+++ b/src/Jikka/RestrictedPython/Language/Expr.hs
@@ -12,7 +12,7 @@
module Jikka.RestrictedPython.Language.Expr
( -- * types
TypeName (..),
- unTypeName,
+ formatTypeName,
Type (..),
pattern NoneTy,
@@ -31,7 +31,7 @@
-- * exprs
VarName (..),
- unVarName,
+ formatVarName,
module Jikka.Common.Location,
VarName',
Expr (..),
@@ -48,21 +48,30 @@
)
where
-import Data.String (IsString)
+import Data.String
import Jikka.Common.Location
+import Jikka.Common.Name
import Jikka.Python.Language.Expr (BoolOp (..), CmpOp (..), Operator (..), UnaryOp (..))
-newtype VarName = VarName String deriving (Eq, Ord, Show, Read, IsString)
+data VarName = VarName OccName NameFlavour (Maybe NameHint) deriving (Eq, Ord, Show, Read)
-unVarName :: VarName -> String
-unVarName (VarName x) = x
+instance IsString VarName where
+ fromString s =
+ let (occ, flavour) = toFlavouredName s
+ in VarName occ flavour Nothing
+formatVarName :: VarName -> String
+formatVarName (VarName occ flavour _) = formatFlavouredName occ flavour
+
type VarName' = WithLoc' VarName
-newtype TypeName = TypeName String deriving (Eq, Ord, Show, Read, IsString)
+data TypeName = TypeName OccName NameFlavour deriving (Eq, Ord, Show, Read)
-unTypeName :: TypeName -> String
-unTypeName (TypeName x) = x
+instance IsString TypeName where
+ fromString = uncurry TypeName . toFlavouredName
+
+formatTypeName :: TypeName -> String
+formatTypeName (TypeName occ flavour) = formatFlavouredName occ flavour
newtype AttributeName = AttributeName String deriving (Eq, Ord, Show, Read, IsString)
diff --git a/src/Jikka/RestrictedPython/Language/Util.hs b/src/Jikka/RestrictedPython/Language/Util.hs
--- a/src/Jikka/RestrictedPython/Language/Util.hs
+++ b/src/Jikka/RestrictedPython/Language/Util.hs
@@ -53,6 +53,11 @@
-- * programs
toplevelMainDef,
+
+ -- * variable names
+ mainVarName,
+ solveVarName,
+ underscoreVarName,
)
where
@@ -64,18 +69,15 @@
import Jikka.RestrictedPython.Language.Expr
genType :: MonadAlpha m => m Type
-genType = do
- i <- nextCounter
- return $ VarTy (TypeName ('$' : show i))
+genType = VarTy . TypeName Nothing . Just <$> nextCounter
genVarName :: MonadAlpha m => VarName' -> m VarName'
-genVarName x = do
+genVarName x@(WithLoc' _ (VarName occ _ hint)) = do
i <- nextCounter
- let base = if unVarName (value' x) == "_" then "" else takeWhile (/= '$') (unVarName (value' x))
- return $ WithLoc' (loc' x) (VarName (base ++ '$' : show i))
+ return . WithLoc' (loc' x) $ VarName occ (Just i) hint
genVarName' :: MonadAlpha m => m VarName'
-genVarName' = genVarName (withoutLoc (VarName "_"))
+genVarName' = genVarName (withoutLoc underscoreVarName)
freeTyVars :: Type -> [TypeName]
freeTyVars = nub . go
@@ -353,4 +355,13 @@
SubscriptTrg e1 e2 -> Subscript (targetToExpr e1) e2
toplevelMainDef :: [Statement] -> Program
-toplevelMainDef body = [ToplevelFunctionDef (WithLoc' Nothing (VarName "main")) [] IntTy body]
+toplevelMainDef body = [ToplevelFunctionDef (WithLoc' Nothing mainVarName) [] IntTy body]
+
+mainVarName :: VarName
+mainVarName = VarName (Just "main") Nothing Nothing
+
+solveVarName :: VarName
+solveVarName = VarName (Just "solve") Nothing Nothing
+
+underscoreVarName :: VarName
+underscoreVarName = VarName Nothing Nothing Nothing
diff --git a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs
--- a/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs
+++ b/test/Jikka/CPlusPlus/Convert/FromCoreSpec.hs
@@ -5,8 +5,10 @@
)
where
+import qualified Jikka.CPlusPlus.Convert.BurnFlavouredNames as Y_BurnFlavouredNames
import Jikka.CPlusPlus.Convert.FromCore
import qualified Jikka.CPlusPlus.Language.Expr as Y
+import qualified Jikka.CPlusPlus.Language.Util as Y
import Jikka.Common.Alpha
import Jikka.Common.Error
import qualified Jikka.Core.Language.BuiltinPatterns as X
@@ -14,7 +16,9 @@
import Test.Hspec
run' :: X.Program -> Either Error Y.Program
-run' = flip evalAlphaT 0 . run
+run' prog = flip evalAlphaT 0 $ do
+ prog <- run prog
+ Y_BurnFlavouredNames.run prog
spec :: Spec
spec = describe "run" $ do
@@ -34,35 +38,35 @@
let expectedF =
Y.FunDef
Y.TyInt64
- "f_0"
- [(Y.TyInt64, "n_1")]
- [ Y.Declare Y.TyInt64 "x2" Y.DeclareDefault,
+ "f"
+ [(Y.TyInt64, "n")]
+ [ Y.Declare Y.TyInt64 "x" Y.DeclareDefault,
Y.If
- (Y.BinOp Y.Equal (Y.Var "n_1") (Y.Lit (Y.LitInt64 0)))
- [Y.Assign (Y.AssignExpr Y.SimpleAssign (Y.LeftVar "x2") (Y.Lit (Y.LitInt64 1)))]
+ (Y.BinOp Y.Equal (Y.Var "n") (Y.Lit (Y.LitInt64 0)))
+ [Y.Assign (Y.AssignExpr Y.SimpleAssign (Y.LeftVar "x") (Y.Lit (Y.LitInt64 1)))]
( Just
[ Y.Assign
( Y.AssignExpr
Y.SimpleAssign
- (Y.LeftVar "x2")
+ (Y.LeftVar "x")
( Y.BinOp
Y.Mul
- (Y.Var "n_1")
- ( Y.CallExpr
- (Y.Var "f_0")
- [Y.BinOp Y.Sub (Y.Var "n_1") (Y.Lit (Y.LitInt64 1))]
+ (Y.Var "n")
+ ( Y.Call'
+ (Y.Function "f" [])
+ [Y.BinOp Y.Sub (Y.Var "n") (Y.Lit (Y.LitInt64 1))]
)
)
)
]
),
- Y.Return (Y.Var "x2")
+ Y.Return (Y.Var "x")
]
let expectedSolve =
Y.FunDef
Y.TyInt64
"solve"
- [(Y.TyInt64, "a3")]
- [Y.Return (Y.CallExpr (Y.Var "f_0") [Y.Var "a3"])]
+ [(Y.TyInt64, "a")]
+ [Y.Return (Y.Call' (Y.Function "f" []) [Y.Var "a"])]
let expected = Y.Program [expectedF, expectedSolve]
run' prog `shouldBe` Right expected
diff --git a/test/Jikka/CPlusPlus/Convert/MoveSemanticsSpec.hs b/test/Jikka/CPlusPlus/Convert/MoveSemanticsSpec.hs
--- a/test/Jikka/CPlusPlus/Convert/MoveSemanticsSpec.hs
+++ b/test/Jikka/CPlusPlus/Convert/MoveSemanticsSpec.hs
@@ -7,6 +7,7 @@
import Jikka.CPlusPlus.Convert.MoveSemantics
import Jikka.CPlusPlus.Language.Expr
+import Jikka.CPlusPlus.Language.Util
import Jikka.Common.Alpha
import Jikka.Common.Error
import Test.Hspec
@@ -52,10 +53,10 @@
"func"
[(TyVector TyInt32, "a")]
[ Declare (TyVector TyInt32) "b" (DeclareCopy (Var "a")),
- ExprStatement (Call (Method "push_back") [Var "b", Lit (LitInt32 10)]),
+ ExprStatement (Call' (Method "push_back") [Var "b", Lit (LitInt32 10)]),
Declare (TyVector TyInt32) "c" (DeclareCopy (Var "b")),
- ExprStatement (Call (Method "push_back") [Var "b", Lit (LitInt32 10)]),
- Return (BinOp Add (Call MethodSize [Var "b"]) (Call MethodSize [Var "c"]))
+ ExprStatement (Call' (Method "push_back") [Var "b", Lit (LitInt32 10)]),
+ Return (BinOp Add (Call' MethodSize [Var "b"]) (Call' MethodSize [Var "c"]))
]
]
let expected =
@@ -64,10 +65,10 @@
TyInt32
"func"
[(TyVector TyInt32, "a")]
- [ ExprStatement (Call (Method "push_back") [Var "a", Lit (LitInt32 10)]),
+ [ ExprStatement (Call' (Method "push_back") [Var "a", Lit (LitInt32 10)]),
Declare (TyVector TyInt32) "c" (DeclareCopy (Var "a")),
- ExprStatement (Call (Method "push_back") [Var "a", Lit (LitInt32 10)]),
- Return (BinOp Add (Call MethodSize [Var "a"]) (Call MethodSize [Var "c"]))
+ ExprStatement (Call' (Method "push_back") [Var "a", Lit (LitInt32 10)]),
+ Return (BinOp Add (Call' MethodSize [Var "a"]) (Call' MethodSize [Var "c"]))
]
]
run' prog `shouldBe` Right expected
@@ -127,7 +128,7 @@
"func"
[(TyVector TyInt32, "a")]
[ Declare (TyVector TyInt32) "b" (DeclareCopy (Var "a")),
- Assign (AssignExpr AddAssign (LeftAt (LeftVar "b") (Lit (LitInt32 0))) (Call At [Var "a", Lit (LitInt32 1)])),
+ Assign (AssignExpr AddAssign (LeftAt (LeftVar "b") (Lit (LitInt32 0))) (Call' At [Var "a", Lit (LitInt32 1)])),
Assign (AssignExpr SimpleAssign (LeftVar "a") (Var "b")),
Return (Var "a")
]
@@ -138,7 +139,7 @@
(TyVector TyInt32)
"func"
[(TyVector TyInt32, "a")]
- [ Assign (AssignExpr AddAssign (LeftAt (LeftVar "a") (Lit (LitInt32 0))) (Call At [Var "a", Lit (LitInt32 1)])),
+ [ Assign (AssignExpr AddAssign (LeftAt (LeftVar "a") (Lit (LitInt32 0))) (Call' At [Var "a", Lit (LitInt32 1)])),
Return (Var "a")
]
]
diff --git a/test/Jikka/CPlusPlus/Convert/UnpackTuplesSpec.hs b/test/Jikka/CPlusPlus/Convert/UnpackTuplesSpec.hs
--- a/test/Jikka/CPlusPlus/Convert/UnpackTuplesSpec.hs
+++ b/test/Jikka/CPlusPlus/Convert/UnpackTuplesSpec.hs
@@ -5,14 +5,18 @@
)
where
+import qualified Jikka.CPlusPlus.Convert.BurnFlavouredNames as Y_BurnFlavouredNames
import Jikka.CPlusPlus.Convert.UnpackTuples
import Jikka.CPlusPlus.Language.Expr
+import Jikka.CPlusPlus.Language.Util
import Jikka.Common.Alpha
import Jikka.Common.Error
import Test.Hspec
run' :: Program -> Either Error Program
-run' = flip evalAlphaT 0 . run
+run' prog = flip evalAlphaT 0 $ do
+ prog <- run prog
+ Y_BurnFlavouredNames.run prog
spec :: Spec
spec = describe "run" $ do
@@ -23,8 +27,8 @@
TyInt
"func"
[(TyInt, "a")]
- [ Declare (TyTuple [TyInt, TyBool]) "b" (DeclareCopy (Call (StdTuple [TyInt, TyBool]) [Var "a", Lit (LitBool True)])),
- Return (BinOp Add (Call (StdGet 0) [Var "b"]) (Call (StdGet 1) [Var "b"]))
+ [ Declare (TyTuple [TyInt, TyBool]) "b" (DeclareCopy (Call' (StdTuple [TyInt, TyBool]) [Var "a", Lit (LitBool True)])),
+ Return (BinOp Add (Call' (StdGet 0) [Var "b"]) (Call' (StdGet 1) [Var "b"]))
]
]
let expected =
@@ -33,9 +37,9 @@
TyInt
"func"
[(TyInt, "a")]
- [ Declare TyInt "b_0" (DeclareCopy (Var "a")),
- Declare TyBool "b_1" (DeclareCopy (Lit (LitBool True))),
- Return (BinOp Add (Var "b_0") (Var "b_1"))
+ [ Declare TyInt "b" (DeclareCopy (Var "a")),
+ Declare TyBool "b2" (DeclareCopy (Lit (LitBool True))),
+ Return (BinOp Add (Var "b") (Var "b2"))
]
]
run' prog `shouldBe` Right expected
@@ -46,8 +50,8 @@
TyInt32
"func"
[(TyInt32, "a")]
- [ Declare (TyArray TyInt32 3) "b" (DeclareCopy (Call (ArrayExt TyInt32) [Var "a", Lit (LitInt32 10), Lit (LitInt32 15)])),
- Return (BinOp Add (Call At [Var "b", Lit (LitInt32 0)]) (Call At [Var "b", Lit (LitInt32 2)]))
+ [ Declare (TyArray TyInt32 3) "b" (DeclareCopy (Call' (ArrayExt TyInt32) [Var "a", Lit (LitInt32 10), Lit (LitInt32 15)])),
+ Return (BinOp Add (Call' At [Var "b", Lit (LitInt32 0)]) (Call' At [Var "b", Lit (LitInt32 2)]))
]
]
let expected =
@@ -56,10 +60,10 @@
TyInt32
"func"
[(TyInt32, "a")]
- [ Declare TyInt32 "b_0" (DeclareCopy (Var "a")),
- Declare TyInt32 "b_1" (DeclareCopy (Lit (LitInt32 10))),
- Declare TyInt32 "b_2" (DeclareCopy (Lit (LitInt32 15))),
- Return (BinOp Add (Var "b_0") (Var "b_2"))
+ [ Declare TyInt32 "b" (DeclareCopy (Var "a")),
+ Declare TyInt32 "b2" (DeclareCopy (Lit (LitInt32 10))),
+ Declare TyInt32 "b3" (DeclareCopy (Lit (LitInt32 15))),
+ Return (BinOp Add (Var "b") (Var "b3"))
]
]
run' prog `shouldBe` Right expected
diff --git a/test/Jikka/CPlusPlus/FormatSpec.hs b/test/Jikka/CPlusPlus/FormatSpec.hs
--- a/test/Jikka/CPlusPlus/FormatSpec.hs
+++ b/test/Jikka/CPlusPlus/FormatSpec.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module Jikka.CPlusPlus.FormatSpec
( spec,
)
@@ -6,6 +8,7 @@
import Data.List
import Jikka.CPlusPlus.Format
import Jikka.CPlusPlus.Language.Expr
+import Jikka.CPlusPlus.Language.Util
import Test.Hspec
run'' :: Program -> [String]
@@ -19,18 +22,18 @@
Program
[ FunDef
TyInt64
- (VarName "solve")
- [(TyInt32, VarName "n")]
- [ Declare TyInt64 (VarName "x") (DeclareCopy (Lit (LitInt64 0))),
+ "solve"
+ [(TyInt32, "n")]
+ [ Declare TyInt64 "x" (DeclareCopy (Lit (LitInt64 0))),
For
TyInt32
- (VarName "i")
+ "i"
(Lit (LitInt32 0))
- (BinOp LessThan (Var (VarName "i")) (Var (VarName "n")))
- (AssignIncr (LeftVar (VarName "i")))
- [ Assign (AssignExpr AddAssign (LeftVar (VarName "x")) (Call (Cast TyInt64) [Var (VarName "i")]))
+ (BinOp LessThan (Var "i") (Var "n"))
+ (AssignIncr (LeftVar "i"))
+ [ Assign (AssignExpr AddAssign (LeftVar "x") (Call' (Cast TyInt64) [Var "i"]))
],
- Return (Var (VarName "x"))
+ Return (Var "x")
]
]
let formatted =
@@ -49,18 +52,18 @@
Program
[ FunDef
TyInt64
- (VarName "solve")
- [(TyInt32, VarName "n"), (TyVector TyInt64, VarName "h")]
- [ Declare TyInt64 (VarName "x") (DeclareCopy (Lit (LitInt64 0))),
+ "solve"
+ [(TyInt32, "n"), (TyVector TyInt64, "h")]
+ [ Declare TyInt64 "x" (DeclareCopy (Lit (LitInt64 0))),
For
TyInt32
- (VarName "i")
+ "i"
(Lit (LitInt32 2))
- (BinOp LessThan (Var (VarName "i")) (Var (VarName "n")))
- (AssignIncr (LeftVar (VarName "i")))
- [ Assign (AssignExpr AddAssign (LeftVar (VarName "x")) (Call At [Var (VarName "h"), BinOp Sub (Var (VarName "i")) (Lit (LitInt32 2))]))
+ (BinOp LessThan (Var "i") (Var "n"))
+ (AssignIncr (LeftVar "i"))
+ [ Assign (AssignExpr AddAssign (LeftVar "x") (Call' At [Var "h", BinOp Sub (Var "i") (Lit (LitInt32 2))]))
],
- Return (Var (VarName "x"))
+ Return (Var "x")
]
]
let formatted =
diff --git a/test/Jikka/Core/Convert/EtaSpec.hs b/test/Jikka/Core/Convert/EtaSpec.hs
--- a/test/Jikka/Core/Convert/EtaSpec.hs
+++ b/test/Jikka/Core/Convert/EtaSpec.hs
@@ -8,30 +8,40 @@
import Jikka.Common.Alpha
import Jikka.Common.Error
import Jikka.Core.Convert.Eta (run)
-import Jikka.Core.Language.BuiltinPatterns
+import qualified Jikka.Core.Convert.TypeInfer as TypeInfer
import Jikka.Core.Language.Expr
+import Jikka.Core.Parse (parseProgram)
import Test.Hspec
run' :: Program -> Either Error Program
run' = flip evalAlphaT 0 . run
+parseProgram' :: [String] -> Program
+parseProgram' = fromSuccess . flip evalAlphaT 100 . (TypeInfer.run <=< parseProgram . unlines)
+
spec :: Spec
spec = describe "run" $ do
- it "works" $ do
+ it "works on a let" $ do
let prog =
- ResultExpr
- ( Let
- "plus"
- (FunTy IntTy (FunTy IntTy IntTy))
- (Builtin Plus)
- (Var "plus")
- )
+ parseProgram'
+ [ "fun (n: int) ->",
+ " let f = sum",
+ " in f"
+ ]
let expected =
- ResultExpr
- ( Let
- "plus"
- (FunTy IntTy (FunTy IntTy IntTy))
- (Lam "$0" IntTy (Lam "$1" IntTy (Plus' (Var "$0") (Var "$1"))))
- (Var "plus")
- )
+ parseProgram'
+ [ "fun (n: int) ->",
+ " let f = fun $0 -> sum $0",
+ " in f"
+ ]
+ run' prog `shouldBe` Right expected
+ it "works in map" $ do
+ let prog =
+ parseProgram'
+ [ "map sum nil"
+ ]
+ let expected =
+ parseProgram'
+ [ "map (fun $0 -> sum $0) nil"
+ ]
run' prog `shouldBe` Right expected
diff --git a/test/Jikka/Core/Convert/TypeInferSpec.hs b/test/Jikka/Core/Convert/TypeInferSpec.hs
--- a/test/Jikka/Core/Convert/TypeInferSpec.hs
+++ b/test/Jikka/Core/Convert/TypeInferSpec.hs
@@ -8,8 +8,8 @@
import Jikka.Common.Alpha
import Jikka.Common.Error
import Jikka.Core.Convert.TypeInfer (run, runExpr)
-import Jikka.Core.Language.BuiltinPatterns
import Jikka.Core.Language.Expr
+import Jikka.Core.Parse (parseExpr, parseProgram)
import Test.Hspec
run' :: Program -> Either Error Program
@@ -18,105 +18,93 @@
runExpr' :: [(VarName, Type)] -> Expr -> Either Error Expr
runExpr' env = flip evalAlphaT 0 . runExpr env
+parseExpr' :: [String] -> Expr
+parseExpr' = fromSuccess . flip evalAlphaT 100 . parseExpr . unlines
+
+parseProgram' :: [String] -> Program
+parseProgram' = fromSuccess . flip evalAlphaT 100 . parseProgram . unlines
+
spec :: Spec
spec = do
describe "run" $ do
it "works" $ do
let prog =
- ResultExpr
- ( Let
- "x"
- (VarTy "t1")
- Lit0
- ( Let
- "y"
- (VarTy "t2")
- (Plus' (Var "x") Lit1)
- (Var "y")
- )
- )
+ parseProgram'
+ [ "let x: t1 = 0",
+ "in let y: t2 = x + 1",
+ "in y"
+ ]
let expected =
- ResultExpr
- ( Let
- "x"
- IntTy
- Lit0
- ( Let
- "y"
- IntTy
- (Plus' (Var "x") Lit1)
- (Var "y")
- )
- )
+ parseProgram'
+ [ "let x: int = 0",
+ "in let y: int = x + 1",
+ "in y"
+ ]
run' prog `shouldBe` Right expected
it "works on let-rec" $ do
let prog =
- ToplevelLetRec
- "f"
- [("x", VarTy "t1")]
- (VarTy "t2")
- (Var "x")
- (ResultExpr (App (Var "f") Lit0))
+ parseProgram'
+ [ "let rec f (x: t1): t2 = x",
+ "in f 0"
+ ]
let expected =
- ToplevelLetRec
- "f"
- [("x", IntTy)]
- IntTy
- (Var "x")
- (ResultExpr (App (Var "f") Lit0))
+ parseProgram'
+ [ "let rec f (x: int): int = x",
+ "in f 0"
+ ]
run' prog `shouldBe` Right expected
it "replaces undetermined types with 0-tuples" $ do
let prog =
- ToplevelLetRec
- "f"
- [("x", VarTy "t1")]
- (VarTy "t2")
- (Var "x")
- (ResultExpr Lit0)
+ parseProgram'
+ [ "let rec f (x: t1): t2 = x",
+ "in 0"
+ ]
let expected =
- ToplevelLetRec
- "f"
- [("x", TupleTy [])]
- (TupleTy [])
- (Var "x")
- (ResultExpr Lit0)
+ parseProgram'
+ [ "let rec f (x: unit): unit = x",
+ "in 0"
+ ]
run' prog `shouldBe` Right expected
it "works on builtin functions" $ do
let prog =
- ToplevelLetRec
- "solve"
- [("n", IntTy)]
- IntTy
- ( If'
- (VarTy "$0")
- (Equal' IntTy (Var "n") Lit0)
- Lit1
- ( Mult'
- (Var "n")
- (App (Var "solve") (Minus' (Var "n") Lit1))
- )
- )
- (ResultExpr (Var "solve"))
+ parseProgram'
+ [ "let rec solve (n: t0): t1 =",
+ " if@t2 n ==@t3 0",
+ " then 1",
+ " else n * solve (n - 1)",
+ "in solve"
+ ]
let expected =
- ToplevelLetRec
- "solve"
- [("n", IntTy)]
- IntTy
- ( If'
- IntTy
- (Equal' IntTy (Var "n") Lit0)
- Lit1
- ( Mult'
- (Var "n")
- (App (Var "solve") (Minus' (Var "n") Lit1))
- )
- )
- (ResultExpr (Var "solve"))
+ parseProgram'
+ [ "let rec solve (n: int): int =",
+ " if@int n ==@int 0",
+ " then 1",
+ " else n * solve (n - 1)",
+ "in solve"
+ ]
run' prog `shouldBe` Right expected
describe "runExpr" $ do
- it "works" $ do
- let e = Equal' (VarTy "t1") (Var "xs") (Nil' (VarTy "t2"))
- let env = [("xs", ListTy IntTy)]
- let expected = Equal' (ListTy IntTy) (Var "xs") (Nil' IntTy)
+ it "works on an equation" $ do
+ let env = [("xs", ListTy BoolTy)]
+ let e =
+ parseExpr'
+ [ "xs ==@t1 nil@t2"
+ ]
+ let expected =
+ parseExpr'
+ [ "xs ==@(bool list) nil@bool"
+ ]
+ runExpr' env e `shouldBe` Right expected
+
+ it "works on lambdas and applications" $ do
+ let env = [("f", Fun3Ty IntTy BoolTy UnitTy (ListTy IntTy))]
+ let e =
+ parseExpr'
+ [ "fun x y z -> f x y z"
+ ]
+ let expected =
+ parseExpr'
+ [ "fun (x: int) (y: bool) (z: unit) -> f x y z"
+ ]
runExpr' env e `shouldBe` Right expected
diff --git a/test/Jikka/Core/Language/EtaSpec.hs b/test/Jikka/Core/Language/EtaSpec.hs
new file mode 100644
--- /dev/null
+++ b/test/Jikka/Core/Language/EtaSpec.hs
@@ -0,0 +1,110 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Jikka.Core.Language.EtaSpec
+ ( spec,
+ )
+where
+
+import Jikka.Common.Alpha
+import Jikka.Common.Error
+import qualified Jikka.Core.Convert.TypeInfer as TypeInfer
+import Jikka.Core.Language.Eta
+import Jikka.Core.Language.Expr
+import Jikka.Core.Parse (parseExpr)
+import Test.Hspec
+
+etaExpand'' :: [(VarName, Type)] -> Expr -> Either Error (Maybe Expr)
+etaExpand'' env = flip evalAlphaT 0 . etaExpand' env
+
+parseExpr' :: [(VarName, Type)] -> [String] -> Expr
+parseExpr' env = fromSuccess . flip evalAlphaT 100 . (TypeInfer.runExpr env <=< parseExpr . unlines)
+
+spec :: Spec
+spec = do
+ describe "etaExpand'" $ do
+ it "works on sum" $ do
+ let env = []
+ let e =
+ parseExpr'
+ env
+ [ "sum"
+ ]
+ let expected =
+ parseExpr'
+ env
+ [ "fun $0 -> sum $0"
+ ]
+ etaExpand'' env e `shouldBe` Right (Just expected)
+ it "works on let" $ do
+ let env = []
+ let e =
+ parseExpr'
+ env
+ [ "let f = fun x y -> x + y",
+ "in f"
+ ]
+ let expected =
+ parseExpr'
+ env
+ [ "fun $0 $1 ->",
+ " (let f = fun x y -> x + y",
+ " in f) $0 $1"
+ ]
+ etaExpand'' env e `shouldBe` Right (Just expected)
+ it "works on a partial lambda" $ do
+ let env = [("f", Fun3Ty IntTy BoolTy UnitTy (ListTy IntTy))]
+ let e =
+ parseExpr'
+ env
+ [ "fun (x: int) -> f x"
+ ]
+ let expected =
+ parseExpr'
+ env
+ [ "fun (x: int) ($0: bool) ($1: unit) -> f x $0 $1"
+ ]
+ etaExpand'' env e `shouldBe` Right (Just expected)
+ it "does nothing on integers" $ do
+ let env = []
+ let e =
+ parseExpr'
+ env
+ [ "12"
+ ]
+ etaExpand'' env e `shouldBe` Right Nothing
+
+ describe "etaReduce'" $ do
+ it "works on sum" $ do
+ let env = []
+ let e =
+ parseExpr'
+ env
+ [ "fun $0 -> sum $0"
+ ]
+ let expected =
+ parseExpr'
+ env
+ [ "sum"
+ ]
+ etaReduce' e `shouldBe` Just expected
+ it "works on an application which is longer than lambda abstraction" $ do
+ let env = [("f", Fun3STy IntTy)]
+ let e =
+ parseExpr'
+ env
+ [ "fun x y -> f 12 x y"
+ ]
+ let expected =
+ parseExpr'
+ env
+ [ "f 12"
+ ]
+ etaReduce' e `shouldBe` Just expected
+ it "does nothing on a flipped application" $ do
+ let env = [("f", Fun2STy IntTy)]
+ let e =
+ parseExpr'
+ env
+ [ "fun x y -> f y x"
+ ]
+ etaReduce' e `shouldBe` Nothing