{-# LANGUAGE PatternSynonyms #-}
module Graphics.Implicit.ExtOpenScad.Parser.Expr(expr0) where
import Prelude (Char, Maybe(Nothing, Just), String, ($), (<>), id, foldl, foldr, (==), length, head, (&&), (<$>), (<*>), (*>), (<*), flip, (.), pure)
import Graphics.Implicit.ExtOpenScad.Definitions (Expr(LamE, LitE, ListE, (:$)), OVal(ONum, OUndefined), Symbol(Symbol))
import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Expr(Var), Pattern(Name))
import Graphics.Implicit.ExtOpenScad.Parser.Util ((?:), (*<|>), number, boolean, scadString, scadUndefined, variable)
import Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchLet, matchTok, matchColon, matchComma, surroundedBy, matchIdentifier, matchEQ, matchNE, matchLE, matchLT, matchGE, matchGT, matchCAT, matchAND, matchOR)
import Text.Parsec (oneOf, many, sepBy, optionMaybe, option, (<|>), chainl1, chainr1)
import Text.Parsec.String (GenParser)
import Control.Monad.Fix(fix)
pattern Var :: String -> Expr
pattern Var s = GIED.Var (Symbol s)
pattern Name :: String -> GIED.Pattern
pattern Name n = GIED.Name (Symbol n)
expr0 :: GenParser Char st Expr
expr0 = foldr ($) nonAssociativeExpr levels
where
levels :: [GenParser Char st Expr -> GenParser Char st Expr]
levels =
[ id
, \higher -> fix $ \self -> do
condition <- higher
do
trueExpr <- matchTok '?' *> self
falseExpr <- matchColon *> self
pure $ Var "?" :$ [condition, trueExpr, falseExpr]
<|>
pure condition
, \higher ->
chainl1 higher $ binaryOperation <$> matchOR
, \higher ->
chainl1 higher $ binaryOperation <$> matchAND
, \higher ->
chainl1 higher $ binaryOperation <$> (matchEQ <|> matchNE)
, \higher ->
chainl1 higher $ binaryOperation <$> (matchLE <|> matchLT <|> matchGE <|> matchGT)
, \higher ->
chainl1 higher $ binaryOperation . pure <$> oneOf "+-" <* whiteSpace
, \higher ->
chainl1 higher $ binaryOperation <$> matchCAT
, \higher ->
chainr1 higher $ binaryOperation <$> matchTok '^'
, \higher ->
chainl1 higher $ binaryOperation . pure <$> oneOf "*/%" <* whiteSpace
, \higher ->
fix $ \self ->
do
op <- matchTok '!'
right <- self
pure $ case right of
Var "!" :$ [deepright] -> deepright
_ -> Var op :$ [right]
<|>
higher
, \higher ->
fix $ \self ->
do
right <- matchTok '-' *> self
pure $ Var "negate" :$ [right]
<|> do
matchTok '+' *> self
<|>
higher
, \higher ->
flip (foldr bindLets) <$> (matchLet *> surroundedBy '(' (assignment `sepBy` matchTok ',') ')') <*> expr0
<|>
higher
]
nonAssociativeExpr :: GenParser Char st Expr
nonAssociativeExpr =
number
<|> vectorListParentheses
<|> variableish
<|> scadString
<|> boolean
<|> scadUndefined
variableish :: GenParser Char st Expr
variableish = "variable" ?:
do
obj <- variable
args <- option [] (
"function application" ?: do
args <- surroundedBy '(' (sepBy expr0 matchComma) ')'
pure [(:$ args)]
)
mods <- many (
"list indexing" ?: do
i <- surroundedBy '[' expr0 ']'
pure $ \l -> Var "index" :$ [l, i]
*<|> "list splicing" ?: do
start <- matchTok '[' *> optionMaybe expr0
end <- matchColon *> optionMaybe expr0 <* matchTok ']'
pure $ case (start, end) of
(Nothing, Nothing) -> id
(Just s, Nothing) -> \l -> Var "splice" :$ [l, s, LitE OUndefined]
(Nothing, Just e ) -> \l -> Var "splice" :$ [l, LitE $ ONum 0, e]
(Just s, Just e ) -> \l -> Var "splice" :$ [l, s, e]
)
pure $ foldl (\a b -> b a) obj (args <> mods)
vectorListParentheses :: GenParser Char st Expr
vectorListParentheses =
"vector/list/parentheses" ?: do
o <- oneOf "[(" <* whiteSpace
exprs <- sepBy expr0 matchComma
<* if o == '['
then matchTok ']'
else matchTok ')'
pure $ if o == '(' && length exprs == 1
then head exprs
else ListE exprs
*<|> "vector/list generator" ?: do
expr1 <- matchTok '[' *> expr0 <* matchColon
exprs <- do
expr2 <- expr0
expr3 <- optionMaybe (matchColon *> expr0)
pure $ case expr3 of
Just n -> [expr1, expr2, n]
Nothing -> [expr1, LitE $ ONum 1.0, expr2]
<* matchTok ']'
pure $ collector "list_gen" exprs
collector :: String -> [Expr] -> Expr
collector _ [x] = x
collector s l = Var s :$ [ListE l]
binaryOperation :: String -> Expr -> Expr -> Expr
binaryOperation symbol left right = Var symbol :$ [left, right]
assignment :: GenParser Char st Expr
assignment = do
ident <- matchIdentifier
expression <- matchTok '=' *> expr0
pure $ ListE [Var ident, expression]
bindLets :: Expr -> Expr -> Expr
bindLets (ListE [Var boundName, boundExpr]) nestedExpr = LamE [Name boundName] nestedExpr :$ [boundExpr]
bindLets _ e = e