{- ORMOLU_DISABLE -}
-- Implicit CAD. Copyright (C) 2011, Christopher Olah (chris@colah.ca)
-- Copyright 2014 2015 2016, Julia Longtin (julial@turinglace.com)
-- Released under the GNU AGPLV3+, see LICENSE

-- Allow us to use a shorter form of Name.
{-# LANGUAGE PatternSynonyms #-}

-- The entry point for parsing an ExtOpenScad program.
module Graphics.Implicit.ExtOpenScad.Parser.Statement (parseProgram) where

import Prelude(Char, Either, String, ($), (*>), Bool(False, True), (<$>), (<*>), (.), (<$), flip, fmap, filter, not, pure)

import Data.Maybe(Maybe(Just, Nothing))

import Graphics.Implicit.ExtOpenScad.Definitions (Statement(DoNothing, NewModule, Include, If, ModuleCall, (:=)), Expr(LamE), StatementI(StatementI), Symbol(Symbol), SourcePosition)

import qualified Graphics.Implicit.ExtOpenScad.Definitions as GIED (Pattern(Name))

import Graphics.Implicit.ExtOpenScad.Parser.Util ((*<|>), patternMatcher, sourcePosition)

-- the top level of the expression parser.
import Graphics.Implicit.ExtOpenScad.Parser.Expr (expr0)

-- The lexer.
import Graphics.Implicit.ExtOpenScad.Parser.Lexer (whiteSpace, matchFunction, matchInclude, matchUse, matchIf, matchElse, matchModule, matchTok, matchComma, matchSemi, surroundedBy, matchIdentifier)

-- We use parsec to parse.
import Text.Parsec (SourceName, (<?>), sepBy, oneOf, getPosition, parse, eof, ParseError, many, noneOf, option, between, char, optionMaybe)

import Text.Parsec.String (GenParser)

import Control.Applicative ((<*), (<|>))

import Data.Functor (($>))

import Data.Text.Lazy (Text, pack)

-- Let us use the old syntax when defining Names.
pattern Name :: Text -> GIED.Pattern
pattern $bName :: Text -> Pattern
$mName :: forall {r}. Pattern -> (Text -> r) -> ((# #) -> r) -> r
Name n = GIED.Name (Symbol n)

data CompIdx = A1 | A2

-- | all of the token parsers are lexemes which consume all trailing spaces nicely.
-- | This leaves us to deal only with the first spaces in the file.
parseProgram :: SourceName -> String -> Either ParseError [StatementI]
parseProgram :: String -> String -> Either ParseError [StatementI]
parseProgram = forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse forall st. GenParser Char st [StatementI]
program where
    program :: GenParser Char st [StatementI]
    program :: forall st. GenParser Char st [StatementI]
program = [StatementI] -> [StatementI]
removeNoOps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall st. GenParser Char st ()
whiteSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A1) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)

-- | A computable block of code in our openscad-like programming language.
computation :: CompIdx -> GenParser Char st StatementI
computation :: forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A1 =
  forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A2
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall st. GenParser Char st StatementI
throwAway

computation CompIdx
A2 =
  -- suite statements: no semicolon...
  forall st. GenParser Char st StatementI
userModule
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall st. GenParser Char st StatementI
ifStatementI
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  forall st. GenParser Char st StatementI
userModuleDeclaration
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> -- Non suite statements. Semicolon needed...
  ( forall st. GenParser Char st StatementI
include
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    forall st. GenParser Char st StatementI
function
  ) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. GenParser Char st Text
matchSemi
  forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
  forall st. GenParser Char st StatementI
assignment forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. GenParser Char st Text
matchSemi

-- | A suite of s!
--   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 computables which
--  are in turn StatementI s.
{-# ANN suite "HLint: ignore Functor law" #-}
suite :: GenParser Char st [StatementI]
suite :: forall st. GenParser Char st [StatementI]
suite = (
    [StatementI] -> [StatementI]
removeNoOps forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A1
  forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|>
    [StatementI] -> [StatementI]
removeNoOps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'{' (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many (forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A1)) Char
'}'
  ) forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"suite"

-- | Every StatementI requires a source position, thus we can build a combinator.
statementI :: GenParser Char st (Statement StatementI) -> GenParser Char st StatementI
statementI :: forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI GenParser Char st (Statement StatementI)
p = SourcePosition -> Statement StatementI -> StatementI
StatementI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st. GenParser Char st SourcePosition
sourcePos forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenParser Char st (Statement StatementI)
p

-- | Commenting out a computation: use % or * before the statement, and it will not be run.
throwAway :: GenParser Char st StatementI
throwAway :: forall st. GenParser Char st StatementI
throwAway = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall a b. (a -> b) -> a -> b
$ forall st. Statement st
DoNothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
oneOf String
"%*" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. GenParser Char st ()
whiteSpace forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. CompIdx -> GenParser Char st StatementI
computation CompIdx
A2

-- | An include! Basically, inject another extopenscad file here...
include :: GenParser Char st StatementI
include :: forall st. GenParser Char st StatementI
include = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"include/use"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall st. Text -> Bool -> Statement st
Include
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall st. GenParser Char st ()
matchInclude forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall st. GenParser Char st ()
matchUse forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False)
      -- FIXME: better definition of valid filename characters.
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<') (forall st. Char -> GenParser Char st Char
matchTok Char
'>') (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
"<> "))

-- | An assignment (parser)
assignment :: GenParser Char st StatementI
assignment :: forall st. GenParser Char st StatementI
assignment = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"assignment"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall st. Pattern -> Expr -> Statement st
(:=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st. GenParser Char st Pattern
patternMatcher forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall st. Char -> GenParser Char st Char
matchTok Char
'=' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st Expr
expr0

-- | A function declaration (parser)
function :: GenParser Char st StatementI
function :: forall st. GenParser Char st StatementI
function = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"function"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall st. Pattern -> Expr -> Statement st
(:=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st. GenParser Char st Pattern
lval forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st Expr
rval
    lval :: GenParser Char st GIED.Pattern
    lval :: forall st. GenParser Char st Pattern
lval = Text -> Pattern
Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall st. GenParser Char st ()
matchFunction forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st String
matchIdentifier)
    rval :: GenParser Char st Expr
    rval :: forall st. GenParser Char st Expr
rval = [Pattern] -> Expr -> Expr
LamE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'(' (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy forall st. GenParser Char st Pattern
patternMatcher forall st. GenParser Char st Text
matchComma) Char
')' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall st. Char -> GenParser Char st Char
matchTok Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st Expr
expr0)

-- | An if statement (parser)
ifStatementI :: GenParser Char st StatementI
ifStatementI :: forall st. GenParser Char st StatementI
ifStatementI = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"if"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall st. Expr -> [st] -> [st] -> Statement st
If forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall st. GenParser Char st ()
matchIf forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'(' forall st. GenParser Char st Expr
expr0 Char
')') forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st [StatementI]
suite forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (forall st. GenParser Char st ()
matchElse forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st [StatementI]
suite)

-- | parse a call to a module.
userModule :: GenParser Char st StatementI
userModule :: forall st. GenParser Char st StatementI
userModule = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"module call"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall st. Symbol -> [(Maybe Symbol, Expr)] -> [st] -> Statement st
ModuleCall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Symbol
Symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) forall st. GenParser Char st String
matchIdentifier forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st [(Maybe Symbol, Expr)]
moduleArgsUnit forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall st. GenParser Char st [StatementI]
suite forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|> (forall st. GenParser Char st Text
matchSemi forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> []))

-- | declare a module.
userModuleDeclaration :: GenParser Char st StatementI
userModuleDeclaration :: forall st. GenParser Char st StatementI
userModuleDeclaration = forall st.
GenParser Char st (Statement StatementI)
-> GenParser Char st StatementI
statementI forall st. GenParser Char st (Statement StatementI)
p forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"module declaration"
  where
    p :: GenParser Char st (Statement StatementI)
    p :: forall st. GenParser Char st (Statement StatementI)
p = forall st. Symbol -> [(Symbol, Maybe Expr)] -> [st] -> Statement st
NewModule forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Symbol
Symbol forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (forall st. GenParser Char st ()
matchModule forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st String
matchIdentifier) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st [(Symbol, Maybe Expr)]
moduleArgsUnitDecl forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall st. GenParser Char st [StatementI]
suite

-- | parse the arguments passed to a module.
moduleArgsUnit :: GenParser Char st [(Maybe Symbol, Expr)]
moduleArgsUnit :: forall st. GenParser Char st [(Maybe Symbol, Expr)]
moduleArgsUnit =
    forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'('
      (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (
        do
            -- eg. a = 12
            String
symb <- forall st. GenParser Char st String
matchIdentifier
            Expr
expr <- forall st. Char -> GenParser Char st Char
matchTok Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st Expr
expr0
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Text -> Symbol
Symbol forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
symb), Expr
expr)
        forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|> do
            -- eg. a(x,y) = 12
            String
symb <- forall st. GenParser Char st String
matchIdentifier
            [String]
argVars <- forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'(' (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy forall st. GenParser Char st String
matchIdentifier forall st. GenParser Char st Text
matchComma) Char
')'
            Expr
expr <- forall st. Char -> GenParser Char st Char
matchTok Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st Expr
expr0
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Text -> Symbol
Symbol forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
symb), [Pattern] -> Expr -> Expr
LamE (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Pattern
Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) [String]
argVars) Expr
expr)
        forall tok u a.
GenParser tok u a -> GenParser tok u a -> GenParser tok u a
*<|> do
            -- eg. 12
            Expr
expr <- forall st. GenParser Char st Expr
expr0
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Maybe a
Nothing, Expr
expr)
      ) forall st. GenParser Char st Text
matchComma)
      Char
')'

-- | parse the arguments in the module declaration.
moduleArgsUnitDecl ::  GenParser Char st [(Symbol, Maybe Expr)]
moduleArgsUnitDecl :: forall st. GenParser Char st [(Symbol, Maybe Expr)]
moduleArgsUnitDecl =
    forall st a.
Char -> GenParser Char st a -> Char -> GenParser Char st a
surroundedBy Char
'('
      (forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
sepBy (
        do
          String
symb <- forall st. GenParser Char st String
matchIdentifier
          Maybe Expr
expr <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe (forall st. Char -> GenParser Char st Char
matchTok Char
'=' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall st. GenParser Char st Expr
expr0)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Symbol
Symbol forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
symb, Maybe Expr
expr)
      ) forall st. GenParser Char st Text
matchComma)
      Char
')'

-- | Find the source position. Used when generating errors.
sourcePos :: GenParser Char st SourcePosition
sourcePos :: forall st. GenParser Char st SourcePosition
sourcePos = SourcePos -> SourcePosition
sourcePosition forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition

isNoOp :: StatementI -> Bool
isNoOp :: StatementI -> Bool
isNoOp (StatementI SourcePosition
_ Statement StatementI
DoNothing) = Bool
True
isNoOp StatementI
_                        = Bool
False

-- | Remove statements that do nothing.
removeNoOps :: [StatementI] -> [StatementI]
removeNoOps :: [StatementI] -> [StatementI]
removeNoOps = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatementI -> Bool
isNoOp