-
-
Notifications
You must be signed in to change notification settings - Fork 141
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #474 from sorki/srk/interepreter
init implicit-interepreter
- Loading branch information
Showing
12 changed files
with
1,141 additions
and
15 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1 +1,6 @@ | ||
packages: . | ||
packages: | ||
./implicit.cabal | ||
./implicit-interpreter/implicit-interpreter.cabal | ||
|
||
-- due to interpreter tests | ||
write-ghc-environment-files: always |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -1,14 +1,28 @@ | ||
{ rev ? "679cadfdfed2b90311a247b2d6ef6dfd3d6cab73" | ||
{ pkgs ? import <nixpkgs> { } | ||
, compiler ? null | ||
, withImplicitSnap ? false | ||
, pkgs ? | ||
if ((rev == "") || (rev == "default") || (rev == "local")) | ||
then import <nixpkgs> { } | ||
# Do not guard with hash, so the project is able to use current channels (rolling `rev`) of Nixpkgs | ||
else import (builtins.fetchTarball "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz") { } | ||
}: | ||
let | ||
src = pkgs.nix-gitignore.gitignoreSource [ ] ./.; | ||
in | ||
if withImplicitSnap | ||
then pkgs.haskellPackages.callCabal2nixWithOptions "implicit" src "-fimplicitsnap" { } | ||
else pkgs.haskellPackages.callCabal2nix "implicit" src { } | ||
overlay = import ./overlay.nix pkgs compiler withImplicitSnap; | ||
overrideHaskellPackages = orig: { | ||
buildHaskellPackages = | ||
orig.buildHaskellPackages.override overrideHaskellPackages; | ||
overrides = if orig ? overrides | ||
then pkgs.lib.composeExtensions orig.overrides overlay | ||
else overlay; | ||
}; | ||
|
||
packageSet = | ||
if compiler == null | ||
then pkgs.haskellPackages | ||
else pkgs.haskell.packages.${compiler}; | ||
|
||
haskellPackages = packageSet.override overrideHaskellPackages; | ||
in { | ||
inherit (haskellPackages) | ||
implicit | ||
implicit-interpreter; | ||
|
||
inherit haskellPackages; | ||
inherit pkgs; | ||
} |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,10 @@ | ||
# Version [0.1.0.0](https://github.com/HaskellThings/ImplicitCAD/compare/interpreter-0.1.0.0...interpreter-0.1.0.0) (2024-MM-DD) | ||
|
||
* Initial release | ||
|
||
--- | ||
|
||
`implicit-interpreter` uses [PVP Versioning][1]. | ||
|
||
[1]: https://pvp.haskell.org | ||
|
Large diffs are not rendered by default.
Oops, something went wrong.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,3 @@ | ||
# implicit-interpreter | ||
|
||
Interpret implicit objects using [Hint](https://hackage.haskell.org/package/hint). |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,48 @@ | ||
cabal-version: 2.2 | ||
name: implicit-interpreter | ||
version: 0.1.0.0 | ||
synopsis: ImplicitCAD Haskell intepreter | ||
description: Interpret implicit objects using Hint | ||
homepage: https://github.com/HaskellThings/ImplicitCAD | ||
License: AGPL-3.0-or-later | ||
license-file: LICENSE | ||
author: Sorki | ||
maintainer: [email protected] | ||
copyright: 2024 Sorki | ||
category: Graphics | ||
build-type: Simple | ||
|
||
extra-source-files: | ||
LICENSE | ||
README.md | ||
|
||
extra-doc-files: | ||
CHANGELOG.md | ||
|
||
library | ||
ghc-options: -Wall -Wunused-packages | ||
hs-source-dirs: src | ||
exposed-modules: Graphics.Implicit.Interpreter | ||
build-depends: base >= 4.7 && < 5 | ||
, filepath | ||
, hint | ||
, transformers | ||
, temporary | ||
, exceptions | ||
, text | ||
default-language: Haskell2010 | ||
|
||
test-suite implicit-interpreter-tests | ||
type: exitcode-stdio-1.0 | ||
hs-source-dirs: test | ||
main-is: Spec.hs | ||
build-depends: base >= 4.7 && < 5 | ||
, implicit | ||
, implicit-interpreter | ||
, hspec | ||
, text | ||
default-language: Haskell2010 | ||
|
||
source-repository head | ||
type: git | ||
location: https://github.com/HaskellThings/ImplicitCAD |
228 changes: 228 additions & 0 deletions
228
implicit-interpreter/src/Graphics/Implicit/Interpreter.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,228 @@ | ||
{-# LANGUAGE OverloadedStrings #-} | ||
{-# LANGUAGE RecordWildCards #-} | ||
{-# LANGUAGE ScopedTypeVariables #-} | ||
{-# LANGUAGE TypeApplications #-} | ||
|
||
module Graphics.Implicit.Interpreter ( | ||
ImplicitInterpreterError(..) | ||
, renderError | ||
, interpret | ||
, interpretText | ||
) where | ||
|
||
import Control.Monad.Catch (MonadMask) | ||
import Control.Monad.IO.Class (MonadIO) | ||
import Control.Monad.Trans.Maybe (MaybeT(..)) | ||
import Data.Typeable (Typeable) | ||
import Data.Text (Text) | ||
import Language.Haskell.Interpreter (InterpreterError(..), InterpreterT) | ||
|
||
import qualified Control.Monad.IO.Class | ||
import qualified Data.Foldable | ||
import qualified Data.Maybe | ||
import qualified Data.Text | ||
import qualified Data.Text.IO | ||
import qualified Language.Haskell.Interpreter | ||
import qualified System.FilePath | ||
import qualified System.IO.Temp | ||
import qualified Type.Reflection | ||
|
||
data ImplicitInterpreterError | ||
= ImplicitInterpreterError_Unsafe -- ^ Thrown when module contains unsafe functions | ||
| ImplicitInterpreterError_Hint InterpreterError | ||
deriving Show | ||
|
||
renderError :: ImplicitInterpreterError -> Text | ||
renderError ImplicitInterpreterError_Unsafe = "Refusing to evaluate unsafe functions" | ||
renderError (ImplicitInterpreterError_Hint e) = renderHintError e | ||
|
||
renderHintError :: InterpreterError -> Text | ||
renderHintError (WontCompile ghcErrs) = | ||
Data.Text.unlines | ||
$ Data.Text.pack | ||
. Language.Haskell.Interpreter.errMsg | ||
<$> ghcErrs | ||
renderHintError (UnknownError str) = "Unknown error: " <> Data.Text.pack str | ||
renderHintError (NotAllowed str) = "Not allowed: " <> Data.Text.pack str | ||
renderHintError (GhcException str) = "GHC exception: " <> Data.Text.pack str | ||
|
||
-- | Interpret a file, trying to evaluate @obj@ variable | ||
-- representing @SymbolicObj2@ or @SymbolicObj3@. | ||
-- | ||
-- If file defines resolution as @res@ variable, | ||
-- evaluate it (if it is a Double, Float, Int or Integer) | ||
-- and return alongside an evaluated object. Return | ||
-- default resolution of 1 if not defined. | ||
interpret | ||
:: forall a | ||
. Typeable a | ||
=> FilePath | ||
-> IO (Either ImplicitInterpreterError (Double, a)) | ||
interpret modFile = do | ||
let | ||
-- we always eval obj variable | ||
exprToEval = "obj" | ||
initialResolution = 1 | ||
|
||
mo <- | ||
Language.Haskell.Interpreter.runInterpreter | ||
$ do | ||
Language.Haskell.Interpreter.set | ||
[ Language.Haskell.Interpreter.searchPath | ||
Language.Haskell.Interpreter.:= | ||
pure (System.FilePath.takeDirectory modFile) | ||
] | ||
|
||
Language.Haskell.Interpreter.loadModules | ||
[modFile] | ||
|
||
loadedMods | ||
<- Language.Haskell.Interpreter.getLoadedModules | ||
|
||
Language.Haskell.Interpreter.setTopLevelModules | ||
loadedMods | ||
|
||
obj <- | ||
Language.Haskell.Interpreter.interpret | ||
exprToEval | ||
(Language.Haskell.Interpreter.as @a) | ||
|
||
mRes <- | ||
runMaybeT | ||
$ Data.Foldable.asum | ||
$ map | ||
MaybeT | ||
[ evalRes @Double | ||
, fmap realToFrac <$> evalRes @Float | ||
, fmap fromIntegral <$> evalRes @Int | ||
, fmap fromIntegral <$> evalRes @Integer | ||
] | ||
|
||
pure | ||
( Data.Maybe.fromMaybe initialResolution mRes | ||
, obj | ||
) | ||
|
||
pure $ case mo of | ||
Right x -> Right x | ||
Left e -> Left $ ImplicitInterpreterError_Hint e | ||
|
||
evalRes | ||
:: forall t m | ||
. ( MonadIO m | ||
, MonadMask m | ||
, Typeable t | ||
, Num t | ||
) | ||
=> InterpreterT m (Maybe t) | ||
evalRes = do | ||
tcs <- | ||
Language.Haskell.Interpreter.typeChecks | ||
( "res :: " | ||
<> (show $ Type.Reflection.typeOf @t 0) | ||
) | ||
if tcs | ||
then | ||
Just | ||
<$> Language.Haskell.Interpreter.interpret | ||
"res" | ||
(Language.Haskell.Interpreter.as @t) | ||
else pure Nothing | ||
|
||
-- | Interpret a text | ||
-- representing @SymbolicObj2@ or @SymbolicObj3@. | ||
-- | ||
-- Inpute can be either a full module or bare object | ||
-- expression like @sphere 3@ in which case it is | ||
-- wrapped in a module template using @makeModule@ with typical | ||
-- imports and equated to @obj = sphere 3@. | ||
-- | ||
-- Temporary directory is created with a @Object.hs@ file | ||
-- which is then passed to @interpret@, which sets a search | ||
-- path to the directory. | ||
-- | ||
-- Since this is used by implicit-servant to evaluate | ||
-- untrusted input, we refuse to evaluate anything | ||
-- containing @unsafe@ string, which could be used | ||
-- to perform @IO@ using e.g. @unsafePerformIO@ | ||
-- during @obj@ evaluation which is otherwise pure. | ||
interpretText | ||
:: forall a | ||
. Typeable a | ||
=> Text | ||
-> IO (Either ImplicitInterpreterError (Double, a)) | ||
interpretText code | isUnsafe (describeInput code) = | ||
pure $ Left ImplicitInterpreterError_Unsafe | ||
interpretText code = | ||
let | ||
InputDesc{..} = describeInput code | ||
codeModule = | ||
if hasImports && hasModule | ||
then code | ||
else makeModule code | ||
in | ||
withModuleAsFile | ||
codeModule | ||
interpret | ||
|
||
withModuleAsFile | ||
:: ( MonadMask m | ||
, MonadIO m | ||
) | ||
=> Text | ||
-> (FilePath -> m a) | ||
-> m a | ||
withModuleAsFile source action = do | ||
System.IO.Temp.withSystemTempDirectory | ||
"implicitInterpreter" | ||
$ \dir -> do | ||
let | ||
fp = | ||
System.FilePath.joinPath | ||
[ dir | ||
, "Object.hs" | ||
] | ||
|
||
Control.Monad.IO.Class.liftIO | ||
$ Data.Text.IO.writeFile | ||
fp | ||
source | ||
|
||
action fp | ||
|
||
-- | Input description | ||
data InputDesc = InputDesc { | ||
hasImports :: Bool -- ^ Contains import statements | ||
, hasModule :: Bool -- ^ Contains module definition | ||
, hasPragmas :: Bool -- ^ Contains LANGAUGE pragmas | ||
, isUnsafe :: Bool -- ^ Contains any @unsafe@ functions | ||
} deriving (Eq, Show) | ||
|
||
-- | Check if input is a proper module, with | ||
-- imports and detect any @unsafe@ functions. | ||
describeInput :: Text -> InputDesc | ||
describeInput src = | ||
let | ||
has what x = what `Data.Text.isInfixOf` x | ||
hasImports = has "import" src | ||
hasModule = has "module" src | ||
hasPragmas = has "LANGUAGE" src | ||
isUnsafe = has "unsafe" src | ||
in InputDesc {..} | ||
|
||
-- describeInput "module Blah where\nimport Foo\nunsafePerform\nLANGUAGE" | ||
-- InputDesc {hasImports = True, hasModule = True, hasPragmas = True, isUnsafe = True} | ||
|
||
makeModule | ||
:: Text -- ^ Input sauce | ||
-> Text | ||
makeModule rawExpr = | ||
Data.Text.unlines | ||
[ "module Object (obj) where" | ||
, mempty | ||
, "import Linear" | ||
, "import Graphics.Implicit" | ||
, "import Graphics.Implicit.Definitions" | ||
, mempty | ||
, "obj = " <> rawExpr | ||
] |
Oops, something went wrong.