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

-- An executor, which parses openscad code, and executes it.
module Graphics.Implicit.ExtOpenScad (runOpenscad) where

import Prelude(String, IO, ($), (<$>), pure, either, (.), Applicative, Bool(True))

import Graphics.Implicit.Definitions (SymbolicObj2, SymbolicObj3)

import Graphics.Implicit.ExtOpenScad.Definitions (VarLookup, ScadOpts, Message(Message), MessageType(SyntaxError), CompState(CompState, scadVars, oVals, messages), StatementI)

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.Eval.Constant (addConstants)

import Graphics.Implicit.ExtOpenScad.Util.OVal (divideObjs)

import Text.Parsec.Error (errorPos, errorMessages, showErrorMessages, ParseError)

import Control.Monad.State.Lazy (runStateT)

import System.Directory (getCurrentDirectory)

import Data.Foldable (traverse_)

import Data.Text.Lazy (pack)

-- | Small wrapper of our parser to handle parse errors, etc.
runOpenscad :: ScadOpts -> [String] -> String -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
runOpenscad :: ScadOpts
-> [String]
-> String
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
runOpenscad ScadOpts
scadOpts [String]
constants String
source = do
  (VarLookup
initialObjects, [Message]
initialMessages) <- [String] -> Bool -> IO (VarLookup, [Message])
addConstants [String]
constants Bool
True
  let
    err :: Applicative f => ParseError -> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
    err :: ParseError
-> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
err ParseError
e = (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
-> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VarLookup
initialObjects, [], [], ParseError -> Message
mesg ParseError
e Message -> [Message] -> [Message]
forall a. a -> [a] -> [a]
: [Message]
initialMessages)
    run :: [StatementI] -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
    run :: [StatementI]
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
run [StatementI]
sts = ((), CompState)
-> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
rearrange (((), CompState)
 -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]))
-> IO ((), CompState)
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      let sts' :: StateT CompState IO ()
sts' = (StatementI -> StateT CompState IO ())
-> [StatementI] -> StateT CompState IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ StatementI -> StateT CompState IO ()
runStatementI [StatementI]
sts
      String
path <- IO String
getCurrentDirectory
      StateT CompState IO () -> CompState -> IO ((), CompState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT CompState IO ()
sts' (CompState -> IO ((), CompState))
-> CompState -> IO ((), CompState)
forall a b. (a -> b) -> a -> b
$ VarLookup -> [OVal] -> String -> [Message] -> ScadOpts -> CompState
CompState VarLookup
initialObjects [] String
path [Message]
initialMessages ScadOpts
scadOpts
  (ParseError
 -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]))
-> ([StatementI]
    -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]))
-> Either ParseError [StatementI]
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
forall (f :: * -> *).
Applicative f =>
ParseError
-> f (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
err [StatementI]
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
run (Either ParseError [StatementI]
 -> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message]))
-> Either ParseError [StatementI]
-> IO (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
forall a b. (a -> b) -> a -> b
$ String -> String -> Either ParseError [StatementI]
parseProgram String
"" String
source
  where
    rearrange :: ((), CompState) -> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
    rearrange :: ((), CompState)
-> (VarLookup, [SymbolicObj2], [SymbolicObj3], [Message])
rearrange (()
_, CompState
s) =
      let ([SymbolicObj2]
obj2s, [SymbolicObj3]
obj3s, [OVal]
_) = [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal])
divideObjs ([OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal]))
-> [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal])
forall a b. (a -> b) -> a -> b
$ CompState -> [OVal]
oVals CompState
s
      in (CompState -> VarLookup
scadVars CompState
s, [SymbolicObj2]
obj2s, [SymbolicObj3]
obj3s, CompState -> [Message]
messages CompState
s)
    show' :: ParseError -> String
show' = String
-> String -> String -> String -> String -> [Message] -> String
showErrorMessages String
"or" String
"unknown parse error" String
"expecting" String
"unexpected" String
"end of input" ([Message] -> String)
-> (ParseError -> [Message]) -> ParseError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> [Message]
errorMessages
    mesg :: ParseError -> Message
mesg ParseError
e = MessageType -> SourcePosition -> Text -> Message
Message MessageType
SyntaxError (SourcePos -> SourcePosition
sourcePosition (SourcePos -> SourcePosition) -> SourcePos -> SourcePosition
forall a b. (a -> b) -> a -> b
$ ParseError -> SourcePos
errorPos ParseError
e) (Text -> Message) -> Text -> Message
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ParseError -> String
show' ParseError
e