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

-- Allow us to use string literals for Text
{-# LANGUAGE OverloadedStrings #-}
-- Tell GHC to use underlying instances for newtypes
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-- Derive functor automatically
{-# LANGUAGE DeriveFunctor #-}
-- Allow constraints to be written like types
{-# LANGUAGE ConstraintKinds #-}
-- Allow us to set some context variables to actual types
-- Useful for working with transformers and MTL
{-# LANGUAGE FlexibleContexts #-}

module Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFail, APExample),
                                                  Symbol(Symbol),
                                                  Pattern(Wild, Name, ListP),
                                                  Expr(LitE, Var, ListE, LamE, (:$)),
                                                  StatementI(StatementI),
                                                  Statement(DoNothing, NewModule, Include, If, ModuleCall, (:=)),
                                                  OVal(OIO, ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3),
                                                  TestInvariant(EulerCharacteristic),
                                                  SourcePosition(SourcePosition),
                                                  StateC,
                                                  CompState(CompState, scadVars, oVals, sourceDir),
                                                  ImplicitCadM(ImplicitCadM, unImplicitCadM),
                                                  VarLookup(VarLookup),
                                                  Message(Message),
                                                  MessageType(TextOut, Warning, Error, SyntaxError, Compatibility, Unimplemented),
                                                  ScadOpts(ScadOpts, openScadCompatibility, importsAllowed),
                                                  lookupVarIn,
                                                  varUnion,
                                                  runImplicitCadM,
                                                  CanCompState,
                                                  CanCompState'
                                                  ) where

import Prelude(Eq, Show, Ord, Maybe(Just), Bool(True, False), IO, FilePath, (==), show, ($), (<>), and, zipWith, Int, (<$>))

-- Resolution of the world, Integer type, and symbolic languages for 2D and 3D objects.
import Graphics.Implicit.Definitions (ℝ, ℕ, Fastℕ, SymbolicObj2, SymbolicObj3, fromFastℕ)

import Control.Applicative (Applicative, Alternative((<|>), empty), pure, (<*>))

import Control.Monad (Functor, Monad, (>>=), mzero, mplus, MonadPlus, ap, (>=>))

import Data.Default.Class (Default(def))

import Data.Map (Map, lookup, union)

import Data.Maybe (fromMaybe)

import Data.Text.Lazy (Text, unpack, intercalate)

import Control.Monad.State (StateT (runStateT), MonadState)
import Control.Monad.Writer (WriterT (runWriterT), MonadWriter)
import Control.Monad.Reader (ReaderT (runReaderT), MonadReader)
import Control.Monad.IO.Class ( MonadIO )

-- | The state of computation.
data CompState = CompState
  { CompState -> VarLookup
scadVars  :: VarLookup -- ^ A hash of variables and functions.
  , CompState -> [OVal]
oVals     :: [OVal]    -- ^ The result of geometry generating functions.
  , CompState -> FilePath
sourceDir :: FilePath  -- ^ The path we are looking for includes in.
  } deriving (Int -> CompState -> ShowS
[CompState] -> ShowS
CompState -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [CompState] -> ShowS
$cshowList :: [CompState] -> ShowS
show :: CompState -> FilePath
$cshow :: CompState -> FilePath
showsPrec :: Int -> CompState -> ShowS
$cshowsPrec :: Int -> CompState -> ShowS
Show)

-- Similar to StateC, except we are pulling out the bits of state that do not need to be mutable
-- in the ways they are. scadOpts is only ever read, and messages are only ever written.
-- This helps enforce that scadOpts is never changed, and messages are only ever appended to.
--
-- Transformer stacks are often seen as being "inside out" when first encountered.
-- For example, `Reader r (Writer w IO) a` runs to a type of `IO (a, w)`
-- This happens because as you run each layer of the transformer you are exposing the
-- monad inside of it, usually either IO or Identity at the very bottom.
-- Running reader gives a Writer Monad, which when run will give an IO monad.
--
-- This has been parameterised over all of the transformer types so that we can
-- also use this to implement StateE using the same stack.
newtype ImplicitCadM r w s m a = ImplicitCadM {
  forall r w s (m :: * -> *) a.
ImplicitCadM r w s m a -> ReaderT r (WriterT w (StateT s m)) a
unImplicitCadM :: ReaderT r (WriterT w (StateT s m)) a
} deriving
  -- We can have mtl/transformers give us all the instances we care
  -- about for the newtype, dropping any that won't work when this is
  -- parameterised at the call site.
  ( MonadReader r
  , MonadWriter w
  , MonadState s
  , forall a. IO a -> ImplicitCadM r w s m a
forall {r} {w} {s} {m :: * -> *}.
(Monoid w, MonadIO m) =>
Monad (ImplicitCadM r w s m)
forall r w s (m :: * -> *) a.
(Monoid w, MonadIO m) =>
IO a -> ImplicitCadM r w s m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ImplicitCadM r w s m a
$cliftIO :: forall r w s (m :: * -> *) a.
(Monoid w, MonadIO m) =>
IO a -> ImplicitCadM r w s m a
MonadIO -- This only exists if `m` is also MonadIO.
  , forall a. a -> ImplicitCadM r w s m a
forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
forall a b.
ImplicitCadM r w s m a
-> (a -> ImplicitCadM r w s m b) -> ImplicitCadM r w s m b
forall {r} {w} {s} {m :: * -> *}.
(Monoid w, Monad m) =>
Applicative (ImplicitCadM r w s m)
forall r w s (m :: * -> *) a.
(Monoid w, Monad m) =>
a -> ImplicitCadM r w s m a
forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> (a -> ImplicitCadM r w s m b) -> ImplicitCadM r w s m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ImplicitCadM r w s m a
$creturn :: forall r w s (m :: * -> *) a.
(Monoid w, Monad m) =>
a -> ImplicitCadM r w s m a
>> :: forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
$c>> :: forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
>>= :: forall a b.
ImplicitCadM r w s m a
-> (a -> ImplicitCadM r w s m b) -> ImplicitCadM r w s m b
$c>>= :: forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> (a -> ImplicitCadM r w s m b) -> ImplicitCadM r w s m b
Monad
  , forall a. a -> ImplicitCadM r w s m a
forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
forall a b.
ImplicitCadM r w s m (a -> b)
-> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
forall a b c.
(a -> b -> c)
-> ImplicitCadM r w s m a
-> ImplicitCadM r w s m b
-> ImplicitCadM r w s m c
forall {r} {w} {s} {m :: * -> *}.
(Monoid w, Monad m) =>
Functor (ImplicitCadM r w s m)
forall r w s (m :: * -> *) a.
(Monoid w, Monad m) =>
a -> ImplicitCadM r w s m a
forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m (a -> b)
-> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
forall r w s (m :: * -> *) a b c.
(Monoid w, Monad m) =>
(a -> b -> c)
-> ImplicitCadM r w s m a
-> ImplicitCadM r w s m b
-> ImplicitCadM r w s m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
$c<* :: forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
*> :: forall a b.
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
$c*> :: forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m a
-> ImplicitCadM r w s m b -> ImplicitCadM r w s m b
liftA2 :: forall a b c.
(a -> b -> c)
-> ImplicitCadM r w s m a
-> ImplicitCadM r w s m b
-> ImplicitCadM r w s m c
$cliftA2 :: forall r w s (m :: * -> *) a b c.
(Monoid w, Monad m) =>
(a -> b -> c)
-> ImplicitCadM r w s m a
-> ImplicitCadM r w s m b
-> ImplicitCadM r w s m c
<*> :: forall a b.
ImplicitCadM r w s m (a -> b)
-> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
$c<*> :: forall r w s (m :: * -> *) a b.
(Monoid w, Monad m) =>
ImplicitCadM r w s m (a -> b)
-> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
pure :: forall a. a -> ImplicitCadM r w s m a
$cpure :: forall r w s (m :: * -> *) a.
(Monoid w, Monad m) =>
a -> ImplicitCadM r w s m a
Applicative
  , forall a b. a -> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
forall a b.
(a -> b) -> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
forall r w s (m :: * -> *) a b.
Functor m =>
a -> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
forall r w s (m :: * -> *) a b.
Functor m =>
(a -> b) -> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
$c<$ :: forall r w s (m :: * -> *) a b.
Functor m =>
a -> ImplicitCadM r w s m b -> ImplicitCadM r w s m a
fmap :: forall a b.
(a -> b) -> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
$cfmap :: forall r w s (m :: * -> *) a b.
Functor m =>
(a -> b) -> ImplicitCadM r w s m a -> ImplicitCadM r w s m b
Functor
  )

-- These are constraint types, and can be used in the same way as `foo :: Monad m => m a -> m ()`
-- They are useful for when writing code that doesn't care about the exact structure of CompStateM,
-- but rather what you can do with it. This constraint allows you to `ask`, `get/put`, and `tell`
-- without having to worry about wrapping, lifting, etc.
type CanCompState' r w s m = (MonadReader r m, MonadWriter w m, MonadState s m, MonadIO m)
type CanCompState m = CanCompState' ScadOpts [Message] CompState m

-- Keep the name, so ghc can help us along.
type StateC a = ImplicitCadM ScadOpts [Message] CompState IO a

-- This is the function you probably want when trying to actually run an ImplicitCadM
-- It handles running each of the transformers in order and putting the results into a
-- useful tuple form.
runImplicitCadM :: Monad m => r -> s -> ImplicitCadM r w s m a -> m (a, w, s)
runImplicitCadM :: forall (m :: * -> *) r s w a.
Monad m =>
r -> s -> ImplicitCadM r w s m a -> m (a, w, s)
runImplicitCadM r
r s
s ImplicitCadM r w s m a
m = do
  ((a
a, w
w), s
s') <- forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall r w s (m :: * -> *) a.
ImplicitCadM r w s m a -> ReaderT r (WriterT w (StateT s m)) a
unImplicitCadM ImplicitCadM r w s m a
m) r
r) s
s
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, w
w, s
s')

-- | Handles parsing arguments to built-in modules
data ArgParser a
                 = AP Symbol (Maybe OVal) Text (OVal -> ArgParser a)
                 -- ^ For actual argument entries: @AP (argument name) (default) (doc) (next Argparser...)@
                 | APTerminator a
                 -- ^ For returns: @APTerminator (return value)@
                 | APFail Text
                 -- ^ For failure: @APFail (error message)@
                 | APExample Text (ArgParser a)
                 -- ^ An example, then next
                 | APTest Text [TestInvariant] (ArgParser a)
                 -- ^ A string to run as a test, then invariants for the results, then next
                 | APBranch [ArgParser a]
                 -- ^ A branch where there are a number of possibilities for the parser underneath
  deriving forall a b. a -> ArgParser b -> ArgParser a
forall a b. (a -> b) -> ArgParser a -> ArgParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ArgParser b -> ArgParser a
$c<$ :: forall a b. a -> ArgParser b -> ArgParser a
fmap :: forall a b. (a -> b) -> ArgParser a -> ArgParser b
$cfmap :: forall a b. (a -> b) -> ArgParser a -> ArgParser b
Functor

instance Applicative ArgParser where
    pure :: forall a. a -> ArgParser a
pure = forall a. a -> ArgParser a
APTerminator
    <*> :: forall a b. ArgParser (a -> b) -> ArgParser a -> ArgParser b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad ArgParser where
    -- We need to describe how (>>=) works.
    -- Let's get the hard ones out of the way first.
    -- ArgParser actually
    (AP Symbol
str Maybe OVal
fallback Text
d OVal -> ArgParser a
f) >>= :: forall a b. ArgParser a -> (a -> ArgParser b) -> ArgParser b
>>= a -> ArgParser b
g = forall a.
Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
AP Symbol
str Maybe OVal
fallback Text
d (OVal -> ArgParser a
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> ArgParser b
g)
    (APFail Text
errmsg) >>= a -> ArgParser b
_ = forall a. Text -> ArgParser a
APFail Text
errmsg
    -- These next two are easy, they just pass the work along to their child
    (APExample Text
str ArgParser a
child) >>= a -> ArgParser b
g = forall a. Text -> ArgParser a -> ArgParser a
APExample Text
str (ArgParser a
child forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ArgParser b
g)
    (APTest Text
str [TestInvariant]
tests ArgParser a
child) >>= a -> ArgParser b
g = forall a. Text -> [TestInvariant] -> ArgParser a -> ArgParser a
APTest Text
str [TestInvariant]
tests (ArgParser a
child forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ArgParser b
g)
    -- And an ArgParserTerminator happily gives away the value it contains
    (APTerminator a
a) >>= a -> ArgParser b
g = a -> ArgParser b
g a
a
    (APBranch [ArgParser a]
bs) >>= a -> ArgParser b
g = forall a. [ArgParser a] -> ArgParser a
APBranch forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ArgParser b
g) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ArgParser a]
bs

instance MonadPlus ArgParser where
    mzero :: forall a. ArgParser a
mzero = forall a. Text -> ArgParser a
APFail Text
""
    mplus :: forall a. ArgParser a -> ArgParser a -> ArgParser a
mplus (APBranch [ArgParser a]
as) (APBranch [ArgParser a]
bs) = forall a. [ArgParser a] -> ArgParser a
APBranch ( [ArgParser a]
as  forall a. Semigroup a => a -> a -> a
<>  [ArgParser a]
bs )
    mplus (APBranch [ArgParser a]
as) ArgParser a
b             = forall a. [ArgParser a] -> ArgParser a
APBranch ( [ArgParser a]
as  forall a. Semigroup a => a -> a -> a
<> [ArgParser a
b] )
    mplus ArgParser a
a             (APBranch [ArgParser a]
bs) = forall a. [ArgParser a] -> ArgParser a
APBranch ( ArgParser a
a   forall a. a -> [a] -> [a]
:   [ArgParser a]
bs )
    mplus ArgParser a
a             ArgParser a
b             = forall a. [ArgParser a] -> ArgParser a
APBranch [ ArgParser a
a   ,   ArgParser a
b  ]

instance Alternative ArgParser where
        <|> :: forall a. ArgParser a -> ArgParser a -> ArgParser a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
        empty :: forall a. ArgParser a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero

newtype Symbol = Symbol Text
  deriving (Int -> Symbol -> ShowS
[Symbol] -> ShowS
Symbol -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Symbol] -> ShowS
$cshowList :: [Symbol] -> ShowS
show :: Symbol -> FilePath
$cshow :: Symbol -> FilePath
showsPrec :: Int -> Symbol -> ShowS
$cshowsPrec :: Int -> Symbol -> ShowS
Show, Symbol -> Symbol -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Symbol -> Symbol -> Bool
$c/= :: Symbol -> Symbol -> Bool
== :: Symbol -> Symbol -> Bool
$c== :: Symbol -> Symbol -> Bool
Eq, Eq Symbol
Symbol -> Symbol -> Bool
Symbol -> Symbol -> Ordering
Symbol -> Symbol -> Symbol
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Symbol -> Symbol -> Symbol
$cmin :: Symbol -> Symbol -> Symbol
max :: Symbol -> Symbol -> Symbol
$cmax :: Symbol -> Symbol -> Symbol
>= :: Symbol -> Symbol -> Bool
$c>= :: Symbol -> Symbol -> Bool
> :: Symbol -> Symbol -> Bool
$c> :: Symbol -> Symbol -> Bool
<= :: Symbol -> Symbol -> Bool
$c<= :: Symbol -> Symbol -> Bool
< :: Symbol -> Symbol -> Bool
$c< :: Symbol -> Symbol -> Bool
compare :: Symbol -> Symbol -> Ordering
$ccompare :: Symbol -> Symbol -> Ordering
Ord)

newtype VarLookup = VarLookup (Map Symbol OVal)
  deriving (Int -> VarLookup -> ShowS
[VarLookup] -> ShowS
VarLookup -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [VarLookup] -> ShowS
$cshowList :: [VarLookup] -> ShowS
show :: VarLookup -> FilePath
$cshow :: VarLookup -> FilePath
showsPrec :: Int -> VarLookup -> ShowS
$cshowsPrec :: Int -> VarLookup -> ShowS
Show, VarLookup -> VarLookup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VarLookup -> VarLookup -> Bool
$c/= :: VarLookup -> VarLookup -> Bool
== :: VarLookup -> VarLookup -> Bool
$c== :: VarLookup -> VarLookup -> Bool
Eq)

data Pattern = Name Symbol
             | ListP [Pattern]
             | Wild
    deriving (Int -> Pattern -> ShowS
[Pattern] -> ShowS
Pattern -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Pattern] -> ShowS
$cshowList :: [Pattern] -> ShowS
show :: Pattern -> FilePath
$cshow :: Pattern -> FilePath
showsPrec :: Int -> Pattern -> ShowS
$cshowsPrec :: Int -> Pattern -> ShowS
Show, Pattern -> Pattern -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pattern -> Pattern -> Bool
$c/= :: Pattern -> Pattern -> Bool
== :: Pattern -> Pattern -> Bool
$c== :: Pattern -> Pattern -> Bool
Eq)

-- | An expression.
data Expr = Var Symbol
          | LitE OVal -- A literal value.
          | ListE [Expr] -- A list of expressions.
          | LamE [Pattern] Expr -- A lambda expression.
          | Expr :$ [Expr] -- application of a function.
    deriving (Int -> Expr -> ShowS
[Expr] -> ShowS
Expr -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Expr] -> ShowS
$cshowList :: [Expr] -> ShowS
show :: Expr -> FilePath
$cshow :: Expr -> FilePath
showsPrec :: Int -> Expr -> ShowS
$cshowsPrec :: Int -> Expr -> ShowS
Show, Expr -> Expr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Expr -> Expr -> Bool
$c/= :: Expr -> Expr -> Bool
== :: Expr -> Expr -> Bool
$c== :: Expr -> Expr -> Bool
Eq)

-- | A statement, along with the line, column number, and file it is found at.
data StatementI = StatementI SourcePosition (Statement StatementI)
    deriving (Int -> StatementI -> ShowS
[StatementI] -> ShowS
StatementI -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [StatementI] -> ShowS
$cshowList :: [StatementI] -> ShowS
show :: StatementI -> FilePath
$cshow :: StatementI -> FilePath
showsPrec :: Int -> StatementI -> ShowS
$cshowsPrec :: Int -> StatementI -> ShowS
Show, StatementI -> StatementI -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StatementI -> StatementI -> Bool
$c/= :: StatementI -> StatementI -> Bool
== :: StatementI -> StatementI -> Bool
$c== :: StatementI -> StatementI -> Bool
Eq)

data Statement st = Include Text Bool
               | Pattern :=  Expr
               | If Expr [st] [st]
               | NewModule  Symbol [(Symbol, Maybe Expr)] [st]
               | ModuleCall Symbol [(Maybe Symbol, Expr)] [st]
               | DoNothing
    deriving (Int -> Statement st -> ShowS
forall st. Show st => Int -> Statement st -> ShowS
forall st. Show st => [Statement st] -> ShowS
forall st. Show st => Statement st -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Statement st] -> ShowS
$cshowList :: forall st. Show st => [Statement st] -> ShowS
show :: Statement st -> FilePath
$cshow :: forall st. Show st => Statement st -> FilePath
showsPrec :: Int -> Statement st -> ShowS
$cshowsPrec :: forall st. Show st => Int -> Statement st -> ShowS
Show, Statement st -> Statement st -> Bool
forall st. Eq st => Statement st -> Statement st -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Statement st -> Statement st -> Bool
$c/= :: forall st. Eq st => Statement st -> Statement st -> Bool
== :: Statement st -> Statement st -> Bool
$c== :: forall st. Eq st => Statement st -> Statement st -> Bool
Eq)

-- | Objects for our OpenSCAD-like language
data OVal = OUndefined
         | OError Text
         | OBool Bool
         | ONum ℝ
         | OList [OVal]
         | OString Text
         | OFunc (OVal -> OVal)
         | OIO (IO OVal)
         -- Name, arguments, argument parsers.
         | OUModule Symbol (Maybe [(Symbol, Bool)]) (VarLookup -> ArgParser (StateC [OVal]))
         -- Name, implementation, arguments, whether the module accepts/requires a suite.
         | ONModule Symbol (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) [([(Symbol, Bool)],  Maybe Bool)]
         | OVargsModule Symbol (Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ())
         | OObj3 SymbolicObj3
         | OObj2 SymbolicObj2

instance Eq OVal where
    (OBool Bool
a) == :: OVal -> OVal -> Bool
== (OBool Bool
b) = Bool
a forall a. Eq a => a -> a -> Bool
== Bool
b
    (ONum  ℝ
a) == (ONum  ℝ
b) = ℝ
a forall a. Eq a => a -> a -> Bool
== ℝ
b
    (OList [OVal]
a) == (OList [OVal]
b) = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Eq a => a -> a -> Bool
(==) [OVal]
a [OVal]
b
    (OString Text
a) == (OString Text
b) = Text
a forall a. Eq a => a -> a -> Bool
== Text
b
    OVal
OUndefined == OVal
OUndefined = Bool
True
    OVal
_ == OVal
_ = Bool
False

instance Show OVal where
    show :: OVal -> FilePath
show OVal
OUndefined = FilePath
"Undefined"
    show (OBool Bool
b) = forall a. Show a => a -> FilePath
show Bool
b
    show (ONum ℝ
n) = forall a. Show a => a -> FilePath
show ℝ
n
    show (OList [OVal]
l) = forall a. Show a => a -> FilePath
show [OVal]
l
    show (OString Text
s) = forall a. Show a => a -> FilePath
show Text
s
    show (OFunc OVal -> OVal
_) = FilePath
"<function>"
    show (OIO IO OVal
_) = FilePath
"<IO>"
    show (OUModule (Symbol Text
name) Maybe [(Symbol, Bool)]
arguments VarLookup -> ArgParser (StateC [OVal])
_) = FilePath
"module " forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
unpack Text
name forall a. Semigroup a => a -> a -> a
<> FilePath
" (" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
unpack (Text -> [Text] -> Text
intercalate Text
", " ((Symbol, Bool) -> Text
showArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a -> a
fromMaybe [] Maybe [(Symbol, Bool)]
arguments)) forall a. Semigroup a => a -> a -> a
<> FilePath
") {}"
      where
        showArg :: (Symbol, Bool) -> Text
        showArg :: (Symbol, Bool) -> Text
showArg (Symbol Text
a, Bool
hasDefault) = if Bool
hasDefault
                                         then Text
a
                                         else Text
a forall a. Semigroup a => a -> a -> a
<> Text
"=..."
    show (ONModule (Symbol Text
name) SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
_ [([(Symbol, Bool)], Maybe Bool)]
instances) = Text -> FilePath
unpack forall a b. (a -> b) -> a -> b
$ [([(Symbol, Bool)], Maybe Bool)] -> Text
showInstances [([(Symbol, Bool)], Maybe Bool)]
instances
      where
        showArg :: (Symbol, Bool) -> Text
showArg (Symbol Text
a, Bool
hasDefault) = if Bool
hasDefault
                                         then Text
a
                                         else Text
a forall a. Semigroup a => a -> a -> a
<> Text
"=..."
        showInstances :: [([(Symbol, Bool)], Maybe Bool)] -> Text
        showInstances :: [([(Symbol, Bool)], Maybe Bool)] -> Text
showInstances [] = Text
""
        showInstances [([(Symbol, Bool)], Maybe Bool)
oneInstance] = Text
"module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> ([(Symbol, Bool)], Maybe Bool) -> Text
showInstance ([(Symbol, Bool)], Maybe Bool)
oneInstance
        showInstances [([(Symbol, Bool)], Maybe Bool)]
multipleInstances = Text
"Module " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"[ " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (([(Symbol, Bool)], Maybe Bool) -> Text
showInstance forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [([(Symbol, Bool)], Maybe Bool)]
multipleInstances) forall a. Semigroup a => a -> a -> a
<> Text
" ]"
        showInstance :: ([(Symbol, Bool)], Maybe Bool) -> Text
        showInstance :: ([(Symbol, Bool)], Maybe Bool) -> Text
showInstance ([(Symbol, Bool)]
arguments, Maybe Bool
suiteInfo) = Text
" (" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " ((Symbol, Bool) -> Text
showArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Symbol, Bool)]
arguments) forall a. Semigroup a => a -> a -> a
<> Text
") {}" forall a. Semigroup a => a -> a -> a
<> Maybe Bool -> Text
showSuiteInfo Maybe Bool
suiteInfo
        showSuiteInfo :: Maybe Bool -> Text
        showSuiteInfo :: Maybe Bool -> Text
showSuiteInfo Maybe Bool
suiteInfo = case Maybe Bool
suiteInfo of
                          Just Bool
requiresSuite -> if Bool
requiresSuite
                                                then Text
" requiring suite {}"
                                                else Text
" accepting suite {}"
                          Maybe Bool
_ -> Text
""
    show (OVargsModule (Symbol Text
name) Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
_) = FilePath
"varargs module " forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
unpack Text
name
    show (OError Text
msg) = Text -> FilePath
unpack forall a b. (a -> b) -> a -> b
$ Text
"Execution Error:\n" forall a. Semigroup a => a -> a -> a
<> Text
msg
    show (OObj2 SymbolicObj2
obj) = FilePath
"<obj2: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show SymbolicObj2
obj forall a. Semigroup a => a -> a -> a
<> FilePath
">"
    show (OObj3 SymbolicObj3
obj) = FilePath
"<obj3: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show SymbolicObj3
obj forall a. Semigroup a => a -> a -> a
<> FilePath
">"

-- | In order to not propagate Parsec or other modules around, create our own source position type for the AST.
data SourcePosition = SourcePosition
    Fastℕ -- sourceLine
    Fastℕ -- sourceColumn
    FilePath -- sourceName
    deriving (SourcePosition -> SourcePosition -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SourcePosition -> SourcePosition -> Bool
$c/= :: SourcePosition -> SourcePosition -> Bool
== :: SourcePosition -> SourcePosition -> Bool
$c== :: SourcePosition -> SourcePosition -> Bool
Eq)

instance Show SourcePosition where
    show :: SourcePosition -> FilePath
show (SourcePosition Fastℕ
line Fastℕ
col []) = FilePath
"line " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall n. FastN n => Fastℕ -> n
fromFastℕ Fastℕ
line :: Int) forall a. Semigroup a => a -> a -> a
<> FilePath
", column " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall n. FastN n => Fastℕ -> n
fromFastℕ Fastℕ
col :: Int)
    show (SourcePosition Fastℕ
line Fastℕ
col FilePath
filePath) = FilePath
"line " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall n. FastN n => Fastℕ -> n
fromFastℕ Fastℕ
line :: Int) forall a. Semigroup a => a -> a -> a
<> FilePath
", column " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall n. FastN n => Fastℕ -> n
fromFastℕ Fastℕ
col :: Int) forall a. Semigroup a => a -> a -> a
<> FilePath
", file " forall a. Semigroup a => a -> a -> a
<> FilePath
filePath

-- | The types of messages the execution engine can send back to the application.
data MessageType = TextOut -- text intentionally output by the ExtOpenScad program.
                 | Warning
                 | Error
                 | SyntaxError
                 | Compatibility
                 | Unimplemented
  deriving (Int -> MessageType -> ShowS
[MessageType] -> ShowS
MessageType -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MessageType] -> ShowS
$cshowList :: [MessageType] -> ShowS
show :: MessageType -> FilePath
$cshow :: MessageType -> FilePath
showsPrec :: Int -> MessageType -> ShowS
$cshowsPrec :: Int -> MessageType -> ShowS
Show, MessageType -> MessageType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MessageType -> MessageType -> Bool
$c/= :: MessageType -> MessageType -> Bool
== :: MessageType -> MessageType -> Bool
$c== :: MessageType -> MessageType -> Bool
Eq)

-- | An individual message.
data Message = Message MessageType SourcePosition Text
  deriving (Message -> Message -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq)

instance Show Message where
  show :: Message -> FilePath
show (Message MessageType
mtype SourcePosition
pos Text
text) = forall a. Show a => a -> FilePath
show MessageType
mtype forall a. Semigroup a => a -> a -> a
<> FilePath
" at " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show SourcePosition
pos forall a. Semigroup a => a -> a -> a
<> FilePath
": " forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
unpack Text
text

-- | Options changing the behavior of the extended OpenScad engine.
data ScadOpts = ScadOpts
  { ScadOpts -> Bool
openScadCompatibility :: Bool
  , ScadOpts -> Bool
importsAllowed        :: Bool
  } deriving (Int -> ScadOpts -> ShowS
[ScadOpts] -> ShowS
ScadOpts -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ScadOpts] -> ShowS
$cshowList :: [ScadOpts] -> ShowS
show :: ScadOpts -> FilePath
$cshow :: ScadOpts -> FilePath
showsPrec :: Int -> ScadOpts -> ShowS
$cshowsPrec :: Int -> ScadOpts -> ShowS
Show, ScadOpts -> ScadOpts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScadOpts -> ScadOpts -> Bool
$c/= :: ScadOpts -> ScadOpts -> Bool
== :: ScadOpts -> ScadOpts -> Bool
$c== :: ScadOpts -> ScadOpts -> Bool
Eq)

instance Default ScadOpts where
  def :: ScadOpts
def = ScadOpts
    { openScadCompatibility :: Bool
openScadCompatibility = Bool
False
    , importsAllowed :: Bool
importsAllowed        = Bool
True
    }

-- helper, to use union on VarLookups.
varUnion :: VarLookup -> VarLookup -> VarLookup
varUnion :: VarLookup -> VarLookup -> VarLookup
varUnion (VarLookup Map Symbol OVal
a) (VarLookup Map Symbol OVal
b) = Map Symbol OVal -> VarLookup
VarLookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Map k a -> Map k a
union Map Symbol OVal
a Map Symbol OVal
b

-- | For programs using this API to perform variable lookups, after execution of an escad has completed.
lookupVarIn :: Text -> VarLookup -> Maybe OVal
lookupVarIn :: Text -> VarLookup -> Maybe OVal
lookupVarIn Text
target (VarLookup Map Symbol OVal
vars) = forall k a. Ord k => k -> Map k a -> Maybe a
lookup (Text -> Symbol
Symbol Text
target) Map Symbol OVal
vars

newtype TestInvariant = EulerCharacteristic ℕ
    deriving (Int -> TestInvariant -> ShowS
[TestInvariant] -> ShowS
TestInvariant -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TestInvariant] -> ShowS
$cshowList :: [TestInvariant] -> ShowS
show :: TestInvariant -> FilePath
$cshow :: TestInvariant -> FilePath
showsPrec :: Int -> TestInvariant -> ShowS
$cshowsPrec :: Int -> TestInvariant -> ShowS
Show)