├── .gitignore ├── CHANGELOG.md ├── README.md ├── app └── Main.hs ├── flake.lock ├── flake.nix ├── psel.cabal ├── src └── PsEl │ ├── CommandBuild.hs │ ├── CommandRun.hs │ ├── ForeignTemplate.hs │ ├── PselEl.hs │ ├── SExp.hs │ ├── SExpConstructor.hs │ ├── SExpDisplay.hs │ ├── SExpOptimize.hs │ ├── SExpPattern.hs │ ├── SExpRaw.hs │ ├── SExpTraverse.hs │ └── Transpile.hs ├── test-bare.purs ├── .gitignore ├── packages.dhall ├── spago.dhall └── test │ ├── Main.el │ ├── Main.js │ ├── Main.purs │ ├── PsEl │ ├── Record.purs │ └── TCO.purs │ ├── Utils.el │ ├── Utils.js │ └── Utils.purs └── test-lib.purs ├── .gitignore ├── spago.dhall └── test ├── Main.el └── Main.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | /result -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for psel 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # psel: Elisp(Emacs Lisp) backend for PureScript 2 | 3 | WIP 4 | 5 | ## Motivation 6 | 7 | Elisp is powerful and flexible, but when it comes to complex logic code, some might prefer strongly typed language. 8 | Since it is possible to call PS functions from elisp, it is possible to write partially in PS. 9 | Also, you can reuse PureScript libraries as long as they do not depend on JS/browser specific libraries. 10 | 11 | ## Installation 12 | 13 | Currently, there is no release yet. To install `psel` command, you can build from source or use nix to install. 14 | 15 | ### Build from source 16 | 17 | Requires `cabal-install` and `GHC` 8.10.7. 18 | 19 | git clone git@github.com:psel-org/psel.git 20 | cd psel 21 | cabal install 22 | 23 | ### Install using Nix(flake.nix) 24 | 25 | Requires `nix` >= 2.4. 26 | 27 | nix profile install github:psel-org/psel 28 | 29 | ## Usage 30 | 31 | Psel is intended to use through Spago. Set `backend = "psel"` in your `spago.dhall` file. 32 | There is no package-set release yet. You can use WIP package-set `https://raw.githubusercontent.com/psel-org/package-sets/main/src/el-0.14.5-20211116/packages.dhall` for now. 33 | 34 | ```dhall 35 | { name = "your-project-name" 36 | , dependencies = [ "prelude" ] 37 | , packages = https://raw.githubusercontent.com/psel-org/package-sets/main/src/el-0.14.5-20211116/packages.dhall 38 | , backend = "psel" 39 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 40 | } 41 | ``` 42 | 43 | `spago build` will output all .el files under `output.el` directory. To require from emacs, add this path to `load-path` variable. 44 | 45 | ## Module and Top-level bindings 46 | 47 | `Data.Foo` module will be transpiled to `Data.Foo.el`. 48 | Top-level binding `fooBar` in `Data.Foo` module will be transpiled to `(defvar Data.Foo.fooBar ...)`. 49 | 50 | ## Type 51 | 52 | Purescript | Elisp 53 | -----------|------ 54 | Int | Integer 55 | Double | Double 56 | String | String 57 | Array | Vector 58 | Char | Integer(elisp doen't have char type) 59 | Boolean | True -> `t`, False -> `nil` (elisp doesn't have boolean type) 60 | Records | alist (e.g. `(('foo . 1) ('bar . "a"))`) 61 | Unit | nil 62 | Data types | Vector with constructor tag symbol in first slot and arguments in the remaining slots. Constructor with no argument will be represented by tag symbol only.
e.g. `Just 42` -> `['Just 42]`
e.g. `Nothing` -> `'Nothing` 63 | Tuple | `Tuple a b` -> `(cons a b)` 64 | List | `Cons 1 (Cons 2 Nil))` -> `(list 1 2)` 65 | 66 | ## Optimization 67 | 68 | ### TCO(Tail-Call Optimization) 69 | 70 | Currently, TCO is only applied to certain forms of self-recursion functions. 71 | TCO will convert these self-resursive calls to `while` s-exp expression. 72 | 73 | ### MagicDo 74 | 75 | Implemented only for `Effect` monad. 76 | `ST` monad remains unoptimized. Also `whileE` and `forE` combinator of `Effect` monad is also untouched. 77 | 78 | ### Uncurried types 79 | 80 | Not done yet. 81 | 82 | `Data.Function.Uncurried(funcitons package)` and `Effect.Uncurried(effects pacakge)` 83 | 84 | ## TODO 85 | 86 | * [x] Support FFI 87 | * [x] Prelude fork 88 | * [x] Make an github orgiznation 89 | * [x] Make psel command spago friendly 90 | * [x] Create package-set 91 | * [x] Implement TCO 92 | * [x] Implement MagicDo 93 | * [ ] Support core libraries([WIP](https://github.com/psel-org/package-sets)) 94 | * [ ] Minimal example and add Usage document 95 | * [ ] purescript-emacs 96 | * [ ] Support contrib libraries 97 | * [x] Write some tests 98 | * [x] Add flake.nix 99 | * [ ] Setup CI 100 | 101 | ## References 102 | 103 | Learned how to write a CoreFn-type PureScript backend from [purenix](https://github.com/purenix-org/purenix) and [purerl](https://github.com/purerl/purerl). 104 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Main where 7 | 8 | import Options.Generic (ParseRecord (parseRecord), getRecord, lispCaseModifiers, parseRecordWithModifiers) 9 | import PsEl.CommandBuild qualified as CommandBuild 10 | import PsEl.CommandRun qualified as CommandRun 11 | import RIO 12 | import System.Environment (getArgs) 13 | 14 | data Option = Option 15 | { generateMissingFfi :: Bool 16 | , run :: Maybe Text 17 | } 18 | deriving (Generic, Show) 19 | 20 | instance ParseRecord Option where 21 | parseRecord = parseRecordWithModifiers lispCaseModifiers 22 | 23 | -- spagoは一つのコマンドで複数回バックエンドコマンドを起動する 24 | -- 例えばspago test はビルドを意味する無引数で実行した後, 25 | -- --run Test.Main.main コマンドでテストを実行する。 26 | -- ["--run","Test.Main.main"] 27 | main :: IO () 28 | main = do 29 | Option{generateMissingFfi, run} <- getRecord "psel" 30 | runSimpleApp $ do 31 | case run of 32 | Just mainFunc -> do 33 | CommandRun.run mainFunc 34 | Nothing -> do 35 | let config = 36 | CommandBuild.defaultConfig 37 | { CommandBuild.generateMissingFfi = generateMissingFfi 38 | } 39 | liftIO $ CommandBuild.build config 40 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1638122382, 6 | "narHash": "sha256-sQzZzAbvKEqN9s0bzWuYmRaA03v40gaJ4+iL1LXjaeI=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "74f7e4319258e287b0f9cb95426c9853b282730b", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1639320937, 21 | "narHash": "sha256-T/phSkh/rsnRpihiiUSa3QcoOGE9kKgFjA2tcZ2dm58=", 22 | "owner": "NixOS", 23 | "repo": "nixpkgs", 24 | "rev": "b243326a0280807950e554821532929a07dbfd54", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "NixOS", 29 | "repo": "nixpkgs", 30 | "type": "github" 31 | } 32 | }, 33 | "root": { 34 | "inputs": { 35 | "flake-utils": "flake-utils", 36 | "nixpkgs": "nixpkgs" 37 | } 38 | } 39 | }, 40 | "root": "root", 41 | "version": 7 42 | } 43 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2021 Serokell 2 | # 3 | # SPDX-License-Identifier: CC0-1.0 4 | 5 | { 6 | description = "psel"; 7 | 8 | inputs = { 9 | nixpkgs.url = "github:NixOS/nixpkgs"; 10 | flake-utils.url = "github:numtide/flake-utils"; 11 | }; 12 | 13 | outputs = { self, nixpkgs, flake-utils }: 14 | flake-utils.lib.eachDefaultSystem (system: 15 | let 16 | pkgs = nixpkgs.legacyPackages.${system}; 17 | 18 | haskellPackages = pkgs.haskell.packages.ghc8107; 19 | 20 | jailbreakUnbreak = pkg: 21 | pkgs.haskell.lib.doJailbreak (pkg.overrideAttrs (_: { meta = { }; })); 22 | 23 | packageName = "psel"; 24 | in { 25 | packages.${packageName} = 26 | haskellPackages.callCabal2nix packageName self rec { 27 | # Dependency overrides go here 28 | }; 29 | 30 | defaultPackage = self.packages.${system}.${packageName}; 31 | 32 | devShell = pkgs.mkShell { 33 | buildInputs = []; 34 | inputsFrom = builtins.attrValues self.packages.${system}; 35 | }; 36 | }); 37 | } 38 | -------------------------------------------------------------------------------- /psel.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: psel 3 | version: 0.1.0.0 4 | 5 | -- A short (one-line) description of the package. 6 | -- synopsis: 7 | 8 | -- A longer description of the package. 9 | -- description: 10 | 11 | -- A URL where users can report bugs. 12 | -- bug-reports: 13 | 14 | -- The license under which the package is released. 15 | -- license: 16 | author: kamoii 17 | maintainer: kamoii 18 | 19 | -- A copyright notice. 20 | -- copyright: 21 | -- category: 22 | extra-source-files: 23 | CHANGELOG.md 24 | README.md 25 | 26 | library 27 | exposed-modules: 28 | PsEl.CommandBuild 29 | PsEl.CommandRun 30 | PsEl.ForeignTemplate 31 | PsEl.PselEl 32 | PsEl.SExp 33 | PsEl.SExpConstructor 34 | PsEl.SExpDisplay 35 | PsEl.SExpOptimize 36 | PsEl.SExpPattern 37 | PsEl.SExpRaw 38 | PsEl.SExpTraverse 39 | PsEl.Transpile 40 | 41 | -- Modules included in this library but not exported. 42 | other-modules: 43 | 44 | -- LANGUAGE extensions used by modules in this package. 45 | -- other-extensions: 46 | build-depends: 47 | , aeson 48 | , base ^>=4.14.3.0 49 | , generic-lens 50 | , lens 51 | , neat-interpolation 52 | , purescript ^>=0.14.4 53 | , purescript-cst 54 | , recursion-schemes 55 | , reflection 56 | , regex 57 | , rio 58 | 59 | hs-source-dirs: src 60 | default-language: Haskell2010 61 | default-extensions: 62 | NoImplicitPrelude 63 | ImportQualifiedPost 64 | 65 | executable psel 66 | main-is: Main.hs 67 | 68 | -- Modules included in this executable, other than Main. 69 | -- other-modules: 70 | 71 | -- LANGUAGE extensions used by modules in this package. 72 | -- other-extensions: 73 | build-depends: 74 | , base ^>=4.14.3.0 75 | , optparse-applicative 76 | , optparse-generic 77 | , psel 78 | , rio 79 | 80 | hs-source-dirs: app 81 | default-language: Haskell2010 82 | default-extensions: 83 | NoImplicitPrelude 84 | ImportQualifiedPost 85 | -------------------------------------------------------------------------------- /src/PsEl/CommandBuild.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | 6 | module PsEl.CommandBuild ( 7 | build, 8 | Config (..), 9 | defaultConfig, 10 | ) where 11 | 12 | import Data.Aeson qualified as Aeson 13 | import Data.Aeson.Types (parseEither) 14 | import Language.PureScript (ModuleName (ModuleName)) 15 | import Language.PureScript.CoreFn qualified as P 16 | import Language.PureScript.CoreFn.FromJSON (moduleFromJSON) 17 | import PsEl.ForeignTemplate (foreignTemplate) 18 | import PsEl.PselEl (pselEl) 19 | import PsEl.SExp (Feature (..), Symbol, featureFileName) 20 | import PsEl.SExpOptimize (optimize) 21 | import PsEl.SExpDisplay (displayFeature, displayString) 22 | import PsEl.Transpile (ffiFeatureSuffix, pselFeature, transpile) 23 | import RIO 24 | import RIO.Directory qualified as Dir 25 | import RIO.FilePath (()) 26 | import RIO.FilePath qualified as FP 27 | import RIO.List (intersperse, sort) 28 | import RIO.Text (justifyLeft, pack, unpack) 29 | import RIO.Text qualified as T 30 | import System.Exit qualified as Sys 31 | import System.IO (hPutStrLn, putStrLn) 32 | 33 | build :: Config -> IO () 34 | build Config{generateMissingFfi} = do 35 | let workdir = "." 36 | let moduleRoot = workdir "output" 37 | let elispRoot = workdir "output.el" 38 | whenM (Dir.doesDirectoryExist elispRoot) $ Dir.removeDirectoryRecursive elispRoot 39 | Dir.createDirectory elispRoot 40 | writeFileUtf8 (elispRoot featureFileName pselFeature) (pselEl pselFeature) 41 | moduleDirs <- filter (/= "cache-db.json") <$> Dir.listDirectory moduleRoot 42 | warngings' <- forM moduleDirs $ \rel -> do 43 | let coreFnPath = moduleRoot rel "corefn.json" 44 | value <- Aeson.eitherDecodeFileStrict coreFnPath >>= either Sys.die pure 45 | (_version, module') <- either Sys.die pure $ parseEither moduleFromJSON value 46 | handleModule elispRoot module' 47 | let warnings = mconcat warngings' 48 | printWarnings warnings 49 | when generateMissingFfi 50 | . doGenerateMissingForeignFiles 51 | . snd 52 | $ partitionEithers warnings 53 | 54 | data Config = Config 55 | { generateMissingFfi :: Bool 56 | } 57 | 58 | defaultConfig :: Config 59 | defaultConfig = 60 | Config 61 | { generateMissingFfi = False 62 | } 63 | 64 | -- (1) 65 | -- ForeignFileが(provide)を行なっている場合警告を出す必要があるかも。 66 | -- また必要なFFI定義を 67 | handleModule :: FilePath -> P.Module P.Ann -> IO [Warning] 68 | handleModule elispRoot module'@P.Module{P.moduleName, P.modulePath} = do 69 | let feature = optimize $ transpile module' 70 | let Feature{name, requireFFI} = feature 71 | let targetPath = elispRoot featureFileName name 72 | let foreignSourcePath = FP.replaceExtension modulePath "el" 73 | writeFileUtf8Builder targetPath (displayFeature feature) 74 | hasForeignSource <- Dir.doesFileExist foreignSourcePath 75 | case (hasForeignSource, requireFFI) of 76 | (True, Just (ffiName, _foreignSymbols)) -> do 77 | let foreignTargetPath = elispRoot featureFileName ffiName 78 | Dir.copyFile foreignSourcePath foreignTargetPath -- (1) 79 | pure [] 80 | (True, Nothing) -> 81 | pure [Left UnneededFFIFileWarning{moduleName, modulePath}] 82 | (False, Just (ffiName, foreignSymbols)) -> do 83 | pure 84 | [ Right 85 | MissingFFIFileWarning 86 | { moduleName 87 | , modulePath 88 | , foreignSourcePath 89 | , foreignSymbols 90 | } 91 | ] 92 | (False, Nothing) -> 93 | pure [] 94 | 95 | -- PSコンパイラはpackage-awareではない。そのため当然corefnにはモジュールがどのパッ 96 | -- ケージのどのバージョンのものかの情報は含まれていない。ただspago使っている場合, 97 | -- PSのソースコードのパスでパッケージ名は推測できる。 98 | -- 99 | -- 例えばspagoでpreludeをコンパイルした場合,Data.Eqモジュールは次のmodulePathを持つ。 100 | -- 101 | -- e.g. "modulePath":".spago/prelude/master/src/Data/Eq.purs" 102 | -- 103 | guessPackageByModulePath :: FilePath -> Maybe Text 104 | guessPackageByModulePath path = do 105 | path' <- T.stripPrefix ".spago/" (pack path) 106 | let pkg = T.takeWhile (/= '/') path' 107 | guard $ not (T.null pkg) 108 | pure pkg 109 | 110 | -- 依存ではなく現在のパッケージの 111 | guessIsCurrentPackageByModulePath :: FilePath -> Bool 112 | guessIsCurrentPackageByModulePath path = 113 | let path' = pack path 114 | in T.isPrefixOf "src/" path' || T.isPrefixOf "test/" path' 115 | 116 | printWarnings :: [Warning] -> IO () 117 | printWarnings warnings = do 118 | let (unneeds, missings) = partitionEithers warnings 119 | unless (null unneeds) $ putStderrLn $ displayUnneedWarngins unneeds 120 | unless (null missings) $ putStderrLn $ displayMissingWarngins missings 121 | 122 | displayUnneedWarngins :: [UnneededFFIFileWarning] -> Utf8Builder 123 | displayUnneedWarngins [] = 124 | mempty 125 | displayUnneedWarngins warnings = 126 | mconcat 127 | . intersperse "\n" 128 | $ mconcat [header, [""], modules, [""]] 129 | where 130 | header = 131 | [ "!!! WARNING !!!" 132 | , "These modules contains FFI file but does not use any FFI." 133 | , "These FFI files are ignored, so no worry, but this could be smell of a bug." 134 | ] 135 | 136 | modules = map display' warnings 137 | 138 | display' UnneededFFIFileWarning{moduleName = ModuleName mn} = 139 | display mn 140 | 141 | displayMissingWarngins :: [MissingFFIFileWarning] -> Utf8Builder 142 | displayMissingWarngins [] = 143 | mempty 144 | displayMissingWarngins warnings = 145 | mconcat 146 | . intersperse "\n" 147 | $ mconcat [header, [""], modules, [""]] 148 | where 149 | header = 150 | [ "!!! WARNING !!!" 151 | , "These modules uses FFI but missing corresponding FFI file." 152 | , "If you require these module it will fail try requrieing its FFI file." 153 | ] 154 | 155 | modules = 156 | map display $ sort $ map displayText' warnings 157 | 158 | displayText' MissingFFIFileWarning{moduleName = ModuleName mn, modulePath} = 159 | displayColumns 160 | 24 161 | [ "Package: " <> fromMaybe "--" (guessPackageByModulePath modulePath) 162 | , "Module: " <> mn 163 | ] 164 | 165 | -- 166 | doGenerateMissingForeignFiles :: [MissingFFIFileWarning] -> IO () 167 | doGenerateMissingForeignFiles ws = 168 | go $ 169 | filter 170 | ( \MissingFFIFileWarning{modulePath} -> 171 | guessIsCurrentPackageByModulePath modulePath 172 | ) 173 | ws 174 | where 175 | go [] = 176 | putStdoutLn "No missing foreign file." 177 | go ws = do 178 | putStdoutLn "Generating missing foreign files.\n" 179 | forM_ ws $ \MissingFFIFileWarning{foreignSourcePath, foreignSymbols} -> do 180 | let template = foreignTemplate foreignSymbols 181 | writeFileUtf8Builder foreignSourcePath template 182 | putStdoutLn $ display (pack foreignSourcePath) 183 | putStdoutLn "\nNote: You don't need to provide feature(e.g. (provide 'Data.Eq)) in a foreign file." 184 | putStdoutLn "Foreign files will be copied with a diffirent file name." 185 | 186 | putStderrLn :: Utf8Builder -> IO () 187 | putStderrLn ub = hPutBuilder stderr . getUtf8Builder $ ub <> "\n" 188 | 189 | putStdoutLn :: Utf8Builder -> IO () 190 | putStdoutLn ub = hPutBuilder stdout . getUtf8Builder $ ub <> "\n" 191 | 192 | displayColumns :: Int -> [Text] -> Text 193 | displayColumns _ [] = mempty 194 | displayColumns width vs = 195 | mconcat $ mapBut1 (justifyLeft width ' ' . (<> ",")) vs 196 | where 197 | mapBut1 :: (a -> a) -> [a] -> [a] 198 | mapBut1 f [] = [] 199 | mapBut1 f [x] = [x] 200 | mapBut1 f (x : xs) = f x : mapBut1 f xs 201 | 202 | type Warning = 203 | Either UnneededFFIFileWarning MissingFFIFileWarning 204 | 205 | data UnneededFFIFileWarning = UnneededFFIFileWarning 206 | { moduleName :: ModuleName 207 | , modulePath :: FilePath 208 | } 209 | 210 | data MissingFFIFileWarning = MissingFFIFileWarning 211 | { moduleName :: ModuleName 212 | , modulePath :: FilePath 213 | , foreignSourcePath :: FilePath 214 | , foreignSymbols :: [Symbol] 215 | } 216 | -------------------------------------------------------------------------------- /src/PsEl/CommandRun.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module PsEl.CommandRun (run) where 5 | 6 | import Data.Coerce (Coercible, coerce) 7 | import Language.PureScript.CST (ParserState (ParserState), lex, parseQualIdentP, runParser) 8 | import Language.PureScript.CST.Types (Ident (getIdent), QualifiedName (QualifiedName, qualModule, qualName)) 9 | import Language.PureScript.Names (Ident (Ident)) 10 | import PsEl.SExp (funcall0, symbol) 11 | import PsEl.SExpConstructor qualified as C 12 | import PsEl.SExpDisplay (displaySExp) 13 | import PsEl.Transpile qualified as Trp 14 | import RIO 15 | import RIO.Lens (_1, _2) 16 | import RIO.Process (HasProcessContext (processContextL), ProcessContext, mkDefaultProcessContext, proc, runProcess_) 17 | import RIO.Text (unpack) 18 | 19 | -- parseQualIdentP :: Parser (QualifiedName Ident) を 20 | -- e.g. mainFunc = Test.Main.main 21 | -- emacsに渡す引数は次のようになる。 22 | -- 23 | -- emacs --batch --directory output.el --eval "(require 'Test.Main)" --eval "(funcall Test.Main.main)" 24 | -- 25 | -- デバッグしたい場合は --funcall toggle-debug-on-error を --evalの前に入れれば良い 26 | run :: HasLogFunc env => Text -> RIO env () 27 | run mainFunc = do 28 | pc <- mkDefaultProcessContext 29 | env <- ask 30 | runRIO (pc, env) $ do 31 | case snd (parseMainFunc mainFunc) of 32 | Right QualifiedName{qualModule = Just mn, qualName = ident} -> do 33 | let featureName = Trp.featureName mn 34 | let mainFuncSym = symbol $ Trp.globalVar mn (Ident (getIdent ident)) 35 | let args = 36 | mconcat 37 | [ ["--batch"] 38 | , ["--directory", "output.el"] 39 | , ["--eval", showSExp $ C.require featureName] 40 | , ["--eval", showSExp $ funcall0 mainFuncSym] 41 | ] 42 | proc "emacs" args runProcess_ 43 | Right _ -> 44 | logError "Unexpected" 45 | Left ne -> 46 | logError "Unexpected" 47 | where 48 | parseMainFunc t = 49 | runParser (ParserState (lex t) [] []) parseQualIdentP 50 | 51 | showSExp = 52 | unpack . utf8BuilderToText . displaySExp 53 | 54 | -- newtype Ctx e = Ctx (ProcessContext, e) 55 | -- orphan intance にはならない??? 56 | 57 | instance HasProcessContext (ProcessContext, e) where 58 | processContextL = _1 59 | 60 | instance HasLogFunc e => HasLogFunc (a, e) where 61 | logFuncL = _2 . logFuncL 62 | -------------------------------------------------------------------------------- /src/PsEl/ForeignTemplate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module PsEl.ForeignTemplate where 4 | 5 | import PsEl.SExp (DefVar (DefVar, definition, name), SExp (SExp), Symbol, symbol) 6 | import PsEl.SExpDisplay qualified as Display 7 | import RIO 8 | import RIO.List (intersperse) 9 | 10 | -- 必要なforeign識別子からFFIファイルのテンプレートを作成。 11 | foreignTemplate :: [Symbol] -> Utf8Builder 12 | foreignTemplate symbols = 13 | mconcat . intersperse "\n\n" $ 14 | mconcat 15 | [ headLines 16 | , defVarLines 17 | ] 18 | where 19 | headLines = 20 | [ ";; -*- lexical-binding: t; -*-" 21 | ] 22 | 23 | defVarLines = 24 | map Display.displayDefVar templateDefVars 25 | 26 | templateDefVars = 27 | map (\s -> DefVar{name = s, definition = placehold}) symbols 28 | 29 | -- わざと束縛されていないシンボルを使うことでrequire時に実装漏れで例外投げるように 30 | placehold = 31 | symbol "foreign-not-implemeneted" 32 | -------------------------------------------------------------------------------- /src/PsEl/PselEl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module PsEl.PselEl where 4 | 5 | import NeatInterpolation (trimming) 6 | import PsEl.SExp (FeatureName (FeatureName)) 7 | import PsEl.SExpDisplay (displaySymbol) 8 | import RIO 9 | 10 | -- 生成するelで足りない関数を定義。全てのモジュールelよりrequireされる必要あり。 11 | -- emacs標準で同等機能が提供されている場合は乗り換える。 12 | -- psel/alist-set はオブジェクト更新時に使う。 13 | -- 14 | -- ???複数の output.el がload-path上にある場合どうする？ 15 | pselEl :: FeatureName -> Text 16 | pselEl (FeatureName sym) = 17 | let feature = utf8BuilderToText $ displaySymbol sym 18 | in [trimming| 19 | ;; psel.el -*- lexical-binding: t; -*- 20 | 21 | (require 'seq) 22 | 23 | ;; Exception 24 | 25 | (defun psel/unrecoverable-error (&rest args) 26 | (signal 'psel/unrecoverable-error args)) 27 | 28 | (defun psel/assert-error (msg) 29 | (signal 'psel/assert-error (list msg))) 30 | 31 | ;; Alist 32 | 33 | (defun psel/alist-get (field alist) 34 | (let ((c (assq field alist))) 35 | (if (null c) 36 | (psel/unrecoverable-error) 37 | (cdr c)))) 38 | 39 | (defun psel/alist-set (field val alist) 40 | "Update the first cons with car eq to field in a immutable way." 41 | (cond ((null alist) 42 | (psel/unrecoverable-error)) 43 | ((eq (caar alist) field) 44 | (cons (cons field val) (cdr alist))) 45 | (t 46 | (cons (car alist) (psel/alist-set field val (cdr alist)))))) 47 | 48 | (defun psel/alist-set-or-insert (field val alist) 49 | "Update the first appearnce or insert a new field in an immutable way." 50 | (cond ((null alist) 51 | (cons (cons field val) nil)) 52 | ((eq (caar alist) field) 53 | (cons (cons field val) (cdr alist))) 54 | (t 55 | (cons (car alist) (psel/alist-set-or-insert field val (cdr alist)))))) 56 | 57 | (defun psel/alist-delete (field alist) 58 | "Delete the first cons with car eq to field in a immutable way." 59 | (cond ((null alist) 60 | (psel/unrecoverable-error)) 61 | ((eq (caar alist) field) 62 | (cdr alist)) 63 | (t 64 | (cons (car alist) (psel/alist-delete field (cdr alist)))))) 65 | 66 | (defun psel/alist-equal (a b) 67 | "Alist equality. Key order doesn't matter." 68 | (let ((keys (mapcar 'car a))) 69 | (and (eq (length keys) (length b)) 70 | (equal a (mapcar (lambda (key) (assq key b)) keys))))) 71 | 72 | ;; funcall 73 | 74 | (defmacro psel/funcall (f &rest args) 75 | "funcall 1-arg function" 76 | (seq-reduce (lambda (b a) `(funcall ,b ,a)) args f)) 77 | 78 | (provide '$feature) 79 | |] 80 | -------------------------------------------------------------------------------- /src/PsEl/SExp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module PsEl.SExp where 9 | 10 | import Data.Functor.Foldable qualified as RS 11 | import RIO 12 | import RIO.Lens (_1, _2) 13 | import RIO.NonEmpty qualified as NonEmpty 14 | import RIO.Text (unpack) 15 | 16 | -- Fix Point 17 | newtype SExp = SExp {unSExpr :: SExpF SExp} 18 | deriving (Generic) 19 | 20 | type instance RS.Base SExp = SExpF 21 | instance RS.Recursive SExp where 22 | project = unSExpr 23 | 24 | -- Expression Functor 25 | -- 制御構造(let*,letrec,cond,pcase)は List でも表現できるが, 26 | -- SExpに対して最適化をかける際に解析する必要があるため別途コンストラクタで表現。 27 | -- Listは関数呼出しもしくはリテラル時のみ使う。 28 | -- 29 | -- S式とCoreFnの間の中間言語を目指す? 30 | -- 一般的なS式までトランスパイル時に落してしまうと情報も落ちてしまって最適化がしづらくなる。 31 | -- 例えば Quote/Backquote/Comm。自由変数の参照を取得する場合,quote中のシンボルは無視する必要がある。 32 | -- またbackquoteがネストされた場合,そのコンテキストも考慮する必要がある。 33 | -- Quote/Backqoute自体は限定的に使われているので,より情報を残した形で 34 | -- SExpFから除くというのが正しい気もするが 35 | -- Quote もSymbolにしか適用されていないので Quote e よりは QuotedSymbol Symbol として方が 36 | -- 37 | -- ただ懸念としてはあまり上げすぎるとCoreFnと同じレベルになってしまう。 38 | -- 39 | -- Lambda0/FunCall0はMagicDo実装のために導入 40 | data SExpF e 41 | = Integer Integer 42 | | Double Double 43 | | String Text 44 | | Character Char 45 | | Symbol Symbol 46 | | MkAlist [(Symbol, e)] 47 | | Progn [e] 48 | | If e e e 49 | | Cond [(e, e)] 50 | | Let LetType [(Symbol, e)] e 51 | | Pcase [e] [PcaseAlt e] 52 | | -- | 1引数関数 53 | Lambda1 Symbol e 54 | | -- | 1引数関数の呼出し 55 | -- e.g. FunCall1 f a -> (funcall f a) 56 | FunCall1 e e 57 | | -- | 任意引数関数の呼出し 58 | -- Data.Function.UncurriedのFn2などの呼出しを最適化するに利用する。 59 | -- FunCall{0,1}も包含しているが,基本上記の最適化以外では利用しない。 60 | -- e.g. FunCallN f [a0, .., an] -> (funcall f a0 a1 ... an) 61 | FunCallN e [e] 62 | | -- | 任意引数のネイティブ関数の呼出し 63 | -- e.g. FunCallNative "foo" [a, b] -> (foo a b) 64 | FunCallNative Symbol [e] 65 | | -- | e.g. 'foo 66 | QuotedSymbol Symbol 67 | | Lambda0 e 68 | | FunCall0 e 69 | deriving (Functor, Foldable, Traversable, Generic) 70 | 71 | data LetType 72 | = LetStar 73 | | LetRec 74 | deriving (Eq, Ord) 75 | 76 | data PcaseAlt e = PcaseAlt 77 | { patterns :: [PPattern e] 78 | , guard :: Maybe e 79 | , code :: e 80 | } 81 | deriving (Functor, Foldable, Traversable) 82 | 83 | -- pcase pattern 84 | -- 相互再帰の recursion scheme は面倒なのでこちらは普通に定義。 85 | -- guard用のconstructerを用意していないのは, guardを使うのは最も外側のみのため。 86 | -- コンストラクタを減らしたほうが解析しやずいはず。 87 | data PPattern e 88 | = PAny 89 | | PInteger Integer 90 | | PString Text 91 | | PCharacter Char 92 | | -- | 定数の意味でのシンボル(束縛せず) 93 | PSymbol Symbol 94 | | PBind Symbol 95 | | PBackquotedList [PPattern e] 96 | | PBackquotedVector [PPattern e] 97 | | PBackquotedCons (PPattern e) (PPattern e) 98 | | PAnd [PPattern e] 99 | | PPred e 100 | | -- | Boolは特別扱い(最適化でif文に変更しうるので) 101 | -- 本来は以下のようにしていた 102 | -- list [symbol "pred", bool (symbol "null") (symbol "identity") b] 103 | PPredBool Bool 104 | | PApp e (PPattern e) 105 | deriving (Functor, Foldable, Traversable, Generic) 106 | 107 | -- Unsafe prefixは任意のテキストが妥当なelispシンボルにならないことを示している。 108 | newtype Symbol = UnsafeSymbol {symbolText :: Text} 109 | deriving (Eq, Ord, IsString) 110 | 111 | integer :: Integer -> SExp 112 | integer = SExp . Integer 113 | 114 | double :: Double -> SExp 115 | double = SExp . Double 116 | 117 | string :: Text -> SExp 118 | string = SExp . String 119 | 120 | character :: Char -> SExp 121 | character = SExp . Character 122 | 123 | symbol :: Symbol -> SExp 124 | symbol = SExp . Symbol 125 | 126 | progn :: [SExp] -> SExp 127 | progn = SExp . Progn 128 | 129 | quotedSymbol :: Symbol -> SExp 130 | quotedSymbol = SExp . QuotedSymbol 131 | 132 | -- association list(e.g. `((foo . ,v) (bar . 2)) 133 | -- don't need comma 134 | alist :: [(Symbol, SExp)] -> SExp 135 | alist = SExp . MkAlist 136 | 137 | if' :: SExp -> SExp -> SExp -> SExp 138 | if' c t e = SExp $ If c t e 139 | 140 | cond :: [(SExp, SExp)] -> SExp 141 | cond = SExp . Cond 142 | 143 | letStar :: [(Symbol, SExp)] -> SExp -> SExp 144 | letStar bindings body = SExp $ Let LetStar bindings body 145 | 146 | letRec :: [(Symbol, SExp)] -> SExp -> SExp 147 | letRec bindings body = SExp $ Let LetRec bindings body 148 | 149 | pcase :: [SExp] -> [PcaseAlt SExp] -> SExp 150 | pcase exps cases = SExp $ Pcase exps cases 151 | 152 | lambda1 :: Symbol -> SExp -> SExp 153 | lambda1 arg body = SExp $ Lambda1 arg body 154 | 155 | -- e.g. (lambda (a) (lambda (b) ...)) 156 | lambda1Fold :: NonEmpty Symbol -> SExp -> SExp 157 | lambda1Fold args body = 158 | let a0 :| as = NonEmpty.reverse args 159 | in foldl' (flip lambda1) (lambda1 a0 body) as 160 | 161 | funcall1 :: SExp -> SExp -> SExp 162 | funcall1 f arg = SExp $ FunCall1 f arg 163 | 164 | funcallN :: SExp -> [SExp] -> SExp 165 | funcallN f args = SExp $ FunCallN f args 166 | 167 | lambda0 :: SExp -> SExp 168 | lambda0 = SExp . Lambda0 169 | 170 | funcall0 :: SExp -> SExp 171 | funcall0 = SExp . FunCall0 172 | 173 | funcallNative :: Symbol -> [SExp] -> SExp 174 | funcallNative f args = SExp $ FunCallNative f args 175 | 176 | -- 177 | data DefVar = DefVar 178 | { name :: Symbol 179 | , definition :: SExp 180 | } 181 | 182 | newtype FeatureName = FeatureName Symbol 183 | 184 | -- Feature (Emacs requirable file) 185 | data Feature = Feature 186 | { name :: FeatureName 187 | , requires :: [FeatureName] 188 | , requireFFI :: Maybe (FeatureName, [Symbol]) 189 | , defVars :: [DefVar] 190 | } 191 | 192 | featureFileName :: FeatureName -> String 193 | featureFileName (FeatureName (UnsafeSymbol s)) = 194 | unpack s <> ".el" 195 | -------------------------------------------------------------------------------- /src/PsEl/SExpConstructor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module PsEl.SExpConstructor where 4 | 5 | import PsEl.SExp 6 | import RIO 7 | 8 | nil :: SExp 9 | nil = symbol "nil" 10 | 11 | t :: SExp 12 | t = symbol "t" 13 | 14 | require :: FeatureName -> SExp 15 | require (FeatureName name) = 16 | funcallNative "require" [quotedSymbol name] 17 | 18 | provide :: FeatureName -> SExp 19 | provide (FeatureName name) = 20 | funcallNative "provide" [quotedSymbol name] 21 | 22 | -------------------------------------------------------------------------------- /src/PsEl/SExpDisplay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE QuasiQuotes #-} 6 | 7 | module PsEl.SExpDisplay where 8 | 9 | import Data.Functor.Foldable (cata, para) 10 | import Data.List (intersperse) 11 | import PsEl.SExp 12 | import PsEl.SExpConstructor qualified as C 13 | import PsEl.SExpRaw qualified as Raw 14 | import RIO hiding (bracket) 15 | import RIO.Lens (_1, _2) 16 | import RIO.Text.Partial qualified as T 17 | import Text.RE.TDFA.Text qualified as RE 18 | 19 | displayFeature :: Feature -> Utf8Builder 20 | displayFeature Feature{name, requires, requireFFI, defVars} = 21 | mconcat . intersperse "\n" $ 22 | mconcat 23 | [ [headLine] 24 | , requireLines 25 | , loadFFILine 26 | , defVarLines 27 | , [provideLine] 28 | ] 29 | where 30 | headLine = 31 | ";; -*- lexical-binding: t; -*-" 32 | 33 | requireLines = 34 | map (displaySExp . C.require) requires 35 | 36 | -- FFIファイルのファイル名と最終的なファイル名が異なるため,FFIファイルには 37 | -- provide は書かず, load する。FFIファイルは対応するelモジュールファイルか 38 | -- らしかloadされず,elモジュールファイルのほうはrequireされるので複数回load 39 | -- されることはない。loadはロード時にメッセージを出すが第3引数にtを渡すこと 40 | -- で抑制できる。 41 | -- 42 | -- require側で provideするよることも考えたが, requireされた側にprovideがなかっ 43 | -- た場合emacsが例外を投げる。 44 | -- 45 | -- 逆にFFIファイル内ではprovideを書いてはいけない(チェックするべき)。例えば 46 | -- Data/Eq.el という FFIファイルは Dat.Eq._FOREIGN_.el というファイルにコピー 47 | -- される。 48 | loadFFILine = case requireFFI of 49 | Just (FeatureName (UnsafeSymbol name), _) -> 50 | [displaySExp $ funcallNative "load" [string name, C.nil, C.t]] 51 | Nothing -> [] 52 | 53 | defVarLines = 54 | map displayDefVar defVars 55 | 56 | provideLine = 57 | displaySExp $ C.provide name 58 | 59 | displayDefVar :: DefVar -> Utf8Builder 60 | displayDefVar DefVar{name, definition} = 61 | displaySExp $ funcallNative "defvar" [symbol name, definition] 62 | 63 | displaySExp :: SExp -> Utf8Builder 64 | displaySExp = cata displaySExpFRaw . convSExp 65 | 66 | convSExp :: SExp -> Raw.SExp 67 | convSExp = cata conv 68 | where 69 | conv :: SExpF Raw.SExp -> Raw.SExp 70 | conv (Integer i) = Raw.integer i 71 | conv (Double d) = Raw.double d 72 | conv (String s) = Raw.string s 73 | conv (Character c) = Raw.character c 74 | conv (Symbol sym) = Raw.symbol sym 75 | conv (MkAlist xs) = convMkAlist xs 76 | conv (Progn es) = convProgn es 77 | conv (If e et ee) = Raw.list [Raw.symbol "if", e, et, ee] 78 | conv (Cond alts) = Raw.list $ Raw.symbol "cond" : map (\(p, e) -> Raw.list (p : eraseProgn e)) alts 79 | conv (Let letType binds body) = convLetish letType binds body 80 | conv (Pcase exprs cases) = convPcase exprs cases 81 | conv (Lambda1 arg body) = Raw.list $ [Raw.symbol "lambda", Raw.list [Raw.symbol arg]] <> eraseProgn body 82 | conv (Lambda0 body) = Raw.list $ [Raw.symbol "lambda", Raw.list []] <> eraseProgn body 83 | conv (FunCall1 f arg) = Raw.list [Raw.symbol "funcall", f, arg] 84 | conv (FunCall0 f) = Raw.list [Raw.symbol "funcall", f] 85 | conv (FunCallN f args) = Raw.list $ [Raw.symbol "funcall", f] <> args 86 | conv (FunCallNative sym args) = Raw.list $ Raw.symbol sym : args 87 | conv (QuotedSymbol qs) = Raw.quote $ Raw.symbol qs 88 | 89 | -- erase uneeded progns 90 | eraseProgn :: Raw.SExp -> [Raw.SExp] 91 | eraseProgn (Raw.SExp (Raw.Progn es)) = es 92 | eraseProgn e = [e] 93 | 94 | -- remvoe nested progns 95 | convProgn :: [Raw.SExp] -> Raw.SExp 96 | convProgn = Raw.progn . foldr go [] 97 | where 98 | go :: Raw.SExp -> [Raw.SExp] -> [Raw.SExp] 99 | go (Raw.SExp (Raw.Progn es)) = (es <>) 100 | go e = (e :) 101 | 102 | convMkAlist :: [(Symbol, Raw.SExp)] -> Raw.SExp 103 | convMkAlist = 104 | Raw.backquote 105 | . Raw.list 106 | . map (uncurry Raw.cons . over _2 comma' . over _1 Raw.symbol) 107 | where 108 | comma' s 109 | | Raw.isLiteral s = s 110 | | otherwise = Raw.comma s 111 | 112 | -- Let系 113 | convLetish :: LetType -> [(Symbol, Raw.SExp)] -> Raw.SExp -> Raw.SExp 114 | convLetish letType binds body = 115 | Raw.list $ 116 | [ Raw.symbol name 117 | , Raw.list (map (\(s, e) -> Raw.list [Raw.symbol s, e]) binds) 118 | ] 119 | <> eraseProgn body 120 | where 121 | name = case letType of 122 | LetStar -> "let*" 123 | LetRec -> "letrec" 124 | 125 | -- displayPcase :: [Utf8Builder] -> [PcaseAlt Utf8Builder] -> Utf8Builder 126 | -- displayPcase exprs cases = _ 127 | 128 | convPcase :: [Raw.SExp] -> [PcaseAlt Raw.SExp] -> Raw.SExp 129 | convPcase exprs cases = 130 | Raw.list $ [Raw.symbol "pcase", unifyExprs exprs] <> map caseAlt cases 131 | where 132 | unifyExprs = \case 133 | [] -> error "Empty pcase exprs" 134 | [s] -> s 135 | ss -> Raw.list (Raw.symbol "list" : ss) 136 | 137 | unifyPatterns = \case 138 | [] -> error "Empty pcase exprs" 139 | [p] -> p 140 | ps -> PBackquotedList ps 141 | 142 | caseAlt PcaseAlt{patterns, guard, code} = 143 | Raw.list $ 144 | [ pattern' (unifyPatterns patterns) & maybe id addGuard guard 145 | ] 146 | <> eraseProgn code 147 | where 148 | addGuard guard sexp = 149 | Raw.list [Raw.symbol "and", sexp, Raw.list [Raw.symbol "guard", guard]] 150 | 151 | pattern' :: PPattern Raw.SExp -> Raw.SExp 152 | pattern' PAny = 153 | Raw.symbol "_" 154 | pattern' (PInteger i) = 155 | Raw.integer i 156 | pattern' (PString s) = 157 | Raw.string s 158 | pattern' (PCharacter c) = 159 | Raw.character c 160 | pattern' (PSymbol sym) = 161 | Raw.quote $ Raw.symbol sym 162 | pattern' (PBind sym) = 163 | Raw.symbol sym 164 | pattern' (PBackquotedList ps) = 165 | Raw.backquote . Raw.list $ map (commaMaybe . pattern') ps 166 | pattern' (PBackquotedVector ps) = 167 | Raw.backquote . Raw.vector $ map (commaMaybe . pattern') ps 168 | pattern' (PBackquotedCons car cdr) = 169 | Raw.backquote $ Raw.cons (commaMaybe (pattern' car)) (commaMaybe (pattern' cdr)) 170 | pattern' (PAnd ps) = 171 | Raw.list $ Raw.symbol "and" : map pattern' ps 172 | pattern' (PPred pred) = 173 | Raw.list [Raw.symbol "pred", pred] 174 | pattern' (PPredBool b) = 175 | Raw.list [Raw.symbol "pred", bool (Raw.symbol "null") (Raw.symbol "identity") b] 176 | pattern' (PApp s p) = 177 | Raw.list [Raw.symbol "app", s, pattern' p] 178 | 179 | -- バッククオート中の入れ子になっている不要な (`)や(') を取り除く 180 | -- e.g. `[ ... ,`[...] -> `[ ... [...] 181 | commaMaybe :: Raw.SExp -> Raw.SExp 182 | commaMaybe (Raw.SExp (Raw.Backquote se)) = 183 | se 184 | commaMaybe (Raw.SExp (Raw.Quote se)) = 185 | se 186 | commaMaybe s 187 | | Raw.isLiteral s = s 188 | | otherwise = Raw.comma s 189 | 190 | displaySExpFRaw :: Raw.SExpF Utf8Builder -> Utf8Builder 191 | displaySExpFRaw (Raw.Integer i) = display i 192 | displaySExpFRaw (Raw.Double d) = display d 193 | displaySExpFRaw (Raw.String t) = displayString t 194 | displaySExpFRaw (Raw.Character c) = "?" <> display c 195 | displaySExpFRaw (Raw.Symbol sym) = displaySymbol sym 196 | displaySExpFRaw (Raw.Cons car cdr) = paren [car <> " . " <> cdr] 197 | displaySExpFRaw (Raw.Progn es) = paren $ "progn" : es 198 | displaySExpFRaw (Raw.List xs) = paren xs 199 | displaySExpFRaw (Raw.Vector xs) = bracket xs 200 | displaySExpFRaw (Raw.Quote s) = "'" <> s 201 | displaySExpFRaw (Raw.Backquote s) = "`" <> s 202 | displaySExpFRaw (Raw.Comma s) = "," <> s 203 | 204 | -- 取り敢えず雑なquotingで 205 | displayString :: Text -> Utf8Builder 206 | displayString t = "\"" <> display (quote t) <> "\"" 207 | where 208 | quote = T.replace "\"" "\\\"" 209 | 210 | -- elispでは 211 | -- https://www.gnu.org/software/emacs/manual/html_node/elisp/Symbol-Type.html 212 | -- まずエスケープが必要な文字に関しては \ を前置。 213 | -- 文字レベルでエスケープが不要としても全体として数値として解釈されてしまうものは先頭を\でエスケープする。 214 | displaySymbol :: Symbol -> Utf8Builder 215 | displaySymbol (UnsafeSymbol s) = display $ escape s 216 | where 217 | -- 取り敢えず[0-9a-zA-Z-+=*/_~!@$%^&:<>{}_] 以外は \ でエスケープすることにする。 218 | -- ? もエスケープは不要なのだが ?a など文字リテラルと 219 | -- ただし文字リテラル(?a)や数値として解釈されるもの(-1.5)などは先頭に \ を付ける必要がある 220 | escape = 221 | (RE.*=~/ [RE.ed|[^[:alnum:].+=*/_~!@$%^&:<>{}_-]///\${0}|]) 222 | isNumberLiteral = 223 | RE.matched . (RE.?=~ [RE.re|^[+-]?[[:digit:]]*(\.[[:digit:]]+)?$|]) 224 | unambiguousify t = 225 | bool id ("\\" <>) $ isNumberLiteral t 226 | 227 | paren :: [Utf8Builder] -> Utf8Builder 228 | paren xs = "(" <> mconcat (intersperse " " xs) <> ")" 229 | 230 | bracket :: [Utf8Builder] -> Utf8Builder 231 | bracket xs = "[" <> mconcat (intersperse " " xs) <> "]" 232 | -------------------------------------------------------------------------------- /src/PsEl/SExpOptimize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | module PsEl.SExpOptimize where 11 | 12 | import Control.Lens (itoListOf) 13 | import Data.Functor.Foldable (Recursive (para), cata, cataA) 14 | import Data.Generics.Sum (_Ctor) 15 | import Data.Generics.Wrapped (_Unwrapped) 16 | import Language.PureScript qualified as PS 17 | import PsEl.SExp 18 | import PsEl.SExpPattern qualified as P 19 | import PsEl.SExpTraverse (Index (..), freeVars) 20 | import PsEl.Transpile (globalVar, localUnusedVar) 21 | import RIO 22 | import RIO.Lens (_1) 23 | import RIO.Map qualified as Map 24 | import RIO.State (State, evalState, get, put) 25 | 26 | newtype OptimizeM a = OptimizeM {runOptimize :: State Int a} 27 | deriving (Functor, Applicative, Monad) 28 | 29 | -- PSが $ prefixの変数を使わない,という前提 30 | mkUniqVar :: Text -> OptimizeM Symbol 31 | mkUniqVar base = OptimizeM $ do 32 | i <- get 33 | put $ i + 1 34 | pure $ UnsafeSymbol $ "$" <> base <> "-" <> textDisplay i 35 | 36 | optimize :: Feature -> Feature 37 | optimize f@Feature{defVars} = 38 | f 39 | { defVars = 40 | map 41 | (\dv -> dv{definition = optimizeDefVar dv}) 42 | defVars 43 | } 44 | 45 | optimizeDefVar :: DefVar -> SExp 46 | optimizeDefVar DefVar{name, definition} = flip evalState 0 . runOptimize $ do 47 | pure (applyRewrite definition) 48 | >>= applyTopLevelTCO name 49 | >>= applyTCO 50 | where 51 | applyRewrite :: SExp -> SExp 52 | applyRewrite = 53 | cata 54 | ( magicDo 55 | . directlyCallFns 56 | . removeDataFunctions 57 | . removeRebindOnlyPcase 58 | . replacePcaseToIf 59 | . SExp 60 | ) 61 | 62 | applyTopLevelTCO :: Symbol -> SExp -> OptimizeM SExp 63 | applyTopLevelTCO name sexp = 64 | fromMaybe (pure sexp) $ applyTCOToName name sexp 65 | 66 | -- top-downに適用する必要あり 67 | applyTCO :: SExp -> OptimizeM SExp 68 | applyTCO = para applyTCO' 69 | 70 | -- only letrec names are possibily self-resursive 71 | applyTCO' :: SExpF (SExp, OptimizeM SExp) -> OptimizeM SExp 72 | applyTCO' (Let LetRec binds body) = do 73 | binds' <- for binds $ \(name, (orig, sexp)) -> 74 | (name,) <$> case applyTCOToName name orig of 75 | Nothing -> sexp 76 | Just om -> applyTCO =<< om 77 | body' <- snd body 78 | pure . SExp $ Let LetRec binds' body' 79 | applyTCO' sexp = 80 | SExp <$> mapM snd sexp 81 | 82 | applyTCOToName :: Symbol -> SExp -> Maybe (OptimizeM SExp) 83 | applyTCOToName name sexp = 84 | case toLambdas sexp of 85 | ([], _) -> 86 | Nothing 87 | lambdas -> 88 | fmap (fmap fromLambdas) (selfRecursiveTCO name lambdas) 89 | 90 | toLambdas :: SExp -> ([Symbol], SExp) 91 | toLambdas (SExp (Lambda1 sym sexp)) = over _1 (sym :) $ toLambdas sexp 92 | toLambdas sexp = ([], sexp) 93 | 94 | fromLambdas :: ([Symbol], SExp) -> SExp 95 | fromLambdas (args, body) = foldr lambda1 body args 96 | 97 | -- PSでif文を使うとcorefnではcaseに変換される。素直にそのままコード生成すると例 98 | -- えばのようになる。 99 | -- 100 | -- (pcase b ((pred identity) 1) (_ 0)) 101 | -- 102 | -- 上記ケースは (if b 1 0) に変換できる。ただpaseマクロが次まで展開してくれる。 103 | -- 104 | -- (if (identity b) (let nil 1) (let nil 0)) 105 | -- 106 | -- そのため速度的な改善はそれほどでもない。 107 | replacePcaseToIf :: SExp -> SExp 108 | replacePcaseToIf 109 | ( P.Pcase 110 | [e] 111 | [PcaseAlt [PPredBool b] Nothing thenE, PcaseAlt [PAny] Nothing elseE] 112 | ) = if' (bool (funcallNative "not" [e]) e b) thenE elseE 113 | replacePcaseToIf s = s 114 | 115 | -- 変数のbindingのみ行なってる単一Altのpcase式の除去。 116 | -- 例えば: 117 | -- 118 | -- selfRec1 :: Int -> Int -> Int 119 | -- selfRec1 i to 120 | -- | eqInt i to = 1 121 | -- | true = selfRec1 (succInt i) to 122 | -- 123 | -- はそのままコード変換すると次のようになる。 124 | -- 125 | -- (defvar Test.PsEl.TCO.selfRec1 126 | -- (lambda (i) 127 | -- (lambda (to) 128 | -- (pcase (list i to) 129 | -- (`(,i1 ,to1) 130 | -- (cond ((funcall (funcall Test.Util.... 131 | -- 132 | -- pcaseは単に変数を再束縛しているだけであり,変数名を置き換えをすれば除去可能である。 133 | -- PSレベルで行なえる変換に思えるが,CoreFnデータ型ににcond(ifの連結)に相当するものがないからかな？ 134 | removeRebindOnlyPcase :: SExp -> SExp 135 | removeRebindOnlyPcase (P.Pcase exps [PcaseAlt pats Nothing code]) 136 | | Just expsSyms <- traverse (^? _Unwrapped . _Ctor @"Symbol") exps 137 | , Just patsSyms <- traverse (^? _Ctor @"PBind") pats = 138 | code 139 | & over freeVars (symbolsRewrite (zip patsSyms expsSyms)) 140 | removeRebindOnlyPcase s = s 141 | 142 | -- 不要な ($), (&) の除去 143 | -- ほぼ意味がなく結合優先度や適用順序を調整するために使われる。 144 | -- prelude の Data.Functinモジュールの apply($) 及び applyFlipped(&)である。 145 | -- 146 | -- apply :: forall a b. (a -> b) -> a -> b 147 | -- apply f x = f x 148 | -- 149 | -- (funcall apply b>) -> b> 150 | -- 151 | -- applyFlipped :: forall a b. a -> (a -> b) -> b 152 | -- applyFlipped x f = f x 153 | -- 154 | -- (funcall (funcall applyFlipped ) b>) -> (funcall b> ) 155 | -- 156 | -- ??? ModuleNameやIdentはLanguage.PureScript.Constants以下で定義されている？ 157 | removeDataFunctions :: SExp -> SExp 158 | removeDataFunctions (P.FunCall1 (P.Symbol f) a) 159 | | f == globalVar moduleDataFunction (PS.Ident "apply") = a 160 | removeDataFunctions (P.FunCall1 (P.FunCall1 (P.Symbol f) a) ab) 161 | | f == globalVar moduleDataFunction (PS.Ident "applyFlipped") = funcall1 ab a 162 | removeDataFunctions s = s 163 | 164 | moduleDataFunction :: PS.ModuleName 165 | moduleDataFunction = PS.ModuleName "Data.Function" 166 | 167 | -- MagicDo 168 | -- 169 | -- 参考までに pskt での実装方法 170 | -- https://github.com/csicar/pskt/blob/aa0d5df52e9579abd38061c6ab891489ebf295c4/src/CodeGen/MagicDo.hs#L45 171 | -- fuse0 で (funcall0 (lambda0 ..) を除去しているので(多分)bottomupに適用しても問題ないはず。 172 | -- 173 | -- bind :: forall a b. m a -> (a -> m b) -> m b 174 | -- 175 | -- (funcall (funcall (funcall Control.Bind.bind Effect.bindEffect) ) (lambda (arg) )) 176 | -- 177 | -- if arg is unused, then: 178 | -- 179 | -- (lambda () 180 | -- (funcall ) 181 | -- (funcall )) 182 | -- 183 | -- or else: 184 | -- 185 | -- (lambda () 186 | -- (let* ((arg (funcall ))) 187 | -- (funcall ))) 188 | -- 189 | -- 捨てられる場合 190 | -- 191 | -- discard :: forall f b. Bind f => f a -> (a -> f b) -> f b 192 | -- 193 | -- (funcall (funcall (funcall (funcall Control.Bind.discard Control.Bind.discardUnit) Effect.bindEffect) ) (lambda (arg) )) 194 | -- -> 195 | -- (lambda () 196 | -- (funcall ) 197 | -- (funcall )) 198 | -- 199 | -- pure 200 | -- 201 | -- pure :: forall a. a -> f a 202 | -- 203 | -- (funcall (funcall Control.Applicative.pure Effect.applicativeEffect) ) 204 | -- -> 205 | -- (lambda () v) 206 | -- 207 | -- NOTE: psktと同様 while や untilもやるべきかな。 208 | -- あともう少しパターンマッチにしやすいよう Symbolの型変えるか？ 209 | magicDo :: SExp -> SExp 210 | magicDo (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol bind) (P.Symbol bindEffect)) ma) (P.Lambda1 arg mb)) 211 | | bind == identBind && bindEffect == identBindEffect = 212 | if arg == localUnusedVar 213 | then lambda0 $ progn [fuse0 (funcall0 ma), fuse0 (funcall0 mb)] 214 | else lambda0 $ letStar [(arg, fuse0 (funcall0 ma))] (fuse0 (funcall0 mb)) 215 | magicDo (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol discard) (P.Symbol discardUnit)) (P.Symbol bindEffect)) ma) (P.Lambda1 _ mb)) 216 | | discard == identDiscard && discardUnit == identDiscardUnit && bindEffect == identBindEffect = 217 | lambda0 $ progn [fuse0 (funcall0 ma), fuse0 (funcall0 mb)] 218 | magicDo (P.FunCall1 (P.FunCall1 (P.Symbol pure) (P.Symbol applicativeEffect)) v) 219 | | pure == identPure && applicativeEffect == identApplicativeEffect = 220 | lambda0 v 221 | magicDo s = s 222 | 223 | -- NOTE: (lambda0 (funcall0 ..)) もなくせるかと思うが多分そのようなケースは発生しない 224 | -- NOTE: 良く考えたら上記のケースは (lambda0 (funcall 0 (let ((..)) x))) のケースが 225 | -- あるから多分fuseは駄目な気がする 226 | -- magicDo が cata で bottomup に適用されているので再帰除去は不要。 227 | fuse0 :: SExp -> SExp 228 | fuse0 (P.FunCall0 (P.Lambda0 a)) = a 229 | fuse0 s = s 230 | 231 | identBind = globalVar moduleControlBind (PS.Ident "bind") 232 | identPure = globalVar moduleControlApplicative (PS.Ident "pure") 233 | identDiscard = globalVar moduleControlBind (PS.Ident "discard") 234 | identDiscardUnit = globalVar moduleControlBind (PS.Ident "discardUnit") 235 | identBindEffect = globalVar moduleEffect (PS.Ident "bindEffect") 236 | identApplicativeEffect = globalVar moduleEffect (PS.Ident "applicativeEffect") 237 | moduleEffect = PS.ModuleName "Effect" 238 | moduleControlApplicative = PS.ModuleName "Control.Applicative" 239 | moduleControlBind = PS.ModuleName "Control.Bind" 240 | 241 | -- 引数が全部与えられていた場合, FnN{0,..,10} を直接呼ぶ 242 | 243 | directlyCallFns :: SExp -> SExp 244 | directlyCallFns (P.FunCall1 (P.Symbol runFn0) f) 245 | | runFn0 == identRunFn 0 = funcallN f [] 246 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.Symbol runFn1) f) a0) 247 | | runFn1 == identRunFn 1 = funcallN f [a0] 248 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn2) f) a0) a1) 249 | | runFn2 == identRunFn 2 = funcallN f [a0, a1] 250 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn3) f) a0) a1) a2) 251 | | runFn3 == identRunFn 3 = funcallN f [a0, a1, a2] 252 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn4) f) a0) a1) a2) a3) 253 | | runFn4 == identRunFn 4 = funcallN f [a0, a1, a2, a3] 254 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn5) f) a0) a1) a2) a3) a4) 255 | | runFn5 == identRunFn 5 = funcallN f [a0, a1, a2, a3, a4] 256 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn6) f) a0) a1) a2) a3) a4) a5) 257 | | runFn6 == identRunFn 6 = funcallN f [a0, a1, a2, a3, a4, a5] 258 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn7) f) a0) a1) a2) a3) a4) a5) a6) 259 | | runFn7 == identRunFn 7 = funcallN f [a0, a1, a2, a3, a4, a5, a6] 260 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn8) f) a0) a1) a2) a3) a4) a5) a6) a7) 261 | | runFn8 == identRunFn 8 = funcallN f [a0, a1, a2, a3, a4, a5, a6, a7] 262 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn9) f) a0) a1) a2) a3) a4) a5) a6) a7) a8) 263 | | runFn9 == identRunFn 9 = funcallN f [a0, a1, a2, a3, a4, a5, a6, a7, a8] 264 | directlyCallFns (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.FunCall1 (P.Symbol runFn10) f) a0) a1) a2) a3) a4) a5) a6) a7) a8) a9) 265 | | runFn10 == identRunFn 10 = funcallN f [a0, a1, a2, a3, a4, a5, a6, a7, a8, a9] 266 | directlyCallFns s = s 267 | 268 | identRunFn :: Int -> Symbol 269 | identRunFn i = globalVar moduleFunctionUncurried (PS.Ident $ "runFn" <> textDisplay i) 270 | moduleFunctionUncurried = PS.ModuleName "Data.Function.Uncurried" 271 | 272 | -- 自己再帰関数の最適化 273 | -- ただし最適化可能なケース全てに於いて最適化を実行できるわけではない。 274 | -- 差し当り自明なケースのみ最適化を実行する。 275 | -- トップダウンに適用する必要あり。whileループに変換すると 276 | -- 変換後のコードでは末尾呼出し検出がtrue/negativeになってしまう。 277 | -- 278 | -- sym 現在最適化対象の識別子 279 | -- args は少なくとも一つ以上持つとする 280 | -- body は関数の中身 281 | -- 282 | selfRecursiveTCO :: Symbol -> ([Symbol], SExp) -> Maybe (OptimizeM ([Symbol], SExp)) 283 | selfRecursiveTCO sym (args, body) = do 284 | let argLen = length args 285 | let calls = filter ((== sym) . snd) $ itoListOf freeVars body 286 | if not (null calls) && all (isTC argLen . fst) calls 287 | then Just $ (args,) <$> performTCO 288 | else Nothing 289 | where 290 | -- 末尾呼出しかを判定。 291 | -- 必要な1引数呼出し回数が第一引数で渡される。 292 | -- 第二引数の[Index]は逆順であることに注意(内から外の順)。 293 | -- 294 | -- (a) 295 | -- 呼出し途中にある識別子に束縛された場合。現在は単に末尾呼出しされていないとしているが, 296 | -- その識別子が(元bodyから見て)末尾呼出しされている場合は最適化可能なケースが存在する。 297 | -- 実際JSバックエンドはそこまで最適化している。 298 | -- 299 | -- (b) 300 | -- 引数位置にあったとしても最適化可能なケースは存在するが解析が難しいため現在はしない。 301 | -- 302 | -- (c) 303 | -- 本来必要な引数の数を超えて呼び出されるケースは存在する。 304 | -- 例えば foo :: Int -> Int -> Int という型でも実装が foo i = if ... (\j -> i + j) 305 | -- のような形であった場合, 元の args引数の長さは1になる。 306 | -- 307 | -- ?? Lambda0/FunCall0 は直Falseにしなくても救済措置があるかも。 308 | -- ただ実際に有り得るかは疑問。 309 | isTC :: Int -> [Index] -> Bool 310 | isTC i [] = i == 0 311 | isTC i (ix : ixs) = case ix of 312 | ILambda1 -> isTC (i + 1) ixs 313 | ILambda0 -> False 314 | IBind _ -> False -- (a) 315 | IArg -> False -- (b) 316 | ICond -> False 317 | ITail -> isTC i ixs 318 | IFunCall1 319 | | i > 0 -> isTC (i - 1) ixs 320 | | otherwise -> False -- (c) 321 | IFunCall0 -> False 322 | IFunCallN -> False 323 | 324 | -- 例えば次の関数が最適化対象とする。 325 | -- 326 | -- (lambda (i) 327 | -- (lambda (j) 328 | -- <..body..>)) 329 | -- 330 | -- 次のようにwhile文を使ったループに変更する。 331 | -- 生成変数($ prefix)は一意性を持つよう被らないsuffixを付ける。 332 | -- <..body'..> は <..body..>内の再帰呼出しを $loop-fn に置き換え, 333 | -- lambda引数をローカルの物に置き換えたもの。 334 | -- 現状再帰呼出し関数をshadowすれば置き換えは不要だが, 335 | -- 将来的に部分的に置き換えの必要が発生した場合も考えて全て置き換えておく。 336 | -- lambda引数をローカルに置き換える(下の例だと $i, $j)のは, 337 | -- 関数ば部分適用された場合,lambda引数を直でsetqすると呼出し間でその 338 | -- 変更が共有されてしまうため。 339 | -- 340 | -- (lambda (i) 341 | -- (lambda (j) 342 | -- (let* (($i i) 343 | -- ($j j) 344 | -- ($continue (make-symbol "")) ;; uniq symbol 345 | -- ($result $do-loop) 346 | -- ($loop-fn (lambda (_i) 347 | -- (lambda (_j) 348 | -- (setq $i _i $j _j) 349 | -- $continue)))) 350 | -- (while (eq $result $continue) 351 | -- (setq $result <..body'..>)) 352 | -- $result))) 353 | -- 354 | performTCO :: OptimizeM SExp 355 | performTCO = do 356 | varContinue <- mkUniqVar "continue" 357 | varResult <- mkUniqVar "result" 358 | varLoopFn <- mkUniqVar $ symbolText sym 359 | argsLocal <- traverse (mkUniqVar . symbolText) args 360 | argsTmp <- traverse (mkUniqVar . symbolText) args 361 | let bindLocalVars = 362 | zipWith (curry (fmap symbol)) argsLocal args 363 | let bindSpecialVars = 364 | [ (varContinue, funcallNative "make-symbol" [string ""]) 365 | , (varResult, symbol varContinue) 366 | , 367 | ( varLoopFn 368 | , foldr 369 | lambda1 370 | ( progn2 371 | (funcallNative "setq" (zipWith (\a a' -> [symbol a, symbol a']) argsLocal argsTmp & mconcat)) 372 | (symbol varContinue) 373 | ) 374 | argsTmp 375 | ) 376 | ] 377 | let body' = 378 | body & over freeVars (symbolsRewrite ((sym, varLoopFn) : zip args argsLocal)) 379 | pure $ 380 | letStar 381 | (bindLocalVars <> bindSpecialVars) 382 | ( progn2 383 | ( funcallNative 384 | "while" 385 | [ funcallNative "eq" [symbol varResult, symbol varContinue] 386 | , funcallNative "setq" [symbol varResult, body'] 387 | ] 388 | ) 389 | (symbol varResult) 390 | ) 391 | where 392 | progn2 e0 e1 = progn [e0, e1] 393 | 394 | symbolsRewrite :: [(Symbol, Symbol)] -> Symbol -> Symbol 395 | symbolsRewrite symPairs = 396 | let symMap = Map.fromList symPairs 397 | in \sym -> fromMaybe sym (Map.lookup sym symMap) 398 | -------------------------------------------------------------------------------- /src/PsEl/SExpPattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | module PsEl.SExpPattern where 4 | 5 | import PsEl.SExp as S 6 | 7 | pattern Integer i = SExp (S.Integer i) 8 | pattern Symbol s = SExp (S.Symbol s) 9 | pattern Lambda1 s e = SExp (S.Lambda1 s e) 10 | pattern Lambda0 e = SExp (S.Lambda0 e) 11 | pattern FunCall1 f a = SExp (S.FunCall1 f a) 12 | pattern FunCall0 f = SExp (S.FunCall0 f) 13 | pattern Pcase es alts = SExp (S.Pcase es alts) 14 | -------------------------------------------------------------------------------- /src/PsEl/SExpRaw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveTraversable #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module PsEl.SExpRaw where 5 | 6 | import Data.Functor.Foldable qualified as RS 7 | import PsEl.SExp (Symbol) 8 | import RIO 9 | 10 | newtype SExp = SExp {unSExpr :: SExpF SExp} 11 | 12 | type instance RS.Base SExp = SExpF 13 | instance RS.Recursive SExp where 14 | project = unSExpr 15 | 16 | data SExpF e 17 | = Integer Integer 18 | | Double Double 19 | | String Text 20 | | Character Char 21 | | Symbol Symbol 22 | | Cons e e 23 | | Progn [e] 24 | | List [e] 25 | | Vector [e] 26 | | Quote e 27 | | Backquote e 28 | | Comma e 29 | deriving (Functor, Foldable, Traversable) 30 | 31 | integer :: Integer -> SExp 32 | integer = SExp . Integer 33 | 34 | double :: Double -> SExp 35 | double = SExp . Double 36 | 37 | string :: Text -> SExp 38 | string = SExp . String 39 | 40 | character :: Char -> SExp 41 | character = SExp . Character 42 | 43 | symbol :: Symbol -> SExp 44 | symbol = SExp . Symbol 45 | 46 | vector :: [SExp] -> SExp 47 | vector = SExp . Vector 48 | 49 | -- e.g. (car . cdr) 50 | cons :: SExp -> SExp -> SExp 51 | cons car cdr = SExp $ Cons car cdr 52 | 53 | progn :: [SExp] -> SExp 54 | progn = SExp . Progn 55 | 56 | list :: [SExp] -> SExp 57 | list = SExp . List 58 | 59 | quote :: SExp -> SExp 60 | quote = SExp . Quote 61 | 62 | backquote :: SExp -> SExp 63 | backquote = SExp . Backquote 64 | 65 | comma :: SExp -> SExp 66 | comma = SExp . Comma 67 | 68 | -- 文字列や数値などのリテラル表記かを判定。 69 | -- vector(e.g. [1 2 3])もリテラルであることに注意。 70 | isLiteral :: SExp -> Bool 71 | isLiteral (SExp s') = case s' of 72 | Integer _ -> True 73 | Double _ -> True 74 | String _ -> True 75 | Character _ -> True 76 | Vector _ -> True 77 | _ -> False 78 | -------------------------------------------------------------------------------- /src/PsEl/SExpTraverse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TupleSections #-} 5 | 6 | module PsEl.SExpTraverse where 7 | 8 | import Control.Lens (Indexable, IndexedTraversal', indexed) 9 | import Data.Functor.Foldable (cata) 10 | import Data.List (mapAccumL) 11 | import PsEl.SExp 12 | import RIO 13 | import RIO.Lens (_2) 14 | import RIO.NonEmpty qualified as NE 15 | import RIO.Set qualified as Set 16 | 17 | -- indexはシンプルなself-recursiveなTCOを最適化するために必要な情報のみ含む。 18 | -- その意味ではIArgとICondを分ける必要はないかな.. 19 | data Index 20 | = ILambda1 21 | | ILambda0 22 | | IBind Symbol 23 | | -- 引数部 24 | -- progn の最後の式以外もargと見做す 25 | -- e.g. (pcase ...), (alist ), (funcall x ) 26 | IArg 27 | | -- 条件部 28 | -- e.g. (if ..), (cond ( ..) ( ...)) 29 | ICond 30 | | -- 長さ一のボディ 31 | ITail 32 | | -- funcall1(1引数呼出し)の対象 33 | IFunCall1 34 | | IFunCall0 35 | | IFunCallN 36 | 37 | -- | `Taversal' SExp Symbol` for free variables 38 | freeVars :: 39 | forall f p. 40 | (Applicative f, Indexable [Index] p) => 41 | p Symbol (f Symbol) -> 42 | SExp -> 43 | f SExp 44 | freeVars p s = cata go s [] mempty 45 | where 46 | go :: 47 | SExpF ([Index] -> Set Symbol -> f SExp) -> 48 | [Index] -> 49 | Set Symbol -> 50 | f SExp 51 | -- 自由変数のみfを適用する 52 | go (Symbol sym) ix vars 53 | | not (Set.member sym vars) = SExp . Symbol <$> indexed p ix sym 54 | -- 束縛(lambda) 55 | go (Lambda1 sym body) ix vars = do 56 | body' <- body (ILambda1 : ix) (Set.insert sym vars) 57 | pure $ SExp $ Lambda1 sym body' 58 | go (Lambda0 body) ix vars = do 59 | body' <- body (ILambda0 : ix) vars 60 | pure $ SExp $ Lambda0 body' 61 | 62 | -- 束縛(let*) 63 | go (Let LetStar binds body) ix vars = do 64 | let f vars (sym, val) = (Set.insert sym vars, (sym,) <$> val (IBind sym : ix) vars) 65 | let (vars', binds') = mapAccumL f vars binds 66 | binds'' <- sequenceA binds' 67 | body' <- body (ITail : ix) vars' 68 | pure $ SExp $ Let LetStar binds'' body' 69 | 70 | -- 束縛(letrec) 71 | go (Let LetRec binds body) ix vars = do 72 | let vars' = foldr (Set.insert . fst) vars binds 73 | let f (sym, val) = (sym,) <$> val (IBind sym : ix) vars' 74 | binds' <- traverse f binds 75 | body' <- body (ITail : ix) vars 76 | pure $ SExp $ Let LetRec binds' body' 77 | 78 | -- 束縛(pcase) 79 | go (Pcase exps alts) ix vars = do 80 | exps' <- traverse (\e -> e (IArg : ix) vars) exps 81 | alts' <- traverse (pcaseAlt ix vars) alts 82 | pure $ SExp $ Pcase exps' alts' 83 | 84 | -- 関数呼出し(funcall) 85 | go (FunCall1 f arg) ix vars = do 86 | f' <- f (IFunCall1 : ix) vars 87 | arg' <- arg (IArg : ix) vars 88 | pure $ SExp $ FunCall1 f' arg' 89 | go (FunCall0 f) ix vars = do 90 | f' <- f (IFunCall0 : ix) vars 91 | pure $ SExp $ FunCall0 f' 92 | go (FunCallN f args) ix vars = do 93 | f' <- f (IFunCallN : ix) vars 94 | args' <- traverse (\arg -> arg (IArg : ix) vars) args 95 | pure $ SExp $ FunCallN f' args' 96 | 97 | -- 関数呼出し(ネイティブ) 98 | go (FunCallNative sym args) ix vars = do 99 | args' <- traverse (\a -> a (IArg : ix) vars) args 100 | pure $ SExp $ FunCallNative sym args' 101 | 102 | -- if 103 | go (If condE thenE elseE) ix vars = do 104 | condE' <- condE (ICond : ix) vars 105 | thenE' <- thenE (ITail : ix) vars 106 | elseE' <- elseE (ITail : ix) vars 107 | pure $ SExp $ If condE' thenE' elseE' 108 | 109 | -- cond 110 | go (Cond alts) ix vars = do 111 | let f (condE, bodyE) = do 112 | condE' <- condE (ICond : ix) vars 113 | bodyE' <- bodyE (ITail : ix) vars 114 | pure (condE', bodyE') 115 | alts' <- traverse f alts 116 | pure $ SExp $ Cond alts' 117 | 118 | -- mkalist 119 | go (MkAlist xs) ix vars = do 120 | xs' <- traverse (\(f, e) -> (f,) <$> e (IArg : ix) vars) xs 121 | pure $ SExp $ MkAlist xs' 122 | 123 | -- progn 124 | go (Progn xs) ix vars = do 125 | let len = length xs 126 | let addIndex i = if i == len then ITail else IArg 127 | xs' <- traverse (\(i, e) -> e (addIndex i : ix) vars) $ zip [1 ..] xs 128 | pure $ SExp $ Progn xs' 129 | 130 | -- その他(再帰しないもの) 131 | go s ix vars = 132 | SExp <$> sequenceA (error "unreachable" <$> s) 133 | 134 | pcaseAlt :: 135 | [Index] -> 136 | Set Symbol -> 137 | PcaseAlt ([Index] -> Set Symbol -> f SExp) -> 138 | f (PcaseAlt SExp) 139 | pcaseAlt ix vars (PcaseAlt patterns guard code) = 140 | let (vars', patterns') = mapAccumL ppattern vars $ map (fmap ($ (ICond : ix))) patterns 141 | in PcaseAlt 142 | <$> sequenceA patterns' 143 | <*> traverse (\e -> e (ICond : ix) vars') guard 144 | <*> code (ITail : ix) vars' 145 | 146 | -- 相互再帰のrecursion schemeを避けるため ppatternは手動での再帰関数。 147 | -- 構造系では先にくる要素で束縛が存在しうることに注意。 148 | -- PPatternの型パラメータ(Set Symbol -> f SExp)が必要なのは pred と appのみ。 149 | ppattern :: 150 | Set Symbol -> 151 | PPattern (Set Symbol -> f SExp) -> 152 | (Set Symbol, f (PPattern SExp)) 153 | ppattern vars PAny = 154 | (vars, pure PAny) 155 | ppattern vars (PInteger i) = 156 | (vars, pure (PInteger i)) 157 | ppattern vars (PString s) = 158 | (vars, pure (PString s)) 159 | ppattern vars (PCharacter c) = 160 | (vars, pure (PCharacter c)) 161 | ppattern vars (PSymbol c) = 162 | (vars, pure (PSymbol c)) 163 | ppattern vars (PBind sym) = 164 | (Set.insert sym vars, pure (PBind sym)) 165 | ppattern vars (PBackquotedList es) = 166 | let (vars', es') = mapAccumL ppattern vars es 167 | in (vars', PBackquotedList <$> sequenceA es') 168 | ppattern vars (PBackquotedVector es) = 169 | let (vars', es') = mapAccumL ppattern vars es 170 | in (vars', PBackquotedVector <$> sequenceA es') 171 | ppattern vars0 (PBackquotedCons car cdr) = 172 | let (vars1, car') = ppattern vars0 car 173 | (vars2, cdr') = ppattern vars1 cdr 174 | in (vars2, PBackquotedCons <$> car' <*> cdr') 175 | ppattern vars (PAnd pps) = 176 | let (vars', pps') = mapAccumL ppattern vars pps 177 | in (vars', PAnd <$> sequenceA pps') 178 | ppattern vars (PPred pred) = 179 | (vars, PPred <$> pred vars) 180 | ppattern vars (PPredBool b) = 181 | (vars, pure (PPredBool b)) 182 | ppattern vars (PApp e pp) = 183 | let (vars', pp') = ppattern vars pp 184 | in (vars', PApp <$> e vars <*> pp') 185 | -------------------------------------------------------------------------------- /src/PsEl/Transpile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TupleSections #-} 8 | 9 | module PsEl.Transpile where 10 | 11 | import Data.Reflection (Given (given), give) 12 | import Language.PureScript (Ident (..), ModuleName (ModuleName), ProperName (ProperName), ProperNameType (ConstructorName, TypeName)) 13 | import Language.PureScript qualified as P hiding (ProperName) 14 | import Language.PureScript.Constants.Prim qualified as C 15 | import Language.PureScript.CoreFn 16 | import Language.PureScript.Errors (SourceSpan) 17 | import Language.PureScript.Names (ProperName (runProperName), Qualified (Qualified), mkQualified) 18 | import Language.PureScript.PSString (PSString (toUTF16CodeUnits)) 19 | import Language.PureScript.PSString qualified as PS 20 | import PsEl.SExp hiding (Let) 21 | import PsEl.SExpConstructor qualified as C 22 | import RIO 23 | import RIO.Lens 24 | import RIO.NonEmpty qualified as NonEmpty 25 | import RIO.NonEmpty.Partial qualified as NonEmptyPartial 26 | import RIO.Set qualified as Set 27 | import RIO.Text qualified as T 28 | import RIO.Text.Partial qualified as Partial 29 | 30 | transpile :: Module Ann -> Feature 31 | transpile 32 | Module 33 | { moduleSourceSpan 34 | , moduleComments 35 | , moduleName 36 | , modulePath 37 | , moduleImports 38 | , moduleExports 39 | , moduleForeign 40 | , moduleDecls 41 | } = Feature{name, requires, requireFFI, defVars} 42 | where 43 | name = 44 | featureName moduleName 45 | 46 | -- 理由は分からないが, moduleImportsには自モジュールも含まれている。 47 | -- それをrequireしてしまうと再帰ruquireのエラーになるため除外する。 48 | requires = 49 | pselFeature : map featureName (filter (not . ignoreModule) (map snd moduleImports)) 50 | 51 | ignoreModule mn = 52 | mn == moduleName || isPrimModule mn 53 | 54 | defVars = 55 | mconcat $ map (decl moduleName) moduleDecls 56 | 57 | requireFFI = 58 | if null moduleForeign 59 | then Nothing 60 | else Just (ffiFeatureName moduleName, map (globalVar moduleName) moduleForeign) 61 | 62 | isPrimModule mn@(ModuleName t) = 63 | mn == C.Prim || T.isPrefixOf "Prim." t 64 | 65 | -- 全ての生成モジュールに必要になるヘルパーライブラリ 66 | pselFeature :: FeatureName 67 | pselFeature = FeatureName "psel" 68 | 69 | -- モジュール名はそのまま Feqatureとする 70 | -- キャメルケース,ドット区切りはelispの規約に沿っていないが, 71 | -- PSからの生成ファイルということ 72 | featureName :: ModuleName -> FeatureName 73 | featureName (ModuleName t) = FeatureName $ mkSymbol t 74 | 75 | -- PSのモジュール名では _ は多分使わないので大丈夫かな？ 76 | ffiFeatureName :: ModuleName -> FeatureName 77 | ffiFeatureName (ModuleName s) = FeatureName $ mkSymbol $ s <> ffiFeatureSuffix 78 | 79 | ffiFeatureSuffix :: Text 80 | ffiFeatureSuffix = "._FOREIGN_" 81 | 82 | -- elispではシンボルは任意の文字列を 83 | -- ただしS式として表示する際適切なエスケープが必要(例えば空白や ' は \ でのエスケープが必要)。 84 | -- 参照 https://www.gnu.org/software/emacs/manual/html_node/elisp/Symbol-Type.html 85 | mkSymbol :: Text -> Symbol 86 | mkSymbol = UnsafeSymbol 87 | 88 | -- マクロや組込関数(built-ins, special-formも含む)の名前衝突も値スロットだけ使う分には考える必要はない。 89 | -- シンタックス上のキーワードではなく特別な関数が関数スロットに設定されている。 90 | -- 以下のように値スロットに束縛したところで問題ない。 91 | -- 92 | -- (let ((defun 1) ;; defun is macro 93 | -- (let 2)) ;; let is special-form 94 | -- (+ defun let)) ;; => 3 95 | -- 96 | -- ただ定数(特別なシンボルで,キーワードを除けば t, nilのみ)は束縛するとエラーが出る。 97 | -- https://www.gnu.org/software/emacs/manual/html_node/elisp/Constant-Variables.html 98 | -- Purescriptの識別子には使えない ^ 文字をケツにつける。 99 | localVar :: Ident -> Symbol 100 | localVar ident = 101 | mkSymbol $ 102 | if t `elem` constants 103 | then t <> "^" 104 | else t 105 | where 106 | t = _identToText ident 107 | constants = ["t", "nil"] 108 | 109 | -- bindで結果を使わない場合,$__unusedというローカル変数が割当てられる。 110 | -- 最適化の際に識別できるよう識別子として提供する。 111 | -- 本来であれば型によって表現されるべきである。 112 | -- 関連issueが作成されていた記憶がある。 113 | localUnusedVar :: Symbol 114 | localUnusedVar = mkSymbol "$__unused" 115 | 116 | -- グローバル変数の衝突に関しては,PSモジュールのprefix(e.g. Foo.Bar.foo)を使うので衝突は基本起こらない。 117 | globalVar :: ModuleName -> Ident -> Symbol 118 | globalVar (ModuleName mn) ident = 119 | mkSymbol $ mn <> "." <> _identToText ident 120 | 121 | _identToText :: Ident -> Text 122 | _identToText (Ident t) = t 123 | _identToText (GenIdent mvar i) = fromMaybe "__instance" mvar <> textDisplay i 124 | _identToText UnusedIdent = error "impossible" 125 | 126 | -- | Bind 127 | 128 | -- top-level binding で Rec な binding はありえるが(相互再帰の場合), 129 | -- 定義順は関係ないので flatten すればいいだけ。 130 | decl :: ModuleName -> Bind Ann -> [DefVar] 131 | decl mn bind = map (uncurry decl') binds 132 | where 133 | decl' ident e = 134 | DefVar 135 | { name = globalVar mn ident 136 | , definition = give mn (expr e) 137 | } 138 | binds = 139 | case bind of 140 | NonRec _ ident expr -> [(ident, expr)] 141 | Rec bs -> map (over _1 snd) bs 142 | 143 | -- 現在処理中のモジュール名を返す。 144 | -- モジュール別の特殊対応が必要な場合に使う。 145 | -- 引数で渡す・readerモナド導入はかなり面倒なので reflectionライブラリを利用する。 146 | -- https://hackage.haskell.org/package/reflection-2.1.6/docs/Data-Reflection.html 147 | currentModuleName :: Given ModuleName => ModuleName 148 | currentModuleName = given 149 | 150 | -- | Expr 151 | expr :: Given ModuleName => Expr Ann -> SExp 152 | expr (Literal _ lit) = literal lit 153 | expr (Constructor _ tname cname ids) = constructor tname cname ids 154 | expr (Accessor _ ps e) = objectAccess ps (expr e) 155 | expr (ObjectUpdate _ e xs) = objectUpdate (map (over _2 expr) xs) (expr e) 156 | expr (Abs _ id e) = lambda1 (localVar id) (expr e) 157 | expr (App _ e0 e1) = funcall1 (expr e0) (expr e1) 158 | expr (Var _ qident) = var qident 159 | expr (Case _ es cas) = case' (map expr es) cas 160 | expr (Let _ binds e) = let' binds (expr e) 161 | 162 | -- nil 及び t は特別な定数でありは束縛やsetqはできない。 163 | -- vectorのリテラル表記 [a b] は a や b を評価しないことに注意。 164 | -- そのためvectorのリテラル表記ではなく vector関数を使う必要がある 165 | -- 166 | -- A vector, like a string or a number, is considered a constant for evaluation: 167 | -- the result of evaluating it is the same vector. This does not evaluate or 168 | -- even examine the elements of the vector. 169 | -- 170 | literal :: Given ModuleName => Literal (Expr Ann) -> SExp 171 | literal (NumericLiteral (Left i)) = integer i 172 | literal (NumericLiteral (Right d)) = double d 173 | literal (StringLiteral ps) = string $ psstring ps 174 | literal (CharLiteral c) = character c 175 | literal (BooleanLiteral b) = bool C.nil C.t b 176 | literal (ArrayLiteral exs) = funcallNative "vector" (map expr exs) 177 | literal (ObjectLiteral xs) = objectLiteral $ map (over _2 expr) xs 178 | 179 | -- 型チェックの都合上 Prim.undefinedという未定義の参照が入ることがある。 180 | -- (実装に問題がなければ)参照されることはないので適当な未定義の参照に置き換える。 181 | -- -> 違うっぽい。参照はされるが使われることはない,かな。なので 'ps-prim-undefined に。 182 | var :: Qualified Ident -> SExp 183 | var v@(Qualified mn id) 184 | | v == primUndefined = quotedSymbol "ps-prim-undefined" 185 | | otherwise = symbol (maybe localVar globalVar mn id) 186 | where 187 | primUndefined = mkQualified (Ident C.undefined) C.Prim 188 | 189 | -- Rec(相互参照と自己参照など) と NonRec があるので注意が必要。 190 | -- PSのletは順序関係なし(順序によってshadowingは変化しない) 191 | -- 全部 letrec で束縛してしまうのが多分正解かな？ 192 | -- ただ殆どのケースで let* (頑張れば let)で十分なのに letrec は微妙か？ 193 | -- NonRec のみなら let*,一つでも Rec があれば letrec でいいかな。 194 | let' :: Given ModuleName => [Bind Ann] -> SExp -> SExp 195 | let' binds = letC bindS 196 | where 197 | ext :: Bind a -> [((Ident, Expr a), Bool)] 198 | ext = \case 199 | NonRec _ ident expr -> [((ident, expr), False)] 200 | Rec bs -> map ((,True) . over _1 snd) bs 201 | 202 | binds' = 203 | mconcat $ map ext binds 204 | 205 | letC = 206 | if any snd binds' 207 | then letRec 208 | else letStar 209 | 210 | bindS = 211 | map (bimap localVar expr . fst) binds' 212 | 213 | -- pcaseマクロを利用する 214 | -- 215 | -- 対象がリストなのはカンマ区切りで複数対象を指定できるので(e.g. case a, b of) 216 | -- 各CaseAlternativeは同じ数だけのbinderが必要。 217 | -- 複数指定の場合はリストに包んでpcaseに適用させる。(e.g. (pcase (list a b) ..)) 218 | case' :: Given ModuleName => [SExp] -> [CaseAlternative Ann] -> SExp 219 | case' ss cas = pcase ss cases 220 | where 221 | -- マッチング節が一つしかなくガード節を使っている場合は cond が利用できる。 222 | cases :: [PcaseAlt SExp] 223 | cases = case cas of 224 | [] -> 225 | [] 226 | [CaseAlternative bs (Left xs)] -> 227 | [ PcaseAlt 228 | { patterns = map binder bs 229 | , guard = Nothing 230 | , code = cond (map (bimap expr expr) xs) 231 | } 232 | ] 233 | cs -> 234 | concatMap caseAlt cs 235 | 236 | -- ガード毎に別のマッチングにする必要がある。 237 | -- あるマッチング節のいずれのガード節でも該当しない場合次のマッチング節に移る必要があるが, 238 | -- マッチング節一つでcondで分岐した場合,移ることができないため。そのためにリストを返している。 239 | -- 同じbinderなのにガード節毎にbinderが重複する形になるが仕方なし。 240 | caseAlt :: CaseAlternative Ann -> [PcaseAlt SExp] 241 | caseAlt (CaseAlternative bs e) = do 242 | (guard', ex) <- case e of 243 | Left xs -> do 244 | (guard, ex) <- xs 245 | pure (Just guard, ex) 246 | Right ex -> 247 | pure (Nothing, ex) 248 | pure $ 249 | PcaseAlt 250 | { patterns = map binder bs 251 | , guard = expr <$> guard' 252 | , code = expr ex 253 | } 254 | 255 | -- (1) 256 | -- newtypeのマッチングの場合はConstructorBindersが呼ばれる。 257 | -- 当然newtypeなので下の値がそのまま入っているサブbinderは一つのはず。 258 | -- Annのメタ情報を見る必要がある。 259 | -- 260 | -- (2) 261 | -- QualifiedのmnはMaybe ModuleNameである。 262 | -- どのようなケースでNothingとなるのか？ 263 | binder :: Binder Ann -> PPattern SExp 264 | binder (NullBinder _) = 265 | PAny 266 | binder (LiteralBinder _ lit) = 267 | literalBinder lit 268 | binder (VarBinder _ id) = 269 | PBind $ localVar id 270 | binder (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) = 271 | binder b -- (1) 272 | binder (ConstructorBinder (_, _, _, Just IsNewtype) _ _ _bs) = 273 | error "Unexpected binding" 274 | binder (ConstructorBinder _ (Qualified (Just mn) tname) (Qualified _ cname) bs) = 275 | constructorBinder mn tname cname (map binder bs) 276 | binder (ConstructorBinder _ (Qualified Nothing tname) (Qualified _ cname) bs) = 277 | error "Unexpected binding" -- (2) 278 | binder (NamedBinder _ id b) = 279 | PAnd [PBind (localVar id), binder b] 280 | 281 | -- boolean binder と object binder がやっかい。 282 | -- boolean binder だからといって単に t, nil というシンボル使っても意味がない 283 | -- (pred ..) を使って nil か t(nil以外)を判別する必要がある。 284 | -- floatのbinderも使えないので pred + = を使う必要がある。 285 | literalBinder :: Literal (Binder Ann) -> PPattern SExp 286 | literalBinder (NumericLiteral (Left i)) = 287 | PInteger i 288 | literalBinder (NumericLiteral (Right d)) = 289 | PPred (lambda1 "v" (funcallNative "=" [symbol "v", double d])) 290 | literalBinder (StringLiteral ps) = 291 | PString $ psstring ps 292 | literalBinder (CharLiteral c) = 293 | PCharacter c 294 | literalBinder (BooleanLiteral b) = 295 | PPredBool b 296 | literalBinder (ArrayLiteral bs) = 297 | PBackquotedVector $ map binder bs 298 | literalBinder (ObjectLiteral xs) = 299 | objectLiteralBinder $ map (over _2 binder) xs 300 | 301 | -- | DataType 302 | 303 | -- データ型は先頭にタグの入ったベクターで表現する。 304 | -- ただし引数を持たないコンストラクタはシンボルのみで表現する。 305 | -- 306 | -- e.g. Foo 1 2 -> ['Foo 1 2] 307 | -- e.g. Nothing -> 'Nothing 308 | -- 309 | -- consturctorはデータ型の定義箇所で呼ばれる。 310 | -- (newtype のコンスラクタははidentity関数にbindされる)。 311 | -- 例えば Data.List.Types には List型が次のように定義されている。 312 | -- 313 | -- data List a = Nil | Cons a (List a) 314 | -- 315 | -- NilとConsコンストラクに対してそれぞれconstructor関数が呼ばれ, 316 | -- 次のコンストラクタ関数が定義される。 317 | -- 318 | -- (defvar Data.List.Types.Nil (vector 'Nil)) 319 | -- (defvar Data.List.Types.Cons (lambda (value0) (lambda (value1) (vector 'Cons value0 value1)))) 320 | -- 321 | -- ただList型に関しては特別に elisp に於けるリストで表現する。 322 | -- リストはlispに於いて普遍的に使われる構造でありリストを表現に持つデータ型により 323 | -- Elisp/PureScript間のデータの遣り取りが自然に書けるようになる。 324 | -- 325 | -- Tupleも同様の理由で特別な表現を持たせる。Tuple a b は (cons a b) で表現する。 326 | -- ListのConsコンストラクタと混同しないように。 327 | -- 328 | constructor :: 329 | Given ModuleName => 330 | ProperName 'TypeName -> 331 | ProperName 'ConstructorName -> 332 | [Ident] -> 333 | SExp 334 | constructor (ProperName "List") cname ids 335 | | ModuleName "Data.List.Types" <- currentModuleName = 336 | case (cname, ids) of 337 | (ProperName "Nil", []) -> C.nil 338 | (ProperName "Cons", [_, _]) -> constructorNative "cons" ids 339 | _ -> error "Unexpected List constcutor" 340 | constructor (ProperName "Tuple") cname ids 341 | | ModuleName "Data.Tuple" <- currentModuleName = 342 | case (cname, ids) of 343 | (ProperName "Tuple", [_, _]) -> constructorNative "cons" ids 344 | _ -> error "Unexpected Tuple constcutor" 345 | constructor tname cname ids = 346 | case NonEmpty.nonEmpty (map localVar ids) of 347 | Just args -> 348 | let vals = map symbol $ NonEmpty.toList args 349 | in lambda1Fold args 350 | . funcallNative "vector" 351 | $ quotedSymbol (constructorTag cname) : vals 352 | Nothing -> 353 | quotedSymbol (constructorTag cname) 354 | 355 | -- 特別扱いのデータ型のみ使う 356 | constructorNative :: Symbol -> [Ident] -> SExp 357 | constructorNative name ids = 358 | lambda1Fold args (funcallNative name vals) 359 | where 360 | args = localVar <$> NonEmptyPartial.fromList ids 361 | vals = map symbol $ NonEmpty.toList args 362 | 363 | -- e.g. `[Foo ,e0 ,e1] 364 | constructorBinder :: 365 | ModuleName -> 366 | ProperName 'TypeName -> 367 | ProperName 'ConstructorName -> 368 | [PPattern SExp] -> 369 | PPattern SExp 370 | constructorBinder (ModuleName "Data.List.Types") (ProperName "List") cname binds = 371 | case (cname, binds) of 372 | (ProperName "Nil", []) -> PBackquotedList [] 373 | (ProperName "Cons", [car, cdr]) -> PBackquotedCons car cdr 374 | _ -> error "Unexpected List binder" 375 | constructorBinder (ModuleName "Data.Tuple") (ProperName "Tuple") cname binds = 376 | case (cname, binds) of 377 | (ProperName "Tuple", [car, cdr]) -> PBackquotedCons car cdr 378 | _ -> error "Unexpected Tuple binder" 379 | constructorBinder _ _ cname [] = 380 | PSymbol (constructorTag cname) 381 | constructorBinder _ _ cname binds = 382 | PBackquotedVector $ PSymbol (constructorTag cname) : binds 383 | 384 | constructorTag :: ProperName 'ConstructorName -> Symbol 385 | constructorTag = mkSymbol . runProperName 386 | 387 | -- | Object 388 | 389 | -- Assocation List 390 | objectLiteral :: [(PSString, SExp)] -> SExp 391 | objectLiteral xs = alist $ map (over _1 objectField) xs 392 | 393 | -- pcaseに使われるbinder 394 | -- 複数ある場合は and で連結する必要がある。 395 | -- alistを使っての構造分解はできない。順序が異なるし,部分的にマッチングも有りえるため。 396 | -- (app (lambda (v) (alist-get ' v)) PATTERN) を利用する 397 | -- lambda1 で名前vが導入されているが,シャドウする危険はない。 398 | objectLiteralBinder :: [(PSString, PPattern SExp)] -> PPattern SExp 399 | objectLiteralBinder = \case 400 | [] -> PAny 401 | [(ps, bind')] -> bind (objectField ps, bind') 402 | bs -> PAnd $ map (bind . over _1 objectField) bs 403 | where 404 | bind (field, bind') = 405 | PApp 406 | ( lambda1 407 | "v" 408 | ( funcallNative 409 | "psel/alist-get" 410 | [ quotedSymbol field 411 | , symbol "v" 412 | ] 413 | ) 414 | ) 415 | bind' 416 | 417 | -- e.g. (cdr (assq 'foo obj)) 418 | objectAccess :: PSString -> SExp -> SExp 419 | objectAccess fname obj = 420 | funcallNative 421 | "psel/alist-get" 422 | [ quotedSymbol (objectField fname) 423 | , obj 424 | ] 425 | 426 | -- 標準で非破壊的にalistを設定するための関数が提供されていない。 427 | -- (copy-alist + setf + alist-get で出来なくはないがややこい)。 428 | -- psel.el からimmutableにalist を更新するpset/alist-set関数を提供する。 429 | -- e.g. (psel/alist-set 'foo 1 (psel/alist-set 'bar "a" obj)) 430 | -- 431 | -- またレコードの更新構文を使ったとしても必ずしもObjectUpdateにコンパイルされるわけではない。 432 | -- (恐らく)レコードが小さければレコードリテラル+フィールド参照に置き換えられる。 433 | objectUpdate :: [(PSString, SExp)] -> SExp -> SExp 434 | objectUpdate updates obj = foldl' alistSet obj updates 435 | where 436 | alistSet obj (fname, s) = 437 | funcallNative 438 | "psel/alist-set" 439 | [ quotedSymbol (objectField fname) 440 | , s 441 | ] 442 | 443 | -- PSのフィールド名をそのままSymbolにして使う 444 | objectField :: PSString -> Symbol 445 | objectField = mkSymbol . psstring 446 | 447 | -- | PSString 448 | 449 | -- 参照 450 | -- https://hackage.haskell.org/package/purescript-0.13.8/docs/Language-PureScript-PSString.html#t:PSString 451 | -- https://github.com/purescript/purescript/issues/2434 452 | -- 453 | -- 何やら厄介な話。 454 | -- Strings in PureScript are sequences of UTF-16 code units, 455 | -- which do not necessarily represent UTF-16 encoded text. 456 | -- 457 | -- lone surrogatesが含まれる場合が厄介らしい。 458 | -- 恐らく殆んど使われることはないと思うので docodeStringで Nothingの場合はエラーを投げる 459 | -- https://hackage.haskell.org/package/purescript-0.13.8/docs/Language-PureScript-PSString.html#v:decodeString 460 | -- 461 | psstring :: PSString -> Text 462 | psstring ps = case PS.decodeString ps of 463 | Just t -> t 464 | Nothing -> error "Unexpected one surragates in string literal" 465 | -------------------------------------------------------------------------------- /test-bare.purs/.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /output.*/ 6 | /generated-docs/ 7 | /.psc-package/ 8 | /.psc* 9 | /.purs* 10 | /.psa* 11 | /.spago 12 | -------------------------------------------------------------------------------- /test-bare.purs/packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = {=} in upstream 102 | -------------------------------------------------------------------------------- /test-bare.purs/spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | 5 | Need help? See the following resources: 6 | - Spago documentation: https://github.com/purescript/spago 7 | - Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html 8 | 9 | When creating a new Spago project, you can use 10 | `spago init --no-comments` or `spago init -C` 11 | to generate this file without the comments in this block. 12 | -} 13 | { name = "psel test" 14 | , dependencies = [] : List Text 15 | , packages = ./packages.dhall 16 | , backend = "psel" 17 | , sources = [ "test/**/*.purs" ] 18 | } 19 | -------------------------------------------------------------------------------- /test-bare.purs/test/Main.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | 3 | (defvar Test.Main.mkMainLike 4 | (lambda (f) 5 | (lambda () 6 | (funcall f nil)))) 7 | -------------------------------------------------------------------------------- /test-bare.purs/test/Main.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | exports.mkMainLike = function(f) { 4 | return function() { 5 | return f(); 6 | }; 7 | }; 8 | -------------------------------------------------------------------------------- /test-bare.purs/test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Test.PsEl.TCO 4 | import Test.PsEl.Record 5 | import Test.Utils 6 | 7 | -- Pre-prelude world. We don't have == nor Effect yet. 8 | -- Elisp特有の事情だが、レコードの比較は単純なequalでできないため別関数に分けている。 9 | -- spagoからのmain関数起動は無引数の呼出しを想定しているが、 10 | -- Effectモジュールが使えるまでFFIで関数を無引数関数で包む必要がある。 11 | foreign import data MainLike :: Type 12 | foreign import mkMainLike :: forall a. ({} -> a) -> MainLike 13 | 14 | main :: MainLike 15 | main = mkMainLike main' 16 | 17 | -- we don't have Effect nor Binding(do block) yet. 18 | main' :: {} -> Array (Array Boolean) 19 | main' _ = 20 | [ testLet {} 21 | , testCond {} 22 | , testCase {} 23 | , testTypeClass {} 24 | , testTCO {} 25 | , testRecord {} 26 | ] 27 | 28 | testCond :: {} -> Array Boolean 29 | testCond _ = 30 | [ assertEqual "if(1)" (f true) 1 31 | , assertEqual "if(2)" (f false) 0 32 | , assertEqual "guard(1)" (g true) "b" 33 | , assertEqual "guard(2)" (g false) "o" 34 | ] 35 | where 36 | f b = if b then 1 else 0 37 | g b 38 | | b = "b" 39 | | true = "o" 40 | 41 | testLet :: {} -> Array Boolean 42 | testLet _ = 43 | [ let a = 1 44 | b = [a, a] 45 | in assertEqual "let(1)" b [1,1] 46 | , let a [] = b [1] 47 | a [x] = b [x, x] 48 | a xs = xs 49 | b [] = a [] 50 | b [x] = a [x] 51 | b [x, _] = a [x, x, x] 52 | b _ = [] 53 | in assertEqual "letrec(1)" (b []) [1,1,1] 54 | ] 55 | 56 | testCase :: {} -> Array Boolean 57 | testCase _ = 58 | [ assertEqual "case int(1)" (caseInt 1) "a" 59 | , assertEqual "case int(2)" (caseInt 2) "b" 60 | , assertEqual "case int(3)" (caseInt 3) "c" 61 | , assertEqual "case number(1)" (caseNumber 1.1) "a" 62 | , assertEqual "case number(2)" (caseNumber 2.2) "b" 63 | , assertEqual "case number(3)" (caseNumber 1.11) "c" 64 | , assertEqual "case boolean(1)" (caseBoolean true) "true" 65 | , assertEqual "case boolean(2)" (caseBoolean false) "false" 66 | , assertEqual "case record(1)" (caseRecord { a: 1, b: "foo" }) "a" 67 | , assertEqual "case record(2)" (caseRecord { a: 2, b: "foo" }) "foo" 68 | , assertEqual "case record(3)" (caseRecord { a: 3, b: "foo" }) "c" 69 | , assertEqual "case array(1)" (caseArray []) "empty" 70 | , assertEqual "case array(2)" (caseArray ["a"]) "a" 71 | , assertEqual "case array(3)" (caseArray ["a","b","c"]) "b" 72 | , assertEqual "case array(4)" (caseArray ["a","b","b"]) "other" 73 | , assertEqual "case datatype(1)" (caseDataType Zero) "zero" 74 | , assertEqual "case datatype(2)" (caseDataType (One "a")) "a" 75 | , assertEqual "case datatype(3)" (caseDataType (Two "1" 1)) "1" 76 | , assertEqual "case datatype(4)" (caseDataType (Two "1" 2)) "other" 77 | , assertEqual "case newtype(1)" (caseNewType (NT "a")) "a!" 78 | , assertEqual "case newtype(2)" (caseNewType (NT "b")) "b" 79 | , assertEqual "case as(1)" (caseAs [[1,9],[3,4]]) [1,9] 80 | , assertEqual "case as(2)" (caseAs [[1,2],[3,9]]) [3,9] 81 | , assertEqual "case multiple(1)" (caseMultiple 1 "a") "1a" 82 | , assertEqual "case multiple(2)" (caseMultiple 1 "c") "c" 83 | , assertEqual "case multiple(3)" (caseMultiple 2 "a") "2" 84 | , assertEqual "case multiple(4)" (caseMultiple 1 "b") "b" 85 | , assertEqual "case multiple(5)" (caseMultiple 1 "c") "c" 86 | , assertEqual "case complex(1)" (caseComplex { a: [] }) [] 87 | , assertEqual "case complex(2)" (caseComplex { a: [{a1: "a", a2: { a3: "b"}}] }) ["a"] 88 | , assertEqual "case complex(3)" (caseComplex { a: [{a1: "a", a2: { a3: "b"}}, {a1: "c", a2: { a3: "d"}}] }) ["a", "d"] 89 | , assertEqual "case guard(1)" (caseGuard { a: true, b: true }) "a" 90 | , assertEqual "case guard(2)" (caseGuard { a: true, b: false }) "a" 91 | , assertEqual "case guard(3)" (caseGuard { a: false, b: true }) "b" 92 | , assertEqual "case guard(4)" (caseGuard { a: false, b: false }) "c" 93 | ] 94 | 95 | caseInt :: Int -> String 96 | caseInt = case _ of 97 | 1 -> "a" 98 | 2 -> "b" 99 | _ -> "c" 100 | 101 | caseNumber :: Number -> String 102 | caseNumber = case _ of 103 | 1.1 -> "a" 104 | 2.2 -> "b" 105 | _ -> "c" 106 | 107 | caseBoolean :: Boolean -> String 108 | caseBoolean = case _ of 109 | true -> "true" 110 | false -> "false" 111 | 112 | caseRecord :: {a :: Int, b :: String} -> String 113 | caseRecord = case _ of 114 | { a: 1 } -> "a" 115 | { b: v, a: 2 } -> v 116 | _ -> "c" 117 | 118 | caseArray :: Array String -> String 119 | caseArray = case _ of 120 | [] -> "empty" 121 | [v] -> v 122 | ["a", v, "c"] -> v 123 | _ -> "other" 124 | 125 | data DT 126 | = Zero 127 | | One String 128 | | Two String Int 129 | 130 | caseDataType :: DT -> String 131 | caseDataType = case _ of 132 | Zero -> "zero" 133 | One s -> s 134 | Two s 1 -> s 135 | Two _ _ -> "other" 136 | 137 | newtype NT = NT String 138 | 139 | caseNewType :: NT -> String 140 | caseNewType = case _ of 141 | NT "a" -> "a!" 142 | NT s -> s 143 | 144 | caseAs :: Array (Array Int) -> Array Int 145 | caseAs = case _ of 146 | [t@[1, _], [3, 4]] -> t 147 | [[1, 2], v@[_, 9]] -> v 148 | _ -> [] 149 | 150 | caseMultiple :: Int -> String -> String 151 | caseMultiple = case _,_ of 152 | 1, "a" -> "1a" 153 | 2, _ -> "2" 154 | _, "b" -> "b" 155 | _, _ -> "c" 156 | 157 | caseComplex :: { a :: Array { a1 :: String, a2 :: { a3 :: String }}} -> Array String 158 | caseComplex = case _ of 159 | { a: [{ a1: "a"}] } -> ["a"] 160 | { a: [{ a1: v1, a2: _}, { a1: _, a2: { a3: v2}} ] } -> [v1, v2] 161 | _ -> [] 162 | 163 | caseGuard :: { a :: Boolean, b :: Boolean } -> String 164 | caseGuard = case _ of 165 | o 166 | | o.a -> "a" 167 | | o.b -> "b" 168 | o -> "c" 169 | 170 | testTypeClass :: {} -> Array Boolean 171 | testTypeClass _ = 172 | [ assertEqual "type class(1)" (m1 1) "int" 173 | , assertEqual "type class(2)" (m2 1) 1 174 | , assertEqual "type class(3)" (m1 "b") "b" 175 | , assertEqual "type class(4)" (m2 "b") 0 176 | ] 177 | 178 | class TC a where 179 | m1 :: a -> String 180 | m2 :: a -> Int 181 | 182 | instance tcInt :: TC Int where 183 | m1 _ = "int" 184 | m2 a = a 185 | 186 | instance tcString :: TC String where 187 | m1 s = s 188 | m2 _ = 0 189 | -------------------------------------------------------------------------------- /test-bare.purs/test/PsEl/Record.purs: -------------------------------------------------------------------------------- 1 | module Test.PsEl.Record where 2 | 3 | import Test.Utils 4 | 5 | testRecord :: {} -> Array Boolean 6 | testRecord _ = 7 | [ assertEqual "record access(1)" rec1.a 1 8 | , assertEqual "record access(2)" rec1.a' 2 9 | , assertEqual "record access(3)" rec1." a+-*/{}()'\"\\ " 3 10 | , assertEqual "record access(4)" rec1."123" 4 11 | , assertEqualRecord "record update(1)" (rec2 { a = 2 }) { a:2, b:2 } 12 | , assertEqualRecord "record update(2)" (rec2 { b = 1 }) { a:1, b:1 } 13 | ] 14 | where 15 | -- レコード任意の文字列をフォールド名として持てる 16 | rec1 = 17 | { a: 1 18 | , a': 2 19 | , " a+-*/{}()'\"\\ ": 3 20 | , "123": 4 21 | } 22 | 23 | rec2 = { a: 1, b: 2 } 24 | -------------------------------------------------------------------------------- /test-bare.purs/test/PsEl/TCO.purs: -------------------------------------------------------------------------------- 1 | module Test.PsEl.TCO where 2 | 3 | import Test.Utils 4 | 5 | testTCO :: {} -> Array Boolean 6 | testTCO _ = 7 | [ assertEqual "self recursion(1-1) 10" (selfRec1 0 10) 1 8 | , assertEqual "self recursion(1-2) 10000" (selfRec1 0 10000) 1 9 | , assertEqual "self recursion(2-1) 10" ((selfRec2 0 10) {}) 1 10 | , assertEqual "self recursion(2-2) 10000" ((selfRec2 0 10000) {}) 1 11 | , assertEqual "self recursion(3) 20" (selfRec3 0 20) 2 12 | , assertEqual "self recursion(4-1) 10" (selfRec4 0 10) 1 13 | -- , assertEqual "self recursion(4-2) 10000" (selfRec4 0 10000) 1 14 | , assertEqual "self recursion(5-1) 10" (selfRec5 0 10) 1 15 | -- , assertEqual "self recursion(5-2) 10000" (selfRec5 0 10000) 1 16 | , assertEqual "self recursion(6-1) 10" (selfRec6 0 10) 1 17 | -- , assertEqual "self recursion(6-2) 10000" (selfRec6 0 10000) 1 18 | , assertEqual "self recursion(7-1) 10" (selfRec7 0 10) 1 19 | , assertEqual "self recursion(7-2) 10000" (selfRec7 0 10000) 1 20 | , assertEqual "self recursion(8-1) 10" (selfRec8 10) 1 21 | , assertEqual "self recursion(8-2) 10" (selfRec8 10000) 1 22 | -- to check partial applied i is not changed 23 | , assertEqual "self recursion(8-3) 10" (selfRec8 10) 1 24 | ] 25 | 26 | selfRec1 :: Int -> Int -> Int 27 | selfRec1 i to 28 | | eqInt i to = 1 29 | | true = selfRec1 (succInt i) to 30 | 31 | selfRec2 :: Int -> Int -> {} -> Int 32 | selfRec2 i to 33 | | eqInt i to = \_ -> 1 34 | | true = selfRec2 (succInt i) to 35 | 36 | -- 末尾呼出しと非末尾呼出しが混在している場合、結構ややこい 37 | -- JS backend doesn't apply TCO for this function. 38 | -- 多分非末尾呼出しが混在しているからかな。末尾呼出しの方が取れほど呼ばれるかは不明だからか。 39 | selfRec3 :: Int -> Int -> Int 40 | selfRec3 i to 41 | | eqInt i to = 1 42 | | eqInt i 10 = succInt (selfRec3 (succInt i) to) -- non-recursive call 43 | | true = selfRec3 (succInt i) to -- recursive call 44 | 45 | -- lambda 46 | selfRec4 :: Int -> Int -> Int 47 | selfRec4 i to = go i 48 | where 49 | go i 50 | | eqInt i to = 1 51 | | true = selfRec4 (succInt i) to 52 | 53 | -- 再帰関数のローカル変数も再帰関数の場合。 54 | -- top-downに再帰関数をloop化した場合でも正常に動作する必要あり。 55 | -- これJS正しいのか？？？怪しいところ 56 | selfRec5 :: Int -> Int -> Int 57 | selfRec5 i to 58 | | eqInt i to = 1 59 | | eqInt i 10 = go i 60 | where 61 | go i 62 | | eqInt i 20 = go (succInt i) 63 | | true = selfRec5 i to 64 | | true = selfRec5 (succInt i) to 65 | 66 | -- JS backend doesn't optimize this case, though it should be able. 67 | -- Rare case. 68 | selfRec6 :: Int -> Int -> Int 69 | selfRec6 i to 70 | | eqInt i to = 1 71 | | true = 72 | let f = selfRec6 (succInt i) 73 | in f to 74 | 75 | -- ローカルな自己再帰関数 76 | selfRec7 :: Int -> Int -> Int 77 | selfRec7 i to = go i to 78 | where 79 | go i to 80 | | eqInt i to = 1 81 | | true = go (succInt i) to 82 | 83 | -- ローカルな自己再帰関数(部分適用版) 84 | selfRec8 :: Int -> Int 85 | selfRec8 = go 0 86 | where 87 | go i to 88 | | eqInt i to = 1 89 | | true = go (succInt i) to 90 | 91 | 92 | -- 型クラス使って辞書受け取るバージョンも 93 | -------------------------------------------------------------------------------- /test-bare.purs/test/Utils.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | 3 | (defvar Test.Utils.assertEqual 4 | (lambda (label) 5 | (lambda (a) 6 | (lambda (b) 7 | (message label) 8 | (if (equal a b) 9 | t 10 | (psel/assert-error label)))))) 11 | 12 | (defvar Test.Utils.assertEqualRecord 13 | (lambda (label) 14 | (lambda (a) 15 | (lambda (b) 16 | (message label) 17 | (if (psel/alist-equal a b) 18 | t 19 | (psel/assert-error label)))))) 20 | 21 | (defvar Test.Utils.eqInt 22 | (lambda (a) 23 | (lambda (b) 24 | (= a b)))) 25 | 26 | (defvar Test.Utils.succInt 27 | (lambda (i) 28 | (1+ i))) 29 | -------------------------------------------------------------------------------- /test-bare.purs/test/Utils.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | exports.assertEqual = function(label) { 4 | return function(a) { 5 | return function(b) { 6 | console.log(label); 7 | // 取り敢えず実装 8 | return true; 9 | // if (a == b) { 10 | // return true; 11 | // } else { 12 | // throw new Error(label); 13 | // } 14 | }; 15 | }; 16 | }; 17 | 18 | exports.assertEqualRecord = function(label) { 19 | return function(a) { 20 | return function(b) { 21 | console.log(label); 22 | // 取り敢えず実装 23 | return true; 24 | }; 25 | }; 26 | }; 27 | 28 | exports.eqInt = function(a) { 29 | return function(b) { 30 | return a == b; 31 | }; 32 | }; 33 | 34 | exports.succInt = function(a) { 35 | return a + 1; 36 | }; 37 | -------------------------------------------------------------------------------- /test-bare.purs/test/Utils.purs: -------------------------------------------------------------------------------- 1 | module Test.Utils where 2 | 3 | foreign import assertEqual :: forall a. String -> a -> a -> Boolean 4 | foreign import assertEqualRecord :: forall r. String -> { | r } -> { | r } -> Boolean 5 | 6 | -- for tests 7 | foreign import eqInt :: Int -> Int -> Boolean 8 | foreign import succInt :: Int -> Int 9 | -------------------------------------------------------------------------------- /test-lib.purs/.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /output.*/ 6 | /generated-docs/ 7 | /.psc-package/ 8 | /.psc* 9 | /.purs* 10 | /.psa* 11 | /.spago 12 | -------------------------------------------------------------------------------- /test-lib.purs/spago.dhall: -------------------------------------------------------------------------------- 1 | { name = "test-lib" 2 | , dependencies = 3 | [ "prelude" 4 | , "effect" 5 | , "console" 6 | , "assert" 7 | , "refs" 8 | , "lists" 9 | , "functions" 10 | , "tuples" 11 | ] 12 | , packages = 13 | https://raw.githubusercontent.com/psel-org/package-sets/main/src/el-0.14.5-20211116/packages.dhall 14 | , backend = "psel" 15 | , sources = [ "test/**/*.purs" ] 16 | } 17 | -------------------------------------------------------------------------------- /test-lib.purs/test/Main.el: -------------------------------------------------------------------------------- 1 | ;; -*- lexical-binding: t; -*- 2 | 3 | (defvar Test.Main.nativeList 4 | '(1 2 3)) 5 | 6 | (defvar Test.Main.add2 7 | (lambda (a b) 8 | (+ a b))) 9 | -------------------------------------------------------------------------------- /test-lib.purs/test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Effect 5 | import Effect.Ref as Ref 6 | import Effect.Console (log) 7 | import Test.Assert (assertEqual) 8 | import Data.List 9 | import Data.Tuple as Tuple 10 | import Data.Function.Uncurried 11 | 12 | main :: Effect Unit 13 | main = do 14 | testApply 15 | testEffect 16 | testList 17 | testTuple 18 | testFunctionUncurried 19 | 20 | testApply :: Effect Unit 21 | testApply = do 22 | log "apply(1)" 23 | assertEqual 24 | { actual: (+) 1 $ 1 25 | , expected: 2 26 | } 27 | log "apply(2)" 28 | assertEqual 29 | { actual: (+) 1 $ (+) 1 $ 1 30 | , expected: 3 31 | } 32 | log "applyFlipped(1)" 33 | assertEqual 34 | { actual: 1 # (+) 1 35 | , expected: 2 36 | } 37 | log "applyFlipped(2)" 38 | assertEqual 39 | { actual: 1 # (+) 1 # (+) 1 40 | , expected: 3 41 | } 42 | 43 | testEffect :: Effect Unit 44 | testEffect = do 45 | log "effect(1)" 46 | v <- testEffect1 47 | assertEqual { actual: v, expected: 4 } 48 | 49 | -- disgarding effects 50 | testEffect1 :: Effect Int 51 | testEffect1 = do 52 | ref <- Ref.new 1 53 | succVoid ref 54 | _ <- succ ref 55 | succVoid ref 56 | val <- Ref.read ref 57 | pure val 58 | where 59 | succ ref = Ref.modify (_ + 1) ref 60 | succVoid ref = void $ Ref.modify (_ + 1) ref 61 | 62 | foreign import nativeList :: List Int 63 | 64 | testList :: Effect Unit 65 | testList = do 66 | let l = (1..3) 67 | log "list(1)" 68 | assertEqual { actual: nativeList, expected: l } 69 | log "list(2)" 70 | assertEqual { actual: f nativeList, expected: 6 } 71 | assertEqual { actual: f l, expected: 6 } 72 | where 73 | f (Cons a (Cons b (Cons c Nil))) = a + b + c 74 | f _ = 0 75 | 76 | testTuple :: Effect Unit 77 | testTuple = do 78 | log "tuple(1)" 79 | assertEqual { actual: Tuple.fst a, expected: 1 } 80 | log "tuple(2)" 81 | assertEqual { actual: Tuple.snd a, expected: "a" } 82 | where 83 | a = Tuple.Tuple 1 "a" 84 | 85 | foreign import add2 :: Fn2 Int Int Int 86 | 87 | add2Wrapper :: Int -> Int -> Int 88 | add2Wrapper a b = runFn2 add2 a b 89 | 90 | testFunctionUncurried :: Effect Unit 91 | testFunctionUncurried = do 92 | log "function uncurried(1)" 93 | assertEqual { actual: runFn2 add2 1 2, expected: 3 } 94 | log "function uncurried(2)" 95 | let t = runFn2 add2 1 96 | assertEqual { actual: t 3, expected: 4 } 97 | assertEqual { actual: t 4, expected: 5 } 98 | log "function uncurried(3)" 99 | assertEqual { actual: add2Wrapper 1 2, expected: 3 } 100 | --------------------------------------------------------------------------------