mirror of
https://github.com/Haskell-Things/ImplicitCAD.git
synced 2024-09-11 04:55:41 +03:00
add message passing back from the extopenscad executor to the application calling it, for errors, and non-model program output.
This commit is contained in:
parent
216bc207ec
commit
8716766ed4
@ -8,37 +8,47 @@
|
||||
-- An executor, which parses openscad code, and executes it.
|
||||
module Graphics.Implicit.ExtOpenScad (runOpenscad) where
|
||||
|
||||
import Prelude(String, Either(Left, Right), IO, ($), fmap)
|
||||
import Prelude(String, Either(Left, Right), IO, ($), fmap, return)
|
||||
|
||||
import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, Message(Message), MessageType(SyntaxError))
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Parser.Util (sourcePosition)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Eval.Statement (runStatementI)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Default (defaultObjects)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Util.StateC (CompState(CompState))
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Util.OVal (divideObjs)
|
||||
|
||||
import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages)
|
||||
|
||||
import Text.Parsec.Error (ParseError)
|
||||
import Control.Monad (mapM_)
|
||||
|
||||
import Control.Monad.State (runStateT)
|
||||
|
||||
import System.Directory (getCurrentDirectory)
|
||||
|
||||
-- | Small wrapper of our parser to handle parse errors, etc.
|
||||
runOpenscad :: String -> Either ParseError (IO (VarLookup, [SymbolicObj2], [SymbolicObj3]))
|
||||
runOpenscad :: String -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
|
||||
runOpenscad source =
|
||||
let
|
||||
initial = defaultObjects
|
||||
rearrange :: (t, CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3])
|
||||
rearrange (_, (CompState (varlookup, ovals, _))) = (varlookup, obj2s, obj3s) where
|
||||
rearrange :: (t, CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
|
||||
rearrange (_, (CompState (varlookup, ovals, _, messages))) = (varlookup, obj2s, obj3s, messages) where
|
||||
(obj2s, obj3s, _ ) = divideObjs ovals
|
||||
show' err = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages err)
|
||||
mesg e = Message SyntaxError (sourcePosition $ errorPos e) $ show' e
|
||||
in case parseProgram "" source of
|
||||
Left e -> Left e
|
||||
Right sts -> Right
|
||||
$ fmap rearrange
|
||||
Left e -> return (initial, [], [], [mesg e])
|
||||
Right sts -> fmap rearrange
|
||||
$ (\sts' -> do
|
||||
path <- getCurrentDirectory
|
||||
runStateT sts' $ CompState (initial, [], path)
|
||||
runStateT sts' $ CompState (initial, [], path, [])
|
||||
)
|
||||
$ mapM_ runStatementI sts
|
||||
|
@ -13,8 +13,9 @@ module Graphics.Implicit.ExtOpenScad.Default (defaultObjects) where
|
||||
import Prelude (String, Bool(True, False), Maybe(Just, Nothing), ($), (++), map, pi, sin, cos, tan, asin, acos, atan, sinh, cosh, tanh, abs, signum, fromInteger, (.), floor, ceiling, round, exp, log, sqrt, max, min, atan2, (**), flip, (<), (>), (<=), (>=), (==), (/=), (&&), (||), not, show, foldl, (*), (/), mod, (+), zipWith, (-), otherwise)
|
||||
|
||||
import Graphics.Implicit.Definitions (ℝ, ℕ)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc), Symbol(Symbol), SourcePosition)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal(OList, ONum, OString, OUndefined, OError, OModule, OFunc), Symbol(Symbol), SourcePosition, MessageType(Info, Unimplemented))
|
||||
import Graphics.Implicit.ExtOpenScad.Util.OVal (toOObj, oTypeStr)
|
||||
import Graphics.Implicit.ExtOpenScad.Util.StateC (addMessage)
|
||||
import Graphics.Implicit.ExtOpenScad.Primitives (primitives)
|
||||
import Data.Map (fromList)
|
||||
import Data.List (genericIndex, genericLength)
|
||||
|
@ -12,6 +12,8 @@ module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch
|
||||
VarLookup(VarLookup),
|
||||
TestInvariant(EulerCharacteristic),
|
||||
SourcePosition(SourcePosition),
|
||||
Message(Message),
|
||||
MessageType(..),
|
||||
lookupVarIn,
|
||||
collector) where
|
||||
|
||||
@ -153,6 +155,28 @@ instance Show SourcePosition where
|
||||
show (SourcePosition line col []) = "line " ++ show line ++ ", column " ++ show col
|
||||
show (SourcePosition line col filePath) = "line " ++ show line ++ ", column " ++ show col ++ ", file " ++ filePath
|
||||
|
||||
-- | the types of messages the execution engine can send back to the application.
|
||||
data MessageType = Info
|
||||
| Debug
|
||||
| Trace
|
||||
| Warning
|
||||
| Error
|
||||
| SyntaxError
|
||||
| Advice
|
||||
| Lint
|
||||
| Compatibility
|
||||
| Unimplemented
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- | An individual message.
|
||||
data Message = Message MessageType SourcePosition String
|
||||
deriving (Eq)
|
||||
|
||||
instance Show Message where
|
||||
show (Message mtype pos text) = show mtype ++ " at " ++ show pos ++ ": " ++ text
|
||||
|
||||
|
||||
|
||||
-- | Apply a symbolic operator to a list of expressions, returning one big expression.
|
||||
-- Accepts a string for the operator, to simplify callers.
|
||||
collector :: String -> [Expr] -> Expr
|
||||
|
@ -83,7 +83,7 @@ runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do
|
||||
argTemplate' <- forM argTemplate $ \(name', defexpr) -> do
|
||||
defval <- mapMaybeM evalExpr defexpr
|
||||
return (name', defval)
|
||||
(CompState (VarLookup varlookup, _, path)) <- get
|
||||
(CompState (VarLookup varlookup, _, path, _)) <- get
|
||||
-- FIXME: \_? really?
|
||||
runStatementI . StatementI sourcePos $ (Name name :=) $ LitE $ OModule $ \_ -> do
|
||||
newNameVals <- forM argTemplate' $ \(name', maybeDef) -> do
|
||||
@ -114,7 +114,7 @@ runStatementI (StatementI sourcePos (NewModule name argTemplate suite)) = do
|
||||
|
||||
runStatementI (StatementI sourcePos (ModuleCall (Symbol name) argsExpr suite)) = do
|
||||
maybeMod <- lookupVar (Symbol name)
|
||||
(CompState (varlookup, _, path)) <- get
|
||||
(CompState (varlookup, _, path, _)) <- get
|
||||
childVals <- fmap reverse . liftIO $ runSuiteCapture varlookup path suite
|
||||
argsVal <- forM argsExpr $ \(posName, expr) -> do
|
||||
val <- evalExpr expr
|
||||
@ -154,7 +154,7 @@ runSuiteCapture :: VarLookup -> FilePath -> [StatementI] -> IO [OVal]
|
||||
runSuiteCapture varlookup path suite = do
|
||||
(res, _) <- runStateT
|
||||
(runSuite suite >> getVals)
|
||||
(CompState (varlookup, [], path))
|
||||
(CompState (varlookup, [], path, []))
|
||||
return res
|
||||
|
||||
|
||||
|
@ -9,11 +9,11 @@
|
||||
{-# LANGUAGE KindSignatures, FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
|
||||
|
||||
module Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC, CompState(CompState)) where
|
||||
module Graphics.Implicit.ExtOpenScad.Util.StateC (addMessage, getVarLookup, modifyVarLookup, lookupVar, pushVals, getVals, putVals, withPathShiftedBy, getPath, getRelPath, errorC, mapMaybeM, StateC, CompState(CompState)) where
|
||||
|
||||
import Prelude(FilePath, IO, String, Maybe(Just, Nothing), Show, Monad, fmap, (.), ($), (++), return, putStrLn, show)
|
||||
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions(VarLookup(VarLookup), OVal, Symbol, SourcePosition, Message(Message), MessageType(Error))
|
||||
|
||||
import Data.Map (lookup)
|
||||
import Control.Monad.State (StateT, get, put, modify, liftIO)
|
||||
@ -21,16 +21,16 @@ import System.FilePath((</>))
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Data.Kind (Type)
|
||||
|
||||
-- | This is the state of a computation. It contains a hash of variables, an array of OVals, and a path.
|
||||
newtype CompState = CompState (VarLookup, [OVal], FilePath)
|
||||
-- | This is the state of a computation. It contains a hash of variables, an array of OVals, a path, and messages.
|
||||
newtype CompState = CompState (VarLookup, [OVal], FilePath, [Message])
|
||||
|
||||
type StateC = StateT CompState IO
|
||||
|
||||
getVarLookup :: StateC VarLookup
|
||||
getVarLookup = fmap (\(CompState (a,_,_)) -> a) get
|
||||
getVarLookup = fmap (\(CompState (a,_,_,_)) -> a) get
|
||||
|
||||
modifyVarLookup :: (VarLookup -> VarLookup) -> StateC ()
|
||||
modifyVarLookup = modify . (\f (CompState (a,b,c)) -> CompState (f a, b, c))
|
||||
modifyVarLookup = modify . (\f (CompState (a,b,c,d)) -> CompState (f a, b, c, d))
|
||||
|
||||
-- | Perform a variable lookup
|
||||
lookupVar :: Symbol -> StateC (Maybe OVal)
|
||||
@ -39,31 +39,31 @@ lookupVar name = do
|
||||
return $ lookup name varlookup
|
||||
|
||||
pushVals :: [OVal] -> StateC ()
|
||||
pushVals vals = modify (\(CompState (a,b,c)) -> CompState (a, vals ++ b, c))
|
||||
pushVals vals = modify (\(CompState (a,b,c,d)) -> CompState (a, vals ++ b, c, d))
|
||||
|
||||
getVals :: StateC [OVal]
|
||||
getVals = do
|
||||
(CompState (_,b,_)) <- get
|
||||
(CompState (_,b,_,_)) <- get
|
||||
return b
|
||||
|
||||
putVals :: [OVal] -> StateC ()
|
||||
putVals vals = do
|
||||
(CompState (a,_,c)) <- get
|
||||
put $ CompState (a,vals,c)
|
||||
(CompState (a,_,c,d)) <- get
|
||||
put $ CompState (a,vals,c,d)
|
||||
|
||||
withPathShiftedBy :: FilePath -> StateC a -> StateC a
|
||||
withPathShiftedBy pathShift s = do
|
||||
(CompState (a,b,path)) <- get
|
||||
put $ CompState (a, b, path </> pathShift)
|
||||
(CompState (a,b,path,d)) <- get
|
||||
put $ CompState (a, b, path </> pathShift,d)
|
||||
x <- s
|
||||
(CompState (a',b',_)) <- get
|
||||
put $ CompState (a', b', path)
|
||||
(CompState (a',b',_,d')) <- get
|
||||
put $ CompState (a', b', path, d')
|
||||
return x
|
||||
|
||||
-- | Return the path stored in the state.
|
||||
getPath :: StateC FilePath
|
||||
getPath = do
|
||||
(CompState (_,_,c)) <- get
|
||||
(CompState (_,_,c,_)) <- get
|
||||
return c
|
||||
|
||||
getRelPath :: FilePath -> StateC FilePath
|
||||
@ -71,9 +71,16 @@ getRelPath relPath = do
|
||||
path <- getPath
|
||||
return $ path </> relPath
|
||||
|
||||
addMesg :: Message -> StateC ()
|
||||
addMesg = modify . (\message (CompState (a, b, c, messages)) -> (CompState (a, b, c, messages ++ [message])))
|
||||
|
||||
addMessage :: MessageType -> SourcePosition -> String -> StateC ()
|
||||
addMessage mtype pos text = addMesg $ Message mtype pos text
|
||||
|
||||
errorC :: SourcePosition -> String -> StateC()
|
||||
errorC sourcePos err =
|
||||
errorC sourcePos err = do
|
||||
liftIO $ putStrLn $ "At " ++ show sourcePos ++ ": " ++ err
|
||||
addMessage Error sourcePos err
|
||||
{-# INLINABLE errorC #-}
|
||||
|
||||
mapMaybeM :: forall t (m :: Type -> Type) a. Monad m => (t -> m a) -> Maybe t -> m (Maybe a)
|
||||
|
@ -11,7 +11,7 @@
|
||||
|
||||
-- Let's be explicit about what we're getting from where :)
|
||||
|
||||
import Prelude (Read(readsPrec), Maybe(Just, Nothing), Either(Left, Right), IO, FilePath, Show, Eq, String, (++), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, map, fst, min, sqrt, tail, take, length, putStrLn, show, print, (>>=), lookup)
|
||||
import Prelude (Read(readsPrec), Maybe(Just, Nothing), IO, FilePath, Show, Eq, String, (++), ($), (*), (/), (==), (>), (**), (-), readFile, minimum, drop, error, map, fst, min, sqrt, tail, take, length, putStrLn, show, (>>=), lookup, return, unlines)
|
||||
|
||||
-- Our Extended OpenScad interpreter, and functions to write out files in designated formats.
|
||||
import Graphics.Implicit (runOpenscad, writeSVG, writeDXF2, writeBinSTL, writeOBJ, writeSCAD2, writeSCAD3, writeGCodeHacklabLaser, writePNG2, writePNG3)
|
||||
@ -23,7 +23,7 @@ import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
|
||||
import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3, ℝ)
|
||||
|
||||
-- Use default values when a Maybe is Nothing.
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe (fromMaybe, maybe)
|
||||
|
||||
-- For making the format guesser case insensitive when looking at file extensions.
|
||||
import Data.Char (toLower)
|
||||
@ -34,7 +34,7 @@ import Data.Tuple (swap)
|
||||
-- Functions and types for dealing with the types used by runOpenscad.
|
||||
|
||||
-- The definition of the symbol type, so we can access variables, and see the requested resolution.
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal(ONum), lookupVarIn)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, OVal(ONum), lookupVarIn, Message)
|
||||
|
||||
-- Operator to subtract two points. Used when defining the resolution of a 2d object.
|
||||
import Data.AffineSpace ((.-.))
|
||||
@ -49,6 +49,9 @@ import Options.Applicative (fullDesc, progDesc, header, auto, info, helper, help
|
||||
-- For handling input/output files.
|
||||
import System.FilePath (splitExtension)
|
||||
|
||||
-- For handling handles to output files.
|
||||
import System.IO (Handle, hPutStr, stdout, openFile, IOMode(WriteMode))
|
||||
|
||||
-- | The following is needed to ensure backwards/forwards compatibility
|
||||
-- | with old versions of Data.Monoid:
|
||||
infixr 6 <>
|
||||
@ -61,6 +64,7 @@ data ExtOpenScadOpts = ExtOpenScadOpts
|
||||
, outputFormat :: Maybe OutputFormat
|
||||
, resolution :: Maybe ℝ
|
||||
, inputFile :: FilePath
|
||||
, messageOutputFile :: Maybe FilePath
|
||||
}
|
||||
|
||||
-- | A type serving to enumerate our output formats.
|
||||
@ -98,6 +102,7 @@ guessOutputFormat fileName =
|
||||
(_,ext) = splitExtension fileName
|
||||
|
||||
-- | The parser for our command line arguments.
|
||||
-- FIXME: -q for quiet.
|
||||
extOpenScadOpts :: Parser ExtOpenScadOpts
|
||||
extOpenScadOpts = ExtOpenScadOpts
|
||||
<$> optional (
|
||||
@ -128,6 +133,14 @@ extOpenScadOpts = ExtOpenScadOpts
|
||||
( metavar "FILE"
|
||||
<> help "Input extended OpenSCAD file"
|
||||
)
|
||||
<*> optional (
|
||||
strOption
|
||||
( short 'e'
|
||||
<> long "echo-output"
|
||||
<> metavar "FILE"
|
||||
<> help "Output file name for echo statements"
|
||||
)
|
||||
)
|
||||
|
||||
-- | Try to look up an output format from a supplied extension.
|
||||
readOutputFormat :: String -> Maybe OutputFormat
|
||||
@ -147,12 +160,12 @@ instance Read OutputFormat where
|
||||
else tryParse xs
|
||||
|
||||
-- | Find the resolution to raytrace at.
|
||||
getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3]) -> ℝ
|
||||
getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ
|
||||
-- | First, use a resolution specified by a variable in the input file.
|
||||
getRes (lookupVarIn "$res" -> Just (ONum res), _, _) = res
|
||||
getRes (lookupVarIn "$res" -> Just (ONum res), _, _, _) = res
|
||||
-- | Use a resolution chosen for 3D objects.
|
||||
-- FIXME: magic numbers.
|
||||
getRes (vars, _, obj:_) =
|
||||
getRes (vars, _, obj:_, _) =
|
||||
let
|
||||
((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
|
||||
(x,y,z) = (x2-x1, y2-y1, z2-z1)
|
||||
@ -161,7 +174,7 @@ getRes (vars, _, obj:_) =
|
||||
_ -> min (minimum [x,y,z]/2) ((x*y*z)**(1/3) / 22)
|
||||
-- | Use a resolution chosen for 2D objects.
|
||||
-- FIXME: magic numbers.
|
||||
getRes (vars, obj:_, _) =
|
||||
getRes (vars, obj:_, _, _) =
|
||||
let
|
||||
(p1,p2) = getBox2 obj
|
||||
(x,y) = p2 .-. p1
|
||||
@ -194,6 +207,10 @@ export2 posFmt res output obj =
|
||||
Nothing -> writeSVG res output obj
|
||||
Just fmt -> putStrLn $ "Unrecognized 2D format: "<>show fmt
|
||||
|
||||
-- | Determine where to direct the text output of running the extopenscad program.
|
||||
messageOutputHandle :: ExtOpenScadOpts -> IO Handle
|
||||
messageOutputHandle args = maybe (return stdout) (`openFile` WriteMode) (messageOutputFile args)
|
||||
|
||||
-- | Interpret arguments, and render the object defined in the supplied input file.
|
||||
run :: ExtOpenScadOpts -> IO ()
|
||||
run args = do
|
||||
@ -206,38 +223,40 @@ run args = do
|
||||
_ | Just fmt <- outputFormat args -> Just fmt
|
||||
_ | Just file <- outputFile args -> Just $ guessOutputFormat file
|
||||
_ -> Nothing
|
||||
putStrLn "Processing File."
|
||||
openscadProgram = runOpenscad content
|
||||
|
||||
case runOpenscad content of
|
||||
Left err -> print err
|
||||
Right openscadProgram -> do
|
||||
s@(_, obj2s, obj3s) <- openscadProgram
|
||||
let res = fromMaybe (getRes s) (resolution args)
|
||||
let basename = fst (splitExtension $ inputFile args)
|
||||
let posDefExt = case format of
|
||||
Just f -> Prelude.lookup f (map swap formatExtensions)
|
||||
Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default
|
||||
case (obj2s, obj3s) of
|
||||
([], [obj]) -> do
|
||||
let output = fromMaybe
|
||||
(basename ++ "." ++ fromMaybe "stl" posDefExt)
|
||||
(outputFile args)
|
||||
putStrLn $ "Rendering 3D object to " ++ output
|
||||
putStrLn $ "With resolution " ++ show res
|
||||
putStrLn $ "In box " ++ show (getBox3 obj)
|
||||
print obj
|
||||
export3 format res output obj
|
||||
([obj], []) -> do
|
||||
let output = fromMaybe
|
||||
(basename ++ "." ++ fromMaybe "svg" posDefExt)
|
||||
(outputFile args)
|
||||
putStrLn $ "Rendering 2D object to " ++ output
|
||||
putStrLn $ "With resolution " ++ show res
|
||||
putStrLn $ "In box " ++ show (getBox2 obj)
|
||||
print obj
|
||||
export2 format res output obj
|
||||
([], []) -> putStrLn "No objects to render."
|
||||
_ -> putStrLn "A mixture of 2D and 3D objects, what do you want to render?"
|
||||
putStrLn "Processing File."
|
||||
|
||||
hMessageOutput <- messageOutputHandle args
|
||||
|
||||
s@(_, obj2s, obj3s, messages) <- openscadProgram
|
||||
let res = fromMaybe (getRes s) (resolution args)
|
||||
basename = fst (splitExtension $ inputFile args)
|
||||
posDefExt = case format of
|
||||
Just f -> Prelude.lookup f (map swap formatExtensions)
|
||||
Nothing -> Nothing -- We don't know the format -- it will be 2D/3D default
|
||||
hPutStr hMessageOutput $ unlines $ map show messages
|
||||
case (obj2s, obj3s) of
|
||||
([], [obj]) -> do
|
||||
let output = fromMaybe
|
||||
(basename ++ "." ++ fromMaybe "stl" posDefExt)
|
||||
(outputFile args)
|
||||
putStrLn $ "Rendering 3D object to " ++ output
|
||||
putStrLn $ "With resolution " ++ show res
|
||||
putStrLn $ "In box " ++ show (getBox3 obj)
|
||||
putStrLn $ show obj
|
||||
export3 format res output obj
|
||||
([obj], []) -> do
|
||||
let output = fromMaybe
|
||||
(basename ++ "." ++ fromMaybe "svg" posDefExt)
|
||||
(outputFile args)
|
||||
putStrLn $ "Rendering 2D object to " ++ output
|
||||
putStrLn $ "With resolution " ++ show res
|
||||
putStrLn $ "In box " ++ show (getBox2 obj)
|
||||
putStrLn $ show obj
|
||||
export2 format res output obj
|
||||
([], []) -> putStrLn "No objects to render."
|
||||
_ -> putStrLn "A mixture of 2D and 3D objects, what do you want to render?"
|
||||
|
||||
-- | The entry point. Use the option parser then run the extended OpenScad code.
|
||||
main :: IO ()
|
||||
|
@ -15,7 +15,7 @@
|
||||
|
||||
-- Let's be explicit about what we're getting from where :)
|
||||
|
||||
import Prelude (IO, Maybe(Just, Nothing), String, Bool(True, False), Either(Left, Right), Show, ($), (++), (>), (.), (-), (/), (*), (**), sqrt, min, max, minimum, maximum, show, return)
|
||||
import Prelude (IO, Maybe(Just, Nothing), String, Bool(True, False), Either(Left, Right), Show, ($), (++), (>), (.), (-), (/), (*), (**), sqrt, min, max, minimum, maximum, show, return, map)
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
|
||||
@ -27,7 +27,7 @@ import Snap.Util.GZip (withCompression)
|
||||
import Graphics.Implicit (runOpenscad, extrudeR)
|
||||
|
||||
-- Variable access functionality, so we can look up a requested resolution.
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum), VarLookup, lookupVarIn)
|
||||
import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum), VarLookup, lookupVarIn, Message)
|
||||
|
||||
-- Functions for finding a box around an object, so we can define the area we need to raytrace inside of.
|
||||
import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
|
||||
@ -47,6 +47,8 @@ import Data.AffineSpace ((.-.))
|
||||
-- class DiscreteApprox
|
||||
import Graphics.Implicit.Export.DiscreteAproxable (discreteAprox)
|
||||
|
||||
import Data.List (intercalate)
|
||||
|
||||
import Data.String (IsString)
|
||||
|
||||
import Text.ParserCombinators.Parsec (errorPos, sourceLine)
|
||||
@ -89,12 +91,12 @@ renderHandler = method GET $ withCompression $ do
|
||||
(_, _, _) -> writeBS "must provide source and callback as 1 GET variable each"
|
||||
|
||||
-- | Find the resolution to raytrace at.
|
||||
getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3]) -> ℝ
|
||||
getRes :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ
|
||||
-- | If a resolution was specified in the input file, just use it.
|
||||
getRes (lookupVarIn "$res" -> Just (ONum res), _, _) = res
|
||||
getRes (lookupVarIn "$res" -> Just (ONum res), _, _, _) = res
|
||||
-- | If there was no resolution specified, use a resolution chosen for 3D objects.
|
||||
-- FIXME: magic numbers.
|
||||
getRes (vars, _, obj:_) =
|
||||
getRes (vars, _, obj:_, _) =
|
||||
let
|
||||
((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
|
||||
(x,y,z) = (x2-x1, y2-y1, z2-z1)
|
||||
@ -103,7 +105,7 @@ getRes (vars, _, obj:_) =
|
||||
_ -> min (minimum [x,y,z]/2) ((x*y*z )**(1/3) / 22)
|
||||
-- | ... Or use a resolution chosen for 2D objects.
|
||||
-- FIXME: magic numbers.
|
||||
getRes (vars, obj:_, _) =
|
||||
getRes (vars, obj:_, _, _) =
|
||||
let
|
||||
(p1,p2) = getBox2 obj
|
||||
(x,y) = p2 .-. p1
|
||||
@ -115,12 +117,12 @@ getRes _ = 1
|
||||
|
||||
-- | get the maximum dimension of the object being rendered.
|
||||
-- FIXME: shouldn't this get the diagonal across the box?
|
||||
getWidth :: (VarLookup, [SymbolicObj2], [SymbolicObj3]) -> ℝ
|
||||
getWidth (_, _, obj:_) = maximum [x2-x1, y2-y1, z2-z1]
|
||||
getWidth :: (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]) -> ℝ
|
||||
getWidth (_, _, obj:_, _) = maximum [x2-x1, y2-y1, z2-z1]
|
||||
where ((x1,y1,z1),(x2,y2,z2)) = getBox3 obj
|
||||
getWidth (_, obj:_, _) = max (x2-x1) (y2-y1)
|
||||
getWidth (_, obj:_, _, _) = max (x2-x1) (y2-y1)
|
||||
where ((x1,y1),(x2,y2)) = getBox2 obj
|
||||
getWidth (_, [], []) = 0
|
||||
getWidth (_, [], [], _) = 0
|
||||
|
||||
-- | Give an openscad object to run and the basename of
|
||||
-- the target to write to... write an object!
|
||||
@ -137,48 +139,40 @@ executeAndExport content callback maybeFormat =
|
||||
callback ++ "([new Shape()," ++ show msg ++ "," ++ showB is2D ++ "," ++ show w ++ "]);"
|
||||
callbackS :: (Show a1, Show a) => a -> a1 -> String
|
||||
callbackS str msg = callback ++ "([" ++ show str ++ "," ++ show msg ++ ",null,null]);"
|
||||
in case runOpenscad content of
|
||||
Left err ->
|
||||
let
|
||||
line = sourceLine . errorPos $ err
|
||||
showErrorMessages' = showErrorMessages
|
||||
"or" "unknown parse error" "expecting" "unexpected" "end of input"
|
||||
msgs :: String
|
||||
msgs = showErrorMessages' $ errorMessages err
|
||||
in callbackF False False 1 $ (\s-> "error (" ++ show line ++ "):" ++ s) msgs
|
||||
Right openscadProgram -> unsafePerformIO $ do
|
||||
(msgs,s) <- capture openscadProgram
|
||||
let
|
||||
res = getRes s
|
||||
w = getWidth s
|
||||
is2D = case s of
|
||||
(_, _, _:_) -> False
|
||||
(_, _:_, _) -> True
|
||||
_ -> False
|
||||
highResError = "Unreasonable resolution requested: "
|
||||
++ "the server imps revolt! "
|
||||
++ "(Install ImplicitCAD locally -- github.com/colah/ImplicitCAD/)"
|
||||
objOrErr = case s of
|
||||
(_, _, x:_) ->
|
||||
if res > 0
|
||||
then Right (Nothing, x)
|
||||
else Left highResError
|
||||
(_, x:_, _) ->
|
||||
if res > 0
|
||||
then Right (Just x, extrudeR 0 x res)
|
||||
else Left highResError
|
||||
_ -> Left $ msgs ++ "Nothing to render."
|
||||
|
||||
return $ case (objOrErr, maybeFormat) of
|
||||
openscadProgram = runOpenscad content
|
||||
in
|
||||
unsafePerformIO $ do
|
||||
s@(_,_,_,messages) <- openscadProgram
|
||||
let
|
||||
res = getRes s
|
||||
w = getWidth s
|
||||
is2D = case s of
|
||||
(_, _, _:_, _) -> False
|
||||
(_, _:_, _, _) -> True
|
||||
_ -> False
|
||||
highResError = "Unreasonable resolution requested: "
|
||||
++ "the server imps revolt! "
|
||||
++ "(Install ImplicitCAD locally -- github.com/colah/ImplicitCAD/)"
|
||||
objOrErr = case s of
|
||||
(_, _, x:_, _) ->
|
||||
if res > 0
|
||||
then Right (Nothing, x)
|
||||
else Left highResError
|
||||
(_, x:_, _, _) ->
|
||||
if res > 0
|
||||
then Right (Just x, extrudeR 0 x res)
|
||||
else Left highResError
|
||||
_ -> Left $ (intercalate "\n" $ map show messages) ++ "Nothing to render."
|
||||
return $ case (objOrErr, maybeFormat) of
|
||||
(Left errmsg, _) -> callbackF False False 1 errmsg
|
||||
(Right (_,obj), Nothing) ->
|
||||
TL.unpack (jsTHREE (discreteAprox res obj)) ++ callbackF True is2D w msgs
|
||||
TL.unpack (jsTHREE (discreteAprox res obj)) ++ (callbackF True is2D w $ (intercalate "\n" $ map show messages))
|
||||
(Right (_,obj), Just "STL") ->
|
||||
callbackS (TL.unpack (stl (discreteAprox res obj))) msgs
|
||||
callbackS (TL.unpack (stl (discreteAprox res obj))) $ intercalate "\n" $ map show messages
|
||||
(Right (Just obj, _), Just "SVG") ->
|
||||
callbackS (TL.unpack (svg (discreteAprox res obj))) msgs
|
||||
callbackS (TL.unpack (svg (discreteAprox res obj))) $ intercalate "\n" $ map show messages
|
||||
(Right (Just obj, _), Just "gcode/hacklab-laser") ->
|
||||
callbackS (TL.unpack (hacklabLaserGCode (discreteAprox res obj))) msgs
|
||||
callbackS (TL.unpack (hacklabLaserGCode (discreteAprox res obj))) $ intercalate "\n" $ map show messages
|
||||
(Right (_ , _), _) ->
|
||||
callbackF False False 1 "unexpected case"
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user