{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE KindSignatures #-}
module Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) where
import Prelude(Char, Either, String, Maybe(Just, Nothing), Monad, return, fmap, ($), (>>), Bool(False, True), map)
import Text.ParserCombinators.Parsec (try, sepBy, sourceLine, GenParser, oneOf, space, char, getPosition, parse, many1, eof, string, SourceName, ParseError, many, noneOf, Line, (<|>), (<?>))
import Text.Parsec.Prim (ParsecT)
import Data.Functor.Identity(Identity)
import Graphics.Implicit.ExtOpenScad.Definitions (Pattern(Name), Statement(DoNothing, NewModule, Include, Echo, If, For, ModuleCall,(:=)),Expr(LamE), StatementI(StatementI))
import Graphics.Implicit.ExtOpenScad.Parser.Util (genSpace, tryMany, stringGS, (*<|>), (?:), patternMatcher, variableSymb)
import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)
parseProgram :: String -> Either ParseError [StatementI]
parseProgram = parse program "" where
program :: ParsecT String u Identity [StatementI]
program = do
sts <- many1 computation
eof
return sts
computation :: GenParser Char st StatementI
computation =
do
_ <- genSpace
s <- tryMany [
ifStatementI,
forStatementI,
throwAway,
userModuleDeclaration
]
_ <- genSpace
return s
*<|> do
_ <- genSpace
s <- tryMany [
echo,
include,
function,
assignment
]
_ <- stringGS " ; "
return s
*<|> do
_ <- genSpace
s <- userModule
_ <- genSpace
return s
suite :: GenParser Char st [StatementI]
suite = (fmap return computation <|> do
_ <- char '{'
_ <- genSpace
stmts <- many (try computation)
_ <- genSpace
_ <- char '}'
return stmts
) <?> " suite"
throwAway :: GenParser Char st StatementI
throwAway = do
line <- lineNumber
_ <- genSpace
_ <- oneOf "%*"
_ <- genSpace
_ <- computation
return $ StatementI line DoNothing
include :: GenParser Char st StatementI
include = (do
line <- lineNumber
injectVals <- (string "include" >> return True )
<|> (string "use" >> return False)
_ <- stringGS " < "
filename <- many (noneOf "<> ")
_ <- stringGS " > "
return $ StatementI line $ Include filename injectVals
) <?> "include "
assignment :: GenParser Char st StatementI
assignment = ("assignment " ?:) $
do
line <- lineNumber
lvalue <- patternMatcher
_ <- stringGS " = "
valExpr <- expr0
return $ StatementI line $ lvalue := valExpr
function :: GenParser Char st StatementI
function = ("function " ?:) $
do
line <- lineNumber
varSymb <- string "function" >> space >> genSpace >> variableSymb
_ <- stringGS " ( "
argVars <- sepBy patternMatcher (stringGS " , ")
_ <- stringGS " ) = "
valExpr <- expr0
return $ StatementI line $ Name varSymb := LamE argVars valExpr
echo :: GenParser Char st StatementI
echo = do
line <- lineNumber
_ <- stringGS "echo ( "
exprs <- expr0 `sepBy` stringGS " , "
_ <- stringGS " ) "
return $ StatementI line $ Echo exprs
ifStatementI :: GenParser Char st StatementI
ifStatementI =
"if " ?: do
line <- lineNumber
_ <- stringGS "if ( "
bexpr <- expr0
_ <- stringGS " ) "
sTrueCase <- suite
_ <- genSpace
sFalseCase <- (stringGS "else " >> suite ) *<|> return []
return $ StatementI line $ If bexpr sTrueCase sFalseCase
forStatementI :: GenParser Char st StatementI
forStatementI =
"for " ?: do
line <- lineNumber
_ <- stringGS "for ( "
lvalue <- patternMatcher
_ <- stringGS " = "
vexpr <- expr0
_ <- stringGS " ) "
loopContent <- suite
return $ StatementI line $ For lvalue vexpr loopContent
userModule :: GenParser Char st StatementI
userModule = do
line <- lineNumber
name <- variableSymb
_ <- genSpace
args <- moduleArgsUnit
_ <- genSpace
s <- suite *<|> (stringGS " ; " >> return [])
return $ StatementI line $ ModuleCall name args s
userModuleDeclaration :: GenParser Char st StatementI
userModuleDeclaration = do
line <- lineNumber
_ <- stringGS "module "
newModuleName <- variableSymb
_ <- genSpace
args <- moduleArgsUnitDecl
_ <- genSpace
s <- suite
return $ StatementI line $ NewModule newModuleName args s
moduleArgsUnit :: GenParser Char st [(Maybe String, Expr)]
moduleArgsUnit = do
_ <- stringGS " ( "
args <- sepBy (
do
symb <- variableSymb
_ <- stringGS " = "
expr <- expr0
return (Just symb, expr)
*<|> do
symb <- variableSymb
_ <- stringGS " ( "
argVars <- sepBy variableSymb (try $ stringGS " , ")
_ <- stringGS " ) = "
expr <- expr0
return (Just symb, LamE (map Name argVars) expr)
*<|> do
expr <- expr0
return (Nothing, expr)
) (try $ stringGS " , ")
_ <- stringGS " ) "
return args
moduleArgsUnitDecl :: GenParser Char st [(String, Maybe Expr)]
moduleArgsUnitDecl = do
_ <- stringGS " ( "
argTemplate <- sepBy (
do
symb <- variableSymb;
_ <- stringGS " = "
expr <- expr0
return (symb, Just expr)
*<|> do
symb <- variableSymb;
_ <- stringGS " ( "
_ <- sepBy variableSymb (try $ stringGS " , ")
_ <- stringGS " ) = "
expr <- expr0
return (symb, Just expr)
*<|> do
symb <- variableSymb
return (symb, Nothing)
) (try $ stringGS " , ")
_ <- stringGS " ) "
return argTemplate
lineNumber :: forall s u (m :: * -> *).
Monad m => ParsecT s u m Line
lineNumber = fmap sourceLine getPosition