{- 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 specify what package to import what module from.
-- We don't actually care, but when we compile our haskell examples, we do.
{-# LANGUAGE PackageImports #-}

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

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

import Prelude (String, Maybe(Just, Nothing), ($), fmap, 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
                                                 )

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.List (elemIndex)

import Data.Map (fromList, lookup)

import Data.Foldable (fold, traverse_)

import Data.Functor.Identity (Identity)

import Data.Traversable (for)

import Control.Monad (zipWithM)

import Data.Text.Lazy (Text, unpack)

import Control.Monad.State (StateT, get, modify, runState)

data ExprState = ExprState
  { ExprState -> VarLookup
_scadVars  :: VarLookup
  , ExprState -> [String]
patterns  :: [String]
  , ExprState -> [Message]
messages  :: [Message]
  , ExprState -> SourcePosition
_sourcePos :: SourcePosition
  }

type StateE = StateT ExprState Identity

-- 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 (Message -> StateE ()) -> Message -> StateE ()
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 Message
m = (ExprState -> ExprState) -> StateE ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ExprState -> ExprState) -> StateE ())
-> (ExprState -> ExprState) -> StateE ()
forall a b. (a -> b) -> a -> b
$ \ExprState
s -> ExprState
s { messages :: [Message]
messages = ExprState -> [Message]
messages ExprState
s [Message] -> [Message] -> [Message]
forall a. Semigroup a => a -> a -> a
<> Message -> [Message]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Message
m }

-- 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) = (Pattern -> [Text]) -> [Pattern] -> [Text]
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 = [OVal] -> Maybe [OVal]
forall a. a -> Maybe a
Just [OVal
val]
patMatch (ListP [Pattern]
pats) (OList [OVal]
vals) = [[OVal]] -> [OVal]
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([[OVal]] -> [OVal]) -> Maybe [[OVal]] -> Maybe [OVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pattern -> OVal -> Maybe [OVal])
-> [Pattern] -> [OVal] -> Maybe [[OVal]]
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
_ = [OVal] -> Maybe [OVal]
forall a. a -> Maybe a
Just []
patMatch Pattern
_ OVal
_ = Maybe [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 (Map Symbol OVal -> VarLookup)
-> ([OVal] -> Map Symbol OVal) -> [OVal] -> VarLookup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Symbol, OVal)] -> Map Symbol OVal
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Symbol, OVal)] -> Map Symbol OVal)
-> ([OVal] -> [(Symbol, OVal)]) -> [OVal] -> Map Symbol OVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Symbol] -> [OVal] -> [(Symbol, OVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Text -> Symbol
Symbol (Text -> Symbol) -> [Text] -> [Symbol]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Text]
patVars Pattern
pat) ([OVal] -> VarLookup) -> Maybe [OVal] -> Maybe VarLookup
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
      ([OVal] -> OVal
valf, ExprState
s) = State ExprState ([OVal] -> OVal)
-> ExprState -> ([OVal] -> OVal, ExprState)
forall s a. State s a -> s -> (a, s)
runState (Expr -> State ExprState ([OVal] -> OVal)
evalExpr' Expr
expr) (ExprState -> ([OVal] -> OVal, ExprState))
-> ExprState -> ([OVal] -> OVal, ExprState)
forall a b. (a -> b) -> a -> b
$ VarLookup -> [String] -> [Message] -> SourcePosition -> ExprState
ExprState VarLookup
vars [] [] SourcePosition
pos
      moveMessage :: Message -> StateC ()
moveMessage (Message MessageType
mtype SourcePosition
mpos Text
text) = MessageType -> SourcePosition -> Text -> StateC ()
GIEUS.addMessage MessageType
mtype SourcePosition
mpos Text
text
    (Message -> StateC ()) -> [Message] -> StateC ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Message -> StateC ()
moveMessage ([Message] -> StateC ()) -> [Message] -> StateC ()
forall a b. (a -> b) -> a -> b
$ ExprState -> [Message]
messages ExprState
s
    OVal -> StateC OVal
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OVal -> StateC OVal) -> OVal -> StateC OVal
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
    ([OVal] -> OVal
valf, ExprState
s) = State ExprState ([OVal] -> OVal)
-> ExprState -> ([OVal] -> OVal, ExprState)
forall s a. State s a -> s -> (a, s)
runState (Expr -> State ExprState ([OVal] -> OVal)
evalExpr' Expr
expr) (ExprState -> ([OVal] -> OVal, ExprState))
-> ExprState -> ([OVal] -> OVal, ExprState)
forall a b. (a -> b) -> a -> b
$ VarLookup -> [String] -> [Message] -> SourcePosition -> ExprState
ExprState VarLookup
vars [] [] SourcePosition
pos
  ([OVal] -> OVal
valf [], ExprState -> [Message]
messages ExprState
s)

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

-- Evaluate a variable lookup.
evalExpr' :: Expr -> State ExprState ([OVal] -> OVal)
evalExpr' (Var (Symbol Text
name)) = do
  (ExprState (VarLookup Map Symbol OVal
varlookup) [String]
namestack [Message]
_ SourcePosition
spos) <- StateT ExprState Identity ExprState
forall s (m :: * -> *). MonadState s m => m s
get
  case (Symbol -> Map Symbol OVal -> Maybe OVal
forall k a. Ord k => k -> Map k a -> Maybe a
lookup (Text -> Symbol
Symbol Text
name) Map Symbol OVal
varlookup, String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (Text -> String
unpack Text
name) [String]
namestack) of
        (Maybe OVal
_, Just Int
pos) -> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([OVal] -> Int -> OVal
forall a. [a] -> Int -> a
!! Int
pos)
        (Just OVal
val, Maybe Int
_) -> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([OVal] -> OVal) -> State ExprState ([OVal] -> OVal))
-> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ OVal -> [OVal] -> OVal
forall a b. a -> b -> a
const OVal
val
        (Maybe OVal, Maybe Int)
_             -> do
          SourcePosition -> Text -> StateE ()
errorE SourcePosition
spos (Text
"Variable " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not in scope")
          ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([OVal] -> OVal) -> State ExprState ([OVal] -> OVal))
-> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ OVal -> [OVal] -> OVal
forall a b. a -> b -> a
const OVal
OUndefined

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

-- Evaluate a list of expressions.
evalExpr' (ListE [Expr]
exprs) = do
    [[OVal] -> OVal]
valFuncs <- (Expr -> State ExprState ([OVal] -> OVal))
-> [Expr] -> StateT ExprState Identity [[OVal] -> OVal]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> State ExprState ([OVal] -> OVal)
evalExpr' [Expr]
exprs
    ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([OVal] -> OVal) -> State ExprState ([OVal] -> OVal))
-> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ \[OVal]
s -> [OVal] -> OVal
OList ([OVal] -> OVal) -> [OVal] -> OVal
forall a b. (a -> b) -> a -> b
$ (([OVal] -> OVal) -> [OVal] -> OVal
forall a b. (a -> b) -> a -> b
$[OVal]
s) (([OVal] -> OVal) -> OVal) -> [[OVal] -> OVal] -> [OVal]
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 -> State ExprState ([OVal] -> OVal)
evalExpr' Expr
fexpr
    [[OVal] -> OVal]
argValFuncs <- (Expr -> State ExprState ([OVal] -> OVal))
-> [Expr] -> StateT ExprState Identity [[OVal] -> OVal]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Expr -> State ExprState ([OVal] -> OVal)
evalExpr' [Expr]
argExprs
    ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([OVal] -> OVal) -> State ExprState ([OVal] -> OVal))
-> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ \[OVal]
s -> OVal -> [OVal] -> OVal
app ([OVal] -> OVal
fValFunc [OVal]
s) ((([OVal] -> OVal) -> OVal) -> [[OVal] -> OVal] -> [OVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([OVal] -> OVal) -> [OVal] -> OVal
forall a b. (a -> b) -> a -> b
$[OVal]
s) [[OVal] -> OVal]
argValFuncs)
        where
            app :: OVal -> [OVal] -> OVal
app OVal
f [OVal]
l = case (OVal -> Maybe Text
getErrors OVal
f, OVal -> Maybe Text
getErrors (OVal -> Maybe Text) -> OVal -> Maybe Text
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 (Text -> OVal) -> Text -> OVal
forall a b. (a -> b) -> a -> b
$ Text
"Can't apply arguments to " Text -> Text -> Text
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 <- [Pattern]
-> (Pattern
    -> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal))
-> StateT ExprState Identity [([OVal] -> OVal) -> [OVal] -> OVal]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Pattern]
pats ((Pattern
  -> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal))
 -> StateT ExprState Identity [([OVal] -> OVal) -> [OVal] -> OVal])
-> (Pattern
    -> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal))
-> StateT ExprState Identity [([OVal] -> OVal) -> [OVal] -> OVal]
forall a b. (a -> b) -> a -> b
$ \Pattern
pat -> do
        (ExprState -> ExprState) -> StateE ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((ExprState -> ExprState) -> StateE ())
-> (ExprState -> ExprState) -> StateE ()
forall a b. (a -> b) -> a -> b
$ \ExprState
s -> ExprState
s { patterns :: [String]
patterns = (Text -> String
unpack (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pattern -> [Text]
patVars Pattern
pat) [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> ExprState -> [String]
patterns ExprState
s}
        (([OVal] -> OVal) -> [OVal] -> OVal)
-> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((([OVal] -> OVal) -> [OVal] -> OVal)
 -> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal))
-> (([OVal] -> OVal) -> [OVal] -> OVal)
-> StateT ExprState Identity (([OVal] -> OVal) -> [OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ \[OVal] -> OVal
f [OVal]
xss -> (OVal -> OVal) -> OVal
OFunc ((OVal -> OVal) -> OVal) -> (OVal -> OVal) -> OVal
forall a b. (a -> b) -> a -> b
$ \OVal
val -> case Pattern -> OVal -> Maybe [OVal]
patMatch Pattern
pat OVal
val of
            Just [OVal]
xs -> [OVal] -> OVal
f ([OVal]
xs [OVal] -> [OVal] -> [OVal]
forall a. Semigroup a => a -> a -> a
<> [OVal]
xss)
            Maybe [OVal]
Nothing -> Text -> OVal
OError Text
"Pattern match failed"
    [OVal] -> OVal
fval <- Expr -> State ExprState ([OVal] -> OVal)
evalExpr' Expr
fexpr
    ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([OVal] -> OVal) -> State ExprState ([OVal] -> OVal))
-> ([OVal] -> OVal) -> State ExprState ([OVal] -> OVal)
forall a b. (a -> b) -> a -> b
$ ((([OVal] -> OVal) -> [OVal] -> OVal)
 -> ([OVal] -> OVal) -> [OVal] -> OVal)
-> ([OVal] -> OVal)
-> [([OVal] -> OVal) -> [OVal] -> OVal]
-> [OVal]
-> OVal
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([OVal] -> OVal) -> [OVal] -> OVal)
-> ([OVal] -> OVal) -> [OVal] -> OVal
forall a b. (a -> b) -> a -> b
($) [OVal] -> OVal
fval [([OVal] -> OVal) -> [OVal] -> OVal]
fparts