Definitions.hs

-- 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, ONModuleWithSuite, OVargsModule, OError, OObj2, OObj3),
                                                  TestInvariant(EulerCharacteristic, ContoursAreClosed, MeshIsWaterTight),
                                                  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, 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
  { scadVars  :: VarLookup -- ^ A hash of variables and functions.
  , oVals     :: [OVal]    -- ^ The result of geometry generating functions.
  , sourceDir :: FilePath  -- ^ The path we are looking for includes in.
  } deriving (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 {
  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
  , MonadIO -- This only exists if `m` is also MonadIO.
  , Monad
  , Applicative
  , 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 r s m = do
  ((a, w), s') <- runStateT (runWriterT $ runReaderT (unImplicitCadM m) r) s
  pure (a, w, 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)@
                 -- NOTE: we don't use APFail to fail parsing in Primitives.hs, we have errorC.
                 | APExample Text (ArgParser a)
                 -- ^ An example, then next
                 | APTest Text (Maybe ℝ) [TestInvariant] (ArgParser a)
                 -- ^ A string to run as a test, the resolution to render the results, the invariants for the results, then next
                 | APBranch [ArgParser a]
                 -- ^ A branch where there are a number of possibilities for the parser underneath
  deriving Functor

instance Applicative ArgParser where
    pure = APTerminator
    (<*>) = 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 str fallback d f) >>= g = AP str fallback d (f >=> g)
    (APFail errmsg) >>= _ = APFail errmsg
    -- These next two are easy, they just pass the work along to their child
    (APExample str child) >>= g = APExample str (child >>= g)
    (APTest str maybeRes tests child) >>= g = APTest str maybeRes tests (child >>= g)
    -- And an ArgParserTerminator happily gives away the value it contains
    (APTerminator a) >>= g = g a
    (APBranch bs) >>= g = APBranch $ (>>= g) <$> bs

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

instance Alternative ArgParser where
        (<|>) = mplus
        empty = mzero

newtype Symbol = Symbol Text
  deriving (Show, Eq, Ord)

newtype VarLookup = VarLookup (Map Symbol OVal)
  deriving (Show, Eq)

data Pattern = Name Symbol
             | ListP [Pattern]
             | Wild
    deriving (Show, 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 (Show, Eq)

-- | A statement, along with the line, column number, and file it is found at.
data StatementI = StatementI SourcePosition (Statement StatementI)
    deriving (Show, 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 (Show, 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.
         | ONModule Symbol (SourcePosition -> ArgParser (StateC [OVal])) [[(Symbol, Bool)]]
         -- Name, implementation, arguments.
         | ONModuleWithSuite Symbol (SourcePosition -> [OVal] -> ArgParser (StateC [OVal])) [[(Symbol, Bool)]]
         | OVargsModule Symbol (Symbol -> SourcePosition -> [(Maybe Symbol, OVal)] -> [StatementI] -> ([StatementI] -> StateC ()) -> StateC ())
         | OObj3 SymbolicObj3
         | OObj2 SymbolicObj2

instance Eq OVal where
    (OBool a) == (OBool b) = a == b
    (ONum  a) == (ONum  b) = a == b
    (OList a) == (OList b) = and $ zipWith (==) a b
    (OString a) == (OString b) = a == b
    OUndefined == OUndefined = True
    _ == _ = False

instance Show OVal where
    show OUndefined = "Undefined"
    show (OBool b) = show b
    show (ONum n) = show n
    show (OList l) = show l
    show (OString s) = show s
    show (OFunc _) = "<function>"
    show (OIO _) = "<IO>"
    show (OUModule (Symbol name) arguments _) = "module " <> unpack name <> " (" <> unpack (intercalate ", " (showArg <$> fromMaybe [] arguments)) <> ") {}"
      where
        showArg :: (Symbol, Bool) -> Text
        showArg (Symbol a, hasDefault) = if hasDefault
                                         then a
                                         else a <> "=..."
    show (ONModule (Symbol name) _ instances) = unpack $ showInstances instances
      where
        showArg (Symbol a, hasDefault) = if hasDefault
                                         then a
                                         else a <> "=..."
        showInstances :: [[(Symbol, Bool)]] -> Text
        showInstances [] = ""
        showInstances [oneInstance] = "module " <> name <> showInstance oneInstance
        showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (showInstance <$> multipleInstances) <> " ]"
        showInstance :: [(Symbol, Bool)] -> Text
        showInstance arguments = " (" <> intercalate ", " (showArg <$> arguments) <> ") "
    show (ONModuleWithSuite (Symbol name) _ instances) = unpack $ showInstances instances
      where
        showArg (Symbol a, hasDefault) = if hasDefault
                                         then a
                                         else a <> "=..."
        showInstances :: [[(Symbol, Bool)]] -> Text
        showInstances [] = ""
        showInstances [oneInstance] = "module " <> name <> showInstance oneInstance
        showInstances multipleInstances = "Module " <> name <> "[ " <> intercalate ", " (showInstance <$> multipleInstances) <> " ]"
        showInstance :: [(Symbol, Bool)] -> Text
        showInstance arguments = " (" <> intercalate ", " (showArg <$> arguments) <> ") {} requiring suite {}"
    show (OVargsModule (Symbol name) _) = "varargs module " <> unpack name
    show (OError msg) = unpack $ "Execution Error:\n" <> msg
    show (OObj2 obj) = "<obj2: " <> show obj <> ">"
    show (OObj3 obj) = "<obj3: " <> show obj <> ">"

-- | 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 (Eq)

instance Show SourcePosition where
    show (SourcePosition line col []) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int)
    show (SourcePosition line col filePath) = "line " <> show (fromFastℕ line :: Int) <> ", column " <> show (fromFastℕ col :: Int) <> ", file " <> 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 (Show, Eq)

-- | An individual message.
data Message = Message MessageType SourcePosition Text
  deriving (Eq)

instance Show Message where
  show (Message mtype pos text) = show mtype <> " at " <> show pos <> ": " <> unpack text

-- | Options changing the behavior of the extended OpenScad engine.
data ScadOpts = ScadOpts
  { openScadCompatibility :: Bool
  , importsAllowed        :: Bool
  } deriving (Show, Eq)

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

-- helper, to use union on VarLookups.
varUnion :: VarLookup -> VarLookup -> VarLookup
varUnion (VarLookup a) (VarLookup b) = VarLookup $ union a b

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

-- | Our tests. We only have the one, and it is to check the Euler characteristic of a mesh.
data TestInvariant =
    EulerCharacteristic ℕ
  | ContoursAreClosed
  | MeshIsWaterTight
    deriving (Show)