implicit-0.0.2: Graphics/Implicit/ExtOpenScad/Statements.hs
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Released under the GNU GPL, see LICENSE
-- We'd like to parse openscad code, with some improvements, for backwards compatability.
-- Implement statements for things other than primitive objects!
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, TypeSynonymInstances, UndecidableInstances, ScopedTypeVariables, NoMonomorphismRestriction #-}
module Graphics.Implicit.ExtOpenScad.Statements where
import Prelude hiding (lookup)
import Graphics.Implicit.Definitions
import Graphics.Implicit.ObjectUtil (getBox2, getBox3)
import Graphics.Implicit.ExtOpenScad.Definitions
import Graphics.Implicit.ExtOpenScad.Expressions
import Graphics.Implicit.ExtOpenScad.Util
import Graphics.Implicit.ExtOpenScad.Primitives
import qualified Graphics.Implicit.Primitives as Prim
import Data.Map (Map, lookup, insert, union)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import Control.Monad (liftM)
import System.Plugins.Load (load_, LoadStatus(..))
import Control.Monad (forM_)
import Graphics.Implicit.ExtOpenScad.Util.ArgParser
import Graphics.Implicit.ExtOpenScad.Util.Computation
tryMany = (foldl1 (<|>)) . (map try)
-- | A statement in our programming openscad-like programming language.
computationStatement :: GenParser Char st ComputationStateModifier
computationStatement =
(try $ do -- suite statemetns: no semicolon...
many space
s <- tryMany [
ifStatement,
forStatement,
throwAway,
userModuleDeclaration,
unimplemented "mirror",
unimplemented "multmatrix",
unimplemented "color",
unimplemented "render",
unimplemented "surface",
unimplemented "projection",
unimplemented "rotate_extrude",
unimplemented "import_stl"
-- rotateExtrudeStatement
]
many space
return s
) <|> (try $ do -- Non suite statements. Semicolon needed...
many space
s <- tryMany [
echoStatement,
assigmentStatement,
includeStatement,
useStatement
]
many space
char ';'
many space
return s
)<|> (try $ many space >> comment)
<|> (try $ do
many space
s <- userModule
many space
return s
)
-- | A suite of statements!
-- What's a suite? Consider:
--
-- union() {
-- sphere(3);
-- }
--
-- The suite was in the braces ({}). Similarily, the
-- following has the same suite:
--
-- union() sphere(3);
--
-- We consider it to be a list of statements which
-- are in tern ComputationStateModifier s.
-- So this parses them.
suite :: GenParser Char st [ComputationStateModifier]
suite = (liftM return computationStatement <|> do
char '{'
many space
stmts <- many (try computationStatement)
many space
char '}'
return stmts
) <?> "statement suite"
-- | We think of comments as statements that do nothing. It's just convenient.
comment =
(((try $ do
string "//"
many ( noneOf "\n")
string "\n"
) <|> (do
string "/*"
manyTill anyChar (try $ string "*/")
)) >> return id) <?> "comment"
throwAway :: GenParser Char st ComputationStateModifier
throwAway = do
many space
oneOf "%*"
many space
computationStatement
return id
-- An included statement! Basically, inject another openscad file here...
includeStatement :: GenParser Char st ComputationStateModifier
includeStatement = (do
line <- fmap sourceLine getPosition
string "include"
many space
string "<"
filename <- many (noneOf "<>")
string ">"
return $ \ ioWrappedState -> do
state@(varlookup,obj2s,obj3s) <- ioWrappedState;
case reverse filename of
'o':'.':_ -> do
loaded :: LoadStatus VariableLookup
<- load_ filename ["."] "openscadAPI"
case loaded of
LoadFailure errs -> do
putStrLn $ show errs
return state
LoadSuccess _ newapi -> do
putStrLn "Loaded Haskell Module..."
return (union varlookup newapi, obj2s, obj3s)
_ -> do
content <- readFile filename
case parse (many1 computationStatement) "" content of
Left err -> do
errorMessage line $
"Error parsing included file <file>" ++ filename ++ "</file>\n"
++ show err
++ "Ignoring included file <file>" ++ filename ++ "</file>..."
return state
Right result -> runComputations (return state) result
) <?> "include statement"
-- In a use statement, variables are imported but we drop any existing 2D/3D objects.
useStatement :: GenParser Char st ComputationStateModifier
useStatement = (do
line <- fmap sourceLine getPosition
string "use"
many space
string "<"
filename <- many (noneOf "<>")
string ">"
return $ \ ioWrappedState -> do
state@(varlookup, _, _) <- ioWrappedState;
content <- readFile filename
case parse (many1 computationStatement) "" content of
Left err -> do
errorMessage line $
"Error parsing included file <file>" ++ filename ++ "</file>\n"
++ show err
++ "Ignoring included file <file>" ++ filename ++ "</file>..."
return state
Right result -> runComputations (return (varlookup,[],[])) result
) <?> "use statement"
-- | An assignment statement (parser)
assigmentStatement :: GenParser Char st ComputationStateModifier
assigmentStatement =
(try $ do
line <- fmap sourceLine getPosition
pattern <- patternMatcher
many space
char '='
many space
valExpr <- expression 0
return $ \ ioWrappedState -> do
state@(varlookup, obj2s, obj3s) <- ioWrappedState
let
val = valExpr varlookup
match = pattern val
case match of
Just dictWithNew -> case val of
OError e -> do
errorMessage line $
"error in evaluating assignment statement assigned value:"
++ concat (map ("\n "++) e)
return (union dictWithNew varlookup, obj2s, obj3s)
_ -> return (union dictWithNew varlookup, obj2s, obj3s)
Nothing -> do
errorMessage line $ "pattern match fail in assignment statement"
return state
) <|> (try $ do
line <- fmap sourceLine getPosition
varSymb <- (try $ string "function" >> many1 space >> variableSymb)
<|> variableSymb
many space
char '('
many space
argVars <- sepBy variableSymb (many space >> char ',' >> many space)
many space
char ')'
many space
char '='
many space
valExpr <- expression 0
return $ \ ioWrappedState -> do
(varlookup, obj2s, obj3s) <- ioWrappedState
let
makeFunc baseExpr (argVar:xs) varlookup' = OFunc $
\argObj -> makeFunc baseExpr xs (insert argVar argObj varlookup')
makeFunc baseExpr [] varlookup' = baseExpr varlookup'
val = makeFunc valExpr argVars varlookup
case val of
OError e -> do
errorMessage line $ "error in evaluating assignment statement assigned value:"
++ concat (map ("\n "++) e)
return (insert varSymb val varlookup, obj2s, obj3s)
_ -> return (insert varSymb val varlookup, obj2s, obj3s)
)<?> "assignment statement"
-- | An echo statement (parser)
echoStatement :: GenParser Char st ComputationStateModifier
echoStatement = do
line <- fmap sourceLine getPosition
string "echo"
many space
char '('
many space
exprs <- expression 0 `sepBy` (many space >> char ',' >> many space)
many space
char ')'
return $ \ ioWrappedState -> do
state@(varlookup, _, _) <- ioWrappedState
let
vals = map ($varlookup) exprs
isError (OError _) = True
isError _ = False
show2 (OString str) = str
show2 a = show a
errorMessage line $
if any isError vals
then
"in module <module>echo</module>:"
++ ( concat $ concat $
map (map ("\n "++)) $
map (\(OError errs) -> errs) $ filter isError vals
)
else
unwords $ map show2 vals
return state
ifStatement :: GenParser Char st ComputationStateModifier
ifStatement = (do
line <- fmap sourceLine getPosition
string "if"
many space
char '('
bexpr <- expression 0
char ')'
many space
statementsTrueCase <- suite
many space
statementsFalseCase <- try (string "else" >> many space >> suite ) <|> (return [])
return $ \ ioWrappedState -> do
state@(varlookup, _, _) <- ioWrappedState
case bexpr varlookup of
OBool bval ->
if bval
then runComputations (return state) statementsTrueCase
else runComputations (return state) statementsFalseCase
OError errs -> do
errorMessage line $ " error while evaluating if statement conditional:"
++ concat (map ("\n " ++) errs)
return state
obj -> do
errorMessage line $ "inappropriate type for if statement conditional:\n"
++ " value " ++ show obj ++ " is not a boolean."
return state
) <?> "if statement"
forStatement :: GenParser Char st ComputationStateModifier
forStatement = (do
line <- fmap sourceLine getPosition
-- a for loop is of the form:
-- for ( vsymb = vexpr ) loopStatements
-- eg. for ( a = [1,2,3] ) {echo(a); echo "lol";}
-- eg. for ( [a,b] = [[1,2]] ) {echo(a+b); echo "lol";}
string "for"
many space
char '('
many space
pattern <- patternMatcher
many space
char '='
vexpr <- expression 0
char ')'
many space
loopStatements <- suite
return $ \ ioWrappedState -> do
-- a for loop unpackages the state from an io monad
state@(varlookup,_,_) <- ioWrappedState;
let
-- each iteration of the loop consists of unpacking the state
loopOnce ::
ComputationState -- ^ The state at this point in the loop
-> OpenscadObj -- ^ The value of vsymb for this iteration
-> ComputationState -- ^ The resulting state
loopOnce ioWrappedState val = do
state@(varlookup, a, b) <- ioWrappedState;
let
match = pattern val
vsymbSetState = case match of
Just dictWithNew -> return (union dictWithNew varlookup, a, b)
Nothing -> do
errorMessage line $ "Pattern match fail in for loop step"
return state
runComputations vsymbSetState loopStatements
-- Then loops once for every entry in vexpr
case vexpr varlookup of
OList l -> foldl (loopOnce) (return state) l
OError errs -> do
errorMessage line $ "Error while evaluating for loop array:"
++ concat (map ("\n " ++) errs)
return state
obj -> do
errorMessage line $ "Error in for loop iteration array:\n"
++ " Inappropriate type for loop iterated array:\n"
++ " value " ++ show obj ++ " is not a list."
return state
) <?> "for statement"
moduleWithSuite ::
String -> ([ComputationStateModifier] -> ArgParser ComputationStateModifier)
-> GenParser Char st ComputationStateModifier
moduleWithSuite name argHandeler = (do
line <- fmap sourceLine getPosition
string name;
many space;
(unnamed, named) <- moduleArgsUnit
many space;
statements <- suite
return $ \ ioWrappedState -> do
state@(varlookup, obj2s, obj3s) <- ioWrappedState
case argMap
(map ($varlookup) unnamed)
(map (\(a,b) -> (a, b varlookup)) named) (argHandeler statements)
of
(Just computationModifier, []) -> computationModifier (return state)
(Nothing, []) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> failed without a message"
return state
(Nothing, errs) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> failed with the following messages:"
++ concat (map (" "++) errs)
return state
(Just computationModifier, errs) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> gave the following warnings:"
++ concat (map (" "++) errs)
computationModifier (return state)
) <?> (name ++ " statement")
unimplemented :: String -> GenParser Char st ComputationStateModifier
unimplemented name = do
line <- fmap sourceLine getPosition
string name
many space;
moduleArgsUnit
many space;
(try suite <|> (many space >> char ';' >> return []))
return $ \ ioWrappedState -> do
state <- ioWrappedState
errorMessage line $ "OpenSCAD command " ++ name ++ " not yet implemented"
return state
userModule :: GenParser Char st ComputationStateModifier
userModule = do
line <- fmap sourceLine getPosition
name <- variableSymb;
many space;
(unnamed, named) <- moduleArgsUnit
many space;
statements <- ( try suite <|> (many space >> char ';' >> return []))
return $ \ ioWrappedState -> do
state@(varlookup, obj2s, obj3s) <- ioWrappedState
case lookup name varlookup of
Just (OModule m) ->
case argMap
(map ($varlookup) unnamed)
(map (\(a,b) -> (a, b varlookup)) named)
(m statements)
of
(Just computationModifier, []) ->
computationModifier (return state)
(Nothing, []) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> failed without a message"
return state
(Nothing, errs) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> failed with the following messages:"
++ concat (map (" "++) errs)
return state
(Just computationModifier, errs) -> do
errorMessage line $ "Module <module>" ++ name
++ "</module> gave the following warnings:"
++ concat (map (" "++) errs)
computationModifier (return state)
_ -> do
errorMessage line $ "module <module>" ++ name ++ "</module> is not in scope"
return state
userModuleDeclaration :: GenParser Char st ComputationStateModifier
userModuleDeclaration = do
string "module"
many space;
newModuleName <- variableSymb;
many space;
args <- moduleArgsUnitDecl
many space;
codeStatements <- suite
return $ \ envIOWrappedState -> do
(envVarlookup, envObj2s, envObj3s) <- envIOWrappedState
let
newModule = OModule $ \childrenStatements -> do
argVarlookupModifier <- args envVarlookup
return $ \contextIOWrappedState -> do
contextState@(contextVarLookup, contextObj2s, contextObj3s)
<- contextIOWrappedState
(_, childObj2s, childObj3s) <- runComputations
(return contextState)
childrenStatements;
let
children = ONum $ fromIntegral
(length childObj2s + length childObj3s)
child = OModule $ \suite -> do
n :: ℕ <- argument "n";
if n <= length childObj3s
then addObj3 (childObj3s !! n)
else addObj2 (childObj2s !! (n+1-length childObj3s))
childBox = OFunc $ \n -> case fromOObj n :: Maybe ℕ of
Just n | n < length childObj3s + length childObj2s ->
if n <= length childObj3s
then toOObj $ getBox3 (childObj3s !! n)
else toOObj $ getBox2 (childObj2s !! (n+1-length childObj3s))
Nothing -> OUndefined
varlookupForCode =
(insert "child" child) $
(insert "children" children) $
(insert "childBox" childBox) $
(insert newModuleName newModule) $
envVarlookup
(_, resultObj2s, resultObj3s)
<- runComputations
(return (argVarlookupModifier varlookupForCode,[],[]))
codeStatements
return (
contextVarLookup,
contextObj2s ++ resultObj2s,
contextObj3s ++ resultObj3s
)
return (insert newModuleName (newModule) envVarlookup, envObj2s, envObj3s)