diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,76 @@ +# hsjuiz の変更履歴 + +hsjuiz の版は juiz(crates.io の juiz_app、PyPI の pyjuiz / juiz-cli)と同じ番号にそろえています。 +使う libjuiz_sdk も同じ版にしてください。 + +## 0.2.6 + +- hsjuiz の API は 0.2.5 から変えていない(juiz 本体の雛形生成コマンド juiz pkg create / add #455 に版をそろえた)。 + +## 0.2.5 + +- hsjuiz の API は 0.2.4 から変えていない(juiz 本体の juiz run --remap・--depend 名前=none #452、CLI のヘルプ文言 #447 に版をそろえた)。 + +## 0.2.4 + +- ContainerProcess の中から自分以外の Container の位置姿勢を読む `lookupContainerPose` を足した(issue #409)。 +- ContainerProcess の中から Transform の値を書く `setTransform` と、`ContainerTransform`・`identityTransform`・ + `transformToValue`・`transformStampedToValue` を足した。書けないときは `juizTransformNotWritableError`、 + Transform が無いときは `juizTransformNotFoundError`(issue #410)。 + +## 0.2.3 + +- hsjuiz の API は 0.2.2 から変えていない(juiz 本体の不具合修正 #400〜#437 に版をそろえた)。 + Windows で readonly の ContainerProcess を公開する例の .def の書き忘れを直した(#435)。 + +## 0.2.2 + +- readonly の ContainerProcess を書けるようにした。manifest に `& readonly True` を付けると、juiz は Container を + 読み出しロックで呼び、同じ Container の readonly 同士は並行に走る。中で `setContainerPose` を呼ぶと + `juizPoseNotWritableError`(Transformations Step 11、issue #377)。`ProcessManifest` に `pmReadonly` を足した。 + +## 0.2.1 + +- hsjuiz の API は 0.2.0 から変えていない(juiz 本体の System をまたぐ Transform #376 に版をそろえた)。 + +## 0.2.0 + +- ContainerProcess の中から Container の位置姿勢を読み書きする `Juiz.Pose`(`containerPose`・`setContainerPose`・ + `poseToValue`・`poseStampedToValue`)とエラーコード `juizTransformationsNotAttachedError` など(-901〜-905)を足した + (Transformations Step 5、issue #372)。 + +## 0.1.0 + +- 0.0 系を締めくくる版。hsjuiz の API は 0.0.30 から変えていない(juiz 本体の Windows の Haskell DLL の修正 #262、libjuiz_sdk の版照合 #344、HTTP ブローカーの並行化 #356・#362 などに版をそろえた)。 + +## 0.0.30 + +- 対応する GHC を全 OS で 9.6 以降にそろえた。`tested-with` から 9.4.7 を外し、`base` の下限を 4.18(GHC 9.6)に上げた(issue #310)。 +- hsjuiz のほかの変更はない(juiz 本体の Rust プラグインの C ABI 化 #291 などに版をそろえた)。 + +## 0.0.29 + +- hsjuiz 自体の変更はない(juiz 本体の修正 #301・#303・#304 に版をそろえた)。 + +## 0.0.28 + +- アプリ配布形式 `.juizapp` に Haskell のプラグインを入れるため、`scripts/bundle-plugin-deps.sh` で + プラグインと libjuiz_sdk・GHC の共有ライブラリ・libffi・libgmp を 1 つのディレクトリに集められるようにした(issue #287)。 + +## 0.0.27 + +- Windows でも、Haskell のプラグインを DLL として作れるようにした(issue #137。手順の整備は #137 で続ける)。 +- libjuiz_sdk の Windows(x86_64、MSVC)向けアーカイブ `juiz_sdk-<版>-x86_64-pc-windows-msvc.zip` を配るようにした(issue #273)。 + +## 0.0.26 + +- libjuiz_sdk を GitHub Releases のアーカイブ(`juiz_sdk-<版>-<ターゲット名>.tar.gz`)で配るようにした(issue #136)。 + Hackage での公開は準備中で、それまでは juiz のソース(`bindings/hsjuiz`)から使う。 +- juiz は、プラグインが読み込んだ libjuiz_sdk の版が自分と違うと読み込みをエラーにする。 +- 画像を引数・戻り値に使える(`Juiz.Image` の `Image`、`addImageArg`、issue #253)。IPC のブローカー越しにも生バイトで渡る。 + +## 0.0.25 まで + +- Process(`juizProcess`)、Container / ContainerProcess(`juizContainer` / `juizContainerProcess`)、 + Component(`juizComponent`)を Haskell で書ける(issue #132〜#134)。 +- IDL の型を引数・戻り値に使える(`Juiz.Type`、`addTypedArg` など、0.0.23 から、issue #196)。 diff --git a/LICENSE-APACHE b/LICENSE-APACHE new file mode 100644 --- /dev/null +++ b/LICENSE-APACHE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/LICENSE-MIT b/LICENSE-MIT new file mode 100644 --- /dev/null +++ b/LICENSE-MIT @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2024-2026 ysuga + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,542 @@ +# hsjuiz + +juiz の Process / Container を Haskell で書くためのライブラリです(Linux / macOS / Windows、GHC 9.6 以降。Windows の注意は「[Windows](#windows)」)。 + +Haskell の関数を cabal の `foreign-library`(共有ライブラリ)として公開し、juiz が設定ファイルの +`language: "haskell"` のプラグインとして読み込みます。値の受け渡しには libjuiz_sdk の C 関数 +(`bindings/cjuiz/include/juiz_sdk.h`)を使います。 + +## Process を書く + +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module IncrementProcess () where + +import Juiz + +manifest :: ProcessManifest +manifest = processManifest "increment_process_hs" + & description "Adds 1 to arg1." + & addIntArg "arg1" "value to be incremented" 1 + +increment :: Int64 -> IO Int64 +increment arg1 = pure (arg1 + 1) + +juizProcess 'increment 'manifest +``` + +- `processManifest` に渡す名前が、設定ファイルの `type_name` とライブラリの名前になります。 +- 引数は `addBoolArg` / `addIntArg` / `addFloatArg` / `addStringArg` / `addArrayArg` / `addObjectArg` で足します。 + **足した順が関数の引数の順** です。マニフェストの引数の数と関数の引数の数が違うと、juiz が読み込むときにエラーになります。 +- `juizProcess 'func 'manifest` が、juiz が探す C の関数(`manifest_entry_point`、`process_factory_entry_point` など)を生成します。 +- 関数の結果は `IO r` でも、IO の付かない `r` でもかまいません。型は具体的に書いてください(多相な関数は使えません)。 +- 文字列の引数は `OverloadedStrings` を付けて `Text` で書きます。 + +### 使える型 + +引数の型は `FromCapsule`、結果の型は `ToCapsule` のインスタンスにします。用意してあるのは次の型です。 + +| Haskell | juiz の値 | +|---|---| +| `Bool` | 真偽値 | +| `Int64`, `Int`, `Int8`〜`Int32`, `Word8`〜`Word32` | 整数(範囲外ならエラー) | +| `Word64` | 0 以上の整数 | +| `Double`, `Float` | 小数(整数も受け取れる) | +| `Text` | 文字列 | +| `ByteString` | base64 の文字列 | +| `[a]` | 配列 | +| `Map Text a` | オブジェクト | +| `Maybe a` | null なら `Nothing` | +| `()` | null(結果のみ) | +| `Value` | どんな値でも(`JNull`, `JBool`, `JInt`, `JUInt`, `JFloat`, `JString`, `JArray`, `JObject`) | + +オブジェクトを返すときは `object ["x" .= (1 :: Int64), "name" .= ("abc" :: Text)]` のように書けます。 +自分の型は `fromValue :: Value -> Either Text a` / `toValue :: a -> Value` を書いてインスタンスにします。 + +### 型付きの引数・戻り値(IDL の型) + +juiz の IDL(`.jidl`)で定義した型を使うと、引数・戻り値が型付きになります(manifest に型の情報が載り、 +ほかの言語の Process と同じ型で受け渡しでき、接続のときに型が検査されます)。`juiz-idl -g haskell` で +Haskell のモジュールを作り(Template Haskell は使いません)、cabal の `hs-source-dirs` と `other-modules` に足します。 + +```sh +juiz-idl -g haskell -o gen idl/geometry.jidl # gen/Robot/Geometry.hs など +``` + +```haskell +import Juiz +import Robot.Geometry -- Pose2D (..)、Point2D (..)、MotorMode (..) など + +moveManifest :: ProcessManifest +moveManifest = processManifest "pose_move_hs" + & addTypedArgNoDefault (Proxy :: Proxy Pose2D) "pose" "current pose" + & addFloatArg "dx" "" 1.0 + +poseMove :: Pose2D -> Double -> Pose2D +poseMove pose dx = pose { pose2DPosition = (pose2DPosition pose) { point2DX = point2DX (pose2DPosition pose) + dx } } + +juizProcess 'poseMove 'moveManifest +``` + +- 型付きの引数は `addTypedArg 名前 説明 既定値`(既定値はその型の値)、`addTypedArgNoDefault (Proxy :: Proxy T) 名前 説明`(既定値なし)、 + `addTypedArgValue (Proxy :: Proxy T) 名前 説明 辞書の既定値` で足します。関数の引数が型付きの型なのにマニフェストが + `addObjectArg` などの型なしの引数だと、juiz が読み込むときにエラーになります。 +- 関数の結果が型付きの型なら、戻り値の型(`output_schema`)は自動で載ります(`returns (Proxy :: Proxy T)` で書いても同じ)。 +- 生成した record のフィールドの関数は「型名 + フィールド名」(`pose2DPosition`、`frame_id` なら `pose2DFrameId`)、 + 列挙の構築子は「型名 + 記号」(`MotorModeIdle`)です。すべてのフィールドに既定値がある record には `default<型名>` もあります。 +- 引数は juiz が型で読んでから渡します(足りないフィールドは既定値で埋め、型にないキーは無視)。型に合わない値は + `JUIZ_VALUE_DOES_NOT_MATCH_TYPE_ERROR`(-702)になります。戻り値は辞書にして返します。 +- IDL を使わずに手で書いた型も、Avro のスキーマから `unsafeTypeInfo` で型の情報を作り、`JuizType`・`FromCapsule`・`ToCapsule` + のインスタンス(`fromCapsuleType` / `toCapsuleType` で型の情報を返す)を書けば型付きにできます(`Juiz.Type` を参照)。 + +詳しくは juiz の docs/spec/datatype.md §22 にあります。 + +### 画像 + +画像は `Image`(`Juiz.Image`)で受け取り、返します。マニフェストでは `addImageArg` で引数を足します。 +juiz の中では Rust の画像になるので、ほかの言語の Process と接続でき、IPC のブローカー越しにも生バイトのまま渡ります。 + +```haskell +invertManifest :: ProcessManifest +invertManifest = processManifest "image_invert_hs" + & addImageArg "img" "image to invert" + +invert :: Image -> Image +invert img = img { imageData = BS.map (255 -) (imageData img) } -- 8 bit の形式のとき + +juizProcess 'invert 'invertManifest +``` + +- `Image` は `imageWidth`・`imageHeight`・`imageFormat`・`imageStride`(1 行のバイト数)・`imageData`(`ByteString`)を持ちます。 + 受け取った画像は行の余白がありません。新しく作るときは `newImage 幅 高さ 形式 バイト列` を使います(バイト数が合わなければ `Left`)。 +- 形式 `PixelFormat` は `L8`・`LA8`・`RGB8`・`RGBA8`・`L16`・`LA16`・`RGB16`・`RGBA16`・`RGB32F`・`RGBA32F` と、 + 返すときだけ使える `BGR8`・`BGRA8`(juiz が赤と青を入れ替えて `RGB8`・`RGBA8` にします)。16 bit・f32 の画素はホストのバイト順です。 +- 画像は辞書の中(`[Image]` や record のフィールド)には入れられません。 + +詳しくは juiz の docs/spec/large-data.md §10 にあります。 + +### エラー + +関数の中の例外は C の呼び出し元(juiz)に出さず、エラーコードに変えて返します。内容は標準エラー出力に書きます。 + +- 引数が無い・型が合わない: `JUIZ_VALUE_NOT_FOUND_ERROR`(-102)・`JUIZ_VALUE_CONVERTER_ERROR`(-103) +- `throwJuiz code "説明"` で投げた `JuizError`: そのコード +- それ以外の例外(`error` など): `JUIZ_PROCESS_FUNCTION_NULL_OPT_RETURNED`(-501) + +どの場合も juiz の呼び出しはエラーになり、プロセスは落ちません。 + +## Container を書く + +Container は状態を持つもので、ContainerProcess はその状態を第 1 引数に受け取る関数です。 +juiz の設定ファイルでは、Container と ContainerProcess はそれぞれ別の共有ライブラリになります +(1 つのライブラリにまとめるときは [Component](#component-にまとめる) にします)。 + +状態の型は、Container と ContainerProcess のどちらのライブラリからも同じモジュールを使ってそろえます。 + +```haskell +-- ExampleContainerState.hs (両方のライブラリの other-modules に入れる) +module ExampleContainerState (ExampleContainer (..)) where + +import Data.IORef (IORef) +import Data.Int (Int64) + +newtype ExampleContainer = ExampleContainer (IORef Int64) +``` + +```haskell +-- ExampleContainer.hs: Container (example_container_hs) +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module ExampleContainer () where + +import Juiz +import ExampleContainerState + +manifest :: ContainerManifest +manifest = containerManifest "example_container_hs" + & description "Holds an integer value." + & addIntArg "value" "initial value" 0 + +create :: Int64 -> IO ExampleContainer +create value = ExampleContainer <$> newIORef value + +juizContainer 'create 'manifest +``` + +```haskell +-- ExampleContainerIncrement.hs: ContainerProcess (example_container_hs_increment) +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module ExampleContainerIncrement () where + +import Juiz +import ExampleContainerState + +manifest :: ProcessManifest +manifest = containerProcessManifest "example_container_hs_increment" "example_container_hs" + & description "Adds arg0 to the value of the container." + & addIntArg "arg0" "value to be added" 1 + +increment :: ExampleContainer -> Int64 -> IO Int64 +increment (ExampleContainer ref) arg0 = atomicModifyIORef' ref (\v -> (v + arg0, v + arg0)) + +juizContainerProcess 'increment 'manifest +``` + +- `containerManifest` の引数(`addIntArg` など)は、**Container を作る関数の引数** になります。 + 設定ファイルの `containers` に書いた値を受け取り、書いていなければ既定値になります。 +- Container を作る関数の結果(`IO s` または `s`)が状態です。書き換える値は `IORef` などに入れてください + (`Juiz` から `IORef` / `newIORef` / `readIORef` / `writeIORef` / `modifyIORef'` / `atomicModifyIORef'` も使えます)。 + juiz は同じ Container の ContainerProcess を同時には呼びません。 +- `containerProcessManifest "型名" "Container の型名"` で ContainerProcess のマニフェストを作ります。 + 引数は第 1 引数(状態)の後に続く引数の順です。 +- 状態は `StablePtr` に包んで juiz に渡します。Container を削除すると解放され、GC に回収されます。 + デバイスを閉じるなど、削除のときにしたいことがあれば `juizContainerWithDestroy 'create 'destroy 'manifest` + (`destroy :: s -> IO ()`)を使います。 +- ContainerProcess の状態の型と Container の状態の型が違う(別の型の Haskell の Container や、C++ など別の言語の + Container に結びつけた)ときは、呼び出しが `JUIZ_HASKELL_CONTAINER_TYPE_ERROR`(-602)のエラーになります。 + 型は `Typeable` で得たモジュール名つきの型名(`ExampleContainerState.ExampleContainer` など)で比べるので、両方のライブラリで同じモジュールの同じ型を使ってください(Container と ContainerProcess はライブラリごとにパッケージの識別子が変わることがあるため、`cast` は使っていません)。 + +設定ファイルは C++ の Container と同じ形です。 + +```yaml +plugins: + container_factories: + example_container_hs: + language: "haskell" + path: "./target" + processes: + example_container_hs_increment: + path: "./target" +containers: + - type_name: "example_container_hs" + name: "hscont0" + value: 15 + processes: + - type_name: "example_container_hs_increment" + name: "hsinc0" +``` + +### ContainerPose を読み書きする + +ContainerProcess の中から、その Container の位置姿勢(ContainerPose、docs/spec/transformations.md §12.3)を +`Juiz.Pose` の関数で読み書きできます(`Juiz` から使えます)。 + +```haskell +move :: IORef Int64 -> Double -> IO Value +move _ dx = do + (p, _) <- containerPose "map" -- map から見たこの Container の位置姿勢 + let (x, y, z) = cpPosition p + r <- setContainerPose "map" p { cpPosition = (x + dx, y, z) } -- 親 → この Container の Transform を書き換える + pure (poseStampedToValue "map" r) -- juiz_std.geometry.PoseStamped の辞書 +``` + +- ContainerProcess の関数は Container の状態だけを受け取るので、読み書きの相手は「今呼ばれている ContainerProcess の + Container」です。juiz が呼んだスレッドの上(関数の中)でだけ使えます。`forkIO` した先や関数から戻った後では + `juizTransformationsNotAttachedError`(-901)の `JuizError` になります。 +- 四元数の並びは (x, y, z, w)。`cpOrientation` が `(0, 0, 0, 0)` のように長さ 0 なら `juizInvalidPoseValueError`(-904)。 +- 共通の Anchor がない基準は `juizNoCommonAnchorError`(-902)、書けない基準(根の Anchor・自分・子孫)は + `juizPoseNotWritableError`(-903)。捕まえなければ、エントリポイントがそのコードを juiz に返します。 + +## Component にまとめる + +Component は、1 つのライブラリに複数の Process / Container / ContainerProcess をまとめたものです(C++ の +`COMPONENT_PROCESS_FACTORY` などと同じ仕組み)。ライブラリが一つで済み、Container と ContainerProcess が +同じライブラリに入るので、状態の型を別のモジュールに分ける必要もありません。 + +要素の関数とマニフェストは、単体で公開するときと同じものを使います。`juizComponent` に Component の +マニフェストと要素の一覧を渡します。 + +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +module ExampleComponent () where + +import Juiz + +component :: ComponentManifest +component = componentManifest "example_component_hs" + & description "Haskell component example." + +incrementManifest :: ProcessManifest +incrementManifest = processManifest "example_component_hs_increment" + & addIntArg "arg0" "value to be incremented" 3 + +increment :: Int64 -> Int64 +increment arg0 = arg0 + 1 + +newtype Counter = Counter (IORef Int64) + +counterManifest :: ContainerManifest +counterManifest = containerManifest "example_component_hs_counter" + & addIntArg "value" "initial value" 0 + +createCounter :: Int64 -> IO Counter +createCounter value = Counter <$> newIORef value + +counterGetManifest :: ProcessManifest +counterGetManifest = containerProcessManifest "example_component_hs_counter_get" "example_component_hs_counter" + +counterGet :: Counter -> IO Int64 +counterGet (Counter ref) = readIORef ref + +juizComponent 'component + [ componentProcess 'increment 'incrementManifest + , componentContainer 'createCounter 'counterManifest + , componentContainerProcess 'counterGet 'counterGetManifest + ] +``` + +- 要素は `componentProcess` / `componentContainer` / `componentContainerWithDestroy` / `componentContainerProcess` で + 書きます。引数は `juizProcess` などと同じです。別のモジュールに書いた関数とマニフェストも(公開して import すれば)使えます。 +- `componentManifest` に渡す名前が、設定ファイルの `components` に書く名前とライブラリの名前になります。 +- `juizComponent` は C++ と同じ名前の C の関数を生成します: マニフェストを返す `component_manifest_entry_point`、 + 要素ごとの `<関数名>_factory_entry_point`(Container は `<関数名>_factory_destroy_entry_point` も)と + `<関数名>_manifest_entry_point`。要素のマニフェストの `factory` は `<関数名>_factory` に付け直すので、自分で書く必要はありません。 + そのため **関数名は Component の中で重ならないように** してください(重なるとコンパイルエラーになります)。 +- ContainerProcess の Container は同じ Component に入れます。Component に無い Container の ContainerProcess を入れたり、 + 型名が重なっていたりすると、juiz が読み込むときにエラーになります。 + +設定ファイルでは `plugins` の `components` に書き、Process や Container は要素の型名で作ります。 + +```yaml +plugins: + components: + example_component_hs: + language: "haskell" + path: "./target" +processes: + - type_name: "example_component_hs_increment" + name: "hsinc0" +containers: + - type_name: "example_component_hs_counter" + name: "hscounter0" + value: 15 + processes: + - type_name: "example_component_hs_counter_get" + name: "hsget0" +``` + +一つの juiz で複数の Haskell のライブラリ(単体の Process や Container、Component)を読み込むこともできます。 + +## ビルドする + +Process / Container / ContainerProcess / Component ごとに `foreign-library` を一つ作ります。`-threaded` は必須です(juiz は Process をワーカースレッドから呼ぶため。 +付け忘れると、juiz が読み込むときに `juiz_hs_init` が `JUIZ_HASKELL_NOT_THREADED_RTS_ERROR`(-601)を返してエラーになります)。 + +```cabal +foreign-library increment_process_hs + type: native-shared + default-language: Haskell2010 + hs-source-dirs: src + other-modules: IncrementProcess + build-depends: base, hsjuiz + ghc-options: -threaded +``` + +### libjuiz_sdk と hsjuiz を用意する + +ビルドには、使う `juiz` と **同じ版** の libjuiz_sdk が必要です。版の違う libjuiz_sdk でビルドしたライブラリは、juiz が読み込むときにエラーにします。 + +libjuiz_sdk は、v0.0.26 から [GitHub Releases](https://github.com/OpenJUIZ/juiz/releases) に OS・CPU ごとのアーカイブ +(`juiz_sdk-<版>-<ターゲット名>.tar.gz`、Linux x86_64・aarch64 と macOS arm64・x86_64)を置いています。 +`scripts/install-juiz-sdk.sh` で取得して `~/.juiz/sdk/<版>` に展開できます。 + +```terminal +curl -fsSL https://raw.githubusercontent.com/OpenJUIZ/juiz/main/scripts/install-juiz-sdk.sh | sh -s -- 0.2.6 +``` + +それより前の版では、juiz のソースを同じ版のタグで取得し、`cargo build --release -p juiz_sdk` でできる `target/release` の libjuiz_sdk を使います。 + +hsjuiz は Hackage への公開を準備中です。それまでは、juiz のソースを `juiz` と同じ版のタグで取得し、その `bindings/hsjuiz` を +自分のパッケージの `cabal.project` に書いて使います。あわせて hsjuiz に libjuiz_sdk の場所を渡します。`ghc-options` の rpath は、 +Template Haskell(`juizProcess` など)を実行するときに GHC が hsjuiz を読み込むのに必要です。 +できたライブラリにも libjuiz_sdk の場所が rpath として入ります。 + +```cabal +packages: . /home/me/juiz-0.2.6/bindings/hsjuiz + +package hsjuiz + extra-lib-dirs: /home/me/.juiz/sdk/0.2.6/lib + ghc-options: -optl-Wl,-rpath,/home/me/.juiz/sdk/0.2.6/lib +``` + +```terminal +git clone --depth 1 --branch v0.2.6 https://github.com/OpenJUIZ/juiz.git /home/me/juiz-0.2.6 +cabal build all +``` + +Hackage で公開したあとは、`packages:` に hsjuiz のソースを書かずに、`cabal update` で Hackage から入れられるようになります。 + +juiz のリポジトリの中でビルドするときは、`cargo build` でできる `target/debug` の libjuiz_sdk を +`--extra-lib-dirs` で渡します(`examples/haskell/build.sh` がこの方法です)。 + +```terminal +cabal build all --extra-lib-dirs=/target/debug --ghc-options="-optl-Wl,-rpath,/target/debug" +``` + +macOS で、選んでいる Xcode より新しい Command Line Tools が入っている(たとえば Xcode 26 に Command Line Tools 27 の +MacOSX27.0.sdk)と、リンクが `tapi error: malformed file ... unknown architecture arm64e.x1-macos` で失敗します。 +GHC はリンクのときに Command Line Tools の SDK(`/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk`)を `-L` で渡すので、 +Xcode の古いリンカが新しい SDK の `.tbd` を読めないためです(issue #143)。Command Line Tools のリンカを使えば通ります。 + +```terminal +DEVELOPER_DIR=/Library/Developer/CommandLineTools cabal build all ... +``` + +Xcode を Command Line Tools と同じ版に上げても直ります。`examples/haskell/build.sh` はこの組み合わせを見つけると自動で `DEVELOPER_DIR` を切り替えます。 + +できた `lib<名前>.so`(macOS は `.dylib`)を、設定ファイルの `path` のディレクトリに置きます。 + +```yaml +plugins: + process_factories: + increment_process_hs: + language: "haskell" + path: "./target" +``` + +- RTS(GHC のランタイム)は GHC の共有ライブラリで、同じプロセスに読み込んだ Haskell のライブラリすべてで共有されます。 + **一つの juiz で読み込む Haskell のライブラリは、すべて同じ GHC でビルドしてください。**(Windows は違います。下の「Windows」) +- RTS の初期化(`juiz_hs_init`)は hsjuiz が用意しているので、自分で書く必要はありません。 + GHC は `hs_exit` の後に初期化し直せないため、hsjuiz は `hs_exit` を呼ばず、`juiz_hs_exit` も用意していません。 +- hsjuiz の `juiz_hs_init` は、RTS を初期化する前に `setKeepCAFs()` を呼び、CAF(トップレベルの値)を GC で + 回収しないようにしています。2 つ目以降に開いたライブラリの `foreign export` が GC の根にならず、 + エントリポイントが回収されてプロセスが落ちるのを防ぐためです(issue #133)。 + +例は `examples/haskell` にあります。 + +### Windows + +Windows(GHC 9.6、x86_64)では、できるライブラリは lib の付かない `<名前>.dll` です。Linux / macOS と次の点が違います(issue #137)。 + +- Windows の GHC は Haskell の共有ライブラリを持たないので、RTS と依存するパッケージを DLL に静的に取り込みます。 + `foreign-library` ごとに `options: standalone` を書きます(`common` に書いても cabal は受け付けません)。 +- 公開するシンボルを `.def` ファイルに並べ、`mod-def-file` で渡します。書かないと、リンカがすべてのシンボルを公開しようとして + DLL が公開できる数(65535)を超えるか、GHC がモジュールをアーカイブにするためにプラグインのコードが DLL に入りません。 + 並べるのは `juiz_hs_init` と、juiz が探す関数(`manifest_entry_point`、`process_factory_entry_point` など。 + `bindings/cjuiz/README.md` の「プラグインが公開する関数」)です。Component では `component_manifest_entry_point` と、 + `componentProcess 'func` ごとの `func_manifest_entry_point` / `func_factory_entry_point` + (Container は `func_factory_destroy_entry_point` も)です。 + + ```cabal + foreign-library increment_process_hs + type: native-shared + if os(windows) + options: standalone + mod-def-file: increment_process_hs.def + ... + ``` + + ```text + EXPORTS + juiz_hs_init + manifest_entry_point + process_factory_entry_point + ``` + +- Rust が作る libjuiz_sdk のインポートライブラリは `juiz_sdk.dll.lib` という名前で、GHC の `-ljuiz_sdk` は見つけられないので、 + `juiz_sdk.lib` という名前で複製して `--extra-lib-dirs` で渡します。Windows に rpath は無く、`juiz_sdk.dll` は juiz の実行ファイルと + 同じディレクトリ(または `PATH`)から読み込まれます。 +- **DLL ごとに RTS が別になります。** そのため、ある DLL の Container を別の DLL の ContainerProcess に渡すことはできません + (`JUIZ_HASKELL_CONTAINER_TYPE_ERROR`(-602)になります)。Container とその ContainerProcess は `juizComponent` で + 一つの Component(一つの DLL)にまとめてください。別の GHC でビルドした DLL を同じ juiz に読み込むことはできます。 + 別々の DLL にできるようにすることは issue #348 で検討しています。 +- **`-fno-PIC` を付けてください。** cabal は `foreign-library` を `-fPIC` でコンパイルしますが、Windows の `-fPIC` の + ジャンプテーブルは飛び先の差を 32 bit しか書けません。そのため、構成子が 7 個以上ある型の値で枝分かれする `case` + (`deriving Show` の `show` を含む)を実行すると、プロセスが落ちます(issue #262、GHC の不具合 + [ghc#24016](https://gitlab.haskell.org/ghc/ghc/-/issues/24016))。`-fno-PIC` では表が絶対番地になり、DLL を読み込むときに正しく直されます。 + `options: standalone` と違い、`ghc-options` は `common` に書けます。 + + ```cabal + common plugin + if os(windows) + ghc-options: -fno-PIC + ``` + +- **プロジェクトは浅い場所に置いてください。** cabal の `foreign-library` の中間ファイルはライブラリ名を 3 回含むパス + (`dist-newstyle/build/…/f/<名前>/build/<名前>/<名前>-tmp/…`)に作られ、深い場所では 260 文字を超えて GHC のファイルのコピーが + `does not exist` で失敗します。OS の長いパスの設定(LongPathsEnabled)を有効にしても同じです(issue #279)。 + +`examples/haskell/build.sh` は Git Bash(MSYS2)で動き、上の手順を行います。 + +## Template Haskell を使わずに書く + +`juizProcess` が生成するものは、`Juiz` の `manifestEntryPoint` と `processEntryPoint` を使って手でも書けます。 +Process の関数の結果は `IO r` にしてください。 + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module IncrementProcess () where + +import Juiz + +manifest :: ProcessManifest +manifest = processManifest "increment_process_hs" + & description "Adds 1 to arg1." + & addIntArg "arg1" "value to be incremented" 1 + +increment :: Int64 -> IO Int64 +increment arg1 = pure (arg1 + 1) + +hsManifest :: ManifestFunction +hsManifest = manifestEntryPoint manifest increment + +hsProcess :: ProcessFunction +hsProcess = processEntryPoint manifest increment + +hsFactory :: ProcessFactoryFunction +hsFactory = pure p_hsProcess + +foreign export ccall "manifest_entry_point" hsManifest :: ManifestFunction +-- Process の関数そのもの。名前はほかのライブラリと重ならないものにする +foreign export ccall "increment_process_hs_process_entry_point" hsProcess :: ProcessFunction +foreign import ccall "&increment_process_hs_process_entry_point" p_hsProcess :: FunPtr ProcessFunction +foreign export ccall "process_factory_entry_point" hsFactory :: ProcessFactoryFunction +``` + +Container と ContainerProcess は `containerManifestEntryPoint` / `containerCreateEntryPoint` / +`containerDestroyEntryPoint` と `containerProcessManifestEntryPoint` / `containerProcessEntryPoint` で同じように書けます。 + +```haskell +hsManifest :: ManifestFunction +hsManifest = containerManifestEntryPoint manifest create +hsCreate :: ContainerCreateFunction +hsCreate = containerCreateEntryPoint manifest create +hsDestroy :: ContainerDestroyFunction +hsDestroy = containerDestroyEntryPoint manifest +hsFactory :: ContainerFactoryFunction +hsFactory = pure p_hsCreate + +foreign export ccall "manifest_entry_point" hsManifest :: ManifestFunction +foreign export ccall "example_container_hs_create_entry_point" hsCreate :: ContainerCreateFunction +foreign import ccall "&example_container_hs_create_entry_point" p_hsCreate :: FunPtr ContainerCreateFunction +foreign export ccall "container_factory_entry_point" hsFactory :: ContainerFactoryFunction +foreign export ccall "container_factory_destroy_entry_point" hsDestroy :: ContainerDestroyFunction +``` + +Component は、要素ごとに上と同じ関数を `<関数名>_factory_entry_point` などの名前で公開し、 +マニフェストの `factory` をその名前(`<関数名>_factory`)にしてから、`componentManifestEntryPoint` で +`component_manifest_entry_point` を書きます。`processPart` などは、要素のマニフェストと関数の引数の数を確かめるために使います。 + +```haskell +incrementManifest' :: ProcessManifest +incrementManifest' = incrementManifest & factory "increment_factory" + +hsComponentManifest :: ManifestFunction +hsComponentManifest = componentManifestEntryPoint component + [ processPart incrementManifest' increment + , containerPart counterManifest' createCounter + , containerProcessPart counterGetManifest' counterGet + ] + +foreign export ccall "component_manifest_entry_point" hsComponentManifest :: ManifestFunction +-- increment_factory_entry_point、createCounter の factory の entry_point と destroy_entry_point なども同じように公開する +``` + +公開する関数の決まりは `bindings/cjuiz/README.md` にあります。 + +## ライセンス + +MIT OR Apache-2.0 diff --git a/cbits/hsjuiz.c b/cbits/hsjuiz.c new file mode 100644 --- /dev/null +++ b/cbits/hsjuiz.c @@ -0,0 +1,139 @@ +/* + * hsjuiz の C の部分。 + * + * juiz_hs_init: juiz が language: "haskell" のプラグインを開いた直後に呼ぶ関数 (bindings/cjuiz/README.md)。 + * GHC のランタイム (RTS) を初期化する。成功なら 0 を返す。 + * + * - juiz は Process をワーカースレッドから呼ぶので、-threaded の RTS でビルドされていなければ + * 初期化せずにエラー (HSJUIZ_NOT_THREADED_RTS_ERROR) を返す。 + * - hs_init はスレッド安全ではないので、pthread_once で一度だけ呼ぶ。別の Haskell ライブラリと + * 同時に呼ばないよう、juiz の側でも一つずつ呼ぶ (RTS は libHSrts の共有ライブラリで共有される)。 + * - GHC は hs_exit の後に hs_init し直せないので、hs_exit は呼ばない (juiz_hs_exit も用意しない)。 + * juiz はライブラリを閉じず、RTS はプロセスの終了とともに片付く。 + * - hs_init の前に setKeepCAFs を呼び、CAF (トップレベルの値) を GC で回収しないようにする。 + * foreign export した関数は、ライブラリを開いたときに GC の根 (StablePtr) として登録を待つが、 + * その登録は hs_init の中でしか処理されない。そのため hs_init の後に開いた 2 つ目以降の Haskell の + * ライブラリでは、foreign export した CAF (juizProcess などが生成するエントリポイント) が GC の根にならず、 + * major GC で回収されて、次の呼び出しでプロセスが落ちる (issue #133)。GHCi が読み込んだコードと同じく + * CAF をすべて残すことで防ぐ。 + */ +#include +#include +#include +#ifdef _WIN32 +#include +#else +#include +#endif +#include +#include /* rtsSupportsBoundThreads, setKeepCAFs */ + +/* -threaded でない RTS にリンクされている */ +#define HSJUIZ_NOT_THREADED_RTS_ERROR INT64_C(-601) + +#ifdef _WIN32 +static INIT_ONCE juiz_hs_init_once = INIT_ONCE_STATIC_INIT; +#else +static pthread_once_t juiz_hs_init_once = PTHREAD_ONCE_INIT; +#endif + +static void juiz_hs_init_impl(void) +{ + static char program_name[] = "juiz"; + static char *argv_buf[] = { program_name, NULL }; + int argc = 1; + char **argv = argv_buf; + setKeepCAFs(); + hs_init(&argc, &argv); +} + +#ifdef _WIN32 +static BOOL CALLBACK juiz_hs_init_once_callback(PINIT_ONCE once, PVOID param, PVOID *context) +{ + (void)once; (void)param; (void)context; + juiz_hs_init_impl(); + return TRUE; +} +#endif + +int64_t juiz_hs_init(void) +{ + if (!rtsSupportsBoundThreads()) { + return HSJUIZ_NOT_THREADED_RTS_ERROR; + } +#ifdef _WIN32 + InitOnceExecuteOnce(&juiz_hs_init_once, juiz_hs_init_once_callback, NULL, NULL); +#else + pthread_once(&juiz_hs_init_once, juiz_hs_init_impl); +#endif + return 0; +} + +/* + * この hsjuiz (と GHC の RTS) の実体を表す値 (Juiz.Container が Container の目印と一緒に置く)。 + * Linux / macOS では hsjuiz も RTS も共有ライブラリで、すべての Haskell のプラグインが同じものを使うので、 + * どのプラグインでも同じ値になる。Windows では RTS と hsjuiz がプラグインの DLL ごとに静的に入るので、 + * DLL ごとに違う値になる。違う RTS の StablePtr は読めないので、ContainerProcess はこの値を比べて、 + * 別の DLL で作られた Container を受け付けない (issue #137) + */ +static const char hsjuiz_runtime_tag_value = 0; + +const void* hsjuiz_runtime_tag(void) +{ + return &hsjuiz_runtime_tag_value; +} + +/* + * value の型を整数で返す (Juiz.Internal.FFI の valueType*)。 + * value_is_* は C の bool を返すので、Haskell から直接呼ばずにここで整数にする。 + */ +typedef struct value_struct value; +bool value_is_null(value* v); +bool value_is_int(value* v); +bool value_is_uint(value* v); +bool value_is_float(value* v); +bool value_is_bool(value* v); +bool value_is_string(value* v); +bool value_is_object(value* v); +bool value_is_array(value* v); + +int64_t hsjuiz_value_type(value* v) +{ + if (value_is_null(v)) return 0; + if (value_is_bool(v)) return 1; + if (value_is_int(v)) return 2; + if (value_is_uint(v)) return 3; + if (value_is_float(v)) return 4; + if (value_is_string(v)) return 5; + if (value_is_array(v)) return 6; + if (value_is_object(v)) return 7; + return -1; +} + +/* + * capsule_ptr の値が画像なら 1、そうでなければ 0 (Juiz.Internal.FFI の c_hsjuiz_capsule_ptr_is_image)。 + * capsule_ptr_is_image は C の bool を返すので、ここで整数にする。 + */ +typedef struct capsule_ptr_struct capsule_ptr; +bool capsule_ptr_is_image(capsule_ptr* cp); + +int64_t hsjuiz_capsule_ptr_is_image(capsule_ptr* cp) +{ + return capsule_ptr_is_image(cp) ? 1 : 0; +} + +/* + * 今このスレッドで呼ばれている ContainerProcess の引数 (capsule_map*) を置き換え、前の値を返す + * (Juiz.Pose.withPoseCall、docs/spec/transformations.md §12.3)。juiz は ContainerProcess を呼ぶとき、 + * 引数に呼び出し元 Container の ContainerPose の口を載せるので、関数の中から読み書きするのに使う。 + * foreign export の呼び出しは呼んだ OS スレッドに結びついた (bound) Haskell スレッドで動くので、 + * スレッドごとの変数に置けばよい + */ +static _Thread_local void* hsjuiz_pose_call = NULL; + +void* hsjuiz_swap_pose_call(void* cm) +{ + void* old = hsjuiz_pose_call; + hsjuiz_pose_call = cm; + return old; +} diff --git a/hsjuiz.cabal b/hsjuiz.cabal new file mode 100644 --- /dev/null +++ b/hsjuiz.cabal @@ -0,0 +1,67 @@ +cabal-version: 3.0 +name: hsjuiz +version: 0.2.6 +synopsis: Write juiz processes and containers in Haskell +description: + Write Process / Container / Component plugins of + (middleware for robots and IoT) in Haskell. + A plugin is a shared library (a cabal @foreign-library@) that juiz loads as + @language: "haskell"@. Values are passed through the C functions of libjuiz_sdk. + . + Building a plugin needs libjuiz_sdk of the same version as juiz. Download it from + + (@juiz_sdk-\-\.tar.gz@, or @scripts/install-juiz-sdk.sh@ in the juiz repository) + and add it to @cabal.project@: + . + > package hsjuiz + > extra-lib-dirs: /lib + > ghc-options: -optl-Wl,-rpath,/lib + . + juiz (ロボット・IoT 向けミドルウェア) の Process / Container を Haskell で書くためのライブラリ。 + 使い方は README を参照。 +license: MIT OR Apache-2.0 +license-files: LICENSE-MIT + LICENSE-APACHE +author: ysuga +maintainer: ysuga +homepage: https://github.com/OpenJUIZ/juiz/tree/main/bindings/hsjuiz +bug-reports: https://github.com/OpenJUIZ/juiz/issues +category: Robotics, FFI +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC ==9.6.* + +source-repository head + type: git + location: https://github.com/OpenJUIZ/juiz.git + subdir: bindings/hsjuiz + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: Juiz + Juiz.Value + Juiz.Error + Juiz.Capsule + Juiz.Manifest + Juiz.Process + Juiz.Container + Juiz.Component + Juiz.TH + Juiz.Type + Juiz.Image + Juiz.Pose + Juiz.Internal.FFI + Juiz.Internal.TypeInfo + Juiz.Internal.Base64 + build-depends: base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , text >=2.0 && <2.3 + , template-haskell >=2.19 && <2.26 + -- juiz_hs_init (RTS の初期化) と、bool を返す C 関数を安全に呼ぶための小さな関数 + c-sources: cbits/hsjuiz.c + -- libjuiz_sdk の場所は利用者が cabal.project の extra-lib-dirs (または --extra-lib-dirs) で渡す (README を参照) + extra-libraries: juiz_sdk + ghc-options: -Wall diff --git a/src/Juiz.hs b/src/Juiz.hs new file mode 100644 --- /dev/null +++ b/src/Juiz.hs @@ -0,0 +1,209 @@ +-- | juiz の Process / Container を Haskell で書くためのライブラリ。 +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE TemplateHaskell #-} +-- > module Increment () where +-- > +-- > import Juiz +-- > +-- > manifest :: ProcessManifest +-- > manifest = processManifest "increment_process_hs" +-- > & description "Adds 1 to arg1." +-- > & addIntArg "arg1" "value to be incremented" 1 +-- > +-- > increment :: Int64 -> IO Int64 +-- > increment arg1 = pure (arg1 + 1) +-- > +-- > juizProcess 'increment 'manifest +-- +-- Container (状態を持つもの) と ContainerProcess (状態を第 1 引数に受け取る関数) は次のように書く。 +-- +-- > manifest :: ContainerManifest +-- > manifest = containerManifest "counter_container_hs" +-- > & addIntArg "value" "initial value" 0 +-- > +-- > create :: Int64 -> IO (IORef Int64) +-- > create = newIORef +-- > +-- > juizContainer 'create 'manifest +-- +-- > manifest :: ProcessManifest +-- > manifest = containerProcessManifest "counter_container_hs_increment" "counter_container_hs" +-- > & addIntArg "arg1" "amount" 1 +-- > +-- > increment :: IORef Int64 -> Int64 -> IO Int64 +-- > increment ref n = atomicModifyIORef' ref (\v -> (v + n, v + n)) +-- > +-- > juizContainerProcess 'increment 'manifest +-- +-- 1 つのライブラリに複数の Process / Container / ContainerProcess をまとめるときは Component にする。 +-- 要素の関数とマニフェストは単体のときと同じものを使う。 +-- +-- > component :: ComponentManifest +-- > component = componentManifest "counter_component_hs" +-- > +-- > juizComponent 'component +-- > [ componentProcess 'add 'addManifest +-- > , componentContainer 'create 'counterManifest +-- > , componentContainerProcess 'increment 'incrementManifest +-- > ] +-- +-- このモジュールを cabal の @foreign-library@ (type: native-shared、ghc-options: -threaded) に入れてビルドし、 +-- juiz の設定ファイルに @language: "haskell"@ で書く。詳しくは bindings/hsjuiz/README.md。 +module Juiz + ( -- * Process / Container の公開 + juizProcess + , juizContainer + , juizContainerWithDestroy + , juizContainerProcess + -- * Component (1 つのライブラリにまとめる) + , juizComponent + , ComponentEntry + , componentProcess + , componentContainer + , componentContainerWithDestroy + , componentContainerProcess + -- * マニフェスト + , ProcessManifest + , ContainerManifest + , ComponentManifest + , HasDescription + , HasArguments + , processManifest + , containerManifest + , containerProcessManifest + , componentManifest + , addProcess + , addContainer + , description + , factory + , useMemo + , readonly + , containerType + , addArg + , addBoolArg + , addIntArg + , addFloatArg + , addStringArg + , addArrayArg + , addObjectArg + , addImageArg + , addTypedArg + , addTypedArgValue + , addTypedArgNoDefault + , returns + , (&) + -- * 値 + , Value (..) + , FromCapsule (..) + , ToCapsule (..) + , object + , (.=) + -- * 画像 (docs/spec/large-data.md §10) + , Image (..) + , PixelFormat (..) + , bytesPerPixel + , newImage + , imageRowBytes + -- * データ型 (juiz-idl -g haskell の生成した型、docs/spec/datatype.md §22) + , JuizType (..) + , TypeInfo + , typeInfoName + , typeInfoFingerprint + , typeInfoSchema + , unsafeTypeInfo + , Proxy (..) + -- * ContainerPose (docs/spec/transformations.md §12.3) + , ContainerPose (..) + , PoseTime (..) + , identityPose + , containerPose + , setContainerPose + , lookupContainerPose + , ContainerTransform (..) + , identityTransform + , setTransform + , transformToValue + , transformStampedToValue + , poseToValue + , poseStampedToValue + -- * エラー + , JuizError (..) + , throwJuiz + , juizHaskellContainerTypeError + , juizValueDoesNotMatchTypeError + , juizImageFormatError + , juizTransformationsNotAttachedError + , juizNoCommonAnchorError + , juizPoseNotWritableError + , juizInvalidPoseValueError + , juizTransformationsError + , juizTransformNotWritableError + , juizTransformNotFoundError + -- * よく使う型 + , Int64 + , Word64 + , Text + , Map + -- * Container の状態によく使う IORef + , IORef + , newIORef + , readIORef + , writeIORef + , modifyIORef' + , atomicModifyIORef' + -- * TH を使わずに書くとき + , ManifestFunction + , ProcessFunction + , ProcessFactoryFunction + , ContainerCreateFunction + , ContainerFactoryFunction + , ContainerDestroyFunction + , ContainerProcessFunction + , ContainerProcessFactoryFunction + , manifestEntryPoint + , processEntryPoint + , containerManifestEntryPoint + , containerCreateEntryPoint + , containerCreateEntryPointWithDestroy + , containerDestroyEntryPoint + , containerProcessManifestEntryPoint + , containerProcessEntryPoint + , ComponentPart + , processPart + , containerPart + , containerProcessPart + , componentManifestEntryPoint + , FunPtr + ) where + +import Data.Function ((&)) +import Data.Int (Int64) +import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import Data.Word (Word64) +import Foreign.Ptr (FunPtr) + +import Juiz.Capsule +import Juiz.Component +import Juiz.Container +import Juiz.Error +import Juiz.Image +import Juiz.Internal.FFI + ( ContainerCreateFunction + , ContainerDestroyFunction + , ContainerFactoryFunction + , ContainerProcessFactoryFunction + , ContainerProcessFunction + , ManifestFunction + , ProcessFactoryFunction + , ProcessFunction + ) +import Juiz.Manifest +import Juiz.Pose +import Juiz.Process +import Juiz.TH +import Juiz.Type +import Juiz.Value diff --git a/src/Juiz/Capsule.hs b/src/Juiz/Capsule.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Capsule.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | juiz の値と Haskell の値の変換 ('FromCapsule' / 'ToCapsule') と、libjuiz_sdk の値の読み書き。 +module Juiz.Capsule + ( -- * 変換の型クラス + FromCapsule (..) + , ToCapsule (..) + , Argument (..) + , Result (..) + , object + , (.=) + -- * libjuiz_sdk の値の読み書き + , peekValue + , readArgument + , readArgumentOrImage + , readTypedArgument + , writeCapsule + , writeResult + , writeCapsulePtr + ) where + +import Control.Exception (SomeException, bracket, throw, throwIO, try) +import Control.Monad (forM_, unless, void) +import qualified Data.ByteString as BS +import Data.IORef +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.C.String (CString) +import Foreign.C.Types (CSize) +import Foreign.Marshal.Alloc (alloca) +import Data.Proxy (Proxy) +import Foreign.Ptr (FunPtr, Ptr, nullPtr) +import Foreign.StablePtr (castStablePtrToPtr, freeStablePtr, newStablePtr) +import Foreign.Storable (Storable, peek) + +import Juiz.Error +import Juiz.Image +import Juiz.Internal.Base64 +import Juiz.Internal.FFI +import Juiz.Internal.TypeInfo +import Juiz.Value + +-- | Process に届いた引数。辞書の値か画像 (docs/spec/large-data.md §10) +data Argument = ArgValue Value | ArgImage Image + deriving (Eq, Show) + +-- | Process の結果として juiz に返すもの。辞書の値か画像 +data Result = ResultValue Value | ResultImage Image + deriving (Eq, Show) + +-- | juiz の値から Haskell の値への変換。Process の引数の型はこのクラスのインスタンスにする +class FromCapsule a where + -- | 変換できなければ理由を 'Left' で返す + fromValue :: Value -> Either Text a + -- | 届いた引数からの変換。既定では辞書の値を 'fromValue' で読み、画像はエラーにする ('Image' は画像を受け取る) + fromArgument :: Argument -> Either Text a + fromArgument (ArgValue v) = fromValue v + fromArgument (ArgImage _) = Left "expected a dictionary value, but got an image" + -- | 型付きの型 (juiz-idl -g haskell の生成した型など、docs/spec/datatype.md §22) ならその型。 + -- 型付きの引数は、juiz が型で読んだ値 (足りないフィールドを既定値で埋めたもの) を受け取る + fromCapsuleType :: Proxy a -> Maybe TypeInfo + fromCapsuleType _ = Nothing + +-- | Haskell の値から juiz の値への変換。Process の戻り値の型はこのクラスのインスタンスにする +class ToCapsule a where + toValue :: a -> Value + -- | Process の結果として返すもの。既定では 'toValue' の辞書 ('Image' は画像のまま返す) + toResult :: a -> Result + toResult = ResultValue . toValue + -- | 型付きの型ならその型。Process の結果がこの型なら、manifest に output_schema を載せる + toCapsuleType :: Proxy a -> Maybe TypeInfo + toCapsuleType _ = Nothing + +instance FromCapsule Value where fromValue = Right +instance ToCapsule Value where toValue = id + +instance FromCapsule Bool where + fromValue (JBool b) = Right b + fromValue v = typeMismatch "Bool" v +instance ToCapsule Bool where toValue = JBool + +instance FromCapsule Int64 where + fromValue (JInt i) = Right i + fromValue v = typeMismatch "Int64" v +instance ToCapsule Int64 where toValue = JInt + +instance FromCapsule Word64 where + fromValue (JUInt w) = Right w + fromValue (JInt i) | i >= 0 = Right (fromIntegral i) + fromValue v = typeMismatch "Word64" v +instance ToCapsule Word64 where + toValue w + | w <= fromIntegral (maxBound :: Int64) = JInt (fromIntegral w) + | otherwise = JUInt w + +instance FromCapsule Int where fromValue = boundedInt "Int" +instance ToCapsule Int where toValue = JInt . fromIntegral +instance FromCapsule Int8 where fromValue = boundedInt "Int8" +instance ToCapsule Int8 where toValue = JInt . fromIntegral +instance FromCapsule Int16 where fromValue = boundedInt "Int16" +instance ToCapsule Int16 where toValue = JInt . fromIntegral +instance FromCapsule Int32 where fromValue = boundedInt "Int32" +instance ToCapsule Int32 where toValue = JInt . fromIntegral +instance FromCapsule Word8 where fromValue = boundedInt "Word8" +instance ToCapsule Word8 where toValue = JInt . fromIntegral +instance FromCapsule Word16 where fromValue = boundedInt "Word16" +instance ToCapsule Word16 where toValue = JInt . fromIntegral +instance FromCapsule Word32 where fromValue = boundedInt "Word32" +instance ToCapsule Word32 where toValue = JInt . fromIntegral + +-- | 整数も小数として受け取る +instance FromCapsule Double where + fromValue (JFloat d) = Right d + fromValue (JInt i) = Right (fromIntegral i) + fromValue (JUInt w) = Right (fromIntegral w) + fromValue v = typeMismatch "Double" v +instance ToCapsule Double where toValue = JFloat + +-- | 整数も小数として受け取る (データ型の float) +instance FromCapsule Float where + fromValue v = realToFrac <$> (fromValue v :: Either Text Double) +instance ToCapsule Float where toValue = JFloat . realToFrac + +instance FromCapsule Text where + fromValue (JString t) = Right t + fromValue v = typeMismatch "Text" v +instance ToCapsule Text where toValue = JString + +-- | バイト列は base64 (RFC 4648 §4、パディングあり) の文字列で表す (データ型の bytes、docs/spec/datatype.md §4) +instance FromCapsule BS.ByteString where + fromValue (JString t) = maybe (Left "invalid base64 string") Right (decodeBase64 (T.unpack t)) + fromValue v = typeMismatch "ByteString (base64 string)" v +instance ToCapsule BS.ByteString where toValue = JString . T.pack . encodeBase64 + +-- | 配列。文字列は 'String' ではなく 'Text' で受け取る +instance FromCapsule a => FromCapsule [a] where + fromValue (JArray xs) = traverse fromValue xs + fromValue v = typeMismatch "Array" v +instance ToCapsule a => ToCapsule [a] where toValue = JArray . map toValue + +-- | オブジェクト +instance FromCapsule a => FromCapsule (Map Text a) where + fromValue (JObject m) = traverse fromValue m + fromValue v = typeMismatch "Object" v +instance ToCapsule a => ToCapsule (Map Text a) where toValue = JObject . Map.map toValue + +-- | null は 'Nothing' +instance FromCapsule a => FromCapsule (Maybe a) where + fromValue JNull = Right Nothing + fromValue v = Just <$> fromValue v +instance ToCapsule a => ToCapsule (Maybe a) where toValue = maybe JNull toValue + +-- | 画像は辞書には入らないので、引数か結果そのものとしてだけ使える (docs/spec/datatype.md §3.3)。 +-- 配列やオブジェクトの中の画像は変換できない +instance FromCapsule Image where + fromValue _ = Left "an image cannot be read from a dictionary value" + fromArgument (ArgImage img) = Right img + fromArgument (ArgValue v) = typeMismatch "Image" v +instance ToCapsule Image where + toValue _ = throw (JuizError juizImageFormatError "an image cannot be put in a dictionary value") + toResult = ResultImage + +-- | 何も返さない Process の戻り値は null になる +instance ToCapsule () where toValue () = JNull + +-- | キーと値の組からオブジェクトを作る。 +-- +-- > object ["x" .= (1 :: Int64), "name" .= ("abc" :: Text)] +object :: [(Text, Value)] -> Value +object = JObject . Map.fromList + +(.=) :: ToCapsule a => Text -> a -> (Text, Value) +k .= v = (k, toValue v) +infixr 8 .= + +typeMismatch :: Text -> Value -> Either Text a +typeMismatch expected v = Left ("expected " <> expected <> ", but got " <> T.pack (show v)) + +boundedInt :: forall a. (Integral a, Bounded a) => Text -> Value -> Either Text a +boundedInt name v = case v of + JInt i | toInteger i >= lo && toInteger i <= hi -> Right (fromIntegral i) + JUInt w | toInteger w <= hi -> Right (fromIntegral w) + JInt _ -> outOfRange + JUInt _ -> outOfRange + _ -> typeMismatch name v + where + lo = toInteger (minBound :: a) + hi = toInteger (maxBound :: a) + outOfRange = Left (T.pack (show v) <> " is out of range of " <> name) + +-- --------------------------------------------------------------------------- +-- libjuiz_sdk の値の読み書き + +-- | callback (C から呼ばれる Haskell の関数) を作って act に渡し、終わったら解放する。 +-- callback の中の例外は C 側に出さずに覚えておき、act の後で投げ直す +withCallback + :: FunPtr cb -- ^ trampoline ("Juiz.Internal.FFI") + -> ((IO () -> IO ()) -> f) -- ^ 例外を捕まえる関数を受け取って、trampoline から呼ぶ関数を作る + -> (FunPtr cb -> Ptr () -> IO r) -- ^ trampoline と callback の arg を C の関数に渡す + -> IO r +withCallback tramp build act = do + failure <- newIORef Nothing + let guarded body = do + r <- try body + case r of + Left (e :: SomeException) -> modifyIORef' failure (maybe (Just e) Just) + Right () -> pure () + r <- bracket (newStablePtr (build guarded)) freeStablePtr (act tramp . castStablePtrToPtr) + readIORef failure >>= maybe (pure r) throwIO + +-- | lock_as_value_with_arg の callback を作って呼ぶ。callback が書き込みに失敗したら例外になる +withLockCallback :: (Ptr CValue -> IO ()) -> (FunPtr LockCallback -> Ptr () -> IO Int64) -> IO Int64 +withLockCallback body lock = + withCallback lockTrampoline (\guarded v -> juizOk <$ guarded (body v)) lock + +-- | value の中身を 'Value' として読み出す (lock の callback の中で呼ぶ) +peekValue :: Ptr CValue -> IO Value +peekValue v = do + ty <- c_hsjuiz_value_type v + case ty of + 0 -> pure JNull + 1 -> JBool . (/= 0) <$> getWith c_value_get_bool + 2 -> JInt <$> getWith c_value_get_int + 3 -> JUInt <$> getWith c_value_get_uint + 4 -> JFloat <$> getWith c_value_get_float + 5 -> alloca $ \pstr -> alloca $ \plen -> do + check "value_get_string_with_len" =<< c_value_get_string_with_len v pstr plen + str <- peek pstr + len <- peek plen :: IO CSize + bytes <- BS.packCStringLen (str, fromIntegral len) + pure (JString (TE.decodeUtf8 bytes)) + 6 -> do + items <- newIORef [] + _ <- withCallback arrayTrampoline + (\guarded e -> guarded (peekValue e >>= \x -> modifyIORef' items (x :))) + (c_value_array_foreach v) + JArray . reverse <$> readIORef items + 7 -> do + items <- newIORef Map.empty + _ <- withCallback objectTrampoline + (\guarded k e -> guarded $ do + key <- peekText k + x <- peekValue e + modifyIORef' items (Map.insert key x)) + (c_value_object_foreach v) + JObject <$> readIORef items + _ -> throwJuiz juizValueTypeError "unknown value type" + where + getWith :: Storable a => (Ptr CValue -> Ptr a -> IO Int64) -> IO a + getWith f = alloca $ \p -> do + check "value_get" =<< f v p + peek p + +peekText :: CString -> IO Text +peekText s = TE.decodeUtf8 <$> BS.packCString s + +-- | NUL 終端の UTF-8 の文字列として C に渡す (途中に NUL があればそこまでになる) +withText :: Text -> (CString -> IO a) -> IO a +withText t = BS.useAsCString (TE.encodeUtf8 t) + +check :: Text -> Int64 -> IO () +check what r = unless (r == juizOk) $ throwJuiz r (what <> " failed") + +checkPtr :: Text -> Ptr CValue -> IO (Ptr CValue) +checkPtr what p + | p == nullPtr = throwJuiz juizValueConverterError (what <> " failed") + | otherwise = pure p + +-- | Process の引数 name を読み出す。無ければ 'juizValueNotFoundError' の 'JuizError' を投げる +readArgument :: Ptr CCapsuleMap -> Text -> IO Value +readArgument cm name = + withText name $ \cname -> alloca $ \pcp -> do + r <- c_capsule_map_get_capsule cm cname pcp + unless (r == juizOk) $ throwJuiz r ("argument \"" <> name <> "\" not found") + cp <- peek pcp + result <- newIORef JNull + r' <- withLockCallback (\v -> peekValue v >>= writeIORef result) (c_capsule_ptr_lock_as_value_with_arg cp) + unless (r' == juizOk) $ throwJuiz r' ("argument \"" <> name <> "\" is not a value") + readIORef result + +-- | Process の引数 name を読み出す。画像なら 'ArgImage'、そうでなければ辞書の値 ('readArgument') の 'ArgValue' +readArgumentOrImage :: Ptr CCapsuleMap -> Text -> IO Argument +readArgumentOrImage cm name = do + isImage <- withText name $ \cname -> alloca $ \pcp -> do + r <- c_capsule_map_get_capsule cm cname pcp + if r /= juizOk + then pure Nothing + else do + cp <- peek pcp + b <- c_hsjuiz_capsule_ptr_is_image cp + pure (if b /= 0 then Just cp else Nothing) + case isImage of + Just cp -> ArgImage <$> readImage cp + Nothing -> ArgValue <$> readArgument cm name + +-- | 型付きの引数 name を型 t で読み出す (docs/spec/datatype.md §4。足りないフィールドは既定値で埋め、 +-- 型にないキーは落とす)。無ければ 'juizValueNotFoundError'、型に合わなければ 'juizValueDoesNotMatchTypeError' +readTypedArgument :: Ptr CCapsuleMap -> Text -> TypeInfo -> IO Value +readTypedArgument cm name t = + withText name $ \cname -> alloca $ \pcp -> do + r <- c_capsule_map_get_capsule cm cname pcp + unless (r == juizOk) $ throwJuiz r ("argument \"" <> name <> "\" not found") + cp <- peek pcp + result <- newIORef JNull + r' <- withLockCallback (\v -> peekValue v >>= writeIORef result) + (\fp arg -> c_capsule_ptr_read_typed_value cp (typeInfoHandle t) cname fp arg) + unless (r' == juizOk) $ + throwJuiz r' ("argument \"" <> name <> "\" does not match the type " <> typeInfoName t) + readIORef result + +-- | オブジェクトの要素を書き込む +setMember :: Ptr CValue -> Text -> Value -> IO () +setMember obj key x = withText key $ \ck -> case x of + JNull -> void . checkPtr "value_object_set_null" =<< c_value_object_set_null obj ck + JBool b -> void . checkPtr "value_object_set_bool" =<< c_value_object_set_bool obj ck (fromBool b) + JInt i -> void . checkPtr "value_object_set_int" =<< c_value_object_set_int obj ck i + JUInt w -> void . checkPtr "value_object_set_uint" =<< c_value_object_set_uint obj ck w + JFloat d -> void . checkPtr "value_object_set_float" =<< c_value_object_set_float obj ck d + JString t -> withText t $ \cs -> void . checkPtr "value_object_set_string" =<< c_value_object_set_string obj ck cs + JArray xs -> do + a <- checkPtr "value_object_set_empty_array" =<< c_value_object_set_empty_array obj ck + forM_ xs (pushElement a) + JObject m -> do + o <- checkPtr "value_object_set_empty_object" =<< c_value_object_set_empty_object obj ck + forM_ (Map.toList m) (uncurry (setMember o)) + +-- | 配列に要素を足す +pushElement :: Ptr CValue -> Value -> IO () +pushElement arr x = case x of + JNull -> void . checkPtr "value_array_push_null" =<< c_value_array_push_null arr + JBool b -> void . checkPtr "value_array_push_bool" =<< c_value_array_push_bool arr (fromBool b) + JInt i -> void . checkPtr "value_array_push_int" =<< c_value_array_push_int arr i + JUInt w -> void . checkPtr "value_array_push_uint" =<< c_value_array_push_uint arr w + JFloat d -> void . checkPtr "value_array_push_float" =<< c_value_array_push_float arr d + JString t -> withText t $ \cs -> void . checkPtr "value_array_push_string" =<< c_value_array_push_string arr cs + JArray xs -> do + a <- checkPtr "value_array_push_empty_array" =<< c_value_array_push_empty_array arr + forM_ xs (pushElement a) + JObject m -> do + o <- checkPtr "value_array_push_empty_object" =<< c_value_array_push_empty_object arr + forM_ (Map.toList m) (uncurry (setMember o)) + +-- | 中身が空のオブジェクト・配列の value に要素を書き込む +fill :: Value -> Ptr CValue -> IO () +fill (JArray xs) v = forM_ xs (pushElement v) +fill (JObject m) v = forM_ (Map.toList m) (uncurry (setMember v)) +fill _ _ = pure () + +fromBool :: Bool -> Int64 +fromBool b = if b then 1 else 0 + +-- | Process の戻り値 (capsule) に書き込む。戻り値は juiz のエラーコード +writeCapsule :: Ptr CCapsule -> Value -> IO Int64 +writeCapsule cap x = case x of + JNull -> c_capsule_set_null cap + JBool b -> c_capsule_set_bool cap (fromBool b) + JInt i -> c_capsule_set_int cap i + JUInt w -> c_capsule_set_uint cap w + JFloat d -> c_capsule_set_float cap d + JString t -> withText t (c_capsule_set_string cap) + JArray _ -> c_capsule_set_empty_array cap `andThen` lock + JObject _ -> c_capsule_set_empty_object cap `andThen` lock + where + lock = withLockCallback (fill x) (c_capsule_lock_as_value_with_arg cap) + +-- | Process の結果を capsule に書き込む。戻り値は juiz のエラーコード +writeResult :: Ptr CCapsule -> Result -> IO Int64 +writeResult cap (ResultValue v) = writeCapsule cap v +writeResult cap (ResultImage img) = writeImage cap img + +-- | capsule_ptr にオブジェクトを書き込む (マニフェストを返すのに使う) +writeCapsulePtr :: Ptr CCapsulePtr -> Map Text Value -> IO Int64 +writeCapsulePtr cp m = + c_capsule_ptr_set_empty_object cp `andThen` + withLockCallback (fill (JObject m)) (c_capsule_ptr_lock_as_value_with_arg cp) + +andThen :: IO Int64 -> IO Int64 -> IO Int64 +andThen first second = do + r <- first + if r == juizOk then second else pure r + diff --git a/src/Juiz/Component.hs b/src/Juiz/Component.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Component.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Component (1 つのライブラリにまとめた Process / Container / ContainerProcess) の +-- component_manifest_entry_point を作る。 +-- +-- ふつうは "Juiz.TH" の 'Juiz.TH.juizComponent' が、各要素のエントリポイントと一緒に生成する。 +-- Template Haskell を使わずに書く方法は README を参照。 +module Juiz.Component + ( ComponentPart + , processPart + , containerPart + , containerProcessPart + , componentManifestEntryPoint + ) where + +import Data.Proxy (Proxy (..)) +import Data.Text (Text) + +import Juiz.Capsule (ToCapsule, writeCapsulePtr) +import Juiz.Error +import Juiz.Internal.FFI +import Juiz.Manifest +import Juiz.Process +import Juiz.Value + +-- | Component に入れる要素のマニフェスト (型を関数と比べて戻り値の型を補ったもの、合わなければ説明) と、関数の引数の数 +data ComponentPart = ComponentPart + { partAdd :: Either Text (ComponentManifest -> ComponentManifest) + , partName :: Text + , partArguments :: Int + , partArity :: Int + } + +-- | Process ('Juiz.Process.processEntryPoint' と同じ関数とマニフェスト) +processPart :: forall f. (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> f -> ComponentPart +processPart m _ = + ComponentPart (addProcess <$> checkProcessManifest m (Proxy :: Proxy f)) (pmTypeName m) (length (pmArguments m)) + (processArity (Proxy :: Proxy f)) + +-- | Container ('Juiz.Container.containerCreateEntryPoint' と同じ関数とマニフェスト) +containerPart :: forall f. ProcessFn f => ContainerManifest -> f -> ComponentPart +containerPart m _ = + ComponentPart (addContainer m <$ checkArgumentTypes (cmArguments m) (argumentTypes (Proxy :: Proxy f))) + (cmTypeName m) (length (cmArguments m)) (processArity (Proxy :: Proxy f)) + +-- | ContainerProcess ('Juiz.Container.containerProcessEntryPoint' と同じ関数とマニフェスト) +containerProcessPart :: forall s f. (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> (s -> f) -> ComponentPart +containerProcessPart m _ = + ComponentPart (addProcess <$> checkProcessManifest m (Proxy :: Proxy f)) (pmTypeName m) (length (pmArguments m)) + (processArity (Proxy :: Proxy f)) + +-- | component_manifest_entry_point の中身。base に要素を足したマニフェストを書き込む。 +-- 要素のマニフェストの引数の数と関数の引数の数が違う、ContainerProcess の Container が Component に無い、 +-- 型名が重なっている、のどれかならエラーにする (juiz はプラグインを読み込むときに失敗する) +componentManifestEntryPoint :: ComponentManifest -> [ComponentPart] -> ManifestFunction +componentManifestEntryPoint base parts cp = guardEntryPoint (compTypeName base) $ do + mapM_ checkArity parts + adds <- mapM (\p -> either (\msg -> throwJuiz juizValueConverterError (partName p <> ": " <> msg)) pure (partAdd p)) parts + case componentManifestToValue (foldl (flip ($)) base adds) of + Left msg -> throwJuiz juizValueConverterError msg + Right (JObject obj) -> writeCapsulePtr cp obj + Right _ -> pure juizValueConverterError + where + checkArity p + | partArguments p == partArity p = pure () + | otherwise = throwJuiz juizValueConverterError $ + partName p <> ": the manifest has " <> tshow (partArguments p) + <> " arguments, but the function takes " <> tshow (partArity p) diff --git a/src/Juiz/Container.hs b/src/Juiz/Container.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Container.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Container と ContainerProcess のエントリポイント (C から呼ばれる関数) を Haskell の関数から作る。 +-- +-- ふつうは "Juiz.TH" の 'Juiz.TH.juizContainer' と 'Juiz.TH.juizContainerProcess' が、 +-- ここの関数を使って foreign export まで生成する。Template Haskell を使わずに書く方法は README を参照。 +-- +-- Container の状態 (Container を作る関数の結果) は 'StablePtr' に包み、juiz には @void*@ として渡す。 +-- juiz が Container を削除するときに呼ぶ解放関数 (container_factory_destroy_entry_point) で +-- 'freeStablePtr' するので、それまでは GC に回収されない。 +module Juiz.Container + ( containerManifestEntryPoint + , containerCreateEntryPoint + , containerCreateEntryPointWithDestroy + , containerDestroyEntryPoint + , containerProcessManifestEntryPoint + , containerProcessEntryPoint + ) where + +import Control.Exception (finally) +import Control.Monad (unless, void, when) +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import Data.Typeable (TypeRep, Typeable, splitTyConApp, tyConModule, tyConName, typeOf, typeRep) +import Data.Word (Word64) +import Foreign.Marshal.Alloc (free, mallocBytes) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.StablePtr (StablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr) +import Foreign.Storable (peek, peekByteOff, poke, pokeByteOff, sizeOf) +import Unsafe.Coerce (unsafeCoerce) + +import Juiz.Capsule (ToCapsule) +import Juiz.Error +import Juiz.Internal.FFI +import Juiz.Manifest +import Juiz.Pose (withPoseCall) +import Juiz.Process + +-- | juiz に渡す Container の中身: 状態と、解放するときに呼ぶ関数。 +-- 状態の型は 'Typeable' で覚えておき、ContainerProcess に渡すときに確かめる +data ContainerBox = forall s. Typeable s => ContainerBox s (s -> IO ()) + +-- | juiz に渡す @void*@ は、先頭にこの値、続けて作った hsjuiz の実体を表す値 ('c_hsjuiz_runtime_tag')、 +-- 'StablePtr' を置いた malloc の領域。 +-- 別の言語の Container (C++ のオブジェクトなど) が ContainerProcess に渡されたときに、 +-- StablePtr として読んでプロセスが落ちないよう、先頭の値で見分ける。 +-- Windows ではプラグインの DLL ごとに RTS が別なので、別の DLL の StablePtr は読めない。 +-- 実体を表す値が違えば読まずにエラーにする +containerMagic :: Word64 +containerMagic = 0x48534a55495a4332 -- "HSJUIZC2" + +magicSize :: Int +magicSize = sizeOf containerMagic + +-- | StablePtr を置く位置 +stablePtrOffset :: Int +stablePtrOffset = magicSize + sizeOf nullPtr + +-- | Container の manifest_entry_point の中身。マニフェストの引数の数と、Container を作る関数の引数の数が +-- 違えばエラーにする (juiz はプラグインを読み込むときに失敗する) +containerManifestEntryPoint :: forall f. ProcessFn f => ContainerManifest -> f -> ManifestFunction +containerManifestEntryPoint m _ cp = guardEntryPoint (cmTypeName m) $ + case checkArgumentTypes (cmArguments m) (argumentTypes (Proxy :: Proxy f)) of + Left msg -> throwJuiz juizValueConverterError msg + Right () -> checkedManifestEntryPoint (cmTypeName m) (length (cmArguments m)) (processArity (Proxy :: Proxy f)) + (containerManifestToValue m) cp + +-- | Container を作る関数の中身。マニフェストの引数 (設定ファイルの containers に書いた値、 +-- 無ければ既定値) を順に読み出して関数を呼び、結果を Container の状態にする +containerCreateEntryPoint :: (ProcessFn f, Typeable (FnResult f)) => ContainerManifest -> f -> ContainerCreateFunction +containerCreateEntryPoint m f = containerCreateEntryPointWithDestroy m f (\_ -> pure ()) + +-- | 'containerCreateEntryPoint' に、Container を削除するときに呼ぶ関数 (デバイスを閉じるなど) を足したもの +containerCreateEntryPointWithDestroy + :: (ProcessFn f, Typeable (FnResult f)) + => ContainerManifest -> f -> (FnResult f -> IO ()) -> ContainerCreateFunction +containerCreateEntryPointWithDestroy m f destroy cm pobj = guardEntryPoint (cmTypeName m) $ do + args <- readArguments (cmArguments m) cm + s <- applyArgs f args + cell <- mallocBytes (stablePtrOffset + sizeOf (undefined :: StablePtr ContainerBox)) + sp <- newStablePtr (ContainerBox s destroy) + tag <- c_hsjuiz_runtime_tag + poke (castPtr cell) containerMagic + pokeByteOff cell magicSize tag + pokeByteOff cell stablePtrOffset sp + poke pobj cell + pure juizOk + +-- | container_factory_destroy_entry_point の中身。Container の状態を GC に返し、解放する関数を呼ぶ +containerDestroyEntryPoint :: ContainerManifest -> ContainerDestroyFunction +containerDestroyEntryPoint m p = void $ guardEntryPoint (cmTypeName m) $ do + sp <- stablePtrOf p + -- 二重に解放しないよう、先に印を消す + poke (castPtr p) (0 :: Word64) + ContainerBox s destroy <- deRefStablePtr sp + (destroy s `finally` (freeStablePtr sp >> free p)) + pure juizOk + +-- | ContainerProcess の manifest_entry_point の中身。 +-- マニフェストの引数の数と、関数の (Container の状態を除いた) 引数の数が違えばエラーにする +containerProcessManifestEntryPoint + :: forall s f. (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> (s -> f) -> ManifestFunction +containerProcessManifestEntryPoint m _ cp = guardEntryPoint (pmTypeName m) $ + case checkProcessManifest m (Proxy :: Proxy f) of + Left msg -> throwJuiz juizValueConverterError msg + Right m' -> checkedManifestEntryPoint (pmTypeName m') (length (pmArguments m')) (processArity (Proxy :: Proxy f)) + (manifestToValue m') cp + +-- | ContainerProcess の関数の中身。第 1 引数に Container の状態を渡し、 +-- 続けてマニフェストの引数を順に渡して呼ぶ。状態の型が違えば 'juizHaskellContainerTypeError' +containerProcessEntryPoint + :: forall s f. (Typeable s, ProcessFn f, ToCapsule (FnResult f)) + => ProcessManifest -> (s -> f) -> ContainerProcessFunction +containerProcessEntryPoint m f p cm out = guardEntryPoint (pmTypeName m) $ do + sp <- stablePtrOf p + ContainerBox s _ <- deRefStablePtr sp + let actual = typeOf s + expected = typeRep (Proxy :: Proxy s) + if typeKey actual == typeKey expected + -- 型の名前 (モジュール名つき) が同じなら同じ型として扱う + -- 関数の中から Juiz.Pose で呼び出し元 Container の ContainerPose を読み書きできるよう、引数を覚えておく + then withPoseCall cm $ applyAndWrite (pmArguments m) (f (unsafeCoerce s :: s)) cm out + else throwJuiz juizHaskellContainerTypeError $ + "the container state is " <> T.pack (typeKey actual) <> ", but the process expects " + <> T.pack (typeKey expected) + +-- | 型を、パッケージを除いたモジュール名つきの名前で表す (@Data.IORef.IORef (GHC.Int.Int64)@ など)。 +-- +-- Container と ContainerProcess は別々の foreign-library になり、同じモジュールでもライブラリごとに +-- パッケージの識別子 (unit id) が違うことがあるので、'Data.Typeable.cast' (パッケージまで比べる) は使えない。 +-- 両方のライブラリで同じモジュールの同じ型を使うこと (README を参照) +typeKey :: TypeRep -> String +typeKey t = tyConModule tc ++ "." ++ tyConName tc ++ concatMap (\a -> " (" ++ typeKey a ++ ")") args + where + (tc, args) = splitTyConApp t + +-- | juiz から渡された @void*@ から 'StablePtr' を取り出す。hsjuiz の Container でなければエラー +stablePtrOf :: Ptr () -> IO (StablePtr ContainerBox) +stablePtrOf p = do + when (p == nullPtr) $ throwJuiz juizHaskellContainerTypeError "the container is null" + magic <- peek (castPtr p) :: IO Word64 + unless (magic == containerMagic) $ + throwJuiz juizHaskellContainerTypeError "the container is not a Haskell (hsjuiz) container" + tag <- peekByteOff p magicSize :: IO (Ptr ()) + ownTag <- c_hsjuiz_runtime_tag + unless (tag == ownTag) $ + throwJuiz juizHaskellContainerTypeError + "the container was created by another Haskell plugin with its own GHC runtime \ + \(on Windows each Haskell DLL has its own runtime; put the container and its container processes \ + \in one component with juizComponent)" + sp <- peekByteOff p stablePtrOffset + when (castStablePtrToPtr sp == nullPtr) $ throwJuiz juizHaskellContainerTypeError "the container is broken" + pure sp diff --git a/src/Juiz/Error.hs b/src/Juiz/Error.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Error.hs @@ -0,0 +1,107 @@ +-- | juiz のエラーコード (bindings/cjuiz/include/juiz_sdk.h と同じ値) と、Haskell 側で投げる例外。 +module Juiz.Error + ( JuizError (..) + , throwJuiz + -- * エラーコード + , juizOk + , juizValueTypeError + , juizValueNotFoundError + , juizValueConverterError + , juizCapsulePtrLockError + , juizCapsuleMapNoValue + , juizCapsuleTypeError + , juizCapsuleNoValue + , juizProcessFunctionError + , juizHaskellContainerTypeError + , juizTypeSchemaInvalidError + , juizValueDoesNotMatchTypeError + , juizImageFormatError + , juizTransformationsNotAttachedError + , juizNoCommonAnchorError + , juizPoseNotWritableError + , juizInvalidPoseValueError + , juizTransformationsError + , juizTransformNotWritableError + , juizTransformNotFoundError + ) where + +import Control.Exception (Exception, throwIO) +import Data.Int (Int64) +import Data.Text (Text) + +-- | juiz のエラーコードと説明。プラグインの関数の中で投げると、エントリポイントがエラーコードに変えて juiz に返す +data JuizError = JuizError + { juizErrorCode :: !Int64 + , juizErrorMessage :: !Text + } + deriving (Show) + +instance Exception JuizError + +throwJuiz :: Int64 -> Text -> IO a +throwJuiz code msg = throwIO (JuizError code msg) + +juizOk, juizValueTypeError, juizValueNotFoundError, juizValueConverterError :: Int64 +juizOk = 0 +juizValueTypeError = -101 +juizValueNotFoundError = -102 +juizValueConverterError = -103 + +juizCapsulePtrLockError, juizCapsuleMapNoValue, juizCapsuleTypeError, juizCapsuleNoValue :: Int64 +juizCapsulePtrLockError = -201 +juizCapsuleMapNoValue = -301 +juizCapsuleTypeError = -401 +juizCapsuleNoValue = -402 + +-- | Process の関数が値を返せなかった (juiz_sdk.h の JUIZ_PROCESS_FUNCTION_NULL_OPT_RETURNED)。 +-- 'JuizError' 以外の例外 (error や自分で投げた例外) はこのコードになる +juizProcessFunctionError :: Int64 +juizProcessFunctionError = -501 + +-- | ContainerProcess に、期待する型ではない Container が渡された (juiz_sdk.h の JUIZ_HASKELL_CONTAINER_TYPE_ERROR)。 +-- 別の言語の Container や、状態の型が違う Haskell の Container に結びつけたとき +juizHaskellContainerTypeError :: Int64 +juizHaskellContainerTypeError = -602 + +-- | Avro のスキーマが juiz のデータ型の規則に合わない (juiz_sdk.h の JUIZ_TYPE_SCHEMA_INVALID_ERROR) +juizTypeSchemaInvalidError :: Int64 +juizTypeSchemaInvalidError = -701 + +-- | 辞書の値が型に合わない (juiz_sdk.h の JUIZ_VALUE_DOES_NOT_MATCH_TYPE_ERROR)。 +-- 型付きの引数に合わない値が渡されたとき (理由は juiz のログに出る) +juizValueDoesNotMatchTypeError :: Int64 +juizValueDoesNotMatchTypeError = -702 + +-- | 画像の形式・大きさ・stride が正しくない、または扱えない形式 (juiz_sdk.h の JUIZ_IMAGE_FORMAT_ERROR) +juizImageFormatError :: Int64 +juizImageFormatError = -704 + +-- | ContainerPose (docs/spec/transformations.md §12.3・§17)。 +-- Container が System の Transformations につながっていない、または ContainerProcess の外で読み書きした +juizTransformationsNotAttachedError :: Int64 +juizTransformationsNotAttachedError = -901 + +-- | 基準と Container の両方を含む Anchor がない +juizNoCommonAnchorError :: Int64 +juizNoCommonAnchorError = -902 + +-- | 根の Anchor・基準自身・基準が子孫の Container への書き込み +juizPoseNotWritableError :: Int64 +juizPoseNotWritableError = -903 + +-- | 長さ 0 の四元数、NaN・無限大 +juizInvalidPoseValueError :: Int64 +juizInvalidPoseValueError = -904 + +-- | そのほかの ContainerPose の失敗 +juizTransformationsError :: Int64 +juizTransformationsError = -905 + +-- | 'Juiz.Pose.setTransform' で、呼び出し元 Container が端点でも writers でもない Transform への書き込み、 +-- readonly の ContainerProcess からの書き込み (§7.5、#410) +juizTransformNotWritableError :: Int64 +juizTransformNotWritableError = -906 + +-- | 'Juiz.Pose.setTransform' の Transform が無い (§7.5、#410) +juizTransformNotFoundError :: Int64 +juizTransformNotFoundError = -907 diff --git a/src/Juiz/Image.hs b/src/Juiz/Image.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Image.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | 画像の引数と戻り値 (issue #253、docs/spec/large-data.md §10)。 +-- +-- Process の引数を 'Image' にすると、届いた画像 (Rust の Capsule::Image) を複製して受け取る。 +-- 結果を 'Image' にすると、juiz の画像に複製して返す。IPC や qmp のブローカー越しには生バイトのフレームで渡る。 +-- マニフェストでは 'Juiz.Manifest.addImageArg' で引数を足す。 +-- +-- > manifest :: ProcessManifest +-- > manifest = processManifest "invert_hs" & addImageArg "img" "image to invert" +-- > +-- > invert :: Image -> IO Image +-- > invert img = pure img { imageData = BS.map (255 -) (imageData img) } +module Juiz.Image + ( Image (..) + , PixelFormat (..) + , bytesPerPixel + , newImage + , imageRowBytes + , readImage + , writeImage + ) where + +import Control.Exception (SomeException, bracket, throwIO, try) +import Control.Monad (unless, when) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BSU +import Data.Int (Int64) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import Data.Word (Word32) +import Foreign.C.Types (CSize) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.StablePtr (castStablePtrToPtr, freeStablePtr, newStablePtr) +import Foreign.Storable (peekByteOff, pokeByteOff, sizeOf) + +import Juiz.Error +import Juiz.Internal.FFI + +-- | 画素の形式。'L8' 〜 'RGBA32F' は large-data.md §3.4 の表と同じ。 +-- 'BGR8' / 'BGRA8' は送るとき (Process の結果) だけ使え、juiz は赤と青を入れ替えて 'RGB8' / 'RGBA8' で持つ +data PixelFormat + = L8 | LA8 | RGB8 | RGBA8 | L16 | LA16 | RGB16 | RGBA16 | RGB32F | RGBA32F | BGR8 | BGRA8 + deriving (Eq, Ord, Show, Enum, Bounded) + +-- | 画像。画素は 'imageData' の先頭から 1 行 'imageStride' バイトずつ並ぶ。16 bit・f32 の形式はホストのバイト順。 +-- 受け取った画像の 'imageStride' は 'imageRowBytes' (行の余白なし) +data Image = Image + { imageWidth :: !Int + , imageHeight :: !Int + , imageFormat :: !PixelFormat + , imageStride :: !Int + , imageData :: !BS.ByteString + } + deriving (Eq, Show) + +-- | 1 画素のバイト数 +bytesPerPixel :: PixelFormat -> Int +bytesPerPixel f = case f of + L8 -> 1 + LA8 -> 2 + L16 -> 2 + RGB8 -> 3 + BGR8 -> 3 + RGBA8 -> 4 + BGRA8 -> 4 + LA16 -> 4 + RGB16 -> 6 + RGBA16 -> 8 + RGB32F -> 12 + RGBA32F -> 16 + +-- | 1 行の画素のバイト数 (幅 × 1 画素のバイト数) +imageRowBytes :: Image -> Int +imageRowBytes img = imageWidth img * bytesPerPixel (imageFormat img) + +-- | 行の余白のない画像を作る。画素のバイト数が 幅 × 高さ × 1 画素のバイト数 でなければ 'Left' +newImage :: Int -> Int -> PixelFormat -> BS.ByteString -> Either Text Image +newImage w h f bytes + | w < 0 || h < 0 = Left "width and height must not be negative" + | BS.length bytes /= w * h * bytesPerPixel f = + Left ("image data must be " <> T.pack (show (w * h * bytesPerPixel f)) <> " bytes, but " + <> T.pack (show (BS.length bytes))) + | otherwise = Right (Image w h f (w * bytesPerPixel f) bytes) + +-- juiz_sdk.h の juiz_image: uint32_t width, height, format, reserved; size_t stride; const uint8_t* data +offStride, offData, imageStructSize :: Int +offStride = 16 +offData = offStride + sizeOf (undefined :: CSize) +imageStructSize = offData + sizeOf (undefined :: Ptr ()) + +formatCode :: PixelFormat -> Word32 +formatCode = fromIntegral . fromEnum + +-- | capsule_ptr の画像を読む (複製する)。画像でなければ 'juizCapsuleTypeError' の 'JuizError' +readImage :: Ptr CCapsulePtr -> IO Image +readImage cp = do + result <- newIORef Nothing + failure <- newIORef Nothing + let callback p = do + r <- try $ do + w <- peekByteOff p 0 :: IO Word32 + h <- peekByteOff p 4 :: IO Word32 + code <- peekByteOff p 8 :: IO Word32 + stride <- peekByteOff p offStride :: IO CSize + dat <- peekByteOff p offData :: IO (Ptr ()) + when (fromIntegral code > fromEnum (maxBound :: PixelFormat)) $ + throwJuiz juizImageFormatError ("unknown image format " <> T.pack (show code)) + let f = toEnum (fromIntegral code) + rb = fromIntegral w * bytesPerPixel f + st = fromIntegral stride + rows <- mapM (\y -> BS.packCStringLen (castPtr dat `plusPtr` (y * st), rb)) [0 .. fromIntegral h - 1] + writeIORef result (Just (Image (fromIntegral w) (fromIntegral h) f rb (BS.concat rows))) + case r of + Left (e :: SomeException) -> writeIORef failure (Just e) >> pure juizValueConverterError + Right () -> pure juizOk + code <- bracket (newStablePtr (callback :: ImageFunction)) freeStablePtr + (c_capsule_ptr_lock_as_image cp imageTrampoline . castStablePtrToPtr) + readIORef failure >>= maybe (pure ()) throwIO + unless (code == juizOk) $ throwJuiz code (codeMessage code) + maybe (throwJuiz juizCapsuleTypeError "not an image") pure =<< readIORef result + where + codeMessage :: Int64 -> Text + codeMessage c + | c == juizImageFormatError = "unsupported image format" + | otherwise = "not an image" + +-- | 画像を capsule (Process の戻り値) に書き込む (libjuiz_sdk が複製する)。戻り値は juiz のエラーコード。 +-- 'imageData' が 'imageStride' と高さに足りなければ 'juizImageFormatError' を返す +writeImage :: Ptr CCapsule -> Image -> IO Int64 +writeImage cap img + | imageWidth img < 0 || imageHeight img < 0 || imageStride img < imageRowBytes img = pure juizImageFormatError + | BS.length (imageData img) < needed = pure juizImageFormatError + | otherwise = + BSU.unsafeUseAsCString (imageData img) $ \dat -> + allocaBytes imageStructSize $ \p -> do + pokeByteOff p 0 (fromIntegral (imageWidth img) :: Word32) + pokeByteOff p 4 (fromIntegral (imageHeight img) :: Word32) + pokeByteOff p 8 (formatCode (imageFormat img)) + pokeByteOff p 12 (0 :: Word32) + pokeByteOff p offStride (fromIntegral (imageStride img) :: CSize) + pokeByteOff p offData dat + c_capsule_set_image cap (castPtr p) + where + needed + | imageHeight img == 0 = 0 + | otherwise = imageStride img * (imageHeight img - 1) + imageRowBytes img diff --git a/src/Juiz/Internal/Base64.hs b/src/Juiz/Internal/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Internal/Base64.hs @@ -0,0 +1,59 @@ +-- | base64 (RFC 4648 §4、パディングあり)。データ型の bytes を辞書で表すのに使う (docs/spec/datatype.md §4) +module Juiz.Internal.Base64 + ( encodeBase64 + , decodeBase64 + ) where + +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC +import Data.Char (chr, ord) +import Data.Word (Word8) + +alphabet :: BS.ByteString +alphabet = BC.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" + +encodeBase64 :: BS.ByteString -> String +encodeBase64 bs = go (BS.unpack bs) + where + sym :: Int -> Char + sym i = chr (fromIntegral (BS.index alphabet i)) + go (a : b : c : rest) = + let n = w a `shiftL` 16 .|. w b `shiftL` 8 .|. w c + in map (\s -> sym ((n `shiftR` s) .&. 63)) [18, 12, 6, 0] ++ go rest + go [a, b] = + let n = w a `shiftL` 16 .|. w b `shiftL` 8 + in map (\s -> sym ((n `shiftR` s) .&. 63)) [18, 12, 6] ++ "=" + go [a] = + let n = w a `shiftL` 16 + in map (\s -> sym ((n `shiftR` s) .&. 63)) [18, 12] ++ "==" + go [] = [] + w :: Word8 -> Int + w = fromIntegral + +-- | パディングまで正しい base64 だけを受け付ける。誤りなら Nothing +decodeBase64 :: String -> Maybe BS.ByteString +decodeBase64 s + | length s `mod` 4 /= 0 = Nothing + | otherwise = BS.pack . concat <$> mapM quad (chunks s) + where + chunks [] = [] + chunks xs = let (a, b) = splitAt 4 xs in a : chunks b + value c + | c >= 'A' && c <= 'Z' = Just (ord c - ord 'A') + | c >= 'a' && c <= 'z' = Just (ord c - ord 'a' + 26) + | c >= '0' && c <= '9' = Just (ord c - ord '0' + 52) + | c == '+' = Just 62 + | c == '/' = Just 63 + | otherwise = Nothing + -- 使わない下位のビットが 0 でなければ誤り (同じバイト列の表し方を 1 つにする) + bytes :: Int -> [Int] -> Maybe [Word8] + bytes count vs + | n .&. ((1 `shiftL` (8 * (3 - count))) - 1) /= 0 = Nothing + | otherwise = Just [fromIntegral ((n `shiftR` (16 - 8 * i)) .&. 255) | i <- [0 .. count - 1]] + where + n = combine vs + quad [a, b, '=', '='] = mapM value [a, b] >>= bytes 1 + quad [a, b, c, '='] = mapM value [a, b, c] >>= bytes 2 + quad q = mapM value q >>= bytes 3 + combine vs = foldl (\acc v -> acc `shiftL` 6 .|. v) 0 vs `shiftL` (6 * (4 - length vs)) diff --git a/src/Juiz/Internal/FFI.hs b/src/Juiz/Internal/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Internal/FFI.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | libjuiz_sdk の C 関数 (bindings/cjuiz/include/juiz_sdk.h) の宣言。 +-- +-- ふつうは "Juiz" の関数を使い、ここを直接使う必要はない。 +-- 宣言は juiz_sdk.h と合わせること。callback で Haskell に戻ってくる関数は safe で呼ぶ。 +module Juiz.Internal.FFI + ( -- * 不透明な型 + CCapsulePtr, CCapsule, CCapsuleMap, CValue, CJuizType, CImage + -- * プラグインが公開する関数の型 + , ProcessFunction, ManifestFunction, ProcessFactoryFunction + , ContainerCreateFunction, ContainerFactoryFunction, ContainerDestroyFunction + , ContainerProcessFunction, ContainerProcessFactoryFunction + -- * callback の型 + , LockCallback, ObjectCallback, ArrayCallback + , ImageCallback + , LockFunction, ObjectFunction, ArrayFunction, ImageFunction + , lockTrampoline, objectTrampoline, arrayTrampoline, imageTrampoline + -- * capsule_map + , c_capsule_map_get_capsule + -- * capsule_ptr + , c_capsule_ptr_set_empty_object, c_capsule_ptr_lock_as_value_with_arg + -- * capsule + , c_capsule_set_null, c_capsule_set_bool, c_capsule_set_int, c_capsule_set_uint + , c_capsule_set_float, c_capsule_set_string + , c_capsule_set_empty_object, c_capsule_set_empty_array + , c_capsule_lock_as_value_with_arg + -- * value + , c_hsjuiz_value_type, c_hsjuiz_runtime_tag + , c_value_get_bool, c_value_get_int, c_value_get_uint, c_value_get_float + , c_value_get_string_with_len + , c_value_object_foreach, c_value_array_foreach + , c_value_object_set_null, c_value_object_set_bool, c_value_object_set_int + , c_value_object_set_uint, c_value_object_set_float, c_value_object_set_string + , c_value_object_set_empty_object, c_value_object_set_empty_array + , c_value_array_push_null, c_value_array_push_bool, c_value_array_push_int + , c_value_array_push_uint, c_value_array_push_float, c_value_array_push_string + , c_value_array_push_empty_object, c_value_array_push_empty_array + -- * juiz_type (データ型、docs/spec/datatype.md §22) + , c_juiz_type_new, c_juiz_type_describe, c_capsule_ptr_read_typed_value + -- * 画像 (docs/spec/large-data.md §10) + , c_hsjuiz_capsule_ptr_is_image, c_capsule_ptr_lock_as_image, c_capsule_set_image + ) where + +import Data.Int (Int64) +import Data.Word (Word8, Word64) +import Foreign.C.String (CString) +import Foreign.C.Types (CSize (..)) +import Foreign.Ptr (FunPtr, Ptr) +import Foreign.StablePtr (castPtrToStablePtr, deRefStablePtr) + +-- | juiz_sdk.h の capsule_ptr (Rust の CapsulePtr)。ポインタとしてだけ使う +data CCapsulePtr +-- | juiz_sdk.h の capsule (Rust の Capsule)。Process の戻り値の入れ物 +data CCapsule +-- | juiz_sdk.h の capsule_map (Rust の CapsuleMap)。Process の引数 +data CCapsuleMap +-- | juiz_sdk.h の value (Rust の Value) +data CValue +-- | juiz_sdk.h の juiz_type (Rust の型のモデル)。juiz_type_new で作る +data CJuizType +-- | juiz_sdk.h の juiz_image (画像の幅・高さ・形式・stride・画素の先頭)。"Juiz.Image" が読み書きする +data CImage + +-- | Process の関数 (int64_t (*)(capsule_map*, capsule*)) +type ProcessFunction = Ptr CCapsuleMap -> Ptr CCapsule -> IO Int64 +-- | manifest_entry_point (int64_t (capsule_ptr*)) +type ManifestFunction = Ptr CCapsulePtr -> IO Int64 +-- | process_factory_entry_point (int64_t (*(void))(capsule_map*, capsule*)) +type ProcessFactoryFunction = IO (FunPtr ProcessFunction) + +-- | Container を作る関数 (int64_t (*)(capsule_map*, void**))。作った Container を void* で返す +type ContainerCreateFunction = Ptr CCapsuleMap -> Ptr (Ptr ()) -> IO Int64 +-- | container_factory_entry_point (int64_t (*(void))(capsule_map*, void**)) +type ContainerFactoryFunction = IO (FunPtr ContainerCreateFunction) +-- | container_factory_destroy_entry_point (void (void*))。Container を解放する +type ContainerDestroyFunction = Ptr () -> IO () +-- | ContainerProcess の関数 (int64_t (*)(void*, capsule_map*, capsule*))。第 1 引数が Container +type ContainerProcessFunction = Ptr () -> Ptr CCapsuleMap -> Ptr CCapsule -> IO Int64 +-- | container_process_factory_entry_point (int64_t (*(void))(void*, capsule_map*, capsule*)) +type ContainerProcessFactoryFunction = IO (FunPtr ContainerProcessFunction) + +-- | *_lock_as_value_with_arg の callback (int64_t (*)(void*, value*)) +type LockCallback = Ptr () -> Ptr CValue -> IO Int64 +-- | value_object_foreach の callback (void (*)(void*, const char*, value*)) +type ObjectCallback = Ptr () -> CString -> Ptr CValue -> IO () +-- | value_array_foreach の callback (void (*)(void*, value*)) +type ArrayCallback = Ptr () -> Ptr CValue -> IO () + +-- | capsule_ptr_lock_as_image の callback (int64_t (*)(void*, const juiz_image*)) +type ImageCallback = Ptr () -> Ptr CImage -> IO Int64 + +-- callback は "wrapper" で作らず、決まった関数 (trampoline) を渡し、呼ぶ Haskell の関数は +-- 第 1 引数 (void* arg) に StablePtr で渡す。"wrapper" は adjustor (実行できるメモリ) を作るが、 +-- Windows の GHC は多くのスレッドから作ると確保に失敗して落ちることがある (issue #137) + +-- | lock の callback で呼ぶ関数 ('LockCallback' から arg を除いたもの) +type LockFunction = Ptr CValue -> IO Int64 +-- | value_object_foreach の callback で呼ぶ関数 +type ObjectFunction = CString -> Ptr CValue -> IO () +-- | value_array_foreach の callback で呼ぶ関数 +type ArrayFunction = Ptr CValue -> IO () +-- | capsule_ptr_lock_as_image の callback で呼ぶ関数 +type ImageFunction = Ptr CImage -> IO Int64 + +hsjuizLockTrampoline :: Ptr () -> Ptr CValue -> IO Int64 +hsjuizLockTrampoline arg v = deRefStablePtr (castPtrToStablePtr arg) >>= \(f :: LockFunction) -> f v +hsjuizObjectTrampoline :: Ptr () -> CString -> Ptr CValue -> IO () +hsjuizObjectTrampoline arg k v = deRefStablePtr (castPtrToStablePtr arg) >>= \(f :: ObjectFunction) -> f k v +hsjuizArrayTrampoline :: Ptr () -> Ptr CValue -> IO () +hsjuizArrayTrampoline arg v = deRefStablePtr (castPtrToStablePtr arg) >>= \(f :: ArrayFunction) -> f v +hsjuizImageTrampoline :: Ptr () -> Ptr CImage -> IO Int64 +hsjuizImageTrampoline arg p = deRefStablePtr (castPtrToStablePtr arg) >>= \(f :: ImageFunction) -> f p + +foreign export ccall "hsjuiz_lock_trampoline" hsjuizLockTrampoline :: Ptr () -> Ptr CValue -> IO Int64 +foreign export ccall "hsjuiz_object_trampoline" hsjuizObjectTrampoline :: Ptr () -> CString -> Ptr CValue -> IO () +foreign export ccall "hsjuiz_array_trampoline" hsjuizArrayTrampoline :: Ptr () -> Ptr CValue -> IO () +foreign export ccall "hsjuiz_image_trampoline" hsjuizImageTrampoline :: Ptr () -> Ptr CImage -> IO Int64 + +foreign import ccall "&hsjuiz_lock_trampoline" lockTrampoline :: FunPtr LockCallback +foreign import ccall "&hsjuiz_object_trampoline" objectTrampoline :: FunPtr ObjectCallback +foreign import ccall "&hsjuiz_array_trampoline" arrayTrampoline :: FunPtr ArrayCallback +foreign import ccall "&hsjuiz_image_trampoline" imageTrampoline :: FunPtr ImageCallback + +-- capsule_map +foreign import ccall unsafe "capsule_map_get_capsule" + c_capsule_map_get_capsule :: Ptr CCapsuleMap -> CString -> Ptr (Ptr CCapsulePtr) -> IO Int64 + +-- capsule_ptr +foreign import ccall unsafe "capsule_ptr_set_empty_object" + c_capsule_ptr_set_empty_object :: Ptr CCapsulePtr -> IO Int64 +foreign import ccall safe "capsule_ptr_lock_as_value_with_arg" + c_capsule_ptr_lock_as_value_with_arg :: Ptr CCapsulePtr -> FunPtr LockCallback -> Ptr () -> IO Int64 + +-- capsule +foreign import ccall unsafe "capsule_set_null" c_capsule_set_null :: Ptr CCapsule -> IO Int64 +foreign import ccall unsafe "capsule_set_bool" c_capsule_set_bool :: Ptr CCapsule -> Int64 -> IO Int64 +foreign import ccall unsafe "capsule_set_int" c_capsule_set_int :: Ptr CCapsule -> Int64 -> IO Int64 +foreign import ccall unsafe "capsule_set_uint" c_capsule_set_uint :: Ptr CCapsule -> Word64 -> IO Int64 +foreign import ccall unsafe "capsule_set_float" c_capsule_set_float :: Ptr CCapsule -> Double -> IO Int64 +foreign import ccall unsafe "capsule_set_string" c_capsule_set_string :: Ptr CCapsule -> CString -> IO Int64 +foreign import ccall unsafe "capsule_set_empty_object" c_capsule_set_empty_object :: Ptr CCapsule -> IO Int64 +foreign import ccall unsafe "capsule_set_empty_array" c_capsule_set_empty_array :: Ptr CCapsule -> IO Int64 +foreign import ccall safe "capsule_lock_as_value_with_arg" + c_capsule_lock_as_value_with_arg :: Ptr CCapsule -> FunPtr LockCallback -> Ptr () -> IO Int64 + +-- value (読み出し) +foreign import ccall unsafe "hsjuiz_value_type" c_hsjuiz_value_type :: Ptr CValue -> IO Int64 +-- この hsjuiz (と RTS) の実体を表す値 (cbits/hsjuiz.c、Juiz.Container が使う) +foreign import ccall unsafe "hsjuiz_runtime_tag" c_hsjuiz_runtime_tag :: IO (Ptr ()) +-- value_get_bool は bool* (1 バイト) に書き込む +foreign import ccall unsafe "value_get_bool" c_value_get_bool :: Ptr CValue -> Ptr Word8 -> IO Int64 +foreign import ccall unsafe "value_get_int" c_value_get_int :: Ptr CValue -> Ptr Int64 -> IO Int64 +foreign import ccall unsafe "value_get_uint" c_value_get_uint :: Ptr CValue -> Ptr Word64 -> IO Int64 +foreign import ccall unsafe "value_get_float" c_value_get_float :: Ptr CValue -> Ptr Double -> IO Int64 +foreign import ccall unsafe "value_get_string_with_len" + c_value_get_string_with_len :: Ptr CValue -> Ptr CString -> Ptr CSize -> IO Int64 +foreign import ccall safe "value_object_foreach" + c_value_object_foreach :: Ptr CValue -> FunPtr ObjectCallback -> Ptr () -> IO Int64 +foreign import ccall safe "value_array_foreach" + c_value_array_foreach :: Ptr CValue -> FunPtr ArrayCallback -> Ptr () -> IO Int64 + +-- value (オブジェクトへの書き込み。入れた要素を返す) +foreign import ccall unsafe "value_object_set_null" c_value_object_set_null :: Ptr CValue -> CString -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_bool" c_value_object_set_bool :: Ptr CValue -> CString -> Int64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_int" c_value_object_set_int :: Ptr CValue -> CString -> Int64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_uint" c_value_object_set_uint :: Ptr CValue -> CString -> Word64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_float" c_value_object_set_float :: Ptr CValue -> CString -> Double -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_string" c_value_object_set_string :: Ptr CValue -> CString -> CString -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_empty_object" c_value_object_set_empty_object :: Ptr CValue -> CString -> IO (Ptr CValue) +foreign import ccall unsafe "value_object_set_empty_array" c_value_object_set_empty_array :: Ptr CValue -> CString -> IO (Ptr CValue) + +-- value (配列への追加。足した要素を返す) +foreign import ccall unsafe "value_array_push_null" c_value_array_push_null :: Ptr CValue -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_bool" c_value_array_push_bool :: Ptr CValue -> Int64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_int" c_value_array_push_int :: Ptr CValue -> Int64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_uint" c_value_array_push_uint :: Ptr CValue -> Word64 -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_float" c_value_array_push_float :: Ptr CValue -> Double -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_string" c_value_array_push_string :: Ptr CValue -> CString -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_empty_object" c_value_array_push_empty_object :: Ptr CValue -> IO (Ptr CValue) +foreign import ccall unsafe "value_array_push_empty_array" c_value_array_push_empty_array :: Ptr CValue -> IO (Ptr CValue) + +-- juiz_type (データ型)。callback の型は lock_as_value_with_arg と同じ (int64_t (*)(void*, value*)) +foreign import ccall unsafe "juiz_type_new" + c_juiz_type_new :: CString -> Ptr (Ptr CJuizType) -> IO Int64 +foreign import ccall safe "juiz_type_describe" + c_juiz_type_describe :: Ptr CJuizType -> FunPtr LockCallback -> Ptr () -> IO Int64 +foreign import ccall safe "capsule_ptr_read_typed_value" + c_capsule_ptr_read_typed_value + :: Ptr CCapsulePtr -> Ptr CJuizType -> CString -> FunPtr LockCallback -> Ptr () -> IO Int64 + +-- 画像。capsule_ptr_is_image は C の bool を返すので、cbits の整数を返す関数を使う +foreign import ccall unsafe "hsjuiz_capsule_ptr_is_image" + c_hsjuiz_capsule_ptr_is_image :: Ptr CCapsulePtr -> IO Int64 +foreign import ccall safe "capsule_ptr_lock_as_image" + c_capsule_ptr_lock_as_image :: Ptr CCapsulePtr -> FunPtr ImageCallback -> Ptr () -> IO Int64 +foreign import ccall unsafe "capsule_set_image" + c_capsule_set_image :: Ptr CCapsule -> Ptr CImage -> IO Int64 diff --git a/src/Juiz/Internal/TypeInfo.hs b/src/Juiz/Internal/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Internal/TypeInfo.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | 型付きの引数・戻り値の型 ('TypeInfo') のデータ。作るのは "Juiz.Type" の 'Juiz.Type.newTypeInfo'。 +-- +-- "Juiz.Capsule" の 'Juiz.Capsule.FromCapsule' / 'Juiz.Capsule.ToCapsule' がこの型を参照するので、 +-- 循環しないようにデータだけをここに置く。 +module Juiz.Internal.TypeInfo + ( TypeInfo (..) + , typeInfoName + , typeInfoFingerprint + ) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Foreign.Ptr (Ptr) + +import Juiz.Internal.FFI (CJuizType) +import Juiz.Value + +-- | juiz のデータ型 (docs/spec/datatype.md)。libjuiz_sdk の juiz_type と、それを juiz_type_describe で +-- 読んだ型参照・manifest の type_name を持つ。指紋は libjuiz_sdk (Rust の juiz_types) が計算するので、 +-- .avsc・Rust・Python・C++ と一致する +data TypeInfo = TypeInfo + { typeInfoHandle :: !(Ptr CJuizType) + -- | 型参照 @{name, fingerprint, avro}@ (manifest の schema / output_schema に載せるもの) + , typeInfoSchema :: !Value + -- | manifest の type_name ("Object"・"String" など、仕様 §6 の表) + , typeInfoTypeName :: !Text + } + +-- | 型の完全名 (@robot.geometry.Pose2D@ など) +typeInfoName :: TypeInfo -> Text +typeInfoName = schemaText "name" + +-- | 型の指紋 (@sha256:…@) +typeInfoFingerprint :: TypeInfo -> Text +typeInfoFingerprint = schemaText "fingerprint" + +schemaText :: Text -> TypeInfo -> Text +schemaText key t = case typeInfoSchema t of + JObject m | Just (JString s) <- Map.lookup key m -> s + _ -> "" + +-- | 名前と指紋が同じなら同じ型 +instance Eq TypeInfo where + a == b = typeInfoName a == typeInfoName b && typeInfoFingerprint a == typeInfoFingerprint b + +instance Show TypeInfo where + show t = "TypeInfo " ++ show (typeInfoName t) ++ " " ++ show (typeInfoFingerprint t) diff --git a/src/Juiz/Manifest.hs b/src/Juiz/Manifest.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Manifest.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Process / Container のマニフェストの組み立て。 +-- +-- > manifest :: ProcessManifest +-- > manifest = processManifest "increment_process_hs" +-- > & description "Adds 1 to arg1." +-- > & addIntArg "arg1" "value to be incremented" 1 +-- +-- 引数を足した順が、Process の関数の引数の順になる。 +-- Container ('containerManifest') では、Container を作る関数の引数の順になる。 +-- ContainerProcess ('containerProcessManifest') では、第 1 引数 (Container の状態) の後に続く引数の順になる。 +-- +-- Component ('componentManifest') は、1 つのライブラリにまとめた Process / Container / ContainerProcess の +-- マニフェストを束ねたもの。ふつうは 'Juiz.TH.juizComponent' が組み立てる。 +module Juiz.Manifest + ( ProcessManifest (..) + , ContainerManifest (..) + , ComponentManifest (..) + , ArgumentManifest (..) + , HasDescription (..) + , HasArguments (..) + , processManifest + , containerManifest + , containerProcessManifest + , componentManifest + , addProcess + , addContainer + , description + , factory + , useMemo + , readonly + , containerType + , addArg + , addBoolArg + , addIntArg + , addFloatArg + , addStringArg + , addArrayArg + , addObjectArg + , addImageArg + , addTypedArg + , addTypedArgValue + , addTypedArgNoDefault + , returns + , manifestToValue + , containerManifestToValue + , componentManifestToValue + ) where + +import Data.Int (Int64) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (..)) +import Data.Text (Text) + +import Juiz.Capsule (ToCapsule (..), object, (.=)) +import Juiz.Internal.TypeInfo +import Juiz.Type (JuizType (..)) +import Juiz.Value + +data ArgumentManifest = ArgumentManifest + { argName :: !Text + -- | juiz の型名 ("Bool", "Int", "Float", "String", "Array", "Object") + , argTypeName :: !Text + , argDescription :: !Text + , argDefault :: !Value + -- | 型付きの引数の型 ('addTypedArg' など)。manifest の schema になり、呼ばれたときは値をこの型で読む + , argType :: !(Maybe TypeInfo) + } + deriving (Eq, Show) + +data ProcessManifest = ProcessManifest + { pmTypeName :: !Text + , pmDescription :: !Text + , pmLanguage :: !Text + -- | 関数を探すときのシンボル名。単体の Process は "process_factory" + , pmFactory :: !Text + , pmArguments :: ![ArgumentManifest] + , pmUseMemo :: !Bool + -- | ContainerProcess のとき、結びつける Container の型名 + , pmContainerType :: !(Maybe Text) + -- | 戻り値の型 ('returns'、または関数の結果の型)。manifest の output_schema になる + , pmOutputType :: !(Maybe TypeInfo) + -- | readonly の ContainerProcess ('readonly'、juiz の readonly) + , pmReadonly :: !Bool + } + deriving (Eq, Show) + +data ContainerManifest = ContainerManifest + { cmTypeName :: !Text + , cmDescription :: !Text + , cmLanguage :: !Text + -- | 関数を探すときのシンボル名。単体の Container は "container_factory" + , cmFactory :: !Text + -- | Container を作る関数の引数 (設定ファイルの containers に書いた値) + , cmArguments :: ![ArgumentManifest] + } + deriving (Eq, Show) + +-- | 1 つのライブラリにまとめる Process / Container / ContainerProcess のマニフェスト。 +-- ContainerProcess ('pmContainerType' のある 'ProcessManifest') は、juiz に渡すときに +-- 同じ型名の Container の processes に入れる +data ComponentManifest = ComponentManifest + { compTypeName :: !Text + , compDescription :: !Text + , compLanguage :: !Text + , compContainers :: ![ContainerManifest] + -- | Process と ContainerProcess (足した順) + , compProcesses :: ![ProcessManifest] + } + deriving (Eq, Show) + +-- | 説明を持つマニフェスト +class HasDescription m where + setDescription :: Text -> m -> m + +-- | 説明・シンボル名・引数を持つマニフェスト ('ProcessManifest' と 'ContainerManifest') +class HasDescription m => HasArguments m where + setFactory :: Text -> m -> m + appendArgument :: ArgumentManifest -> m -> m + manifestArguments :: m -> [ArgumentManifest] + +instance HasDescription ProcessManifest where + setDescription d m = m { pmDescription = d } + +instance HasArguments ProcessManifest where + setFactory f m = m { pmFactory = f } + appendArgument a m = m { pmArguments = pmArguments m ++ [a] } + manifestArguments = pmArguments + +instance HasDescription ContainerManifest where + setDescription d m = m { cmDescription = d } + +instance HasDescription ComponentManifest where + setDescription d m = m { compDescription = d } + +instance HasArguments ContainerManifest where + setFactory f m = m { cmFactory = f } + appendArgument a m = m { cmArguments = cmArguments m ++ [a] } + manifestArguments = cmArguments + +-- | 型名 (設定ファイルの type_name) を指定してマニフェストを作る +processManifest :: Text -> ProcessManifest +processManifest typeName = ProcessManifest + { pmTypeName = typeName + , pmDescription = "" + , pmLanguage = "haskell" + , pmFactory = "process_factory" + , pmArguments = [] + , pmUseMemo = False + , pmContainerType = Nothing + , pmOutputType = Nothing + , pmReadonly = False + } + +-- | 型名 (設定ファイルの type_name) を指定して Container のマニフェストを作る +containerManifest :: Text -> ContainerManifest +containerManifest typeName = ContainerManifest + { cmTypeName = typeName + , cmDescription = "" + , cmLanguage = "haskell" + , cmFactory = "container_factory" + , cmArguments = [] + } + +-- | ContainerProcess のマニフェストを作る。型名 → 結びつける Container の型名 +containerProcessManifest :: Text -> Text -> ProcessManifest +containerProcessManifest typeName ctype = (processManifest typeName) + { pmFactory = "container_process_factory" + , pmContainerType = Just ctype + } + +-- | Component のマニフェストを作る。名前が設定ファイルの components に書く名前とライブラリの名前になる +componentManifest :: Text -> ComponentManifest +componentManifest typeName = ComponentManifest + { compTypeName = typeName + , compDescription = "" + , compLanguage = "haskell" + , compContainers = [] + , compProcesses = [] + } + +-- | Component に Process か ContainerProcess を足す。'pmFactory' は Component の中のシンボル名にしておく +addProcess :: ProcessManifest -> ComponentManifest -> ComponentManifest +addProcess p c = c { compProcesses = compProcesses c ++ [p] } + +-- | Component に Container を足す。'cmFactory' は Component の中のシンボル名にしておく +addContainer :: ContainerManifest -> ComponentManifest -> ComponentManifest +addContainer m c = c { compContainers = compContainers c ++ [m] } + +description :: HasDescription m => Text -> m -> m +description = setDescription + +factory :: HasArguments m => Text -> m -> m +factory = setFactory + +-- | 結びつける Container の型名 (juiz の container_type) +containerType :: Text -> ProcessManifest -> ProcessManifest +containerType c m = m { pmContainerType = Just c } + +-- | 同じ引数で呼ばれたときに前の結果を使い回すか (juiz の use_memo) +useMemo :: Bool -> ProcessManifest -> ProcessManifest +useMemo b m = m { pmUseMemo = b } + +-- | readonly の ContainerProcess にする (juiz の readonly、docs/spec/transformations.md §14)。 +-- juiz は Container を読み出しロックで呼ぶので、同じ Container の readonly 同士は並行に走る。 +-- 中で 'Juiz.Pose.setContainerPose' を呼ぶと 'juizPoseNotWritableError' になる。 +-- Container の状態 (IORef など) を書き換えないことは書き手が守る +readonly :: Bool -> ProcessManifest -> ProcessManifest +readonly b m = m { pmReadonly = b } + +-- | 引数を足す。型名 → 名前 → 説明 → 既定値 +addArg :: HasArguments m => Text -> Text -> Text -> Value -> m -> m +addArg typeName name desc def = appendArgument (ArgumentManifest name typeName desc def Nothing) + +addBoolArg :: HasArguments m => Text -> Text -> Bool -> m -> m +addBoolArg name desc def = addArg "Bool" name desc (JBool def) + +addIntArg :: HasArguments m => Text -> Text -> Int64 -> m -> m +addIntArg name desc def = addArg "Int" name desc (JInt def) + +addFloatArg :: HasArguments m => Text -> Text -> Double -> m -> m +addFloatArg name desc def = addArg "Float" name desc (JFloat def) + +addStringArg :: HasArguments m => Text -> Text -> Text -> m -> m +addStringArg name desc def = addArg "String" name desc (JString def) + +addArrayArg :: HasArguments m => Text -> Text -> [Value] -> m -> m +addArrayArg name desc def = addArg "Array" name desc (JArray def) + +addObjectArg :: HasArguments m => Text -> Text -> [(Text, Value)] -> m -> m +addObjectArg name desc def = addArg "Object" name desc (JObject (Map.fromList def)) + +-- | 画像の引数を足す ('Juiz.Image.Image' で受け取る、docs/spec/large-data.md §10)。名前 → 説明。 +-- Rust の add_image_arg と同じく、既定値は空のオブジェクト +addImageArg :: HasArguments m => Text -> Text -> m -> m +addImageArg name desc = addArg "Image" name desc (JObject Map.empty) + +-- | 型付きの引数を足す (型は juiz-idl -g haskell の生成した型など、docs/spec/datatype.md §22)。 +-- 名前 → 説明 → 既定値 (その型の値)。 +-- +-- > addTypedArg "target" "goal pose" defaultPose2D +addTypedArg :: forall a m. (JuizType a, HasArguments m) => Text -> Text -> a -> m -> m +addTypedArg name desc def = addTypedArgValue (Proxy :: Proxy a) name desc (toValue def) + +-- | 型付きの引数を足す。既定値は辞書の表し方 (仕様 §4) で書く。'JNull' は既定値なし +addTypedArgValue :: (JuizType a, HasArguments m) => Proxy a -> Text -> Text -> Value -> m -> m +addTypedArgValue p name desc def = + let t = juizType p + in appendArgument (ArgumentManifest name (typeInfoTypeName t) desc def (Just t)) + +-- | 既定値のない型付きの引数を足す (呼ぶときに必ず渡す) +-- +-- > addTypedArgNoDefault (Proxy :: Proxy Pose2D) "target" "goal pose" +addTypedArgNoDefault :: (JuizType a, HasArguments m) => Proxy a -> Text -> Text -> m -> m +addTypedArgNoDefault p name desc = addTypedArgValue p name desc JNull + +-- | 戻り値の型 (output_schema)。関数の結果が型付きの型なら書かなくても載る。書いたときは関数の結果の型と同じにする +returns :: JuizType a => Proxy a -> ProcessManifest -> ProcessManifest +returns p m = m { pmOutputType = Just (juizType p) } + +-- | juiz に渡す形 (C++ の ProcessManifest::into_value と同じ項目) +manifestToValue :: ProcessManifest -> Value +manifestToValue m = object $ + [ "type_name" .= pmTypeName m + , "language" .= pmLanguage m + , "description" .= pmDescription m + , "factory" .= pmFactory m + , "use_memo" .= pmUseMemo m + , "arguments" .= map argumentToValue (pmArguments m) + ] + ++ maybe [] (\c -> ["container_type" .= c]) (pmContainerType m) + ++ ["readonly" .= True | pmReadonly m] + ++ maybe [] outputSchema (pmOutputType m) + where + -- 古いクライアント向けに、type_name だけの outputs も載せる (仕様 §6) + outputSchema t = + [ "output_schema" .= typeInfoSchema t + , "outputs" .= object + [ "enum_type" .= ("Primitive" :: Text) + , "type_name" .= typeInfoTypeName t + , "default_value" .= JNull + ] + ] + +-- | juiz に渡す形 (C++ の ContainerManifest::into_value と同じ項目) +containerManifestToValue :: ContainerManifest -> Value +containerManifestToValue = containerWithProcessesToValue [] + +containerWithProcessesToValue :: [ProcessManifest] -> ContainerManifest -> Value +containerWithProcessesToValue ps m = object + [ "type_name" .= cmTypeName m + , "language" .= cmLanguage m + , "description" .= cmDescription m + , "factory" .= cmFactory m + , "arguments" .= map argumentToValue (cmArguments m) + , "processes" .= map manifestToValue ps + ] + +-- | juiz に渡す形 (C++ の ComponentManifest::into_value と同じ項目)。 +-- ContainerProcess の Container が Component に無い、または型名が重なっていれば Left (説明) +componentManifestToValue :: ComponentManifest -> Either Text Value +componentManifestToValue c + | (n : _) <- duplicates (map cmTypeName (compContainers c) ++ map pmTypeName (compProcesses c)) = + Left ("the type name \"" <> n <> "\" is used twice in the component") + | (p : _) <- filter (not . hasContainer) containerProcesses = + Left ("the container process \"" <> pmTypeName p <> "\" belongs to the container \"" + <> maybe "" id (pmContainerType p) <> "\", which is not in the component") + | otherwise = Right $ object + [ "type_name" .= compTypeName c + , "language" .= compLanguage c + , "description" .= compDescription c + , "containers" .= map containerValue (compContainers c) + , "processes" .= map manifestToValue [p | p <- compProcesses c, pmContainerType p == Nothing] + ] + where + containerProcesses = [p | p <- compProcesses c, pmContainerType p /= Nothing] + hasContainer p = pmContainerType p `elem` map (Just . cmTypeName) (compContainers c) + containerValue m = + containerWithProcessesToValue [p | p <- containerProcesses, pmContainerType p == Just (cmTypeName m)] m + duplicates xs = [x | (i, x) <- zip [0 :: Int ..] xs, x `elem` take i xs] + +argumentToValue :: ArgumentManifest -> Value +argumentToValue a = object $ + [ "name" .= argName a + , "type_name" .= argTypeName a + , "description" .= argDescription a + , "default" .= argDefault a + ] + ++ maybe [] (\t -> ["schema" .= typeInfoSchema t]) (argType a) diff --git a/src/Juiz/Pose.hs b/src/Juiz/Pose.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Pose.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | ContainerProcess の中から、呼び出し元 Container の位置姿勢 (ContainerPose) を読み書きする +-- (docs/spec/transformations.md §12.3)。 +-- +-- > update :: IORef Int64 -> Double -> IO Value +-- > update _ dx = do +-- > (p, _) <- containerPose "map" -- map から見たこの Container の位置姿勢 +-- > let (x, y, z) = cpPosition p +-- > (q, _) <- setContainerPose "map" p { cpPosition = (x + dx, y, z) } -- 親 → この Container の Transform を書き換える +-- > pure (poseToValue q) +-- +-- 自分以外の Container の位置は 'lookupContainerPose' で読む (§7.4、#409。tf の lookupTransform に当たる): +-- +-- > (p, _) <- lookupContainerPose "lidar0" "robot0" -- robot0 から見た lidar0 の位置姿勢 +-- +-- Transform の値は 'setTransform' で書く (§7.5、#410。この Container が端点か、conf の transforms: の +-- writers に入っている Transform だけ): +-- +-- > (t, _) <- setTransform "map" "odom" (ContainerTransform (0.1, 0, 0) (0, 0, 0, 1)) +-- +-- ContainerProcess の関数は Container の状態だけを受け取り、Container そのものは受け取らないので、 +-- 読み書きの相手は「今呼ばれている ContainerProcess の Container」になる。juiz が呼んだスレッドの上 +-- (関数の中) でだけ使える。'Control.Concurrent.forkIO' した先や、関数から戻った後では +-- 'juizTransformationsNotAttachedError' になる。四元数の並びは (x, y, z, w)。 +module Juiz.Pose + ( ContainerPose (..) + , PoseTime (..) + , identityPose + , containerPose + , setContainerPose + , lookupContainerPose + , ContainerTransform (..) + , identityTransform + , setTransform + , transformToValue + , transformStampedToValue + , poseToValue + , poseStampedToValue + -- * 内部 (ContainerProcess のエントリポイントが使う) + , withPoseCall + ) where + +import Control.Exception (finally) +import Control.Monad (when) +import Data.Int (Int32, Int64) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE +import Foreign.C.String (CString, peekCString) +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (peekByteOff, pokeByteOff) + +import Juiz.Error +import Juiz.Internal.FFI (CCapsuleMap) +import Juiz.Value + +-- | 位置姿勢 (@juiz_std.geometry.Pose@)。位置 (x, y, z) [m] と四元数 (x, y, z, w) +data ContainerPose = ContainerPose + { cpPosition :: !(Double, Double, Double) + , cpOrientation :: !(Double, Double, Double, Double) + } + deriving (Eq, Show) + +-- | 計算・書き込みの時刻 (@juiz_std.common.Time@) +data PoseTime = PoseTime + { ptSec :: !Int64 + , ptNanosec :: !Int32 + } + deriving (Eq, Show) + +-- | 原点・回転なし +identityPose :: ContainerPose +identityPose = ContainerPose (0, 0, 0) (0, 0, 0, 1) + +-- | Transform の値 (@juiz_std.geometry.Transform@)。平行移動 (x, y, z) [m] と四元数 (x, y, z, w) +data ContainerTransform = ContainerTransform + { ctTranslation :: !(Double, Double, Double) + , ctRotation :: !(Double, Double, Double, Double) + } + deriving (Eq, Show) + +-- | 平行移動なし・回転なし +identityTransform :: ContainerTransform +identityTransform = ContainerTransform (0, 0, 0) (0, 0, 0, 1) + +foreign import ccall unsafe "hsjuiz_swap_pose_call" + c_hsjuiz_swap_pose_call :: Ptr CCapsuleMap -> IO (Ptr CCapsuleMap) + +-- 書き込みは Pose 通知で Haskell の Process を呼ぶことがあるので safe で呼ぶ +foreign import ccall safe "juiz_container_pose_get" + c_juiz_container_pose_get :: Ptr CCapsuleMap -> CString -> Ptr () -> IO Int64 +foreign import ccall safe "juiz_container_pose_set" + c_juiz_container_pose_set :: Ptr CCapsuleMap -> CString -> Ptr () -> Ptr () -> IO Int64 +foreign import ccall safe "juiz_container_pose_lookup" + c_juiz_container_pose_lookup :: Ptr CCapsuleMap -> CString -> CString -> Ptr () -> IO Int64 +foreign import ccall safe "juiz_container_transform_set" + c_juiz_container_transform_set :: Ptr CCapsuleMap -> CString -> CString -> Ptr () -> Ptr () -> IO Int64 +foreign import ccall unsafe "juiz_container_pose_last_error" + c_juiz_container_pose_last_error :: IO CString + +-- | ContainerProcess の関数を呼ぶ間、その引数 (呼び出し元 Container の口が載っている) を覚えておく。 +-- 入れ子 (Pose 通知で同じスレッドから別の ContainerProcess が呼ばれる) でも元に戻す +withPoseCall :: Ptr CCapsuleMap -> IO a -> IO a +withPoseCall cm act = do + old <- c_hsjuiz_swap_pose_call cm + act `finally` c_hsjuiz_swap_pose_call old + +currentPoseCall :: IO (Ptr CCapsuleMap) +currentPoseCall = do + cm <- c_hsjuiz_swap_pose_call nullPtr + _ <- c_hsjuiz_swap_pose_call cm + when (cm == nullPtr) $ + throwJuiz juizTransformationsNotAttachedError + "containerPose / setContainerPose / lookupContainerPose / setTransform can be used only inside a container process (on the thread that juiz called it)" + pure cm + +-- juiz_pose_stamped の並び: position (0, 8, 16)、orientation (24, 32, 40, 48)、stamp.sec 56、stamp.nanosec 64 +pokePose :: Ptr () -> ContainerPose -> IO () +pokePose p (ContainerPose (x, y, z) (qx, qy, qz, qw)) = + mapM_ (\(o, v) -> pokeByteOff p o v) (zip [0, 8 .. 48] [x, y, z, qx, qy, qz, qw]) + +peekStamped :: Ptr () -> IO (ContainerPose, PoseTime) +peekStamped p = do + [x, y, z, qx, qy, qz, qw] <- mapM (peekByteOff p) [0, 8 .. 48] + sec <- peekByteOff p 56 + nsec <- peekByteOff p 64 + pure (ContainerPose (x, y, z) (qx, qy, qz, qw), PoseTime sec nsec) + +check :: Int64 -> IO () +check 0 = pure () +check code = do + msg <- c_juiz_container_pose_last_error >>= peekCString + throwJuiz code (if null msg then "ContainerPose error (" <> T.pack (show code) <> ")" else T.pack msg) + +-- | 基準 reference (Container の名前か ID) から見た、今呼ばれている ContainerProcess の Container の位置姿勢 (§7.1) +containerPose :: Text -> IO (ContainerPose, PoseTime) +containerPose reference = do + cm <- currentPoseCall + allocaBytes 72 $ \out -> + withUtf8 reference $ \ref -> do + c_juiz_container_pose_get cm ref out >>= check + peekStamped out + +-- | 今呼ばれている ContainerProcess の Container を、基準 reference から見て pose の位置姿勢にする (§7.2)。 +-- 書き換わるのは親 → この Container の Transform。書いた後の値を返す +setContainerPose :: Text -> ContainerPose -> IO (ContainerPose, PoseTime) +setContainerPose reference pose = do + cm <- currentPoseCall + allocaBytes 56 $ \inp -> + allocaBytes 72 $ \out -> + withUtf8 reference $ \ref -> do + pokePose inp pose + c_juiz_container_pose_set cm ref inp out >>= check + peekStamped out + +-- | 今呼ばれている ContainerProcess の Container 以外の Container target (名前か ID) の、 +-- 基準 reference から見た位置姿勢 (§7.4、#409)。名前は呼び出し元 Container のネームスペースで解決する。 +-- 読み出しだけなので readonly の ContainerProcess からも呼べる +lookupContainerPose :: Text -> Text -> IO (ContainerPose, PoseTime) +lookupContainerPose target reference = do + cm <- currentPoseCall + allocaBytes 72 $ \out -> + withUtf8 target $ \tgt -> + withUtf8 reference $ \ref -> do + c_juiz_container_pose_lookup cm tgt ref out >>= check + peekStamped out + +-- | 今呼ばれている ContainerProcess の Container から、Transform (source → destination、名前か ID) の値を +-- t にする (§7.5、#410)。結果は API の transform/update と同じ。名前はこの Container のネームスペースで解決する。 +-- 書けるのはこの Container が端点か、conf の transforms: の writers に入っている Transform だけ +-- ('juizTransformNotWritableError')。書いた後の値を返す +setTransform :: Text -> Text -> ContainerTransform -> IO (ContainerTransform, PoseTime) +setTransform source destination (ContainerTransform t q) = do + cm <- currentPoseCall + -- juiz_transform / juiz_transform_stamped の並びは juiz_pose / juiz_pose_stamped と同じ + allocaBytes 56 $ \inp -> + allocaBytes 72 $ \out -> + withUtf8 source $ \src -> + withUtf8 destination $ \dst -> do + pokePose inp (ContainerPose t q) + c_juiz_container_transform_set cm src dst inp out >>= check + (ContainerPose t' q', stamp) <- peekStamped out + pure (ContainerTransform t' q', stamp) + +-- | @juiz_std.geometry.Transform@ の辞書にする +transformToValue :: ContainerTransform -> Value +transformToValue (ContainerTransform (x, y, z) (qx, qy, qz, qw)) = + JObject $ Map.fromList + [ ("translation", JObject $ Map.fromList [("x", JFloat x), ("y", JFloat y), ("z", JFloat z)]) + , ("rotation", JObject $ Map.fromList [("x", JFloat qx), ("y", JFloat qy), ("z", JFloat qz), ("w", JFloat qw)]) + ] + +-- | @juiz_std.geometry.TransformStamped@ の辞書にする (@header.frame_id@ は source、@child_frame_id@ は destination) +transformStampedToValue :: Text -> Text -> (ContainerTransform, PoseTime) -> Value +transformStampedToValue source destination (t, PoseTime sec nsec) = + JObject $ Map.fromList + [ ( "header" + , JObject $ Map.fromList + [ ("stamp", JObject $ Map.fromList [("sec", JInt sec), ("nanosec", JInt (fromIntegral nsec))]) + , ("frame_id", JString source) + ] + ) + , ("child_frame_id", JString destination) + , ("transform", transformToValue t) + ] + +-- | @juiz_std.geometry.Pose@ の辞書にする +poseToValue :: ContainerPose -> Value +poseToValue (ContainerPose (x, y, z) (qx, qy, qz, qw)) = + JObject $ Map.fromList + [ ("position", JObject $ Map.fromList [("x", JFloat x), ("y", JFloat y), ("z", JFloat z)]) + , ("orientation", JObject $ Map.fromList [("x", JFloat qx), ("y", JFloat qy), ("z", JFloat qz), ("w", JFloat qw)]) + ] + +-- | @juiz_std.geometry.PoseStamped@ の辞書にする (@header.frame_id@ は reference) +poseStampedToValue :: Text -> (ContainerPose, PoseTime) -> Value +poseStampedToValue reference (pose, PoseTime sec nsec) = + JObject $ Map.fromList + [ ( "header" + , JObject $ Map.fromList + [ ("stamp", JObject $ Map.fromList [("sec", JInt sec), ("nanosec", JInt (fromIntegral nsec))]) + , ("frame_id", JString reference) + ] + ) + , ("pose", poseToValue pose) + ] + +withUtf8 :: Text -> (CString -> IO a) -> IO a +withUtf8 t = BS.useAsCString (TE.encodeUtf8 t) diff --git a/src/Juiz/Process.hs b/src/Juiz/Process.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Process.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | Process のエントリポイント (C から呼ばれる関数) を Haskell の関数から作る。 +-- +-- ふつうは "Juiz.TH" の 'Juiz.TH.juizProcess' が、ここの関数を使って foreign export まで生成する。 +-- Template Haskell を使わずに手で書く場合は次のようにする (README を参照)。 +-- +-- > increment :: Int64 -> IO Int64 +-- > increment arg1 = pure (arg1 + 1) +-- > +-- > hsManifest :: ManifestFunction +-- > hsManifest = manifestEntryPoint manifest increment +-- > hsProcess :: ProcessFunction +-- > hsProcess = processEntryPoint manifest increment +-- > hsFactory :: ProcessFactoryFunction +-- > hsFactory = pure p_hsProcess +-- > +-- > foreign export ccall "manifest_entry_point" hsManifest :: ManifestFunction +-- > foreign export ccall "increment_process_entry_point" hsProcess :: ProcessFunction +-- > foreign import ccall "&increment_process_entry_point" p_hsProcess :: FunPtr ProcessFunction +-- > foreign export ccall "process_factory_entry_point" hsFactory :: ProcessFactoryFunction +module Juiz.Process + ( ProcessFn (..) + , manifestEntryPoint + , processEntryPoint + , checkedManifestEntryPoint + , checkProcessManifest + , checkArgumentTypes + , resultType + , readArguments + , applyAndWrite + , guardEntryPoint + , tshow + ) where + +import Control.Exception (SomeException, catch, displayException, evaluate, fromException, try) +import Data.Int (Int64) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Foreign.Ptr (Ptr) +import System.IO (stderr) + +import Juiz.Capsule +import Juiz.Error +import Juiz.Internal.FFI +import Juiz.Internal.TypeInfo +import Juiz.Manifest +import Juiz.Value + +-- | Process にできる関数: 引数が 'FromCapsule'、結果が @IO r@ の関数。 +-- 結果が IO でない関数は 'Juiz.TH.juizProcess' が @pure@ で包む。 +-- Process では @r@ を 'ToCapsule' に、Container を作る関数では @r@ を Container の状態にする +class ProcessFn f where + -- | 結果の型 (@a -> b -> IO r@ なら @r@) + type FnResult f + -- | 引数の数 + processArity :: Proxy f -> Int + -- | 引数 (名前と値の組) を順に渡して呼ぶ + applyArgs :: f -> [(Text, Argument)] -> IO (FnResult f) + -- | 引数ごとの型 (型付きの型なら 'Just'、'Juiz.Capsule.fromCapsuleType') + argumentTypes :: Proxy f -> [Maybe TypeInfo] + +instance (FromCapsule a, ProcessFn b) => ProcessFn (a -> b) where + type FnResult (a -> b) = FnResult b + processArity _ = 1 + processArity (Proxy :: Proxy b) + argumentTypes _ = fromCapsuleType (Proxy :: Proxy a) : argumentTypes (Proxy :: Proxy b) + applyArgs f ((name, v) : rest) = case fromArgument v of + Right a -> applyArgs (f a) rest + Left msg -> throwJuiz juizValueConverterError ("argument \"" <> name <> "\": " <> msg) + applyArgs _ [] = throwJuiz juizValueNotFoundError "too few arguments" + +instance ProcessFn (IO r) where + type FnResult (IO r) = r + processArity _ = 0 + argumentTypes _ = [] + applyArgs act [] = act + applyArgs _ _ = throwJuiz juizValueConverterError "too many arguments" + +-- | manifest_entry_point の中身。マニフェストの引数の数と関数の引数の数が違う、 +-- または型付きの引数・戻り値の型が関数と合わなければエラーにする (juiz はプラグインを読み込むときに失敗する) +manifestEntryPoint :: forall f. (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> f -> ManifestFunction +manifestEntryPoint m _ cp = guardEntryPoint (pmTypeName m) $ + case checkProcessManifest m (Proxy :: Proxy f) of + Left msg -> throwJuiz juizValueConverterError msg + Right m' -> checkedManifestEntryPoint (pmTypeName m') (length (pmArguments m')) (processArity (Proxy :: Proxy f)) + (manifestToValue m') cp + +-- | 関数の結果の型 (型付きの型なら 'Just') +resultType :: forall f. (ProcessFn f, ToCapsule (FnResult f)) => Proxy f -> Maybe TypeInfo +resultType _ = toCapsuleType (Proxy :: Proxy (FnResult f)) + +-- | Process / ContainerProcess のマニフェストの型を関数の型と比べ、戻り値の型を補う (docs/spec/datatype.md §22)。 +-- +-- * 型付きの型の引数は、マニフェストでも同じ型の型付きの引数 ('addTypedArg' など) にする +-- * 関数の結果が型付きの型なら output_schema を載せる ('returns' を書いたときは同じ型でなければならない) +checkProcessManifest :: forall f. (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> Proxy f -> Either Text ProcessManifest +checkProcessManifest m p = do + checkArgumentTypes (pmArguments m) (argumentTypes p) + case (resultType p, pmOutputType m) of + (Just r, Nothing) -> Right m { pmOutputType = Just r } + (Just r, Just o) + | r == o -> Right m + | otherwise -> Left $ "the manifest returns " <> typeInfoName o <> ", but the function returns " <> typeInfoName r + (Nothing, _) -> Right m + +-- | マニフェストの引数と関数の引数の型を比べる。引数の数は比べない ('checkedManifestEntryPoint' が比べる) +checkArgumentTypes :: [ArgumentManifest] -> [Maybe TypeInfo] -> Either Text () +checkArgumentTypes args types = mapM_ check (zip args types) + where + check (a, Just t) = case argType a of + Just at + | at == t -> Right () + | otherwise -> Left $ "argument \"" <> argName a <> "\": the manifest declares " <> typeInfoName at + <> ", but the function takes " <> typeInfoName t + Nothing -> Left $ "argument \"" <> argName a <> "\": the function takes " <> typeInfoName t + <> "; declare it with addTypedArg (or addTypedArgNoDefault)" + -- 型なしの型 (Value など) は型付きの引数も受け取れる + check (_, Nothing) = Right () + +-- | 引数の数を確かめてからマニフェストを書き込む manifest_entry_point +checkedManifestEntryPoint :: Text -> Int -> Int -> Value -> ManifestFunction +checkedManifestEntryPoint name nArgs arity v cp = guardEntryPoint name $ + if nArgs /= arity + then throwJuiz juizValueConverterError $ + "the manifest has " <> tshow nArgs <> " arguments, but the function takes " <> tshow arity + else case v of + JObject obj -> writeCapsulePtr cp obj + _ -> pure juizValueConverterError + +-- | Process の関数の中身。マニフェストの引数を順に読み出して関数を呼び、結果を capsule に書き込む +processEntryPoint :: (ProcessFn f, ToCapsule (FnResult f)) => ProcessManifest -> f -> ProcessFunction +processEntryPoint m f cm out = guardEntryPoint (pmTypeName m) $ applyAndWrite (pmArguments m) f cm out + +-- | マニフェストの引数を順に読み出す +readArguments :: [ArgumentManifest] -> Ptr CCapsuleMap -> IO [(Text, Argument)] +readArguments as cm = mapM read1 as + where + -- 型付きの引数は型で読む (足りないフィールドは既定値、型に合わなければ juizValueDoesNotMatchTypeError)。 + -- 型なしの引数は、画像ならそのまま画像として読む (docs/spec/large-data.md §10) + read1 a = (,) (argName a) <$> case argType a of + Just t -> ArgValue <$> readTypedArgument cm (argName a) t + Nothing -> readArgumentOrImage cm (argName a) + +-- | 引数を読み出して関数を呼び、結果を capsule に書き込む +applyAndWrite :: (ProcessFn f, ToCapsule (FnResult f)) => [ArgumentManifest] -> f -> Ptr CCapsuleMap -> Ptr CCapsule -> IO Int64 +applyAndWrite as f cm out = do + args <- readArguments as cm + r <- applyArgs f args + result <- evaluate (toResult r) + writeResult out result + +-- | Haskell の例外を C の呼び出し元に出さず、juiz のエラーコードに変える。 +-- 'JuizError' はそのコード、それ以外の例外は 'juizProcessFunctionError'。内容は標準エラー出力に書く +guardEntryPoint :: Text -> IO Int64 -> IO Int64 +guardEntryPoint name act = do + r <- try (act >>= evaluate) + case r of + Right code -> pure code + Left (e :: SomeException) -> do + let (code, msg) = case fromException e of + Just (JuizError c m) -> (c, m) + Nothing -> (juizProcessFunctionError, T.pack (displayException e)) + TIO.hPutStrLn stderr ("hsjuiz: " <> name <> ": " <> msg <> " (error " <> tshow code <> ")") + `catch` \(_ :: SomeException) -> pure () + pure code + +tshow :: Show a => a -> Text +tshow = T.pack . show + diff --git a/src/Juiz/TH.hs b/src/Juiz/TH.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/TH.hs @@ -0,0 +1,311 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Process / Container / ContainerProcess / Component のエントリポイントを生成する Template Haskell。 +-- +-- > {-# LANGUAGE TemplateHaskell #-} +-- > increment :: Int64 -> IO Int64 +-- > increment arg1 = pure (arg1 + 1) +-- > +-- > juizProcess 'increment 'manifest +-- +-- 生成するのは juiz が探す次の C の関数 (bindings/cjuiz/README.md)。 +-- +-- * @manifest_entry_point@: マニフェストを返す +-- * @process_factory_entry_point@ / @container_factory_entry_point@ / @container_process_factory_entry_point@: +-- Process の関数 / Container を作る関数 / ContainerProcess の関数を返す +-- * @container_factory_destroy_entry_point@: Container を解放する +-- * 関数そのもの (@hsjuiz_\<モジュール\>_\<関数\>_process_entry_point@ など) +-- +-- Component ('juizComponent') では、上の factory の関数の名前が @\<関数名\>_factory_entry_point@ などになり、 +-- マニフェストは @component_manifest_entry_point@ が返す。 +module Juiz.TH + ( juizProcess + , juizContainer + , juizContainerWithDestroy + , juizContainerProcess + , juizComponent + , ComponentEntry + , componentProcess + , componentContainer + , componentContainerWithDestroy + , componentContainerProcess + ) where + +import Control.Monad (replicateM) +import qualified Data.Text as T +import Data.Char (isAscii, isAlphaNum) +import Foreign.Ptr (FunPtr) +import Language.Haskell.TH + +import Juiz.Component (componentManifestEntryPoint, containerPart, containerProcessPart, processPart) +import Juiz.Container + ( containerCreateEntryPoint + , containerCreateEntryPointWithDestroy + , containerDestroyEntryPoint + , containerManifestEntryPoint + , containerProcessEntryPoint + , containerProcessManifestEntryPoint + ) +import Juiz.Internal.FFI + ( ContainerCreateFunction + , ContainerDestroyFunction + , ContainerFactoryFunction + , ContainerProcessFactoryFunction + , ContainerProcessFunction + , ManifestFunction + , ProcessFactoryFunction + , ProcessFunction + ) +import Juiz.Manifest (ContainerManifest, ProcessManifest, factory) +import Juiz.Process (manifestEntryPoint, processEntryPoint) + +-- | @juizProcess 'func 'manifest@: 関数 func を、マニフェスト manifest の Process として公開する。 +-- +-- func の引数は 'Juiz.Capsule.FromCapsule'、結果は 'Juiz.Capsule.ToCapsule' のインスタンスの型にする。 +-- 結果は @IO r@ でも、IO の付かない @r@ でもよい。引数はマニフェストに足した順に渡される。 +-- func の型は具体的に書く (多相な関数は使えない)。 +juizProcess :: Name -> Name -> Q [Dec] +juizProcess fn man = do + fnE <- ioFunction "juizProcess" fn + processDecs fn fnE (varE man) "manifest_entry_point" "process_factory" + +-- | Process の関数・マニフェスト・関数を返す関数を生成する。factorySym はマニフェストの factory +processDecs :: Name -> ExpQ -> ExpQ -> String -> String -> Q [Dec] +processDecs fn fnE manE manifestSym factorySym = do + let procSym = entrySymbol fn "process" + manifestName = mkName ("juizManifestEntryPoint_" ++ nameBase fn) + processName = mkName ("juizProcessEntryPoint_" ++ nameBase fn) + processPtrName = mkName ("juizProcessEntryPointPtr_" ++ nameBase fn) + factoryName = mkName ("juizProcessFactoryEntryPoint_" ++ nameBase fn) + sequence + [ sigD manifestName [t| ManifestFunction |] + , valD (varP manifestName) (normalB [| manifestEntryPoint $manE $fnE |]) [] + , sigD processName [t| ProcessFunction |] + , valD (varP processName) (normalB [| processEntryPoint $manE $fnE |]) [] + , forImpD cCall safe ("&" ++ procSym) processPtrName [t| FunPtr ProcessFunction |] + , sigD factoryName [t| ProcessFactoryFunction |] + , valD (varP factoryName) (normalB [| pure $(varE processPtrName) |]) [] + , exportD manifestSym manifestName [t| ManifestFunction |] + , exportD procSym processName [t| ProcessFunction |] + , exportD (factorySym ++ "_entry_point") factoryName [t| ProcessFactoryFunction |] + ] + +-- | @juizContainer 'create 'manifest@: 関数 create を、マニフェスト manifest ('Juiz.Manifest.containerManifest') +-- の Container を作る関数として公開する。 +-- +-- create の引数はマニフェストに足した順に、設定ファイルの containers に書いた値 (無ければ既定値) を受け取る。 +-- 結果 (@IO s@ または @s@) が Container の状態になり、ContainerProcess の第 1 引数に渡される。 +-- 状態を書き換えるときは @IORef@ などを返す。Container を削除すると状態は GC に返される。 +juizContainer :: Name -> Name -> Q [Dec] +juizContainer create man = do + fnE <- ioFunction "juizContainer" create + containerDecs create fnE (varE man) Nothing "manifest_entry_point" "container_factory" + +-- | @juizContainerWithDestroy 'create 'destroy 'manifest@: 'juizContainer' に加えて、 +-- Container を削除するときに @destroy :: s -> IO ()@ を呼ぶ (デバイスを閉じるなど) +juizContainerWithDestroy :: Name -> Name -> Name -> Q [Dec] +juizContainerWithDestroy create destroy man = do + fnE <- ioFunction "juizContainerWithDestroy" create + containerDecs create fnE (varE man) (Just destroy) "manifest_entry_point" "container_factory" + +-- | Container を作る関数・解放する関数・マニフェスト・作る関数を返す関数を生成する。factorySym はマニフェストの factory +containerDecs :: Name -> ExpQ -> ExpQ -> Maybe Name -> String -> String -> Q [Dec] +containerDecs create fnE manE destroyOpt manifestSym factorySym = do + let createSym = entrySymbol create "container_create" + base = nameBase create + manifestName = mkName ("juizContainerManifestEntryPoint_" ++ base) + createName = mkName ("juizContainerCreateEntryPoint_" ++ base) + createPtrName = mkName ("juizContainerCreateEntryPointPtr_" ++ base) + factoryName = mkName ("juizContainerFactoryEntryPoint_" ++ base) + destroyName = mkName ("juizContainerDestroyEntryPoint_" ++ base) + createBody = case destroyOpt of + Nothing -> [| containerCreateEntryPoint $manE $fnE |] + Just d -> [| containerCreateEntryPointWithDestroy $manE $fnE $(varE d) |] + sequence + [ sigD manifestName [t| ManifestFunction |] + , valD (varP manifestName) (normalB [| containerManifestEntryPoint $manE $fnE |]) [] + , sigD createName [t| ContainerCreateFunction |] + , valD (varP createName) (normalB createBody) [] + , forImpD cCall safe ("&" ++ createSym) createPtrName [t| FunPtr ContainerCreateFunction |] + , sigD factoryName [t| ContainerFactoryFunction |] + , valD (varP factoryName) (normalB [| pure $(varE createPtrName) |]) [] + , sigD destroyName [t| ContainerDestroyFunction |] + , valD (varP destroyName) (normalB [| containerDestroyEntryPoint $manE |]) [] + , exportD manifestSym manifestName [t| ManifestFunction |] + , exportD createSym createName [t| ContainerCreateFunction |] + , exportD (factorySym ++ "_entry_point") factoryName [t| ContainerFactoryFunction |] + , exportD (factorySym ++ "_destroy_entry_point") destroyName [t| ContainerDestroyFunction |] + ] + +-- | @juizContainerProcess 'func 'manifest@: 関数 func を、マニフェスト manifest +-- ('Juiz.Manifest.containerProcessManifest') の ContainerProcess として公開する。 +-- +-- func の第 1 引数は Container の状態 (Container を作る関数の結果と同じ型)。続く引数と結果は 'juizProcess' と同じ。 +-- 結びつけた Container の状態の型が違うと、呼び出しは 'Juiz.Error.juizHaskellContainerTypeError' のエラーになる。 +juizContainerProcess :: Name -> Name -> Q [Dec] +juizContainerProcess fn man = do + fnE <- ioFunction "juizContainerProcess" fn + containerProcessDecs fn fnE (varE man) "manifest_entry_point" "container_process_factory" + +-- | ContainerProcess の関数・マニフェスト・関数を返す関数を生成する。factorySym はマニフェストの factory +containerProcessDecs :: Name -> ExpQ -> ExpQ -> String -> String -> Q [Dec] +containerProcessDecs fn fnE manE manifestSym factorySym = do + let procSym = entrySymbol fn "container_process" + base = nameBase fn + manifestName = mkName ("juizContainerProcessManifestEntryPoint_" ++ base) + processName = mkName ("juizContainerProcessEntryPoint_" ++ base) + processPtrName = mkName ("juizContainerProcessEntryPointPtr_" ++ base) + factoryName = mkName ("juizContainerProcessFactoryEntryPoint_" ++ base) + sequence + [ sigD manifestName [t| ManifestFunction |] + , valD (varP manifestName) (normalB [| containerProcessManifestEntryPoint $manE $fnE |]) [] + , sigD processName [t| ContainerProcessFunction |] + , valD (varP processName) (normalB [| containerProcessEntryPoint $manE $fnE |]) [] + , forImpD cCall safe ("&" ++ procSym) processPtrName [t| FunPtr ContainerProcessFunction |] + , sigD factoryName [t| ContainerProcessFactoryFunction |] + , valD (varP factoryName) (normalB [| pure $(varE processPtrName) |]) [] + , exportD manifestSym manifestName [t| ManifestFunction |] + , exportD procSym processName [t| ContainerProcessFunction |] + , exportD (factorySym ++ "_entry_point") factoryName [t| ContainerProcessFactoryFunction |] + ] + +-- | 'juizComponent' に渡す、Component の要素 +data ComponentEntry + = EntryProcess Name Name + | EntryContainer Name Name (Maybe Name) + | EntryContainerProcess Name Name + +-- | @componentProcess 'func 'manifest@: 'juizProcess' と同じ関数とマニフェストの Process +componentProcess :: Name -> Name -> ComponentEntry +componentProcess = EntryProcess + +-- | @componentContainer 'create 'manifest@: 'juizContainer' と同じ関数とマニフェストの Container +componentContainer :: Name -> Name -> ComponentEntry +componentContainer create man = EntryContainer create man Nothing + +-- | @componentContainerWithDestroy 'create 'destroy 'manifest@: 'juizContainerWithDestroy' と同じ Container +componentContainerWithDestroy :: Name -> Name -> Name -> ComponentEntry +componentContainerWithDestroy create destroy man = EntryContainer create man (Just destroy) + +-- | @componentContainerProcess 'func 'manifest@: 'juizContainerProcess' と同じ関数とマニフェストの ContainerProcess +componentContainerProcess :: Name -> Name -> ComponentEntry +componentContainerProcess = EntryContainerProcess + +-- | @juizComponent 'manifest [componentProcess 'f 'fManifest, componentContainer 'create 'cManifest, ...]@: +-- 1 つのライブラリに複数の Process / Container / ContainerProcess をまとめた Component として公開する。 +-- +-- manifest は 'Juiz.Manifest.componentManifest' で作り、名前を設定ファイルの components に書く。 +-- 要素のマニフェストは単体のときと同じものでよく、factory (シンボル名) は関数名から付け直す。 +-- 生成する C の関数は C++ の COMPONENT_PROCESS_FACTORY などと同じ名前 +-- (@component_manifest_entry_point@、@\<関数名\>_factory_entry_point@、@\<関数名\>_manifest_entry_point@ など)。 +-- 関数名は Component の中で重ならないようにする (別のモジュールの関数も使える)。 +-- 単体の 'juizProcess' などと同じライブラリに入れてもよいが、その関数を Component にも入れることはできない。 +juizComponent :: Name -> [ComponentEntry] -> Q [Dec] +juizComponent comp entries = do + let bases = map (symbolPart . nameBase . entryFunction) entries + case [b | (i, b) <- zip [0 :: Int ..] bases, b `elem` take i bases] of + (b : _) -> fail $ "juizComponent: 関数名 " ++ b ++ " が Component の中で重なっています" + [] -> pure () + results <- mapM componentEntryDecs entries + let manifestName = mkName "juizComponentManifestEntryPoint" + top <- sequence + [ sigD manifestName [t| ManifestFunction |] + , valD (varP manifestName) + (normalB [| componentManifestEntryPoint $(varE comp) $(listE (map snd results)) |]) [] + , exportD "component_manifest_entry_point" manifestName [t| ManifestFunction |] + ] + pure (concatMap fst results ++ top) + +entryFunction :: ComponentEntry -> Name +entryFunction (EntryProcess fn _) = fn +entryFunction (EntryContainer fn _ _) = fn +entryFunction (EntryContainerProcess fn _) = fn + +-- | 要素のエントリポイントと、component_manifest_entry_point に渡す 'Juiz.Component.ComponentPart' の式 +componentEntryDecs :: ComponentEntry -> Q ([Dec], ExpQ) +componentEntryDecs entry = do + let fn = entryFunction entry + base = symbolPart (nameBase fn) + factorySym = base ++ "_factory" + manifestSym = base ++ "_manifest_entry_point" + manName = mkName ("juizComponentManifest_" ++ nameBase fn) + manE = varE manName + manDecs ty man = sequence + [ sigD manName ty + , valD (varP manName) (normalB [| factory (T.pack $(litE (stringL factorySym))) $(varE man) |]) [] + ] + case entry of + EntryProcess _ man -> do + fnE <- ioFunction "componentProcess" fn + ds <- (++) <$> manDecs [t| ProcessManifest |] man <*> processDecs fn fnE manE manifestSym factorySym + pure (ds, [| processPart $manE $fnE |]) + EntryContainer _ man destroyOpt -> do + fnE <- ioFunction "componentContainer" fn + ds <- (++) <$> manDecs [t| ContainerManifest |] man + <*> containerDecs fn fnE manE destroyOpt manifestSym factorySym + pure (ds, [| containerPart $manE $fnE |]) + EntryContainerProcess _ man -> do + fnE <- ioFunction "componentContainerProcess" fn + ds <- (++) <$> manDecs [t| ProcessManifest |] man + <*> containerProcessDecs fn fnE manE manifestSym factorySym + pure (ds, [| containerProcessPart $manE $fnE |]) + +exportD :: String -> Name -> Q Type -> Q Dec +exportD sym name qty = ForeignD . ExportF CCall sym name <$> qty + +-- | 関数そのものを公開する C のシンボル名 (hsjuiz_\<モジュール\>_\<関数\>_\<種類\>_entry_point) +entrySymbol :: Name -> String -> String +entrySymbol fn kind = + "hsjuiz_" ++ symbolPart (maybe "" id (nameModule fn)) ++ "_" ++ symbolPart (nameBase fn) ++ "_" ++ kind ++ "_entry_point" + +-- | 関数 fn を、結果が IO の関数の式 (型注釈付き) にする。結果が IO でなければ pure で包む +ioFunction :: String -> Name -> Q ExpQ +ioFunction what fn = do + ty <- reifyType fn >>= expandSynonym + case ty of + ForallT {} -> polymorphic + ForallVisT {} -> polymorphic + _ -> pure () + (argTys, resTy) <- splitFunction ty + resTy' <- expandSynonym resTy + let isIO = case resTy' of + AppT (ConT n) _ -> n == ''IO + _ -> False + ioResTy = if isIO then resTy' else AppT (ConT ''IO) resTy' + fnTy = foldr (\a r -> AppT (AppT ArrowT a) r) ioResTy argTys + xs <- replicateM (length argTys) (newName "arg") + let call = foldl appE (varE fn) (map varE xs) + body = if isIO then call else [| pure $call |] + lam = if null xs then body else lamE (map varP xs) body + pure (sigE lam (pure fnTy)) + where + polymorphic = fail $ + what ++ ": " ++ show fn ++ " の型が多相です。Int64 や Text など具体的な型を書いてください" + +-- | 関数の型を引数の型の並びと結果の型に分ける +splitFunction :: Type -> Q ([Type], Type) +splitFunction t = do + t' <- expandSynonym t + case t' of + AppT (AppT ArrowT a) r -> do + (as, res) <- splitFunction r + pure (a : as, res) + _ -> pure ([], t') + +-- | 引数の無い型シノニム (type Handler = Int64 -> IO Int64 など) を展開する +expandSynonym :: Type -> Q Type +expandSynonym t@(ConT n) = do + info <- reify n + case info of + TyConI (TySynD _ [] t') -> expandSynonym t' + _ -> pure t +expandSynonym (AppT (ConT n) x) = do + -- type Result = IO のような、結果の型の頭だけのシノニム + info <- reify n + case info of + TyConI (TySynD _ [] t') -> expandSynonym (AppT t' x) + _ -> pure (AppT (ConT n) x) +expandSynonym t = pure t + +-- | C のシンボル名に使えない文字を _ にする +symbolPart :: String -> String +symbolPart = map (\c -> if isAscii c && isAlphaNum c then c else '_') diff --git a/src/Juiz/Type.hs b/src/Juiz/Type.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Type.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Process の引数・戻り値のデータ型 (docs/spec/datatype.md §22)。 +-- +-- ふつうは @juiz-idl -g haskell@ が .jidl から作ったモジュールの型 (record と直和型) を使う。 +-- 生成した型は 'JuizType' と 'FromCapsule' / 'ToCapsule' のインスタンスで、Process の関数の引数・結果に書くと +-- 型付きの引数・戻り値になる (manifest には 'Juiz.Manifest.addTypedArg' で足す)。 +-- +-- 手で書いた型を型付きにするときは、Avro のスキーマから 'TypeInfo' を作り、インスタンスを書く。 +-- +-- > data Odometry = Odometry { odometryDistance :: Double, odometrySteps :: Int64 } +-- > +-- > odometryType :: TypeInfo +-- > odometryType = unsafeTypeInfo "{\"type\": \"record\", \"name\": \"Odometry\", \"namespace\": \"my\", \"fields\": [...]}" +-- > {-# NOINLINE odometryType #-} +-- > +-- > instance JuizType Odometry where juizType _ = odometryType +-- > instance FromCapsule Odometry where +-- > fromValue v = recordFromValue "my.Odometry" v $ \o -> Odometry <$> field o "distance" Nothing <*> field o "steps" Nothing +-- > fromCapsuleType = Just . juizType +-- > instance ToCapsule Odometry where +-- > toValue x = object ["distance" .= odometryDistance x, "steps" .= odometrySteps x] +-- > toCapsuleType = Just . juizType +module Juiz.Type + ( TypeInfo + , JuizType (..) + , typeInfoSchema + , typeInfoTypeName + , typeInfoName + , typeInfoFingerprint + , newTypeInfo + , unsafeTypeInfo + -- * 生成したコードが使う関数 + , recordFromValue + , field + , enumFromValue + ) where + +import Control.Exception (bracket) +import Data.IORef (newIORef, readIORef, writeIORef) +import qualified Data.ByteString as BS +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Foreign.Marshal.Alloc (alloca) +import Foreign.StablePtr (castStablePtrToPtr, freeStablePtr, newStablePtr) +import Foreign.Storable (peek) +import System.IO.Unsafe (unsafePerformIO) + +import Juiz.Capsule +import Juiz.Error +import Juiz.Internal.FFI +import Juiz.Internal.TypeInfo +import Juiz.Value + +-- | 型付きの型。生成した型はすべてこのインスタンス +class (FromCapsule a, ToCapsule a) => JuizType a where + juizType :: Proxy a -> TypeInfo + +-- | Avro のスキーマ (.avsc の JSON) から型を作る。juiz のデータ型の規則 (仕様 §3) に合わなければ +-- 'juizTypeSchemaInvalidError' の 'JuizError' を投げる (理由は juiz のログに出る)。 +-- 作った型は解放しない (プラグインが読み込まれている間使う) +newTypeInfo :: Text -> IO TypeInfo +newTypeInfo avro = BS.useAsCString (TE.encodeUtf8 avro) $ \cs -> alloca $ \pt -> do + r <- c_juiz_type_new cs pt + if r /= juizOk + then throwJuiz r ("invalid type schema: " <> T.take 200 avro) + else do + t <- peek pt + result <- newIORef JNull + r' <- bracket (newStablePtr ((\v -> juizOk <$ (peekValue v >>= writeIORef result)) :: LockFunction)) freeStablePtr + (c_juiz_type_describe t lockTrampoline . castStablePtrToPtr) + if r' /= juizOk + then throwJuiz r' "juiz_type_describe failed" + else do + desc <- readIORef result + case desc of + JObject m + | Just schema <- Map.lookup "schema" m + , Just (JString typeName) <- Map.lookup "type_name" m -> + pure (TypeInfo t schema typeName) + _ -> throwJuiz juizValueConverterError "juiz_type_describe returned an unexpected value" + +-- | トップレベルの値として型を作る ('newTypeInfo' を 'unsafePerformIO' で呼ぶ)。 +-- 型ごとに 1 度だけ作るよう、@{-# NOINLINE … #-}@ を付けたトップレベルの値にすること +unsafeTypeInfo :: Text -> TypeInfo +unsafeTypeInfo = unsafePerformIO . newTypeInfo + +-- | record を辞書 (オブジェクト) から読む。オブジェクトでなければ Left +recordFromValue :: Text -> Value -> (Map Text Value -> Either Text a) -> Either Text a +recordFromValue _ (JObject o) build = build o +recordFromValue name v _ = Left ("expected " <> name <> " (object), but got " <> T.pack (show v)) + +-- | record のフィールドを読む (仕様 §4)。キーが無ければ既定値 (辞書の表し方) を使い、既定値も無ければ Left。 +-- 誤りの説明の先頭にフィールド名を付ける +field :: FromCapsule a => Map Text Value -> Text -> Maybe Value -> Either Text a +field o name def = case Map.lookup name o of + Just v -> prefix (fromValue v) + Nothing -> case def of + Just d -> prefix (fromValue d) + Nothing -> Left (name <> ": missing field") + where + prefix = either (\msg -> Left (name <> ": " <> msg)) Right + +-- | enum を記号の文字列から読む。知らない記号は既定値 (無ければ Left、仕様 §4) +enumFromValue :: Text -> [(Text, a)] -> Maybe a -> Value -> Either Text a +enumFromValue name symbols def v = case v of + JString s | Just x <- lookup s symbols -> Right x + JString s -> maybe (Left ("unknown symbol " <> s <> " of " <> name)) Right def + _ -> Left ("expected " <> name <> " (string), but got " <> T.pack (show v)) diff --git a/src/Juiz/Value.hs b/src/Juiz/Value.hs new file mode 100644 --- /dev/null +++ b/src/Juiz/Value.hs @@ -0,0 +1,24 @@ +-- | juiz の値 (Rust 側の serde_json::Value) を Haskell で表す型。 +-- +-- aeson の 'Data.Aeson.Value' に相当するが、juiz と同じく整数 ('JInt', 'JUInt') と小数 ('JFloat') を分けて持つ。 +-- Haskell の値との変換は "Juiz.Capsule" の 'Juiz.Capsule.FromCapsule' / 'Juiz.Capsule.ToCapsule' で行う。 +module Juiz.Value + ( Value (..) + ) where + +import Data.Int (Int64) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Data.Word (Word64) + +data Value + = JNull + | JBool !Bool + | JInt !Int64 + -- | Int64 に収まらない正の整数 + | JUInt !Word64 + | JFloat !Double + | JString !Text + | JArray ![Value] + | JObject !(Map Text Value) + deriving (Eq, Show)