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

-- Allow us to use string literals for Text
{-# LANGUAGE OverloadedStrings #-}

module Graphics.Implicit.ExtOpenScad.Eval.Expr (evalExpr, rawRunExpr, matchPat, StateE, ExprState(ExprState), addMessage) where

import Prelude (String, Maybe(Just, Nothing), Bool (True), ($), elem, pure, zip, (&&), const, (<>), foldr, foldMap, (.), (<$>), traverse)

import Graphics.Implicit.ExtOpenScad.Definitions (
                                                  Pattern(Name, ListP, Wild),
                                                  OVal(OList, OError, OFunc, OUndefined),
                                                  Expr(LitE, ListE, LamE, Var, (:$)),
                                                  Symbol(Symbol),
                                                  VarLookup(VarLookup),
                                                  SourcePosition,
                                                  Message(Message),
                                                  MessageType(Error),
                                                  StateC, ImplicitCadM, runImplicitCadM
                                                 )

import Graphics.Implicit.ExtOpenScad.Util.OVal (oTypeStr, getErrors)

import Graphics.Implicit.ExtOpenScad.Util.StateC (getVarLookup)

import qualified Graphics.Implicit.ExtOpenScad.Util.StateC as GIEUS (addMessage)

import Data.Maybe (fromMaybe, isNothing)

import Data.Map (fromList, lookup)

import Data.Foldable (fold, traverse_)

import Data.Traversable (for)

import Control.Monad (zipWithM)

import Data.Text.Lazy (Text, unpack)

import Data.Eq (Eq, (==))
import Text.Show (Show)
import Control.Monad.Writer.Class (tell)
import Control.Monad.State.Lazy (get)
import Control.Monad.State.Class (modify)
import Control.Monad.Identity (Identity (runIdentity))
import Control.Monad.Reader (ask)

-- Patterns is the only thing being modified, so
-- it is the only on in the state structure.
newtype ExprState = ExprState
  { ExprState -> [String]
patterns  :: [String]
  } deriving (ExprState -> ExprState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExprState -> ExprState -> Bool
$c/= :: ExprState -> ExprState -> Bool
== :: ExprState -> ExprState -> Bool
$c== :: ExprState -> ExprState -> Bool
Eq, Int -> ExprState -> ShowS
[ExprState] -> ShowS
ExprState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExprState] -> ShowS
$cshowList :: [ExprState] -> ShowS
show :: ExprState -> String
$cshow :: ExprState -> String
showsPrec :: Int -> ExprState -> ShowS
$cshowsPrec :: Int -> ExprState -> ShowS
Show)

-- varLookup and sourcePos are only ever read from
-- so we can put them into a reader, so they can never
-- accidentally be written to.
data Input = Input
  { Input -> VarLookup
varLookup :: VarLookup
  , Input -> SourcePosition
sourcePos :: SourcePosition
  } deriving (Input -> Input -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Input -> Input -> Bool
$c/= :: Input -> Input -> Bool
== :: Input -> Input -> Bool
$c== :: Input -> Input -> Bool
Eq, Int -> Input -> ShowS
[Input] -> ShowS
Input -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Input] -> ShowS
$cshowList :: [Input] -> ShowS
show :: Input -> String
$cshow :: Input -> String
showsPrec :: Int -> Input -> ShowS
$cshowsPrec :: Int -> Input -> ShowS
Show)

-- Check Graphics.Implicit.ExtOpenScad.Definitions for an explanation
-- of why we are using a transformer stack.
type StateE a = ImplicitCadM Input [Message] ExprState Identity a

runStateE :: Input -> ExprState -> StateE a -> (a, [Message], ExprState)
runStateE :: forall a.
Input -> ExprState -> StateE a -> (a, [Message], ExprState)
runStateE Input
r ExprState
s StateE a
m = forall a. Identity a -> a
runIdentity forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r s w a.
Monad m =>
r -> s -> ImplicitCadM r w s m a -> m (a, w, s)
runImplicitCadM Input
r ExprState
s StateE a
m

-- Add a message to our list of messages contained in the StatE monad.
addMessage :: MessageType -> SourcePosition -> Text -> StateE ()
addMessage :: MessageType -> SourcePosition -> Text -> StateE ()
addMessage MessageType
mtype SourcePosition
pos Text
text = Message -> StateE ()
addMesg forall a b. (a -> b) -> a -> b
$ MessageType -> SourcePosition -> Text -> Message
Message MessageType
mtype SourcePosition
pos Text
text
  where
    addMesg :: Message -> StateE ()
    addMesg :: Message -> StateE ()
addMesg = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- Log an error condition.
errorE :: SourcePosition -> Text -> StateE ()
errorE :: SourcePosition -> Text -> StateE ()
errorE = MessageType -> SourcePosition -> Text -> StateE ()
addMessage MessageType
Error

-- | The names of all of the patterns in the given pattern.
patVars :: Pattern -> [Text]
patVars :: Pattern -> [Text]
patVars (Name (Symbol Text
name)) = [Text
name]
patVars (ListP [Pattern]
pats) = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Pattern -> [Text]
patVars [Pattern]
pats
patVars Pattern
Wild = []

-- | Match patterns and ovals, returning a list of all of the OVals matched.
patMatch :: Pattern -> OVal -> Maybe [OVal]
patMatch :: Pattern -> OVal -> Maybe [OVal]
patMatch (Name Symbol
_) OVal
val = forall a. a -> Maybe a
Just [OVal
val]
patMatch (ListP [Pattern]
pats) (OList [OVal]
vals) = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Pattern -> OVal -> Maybe [OVal]
patMatch [Pattern]
pats [OVal]
vals
patMatch Pattern
Wild OVal
_ = forall a. a -> Maybe a
Just []
patMatch Pattern
_ OVal
_ = forall a. Maybe a
Nothing

-- | Construct a VarLookup from the given Pattern and OVal, if possible.
matchPat :: Pattern -> OVal -> Maybe VarLookup
matchPat :: Pattern -> OVal -> Maybe VarLookup
matchPat Pattern
pat OVal
val = Map Symbol OVal -> VarLookup
VarLookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (Text -> Symbol
Symbol forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Text]
patVars Pattern
pat) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> OVal -> Maybe [OVal]
patMatch Pattern
pat OVal
val

-- | The entry point from StateC. evaluates an expression, pureing the result, and moving any error messages generated into the calling StateC.
evalExpr :: SourcePosition -> Expr -> StateC OVal
evalExpr :: SourcePosition -> Expr -> StateC OVal
evalExpr SourcePosition
pos Expr
expr = do
    VarLookup
vars <- StateC VarLookup
getVarLookup
    let
      input :: Input
input = VarLookup -> SourcePosition -> Input
Input VarLookup
vars SourcePosition
pos
      initState :: ExprState
initState = [String] -> ExprState
ExprState []
      ([OVal] -> OVal
valf, [Message]
messages, ExprState
_) = forall a.
Input -> ExprState -> StateE a -> (a, [Message], ExprState)
runStateE Input
input ExprState
initState (Expr -> StateE ([OVal] -> OVal)
evalExpr' Expr
expr)
      moveMessage :: Message -> StateC ()
moveMessage (Message MessageType
mtype SourcePosition
mpos Text
text) = MessageType -> SourcePosition -> Text -> StateC ()
GIEUS.addMessage MessageType
mtype SourcePosition
mpos Text
text
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Message -> StateC ()
moveMessage [Message]
messages
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [OVal] -> OVal
valf []

-- A more raw entry point, that does not depend on IO.
rawRunExpr :: SourcePosition -> VarLookup -> Expr -> (OVal, [Message])
rawRunExpr :: SourcePosition -> VarLookup -> Expr -> (OVal, [Message])
rawRunExpr SourcePosition
pos VarLookup
vars Expr
expr = do
  let
    input :: Input
input = VarLookup -> SourcePosition -> Input
Input VarLookup
vars SourcePosition
pos
    initState :: ExprState
initState = [String] -> ExprState
ExprState []
    ([OVal] -> OVal
valf, [Message]
messages, ExprState
_) = forall a.
Input -> ExprState -> StateE a -> (a, [Message], ExprState)
runStateE Input
input ExprState
initState (Expr -> StateE ([OVal] -> OVal)
evalExpr' Expr
expr)
  ([OVal] -> OVal
valf [], [Message]
messages)

-- The expression evaluators.
evalExpr' :: Expr -> StateE ([OVal] -> OVal)

-- Evaluate a variable lookup.
evalExpr' :: Expr -> StateE ([OVal] -> OVal)
evalExpr' (Var (Symbol Text
name)) = do
  Input (VarLookup Map Symbol OVal
varlookup) SourcePosition
spos <- forall r (m :: * -> *). MonadReader r m => m r
ask
  (ExprState [String]
namestack) <- forall s (m :: * -> *). MonadState s m => m s
get
  let v :: Maybe OVal
v = forall k a. Ord k => k -> Map k a -> Maybe a
lookup (Text -> Symbol
Symbol Text
name) Map Symbol OVal
varlookup
      n :: Bool
n = Text -> String
unpack Text
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
namestack
  case (Maybe OVal
v, Bool
n) of
    (Maybe OVal
_, Bool
True) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[OVal]
l ->
      let m :: Maybe OVal
m = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
            -- Scan for variable names from the end of the list (newest), and also
            -- ensure that we aren't overriding values if we have already found one.
            -- All in all, this should ensure that we aren't seeing the off by 1 error
            -- when looking up the values for function parameters as raised in this issue.
            -- https://github.com/Haskell-Things/ImplicitCAD/issues/431
            (\(String
n', OVal
v') Maybe OVal
z -> if forall a. Maybe a -> Bool
isNothing Maybe OVal
z Bool -> Bool -> Bool
&& Text -> String
unpack Text
name forall a. Eq a => a -> a -> Bool
== String
n' then forall (f :: * -> *) a. Applicative f => a -> f a
pure OVal
v' else Maybe OVal
z)
            forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$
            -- Zip the names and incoming values so that when looking up values
            -- we are ensuring that names are paired with values. When a LamE is evaled
            -- it is possible that a name is pushed and then used before a value is pushed
            -- and this zip neatly handles that situation.
            forall a b. [a] -> [b] -> [(a, b)]
zip [String]
namestack [OVal]
l
      in forall a. a -> Maybe a -> a
fromMaybe OVal
OUndefined Maybe OVal
m
    (Just OVal
o, Bool
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const OVal
o
    (Maybe OVal, Bool)
_ -> do
      SourcePosition -> Text -> StateE ()
errorE SourcePosition
spos (Text
"Variable " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<> Text
"not in scope")
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const OVal
OUndefined

-- Evaluate a literal value.
evalExpr' (LitE  OVal
val) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const OVal
val

-- Evaluate a list of expressions.
evalExpr' (ListE [Expr]
exprs) = do
    [[OVal] -> OVal]
valFuncs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> StateE ([OVal] -> OVal)
evalExpr' [Expr]
exprs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[OVal]
s -> [OVal] -> OVal
OList forall a b. (a -> b) -> a -> b
$ (forall a b. (a -> b) -> a -> b
$ [OVal]
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[OVal] -> OVal]
valFuncs

-- Evaluate application of a function.
evalExpr' (Expr
fexpr :$ [Expr]
argExprs) = do
    [OVal] -> OVal
fValFunc <- Expr -> StateE ([OVal] -> OVal)
evalExpr' Expr
fexpr
    [[OVal] -> OVal]
argValFuncs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> StateE ([OVal] -> OVal)
evalExpr' [Expr]
argExprs
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[OVal]
s -> OVal -> [OVal] -> OVal
app ([OVal] -> OVal
fValFunc [OVal]
s) ((forall a b. (a -> b) -> a -> b
$ [OVal]
s) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[OVal] -> OVal]
argValFuncs)
        where
            app :: OVal -> [OVal] -> OVal
app OVal
f [OVal]
l = case (OVal -> Maybe Text
getErrors OVal
f, OVal -> Maybe Text
getErrors forall a b. (a -> b) -> a -> b
$ [OVal] -> OVal
OList [OVal]
l) of
                (Maybe Text
Nothing, Maybe Text
Nothing) -> OVal -> [OVal] -> OVal
app' OVal
f [OVal]
l
                    where
                        -- apply function to the list of its arguments until we run out
                        -- of them
                        app' :: OVal -> [OVal] -> OVal
app' (OFunc OVal -> OVal
f') (OVal
x:[OVal]
xs) = OVal -> [OVal] -> OVal
app (OVal -> OVal
f' OVal
x) [OVal]
xs
                        app' OVal
a [] = OVal
a
                        app' OVal
x [OVal]
_ = Text -> OVal
OError forall a b. (a -> b) -> a -> b
$ Text
"Can't apply arguments to " forall a. Semigroup a => a -> a -> a
<> OVal -> Text
oTypeStr OVal
x
                (Just Text
err, Maybe Text
_     ) -> Text -> OVal
OError Text
err
                (Maybe Text
_,      Just Text
err) -> Text -> OVal
OError Text
err

-- Evaluate a lambda function.
evalExpr' (LamE [Pattern]
pats Expr
fexpr) = do
    [([OVal] -> OVal) -> [OVal] -> OVal]
fparts <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Pattern]
pats forall a b. (a -> b) -> a -> b
$ \Pattern
pat -> do
        -- Add new names to the end of the list so that names and values aren't
        -- effectively shifted by 1 when a name is defined but the value hasn't been
        -- calculated yet. This also allows us to neatly zip names and values ensuring
        -- we are only looking at names with defined values.
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \ExprState
s -> ExprState
s { patterns :: [String]
patterns = ExprState -> [String]
patterns ExprState
s forall a. Semigroup a => a -> a -> a
<> (Text -> String
unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Text]
patVars Pattern
pat)}
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \[OVal] -> OVal
f [OVal]
xss -> (OVal -> OVal) -> OVal
OFunc forall a b. (a -> b) -> a -> b
$ \OVal
val -> case Pattern -> OVal -> Maybe [OVal]
patMatch Pattern
pat OVal
val of
            -- Push values to the end once they are calculated.
            Just [OVal]
xs -> [OVal] -> OVal
f ([OVal]
xss forall a. Semigroup a => a -> a -> a
<> [OVal]
xs)
            Maybe [OVal]
Nothing -> Text -> OVal
OError Text
"Pattern match failed"
    [OVal] -> OVal
fval <- Expr -> StateE ([OVal] -> OVal)
evalExpr' Expr
fexpr
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) [OVal] -> OVal
fval [([OVal] -> OVal) -> [OVal] -> OVal]
fparts