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

-- FIXME: required. why?
{-# LANGUAGE ViewPatterns #-}

{-# LANGUAGE ScopedTypeVariables #-}

{-# LANGUAGE TypeSynonymInstances #-}

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

module Graphics.Implicit.ExtOpenScad.Util.OVal(OTypeMirror, (<||>), fromOObj, toOObj, divideObjs, caseOType, oTypeStr, getErrors) where

import Prelude(Maybe(Just, Nothing), Bool(True, False), Either(Left,Right), (==), fromInteger, floor, ($), (.), fmap, error, (<>), show, flip, filter, not, return)

import Graphics.Implicit.Definitions(V2, ℝ, ℝ2, ℕ, SymbolicObj2, SymbolicObj3, ExtrudeMScale(C1, C2, Fn), fromℕtoℝ)

import Graphics.Implicit.ExtOpenScad.Definitions (OVal(ONum, OBool, OString, OList, OFunc, OUndefined, OUModule, ONModule, OVargsModule, OError, OObj2, OObj3))

import Control.Monad (msum)

import Data.Maybe (fromMaybe, maybe)

import Data.Traversable (traverse)

import Data.Text.Lazy (Text)

-- for some minimal paralellism.
import Control.Parallel.Strategies (runEval, rpar, rseq)

-- To build vectors of ℝs.
import Linear (V2(V2), V3(V3), V4(V4))

-- Convert OVals (and Lists of OVals) into a given Haskell type
class OTypeMirror a where
    fromOObj :: OVal -> Maybe a
    fromOObjList :: OVal -> Maybe [a]
    fromOObjList (OList [OVal]
list) = (OVal -> Maybe a) -> [OVal] -> Maybe [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj [OVal]
list
    fromOObjList OVal
_ = Maybe [a]
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObjList #-}
    toOObj :: a -> OVal

instance OTypeMirror OVal where
    fromOObj :: OVal -> Maybe OVal
fromOObj = OVal -> Maybe OVal
forall a. a -> Maybe a
Just
    {-# INLINABLE fromOObj #-}
    toOObj :: OVal -> OVal
toOObj OVal
a = OVal
a

instance OTypeMirror ℝ where
    fromOObj :: OVal -> Maybe ℝ
fromOObj (ONum ℝ
n) = ℝ -> Maybe ℝ
forall a. a -> Maybe a
Just ℝ
n
    fromOObj OVal
_ = Maybe ℝ
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: ℝ -> OVal
toOObj = ℝ -> OVal
ONum

instance OTypeMirror ℕ where
    fromOObj :: OVal -> Maybe ℕ
fromOObj (ONum ℝ
n) = if ℝ
n ℝ -> ℝ -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> ℝ
forall a. Num a => Integer -> a
fromInteger (ℝ -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
n) then ℕ -> Maybe ℕ
forall a. a -> Maybe a
Just (ℝ -> ℕ
forall a b. (RealFrac a, Integral b) => a -> b
floor ℝ
n) else Maybe ℕ
forall a. Maybe a
Nothing
    fromOObj OVal
_ = Maybe ℕ
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: ℕ -> OVal
toOObj = ℝ -> OVal
ONum (ℝ -> OVal) -> (ℕ -> ℝ) -> ℕ -> OVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ℕ -> ℝ
fromℕtoℝ

instance OTypeMirror Bool where
    fromOObj :: OVal -> Maybe Bool
fromOObj (OBool Bool
b) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
    fromOObj OVal
_ = Maybe Bool
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: Bool -> OVal
toOObj = Bool -> OVal
OBool

instance (OTypeMirror a) => OTypeMirror [a] where
    fromOObj :: OVal -> Maybe [a]
fromOObj = OVal -> Maybe [a]
forall a. OTypeMirror a => OVal -> Maybe [a]
fromOObjList
    {-# INLINABLE fromOObj #-}
    toOObj :: [a] -> OVal
toOObj [a]
list = [OVal] -> OVal
OList ([OVal] -> OVal) -> [OVal] -> OVal
forall a b. (a -> b) -> a -> b
$ (a -> OVal) -> [a] -> [OVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj [a]
list

instance OTypeMirror Text where
    fromOObj :: OVal -> Maybe Text
fromOObj (OString Text
str) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
str
    fromOObj OVal
_ = Maybe Text
forall a. Maybe a
Nothing
    toOObj :: Text -> OVal
toOObj Text
a = Text -> OVal
OString Text
a

instance (OTypeMirror a) => OTypeMirror (Maybe a) where
    fromOObj :: OVal -> Maybe (Maybe a)
fromOObj OVal
a = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (Maybe a -> Maybe (Maybe a)) -> Maybe a -> Maybe (Maybe a)
forall a b. (a -> b) -> a -> b
$ OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj OVal
a
    {-# INLINABLE fromOObj #-}
    toOObj :: Maybe a -> OVal
toOObj (Just a
a) = a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a
    toOObj Maybe a
Nothing  = OVal
OUndefined

instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a,b) where
    fromOObj :: OVal -> Maybe (a, b)
fromOObj (OList [OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
a,OVal -> Maybe b
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just b
b]) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)
    fromOObj OVal
_ = Maybe (a, b)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: (a, b) -> OVal
toOObj (a
a,b
b) = [OVal] -> OVal
OList [a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a, b -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj b
b]

instance (OTypeMirror a) => OTypeMirror (V2 a) where
    fromOObj :: OVal -> Maybe (V2 a)
fromOObj (OList [OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
a,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
b]) = V2 a -> Maybe (V2 a)
forall a. a -> Maybe a
Just (a -> a -> V2 a
forall a. a -> a -> V2 a
V2 a
a a
b)
    fromOObj OVal
_ = Maybe (V2 a)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: V2 a -> OVal
toOObj (V2 a
a a
b) = [OVal] -> OVal
OList [a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
b]

instance (OTypeMirror a, OTypeMirror b, OTypeMirror c) => OTypeMirror (a,b,c) where
    fromOObj :: OVal -> Maybe (a, b, c)
fromOObj (OList [OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
a,OVal -> Maybe b
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just b
b,OVal -> Maybe c
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just c
c]) =
        (a, b, c) -> Maybe (a, b, c)
forall a. a -> Maybe a
Just (a
a,b
b,c
c)
    fromOObj OVal
_ = Maybe (a, b, c)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: (a, b, c) -> OVal
toOObj (a
a,b
b,c
c) = [OVal] -> OVal
OList [a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a, b -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj b
b, c -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj c
c]

instance (OTypeMirror a) => OTypeMirror (V3 a) where
    fromOObj :: OVal -> Maybe (V3 a)
fromOObj (OList [OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
a,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
b,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
c]) =
        V3 a -> Maybe (V3 a)
forall a. a -> Maybe a
Just (a -> a -> a -> V3 a
forall a. a -> a -> a -> V3 a
V3 a
a a
b a
c)
    fromOObj OVal
_ = Maybe (V3 a)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: V3 a -> OVal
toOObj (V3 a
a a
b a
c) = [OVal] -> OVal
OList [a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
b, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
c]

instance (OTypeMirror a) => OTypeMirror (V4 a) where
    fromOObj :: OVal -> Maybe (V4 a)
fromOObj (OList [OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
a,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
b,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
c,OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just a
d]) =
        V4 a -> Maybe (V4 a)
forall a. a -> Maybe a
Just (a -> a -> a -> a -> V4 a
forall a. a -> a -> a -> a -> V4 a
V4 a
a a
b a
c a
d)
    fromOObj OVal
_ = Maybe (V4 a)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: V4 a -> OVal
toOObj (V4 a
a a
b a
c a
d) = [OVal] -> OVal
OList [a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
a, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
b, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
c, a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
d]

instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (a -> b) where
    fromOObj :: OVal -> Maybe (a -> b)
fromOObj (OFunc OVal -> OVal
f) =  (a -> b) -> Maybe (a -> b)
forall a. a -> Maybe a
Just ((a -> b) -> Maybe (a -> b)) -> (a -> b) -> Maybe (a -> b)
forall a b. (a -> b) -> a -> b
$ \a
input ->
        let
            oInput :: OVal
oInput = a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
input
            oOutput :: OVal
oOutput = OVal -> OVal
f OVal
oInput
            output :: Maybe b
            output :: Maybe b
output = OVal -> Maybe b
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj OVal
oOutput
        in
          b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> b
forall a. HasCallStack => [Char] -> a
error ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ [Char]
"coercing OVal to a -> b isn't always safe; use a -> Maybe b"
                               [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" (trace: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> OVal -> [Char]
forall a. Show a => a -> [Char]
show OVal
oInput [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> OVal -> [Char]
forall a. Show a => a -> [Char]
show OVal
oOutput [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" )") Maybe b
output
    fromOObj OVal
_ = Maybe (a -> b)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}
    toOObj :: (a -> b) -> OVal
toOObj a -> b
f = (OVal -> OVal) -> OVal
OFunc ((OVal -> OVal) -> OVal) -> (OVal -> OVal) -> OVal
forall a b. (a -> b) -> a -> b
$ \OVal
oObj ->
        case OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj OVal
oObj :: Maybe a of
            Maybe a
Nothing  -> Text -> OVal
OError Text
"bad input type"
            Just a
obj -> b -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj (b -> OVal) -> b -> OVal
forall a b. (a -> b) -> a -> b
$ a -> b
f a
obj

instance (OTypeMirror a, OTypeMirror b) => OTypeMirror (Either a b) where
    fromOObj :: OVal -> Maybe (Either a b)
fromOObj (OVal -> Maybe a
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just (a
x :: a)) = Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left  a
x
    fromOObj (OVal -> Maybe b
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just (b
x :: b)) = Either a b -> Maybe (Either a b)
forall a. a -> Maybe a
Just (Either a b -> Maybe (Either a b))
-> Either a b -> Maybe (Either a b)
forall a b. (a -> b) -> a -> b
$ b -> Either a b
forall a b. b -> Either a b
Right b
x
    fromOObj OVal
_ = Maybe (Either a b)
forall a. Maybe a
Nothing
    {-# INLINABLE fromOObj #-}

    toOObj :: Either a b -> OVal
toOObj (Right b
x) = b -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj b
x
    toOObj (Left  a
x) = a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
x

instance OTypeMirror ExtrudeMScale where
    fromOObj :: OVal -> Maybe ExtrudeMScale
fromOObj (OVal -> Maybe ℝ
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just (ℝ
x :: ℝ)) = ExtrudeMScale -> Maybe ExtrudeMScale
forall a. a -> Maybe a
Just (ExtrudeMScale -> Maybe ExtrudeMScale)
-> ExtrudeMScale -> Maybe ExtrudeMScale
forall a b. (a -> b) -> a -> b
$ ℝ -> ExtrudeMScale
C1 ℝ
x
    fromOObj (OVal -> Maybe ℝ2
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just (ℝ2
x :: ℝ2)) = ExtrudeMScale -> Maybe ExtrudeMScale
forall a. a -> Maybe a
Just (ExtrudeMScale -> Maybe ExtrudeMScale)
-> ExtrudeMScale -> Maybe ExtrudeMScale
forall a b. (a -> b) -> a -> b
$ ℝ2 -> ExtrudeMScale
C2 ℝ2
x
    fromOObj (OVal -> Maybe (ℝ -> Either ℝ ℝ2)
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj -> Just (ℝ -> Either ℝ ℝ2
x :: (ℝ -> Either ℝ ℝ2))) = ExtrudeMScale -> Maybe ExtrudeMScale
forall a. a -> Maybe a
Just (ExtrudeMScale -> Maybe ExtrudeMScale)
-> ExtrudeMScale -> Maybe ExtrudeMScale
forall a b. (a -> b) -> a -> b
$ (ℝ -> Either ℝ ℝ2) -> ExtrudeMScale
Fn ℝ -> Either ℝ ℝ2
x
    fromOObj OVal
_ = Maybe ExtrudeMScale
forall a. Maybe a
Nothing

    toOObj :: ExtrudeMScale -> OVal
toOObj (C1 ℝ
x) = ℝ -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj ℝ
x
    toOObj (C2 ℝ2
x) = ℝ2 -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj ℝ2
x
    toOObj (Fn ℝ -> Either ℝ ℝ2
x) = (ℝ -> Either ℝ ℝ2) -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj ℝ -> Either ℝ ℝ2
x

-- A string representing each type.
oTypeStr :: OVal -> Text
oTypeStr :: OVal -> Text
oTypeStr OVal
OUndefined         = Text
"Undefined"
oTypeStr (OBool          Bool
_ ) = Text
"Bool"
oTypeStr (ONum           ℝ
_ ) = Text
"Number"
oTypeStr (OList          [OVal]
_ ) = Text
"List"
oTypeStr (OString        Text
_ ) = Text
"String"
oTypeStr (OFunc          OVal -> OVal
_ ) = Text
"Function"
oTypeStr (OUModule   Symbol
_ Maybe [(Symbol, Bool)]
_ VarLookup -> ArgParser (StateC [OVal])
_ ) = Text
"User Defined Module"
oTypeStr (ONModule   Symbol
_ SourcePosition -> [OVal] -> ArgParser (StateC [OVal])
_ [([(Symbol, Bool)], Maybe Bool)]
_ ) = Text
"Built-in Module"
oTypeStr (OVargsModule Symbol
_ Symbol
-> SourcePosition
-> [(Maybe Symbol, OVal)]
-> [StatementI]
-> ([StatementI] -> StateC ())
-> StateC ()
_ ) = Text
"VargsModule"
oTypeStr (OError         Text
_ ) = Text
"Error"
oTypeStr (OObj2          SymbolicObj2
_ ) = Text
"2D Object"
oTypeStr (OObj3          SymbolicObj3
_ ) = Text
"3D Object"

getErrors :: OVal -> Maybe Text
getErrors :: OVal -> Maybe Text
getErrors (OError Text
er) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
er
getErrors (OList [OVal]
l)   = [Maybe Text] -> Maybe Text
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Text] -> Maybe Text) -> [Maybe Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (OVal -> Maybe Text) -> [OVal] -> [Maybe Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OVal -> Maybe Text
getErrors [OVal]
l
getErrors OVal
_           = Maybe Text
forall a. Maybe a
Nothing

caseOType :: a -> (a -> c) -> c
caseOType :: a -> (a -> c) -> c
caseOType = ((a -> c) -> a -> c) -> a -> (a -> c) -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> c) -> a -> c
forall a b. (a -> b) -> a -> b
($)

infixr 2 <||>
(<||>) :: OTypeMirror desiredType
    => (desiredType -> out)
    -> (OVal -> out)
    -> (OVal -> out)
<||> :: (desiredType -> out) -> (OVal -> out) -> OVal -> out
(<||>) desiredType -> out
f OVal -> out
g OVal
input =
    let
        coerceAttempt :: OTypeMirror desiredType => Maybe desiredType
        coerceAttempt :: Maybe desiredType
coerceAttempt = OVal -> Maybe desiredType
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj OVal
input
    in
        out -> (desiredType -> out) -> Maybe desiredType -> out
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (OVal -> out
g OVal
input) desiredType -> out
f Maybe desiredType
forall desiredType. OTypeMirror desiredType => Maybe desiredType
coerceAttempt

-- separate 2d and 3d objects from a set of OVals.
divideObjs :: [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal])
divideObjs :: [OVal] -> ([SymbolicObj2], [SymbolicObj3], [OVal])
divideObjs [OVal]
children =
    Eval ([SymbolicObj2], [SymbolicObj3], [OVal])
-> ([SymbolicObj2], [SymbolicObj3], [OVal])
forall a. Eval a -> a
runEval (Eval ([SymbolicObj2], [SymbolicObj3], [OVal])
 -> ([SymbolicObj2], [SymbolicObj3], [OVal]))
-> Eval ([SymbolicObj2], [SymbolicObj3], [OVal])
-> ([SymbolicObj2], [SymbolicObj3], [OVal])
forall a b. (a -> b) -> a -> b
$ do
    [SymbolicObj2]
obj2s <- Strategy [SymbolicObj2]
forall a. Strategy a
rseq [ SymbolicObj2
x | OObj2 SymbolicObj2
x <- [OVal]
children ]
    [SymbolicObj3]
obj3s <- Strategy [SymbolicObj3]
forall a. Strategy a
rseq [ SymbolicObj3
x | OObj3 SymbolicObj3
x <- [OVal]
children ]
    [OVal]
objs <- Strategy [OVal]
forall a. Strategy a
rpar ((OVal -> Bool) -> [OVal] -> [OVal]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (OVal -> Bool) -> OVal -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OVal -> Bool
isOObj) [OVal]
children)
    ([SymbolicObj2], [SymbolicObj3], [OVal])
-> Eval ([SymbolicObj2], [SymbolicObj3], [OVal])
forall (m :: * -> *) a. Monad m => a -> m a
return ([SymbolicObj2]
obj2s, [SymbolicObj3]
obj3s, [OVal]
objs)
      where
        isOObj :: OVal -> Bool
isOObj  (OObj2 SymbolicObj2
_) = Bool
True
        isOObj  (OObj3 SymbolicObj3
_) = Bool
True
        isOObj  OVal
_         = Bool
False