{- 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

-- FIXME: why is this required?
{-# LANGUAGE ScopedTypeVariables #-}

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

module Graphics.Implicit.ExtOpenScad.Util.ArgParser (argument, doc, defaultTo, example, test, eulerCharacteristic, argMap) where

-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
import Prelude(String, Maybe(Just, Nothing), ($), (<>), show, return, fmap, snd, filter, (.), fst, foldl1, not, (&&), (<$>), maybe)
import qualified Prelude as P (null)

import Graphics.Implicit.ExtOpenScad.Definitions (ArgParser(AP, APTest, APBranch, APTerminator, APFail, APExample), OVal (OError), TestInvariant(EulerCharacteristic), Symbol, VarLookup(VarLookup))

import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, toOObj, OTypeMirror)

import Graphics.Implicit.Definitions(ℕ)

-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
import Data.Map (fromList, lookup, delete)
import qualified Data.Map as DM (null)

import Data.Maybe (isNothing, fromJust, isJust)

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

import Control.Arrow (first)

-- * ArgParser building functions

-- ** argument and combinators

-- | Builds an argparser for the type that is expected from it.
--   FIXME: make a version of this that accepts multiple symbol names, so we can have h= and height=
argument :: forall desiredType. (OTypeMirror desiredType) => Symbol -> ArgParser desiredType
argument :: Symbol -> ArgParser desiredType
argument Symbol
name =
    Symbol
-> Maybe OVal
-> Text
-> (OVal -> ArgParser desiredType)
-> ArgParser desiredType
forall a.
Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
AP Symbol
name Maybe OVal
forall a. Maybe a
Nothing Text
"" ((OVal -> ArgParser desiredType) -> ArgParser desiredType)
-> (OVal -> ArgParser desiredType) -> ArgParser desiredType
forall a b. (a -> b) -> a -> b
$ \OVal
oObjVal -> do
        let
            val :: Maybe desiredType
            val :: Maybe desiredType
val = OVal -> Maybe desiredType
forall a. OTypeMirror a => OVal -> Maybe a
fromOObj OVal
oObjVal
            errmsg :: Text
            errmsg :: Text
errmsg = case OVal
oObjVal of
                OError Text
err -> Text
"error in computing value for argument " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Symbol -> String
forall a. Show a => a -> String
show Symbol
name)
                              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>  Text
err
                OVal
_   ->  Text
"arg " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (OVal -> String
forall a. Show a => a -> String
show OVal
oObjVal) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" not compatible with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (Symbol -> String
forall a. Show a => a -> String
show Symbol
name)
        ArgParser desiredType
-> (desiredType -> ArgParser desiredType)
-> Maybe desiredType
-> ArgParser desiredType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> ArgParser desiredType
forall a. Text -> ArgParser a
APFail Text
errmsg) desiredType -> ArgParser desiredType
forall a. a -> ArgParser a
APTerminator Maybe desiredType
val
{-# INLINABLE argument #-}

-- | Inline documentation.
doc :: forall a. ArgParser a -> Text -> ArgParser a
doc :: ArgParser a -> Text -> ArgParser a
doc (AP Symbol
name Maybe OVal
defMaybeVal Text
_ OVal -> ArgParser a
next) Text
newDoc = Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
forall a.
Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
AP Symbol
name Maybe OVal
defMaybeVal Text
newDoc OVal -> ArgParser a
next
doc ArgParser a
_ Text
_ = Text -> ArgParser a
forall a. Text -> ArgParser a
APFail Text
"Impossible! doc"

-- | An inline default value.
defaultTo :: forall a. (OTypeMirror a) => ArgParser a -> a -> ArgParser a
defaultTo :: ArgParser a -> a -> ArgParser a
defaultTo (AP Symbol
name Maybe OVal
_ Text
doc' OVal -> ArgParser a
next) a
newDefVal =
    Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
forall a.
Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
AP Symbol
name (OVal -> Maybe OVal
forall a. a -> Maybe a
Just (OVal -> Maybe OVal) -> OVal -> Maybe OVal
forall a b. (a -> b) -> a -> b
$ a -> OVal
forall a. OTypeMirror a => a -> OVal
toOObj a
newDefVal) Text
doc' OVal -> ArgParser a
next
defaultTo ArgParser a
_ a
_ = Text -> ArgParser a
forall a. Text -> ArgParser a
APFail Text
"Impossible! defaultTo"

-- | An inline example.
example :: Text -> ArgParser ()
example :: Text -> ArgParser ()
example Text
str = Text -> ArgParser () -> ArgParser ()
forall a. Text -> ArgParser a -> ArgParser a
APExample Text
str (() -> ArgParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Inline test and combinators.
test :: Text -> ArgParser ()
test :: Text -> ArgParser ()
test Text
str = Text -> [TestInvariant] -> ArgParser () -> ArgParser ()
forall a. Text -> [TestInvariant] -> ArgParser a -> ArgParser a
APTest Text
str [] (() -> ArgParser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a
eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a
eulerCharacteristic (APTest Text
str [TestInvariant]
tests ArgParser a
child) ℕ
χ =
    Text -> [TestInvariant] -> ArgParser a -> ArgParser a
forall a. Text -> [TestInvariant] -> ArgParser a -> ArgParser a
APTest Text
str (ℕ -> TestInvariant
EulerCharacteristic ℕ
χ TestInvariant -> [TestInvariant] -> [TestInvariant]
forall a. a -> [a] -> [a]
: [TestInvariant]
tests) ArgParser a
child
eulerCharacteristic ArgParser a
_ ℕ
_ = Text -> ArgParser a
forall a. Text -> ArgParser a
APFail Text
"Impossible! eulerCharacteristic"

-- * Tools for handeling ArgParsers

-- | Apply arguments to an ArgParser
argMap ::
    [(Maybe Symbol, OVal)]      -- ^ arguments
    -> ArgParser a              -- ^ ArgParser to apply them to
    -> (Maybe a, [String])      -- ^ (result, error messages)
argMap :: [(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
args = [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
unnamedArgs (Map Symbol OVal -> VarLookup
VarLookup (Map Symbol OVal -> VarLookup) -> Map Symbol OVal -> VarLookup
forall a b. (a -> b) -> a -> b
$ [(Symbol, OVal)] -> Map Symbol OVal
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Symbol, OVal)]
namedArgs) where
    unnamedArgs :: [OVal]
unnamedArgs = (Maybe Symbol, OVal) -> OVal
forall a b. (a, b) -> b
snd ((Maybe Symbol, OVal) -> OVal) -> [(Maybe Symbol, OVal)] -> [OVal]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe Symbol, OVal) -> Bool)
-> [(Maybe Symbol, OVal)] -> [(Maybe Symbol, OVal)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Symbol -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Symbol -> Bool)
-> ((Maybe Symbol, OVal) -> Maybe Symbol)
-> (Maybe Symbol, OVal)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Symbol, OVal) -> Maybe Symbol
forall a b. (a, b) -> a
fst) [(Maybe Symbol, OVal)]
args
    namedArgs :: [(Symbol, OVal)]
namedArgs   = (Maybe Symbol -> Symbol) -> (Maybe Symbol, OVal) -> (Symbol, OVal)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Maybe Symbol -> Symbol
forall a. HasCallStack => Maybe a -> a
fromJust ((Maybe Symbol, OVal) -> (Symbol, OVal))
-> [(Maybe Symbol, OVal)] -> [(Symbol, OVal)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Maybe Symbol, OVal) -> Bool)
-> [(Maybe Symbol, OVal)] -> [(Maybe Symbol, OVal)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe Symbol -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Symbol -> Bool)
-> ((Maybe Symbol, OVal) -> Maybe Symbol)
-> (Maybe Symbol, OVal)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Symbol, OVal) -> Maybe Symbol
forall a b. (a, b) -> a
fst) [(Maybe Symbol, OVal)]
args

argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
unnamedArgs VarLookup
namedArgs (APBranch [ArgParser a]
branches) =
    ((Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String]))
-> [(Maybe a, [String])] -> (Maybe a, [String])
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String])
forall a.
(Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String])
merge [(Maybe a, [String])]
solutions where
        solutions :: [(Maybe a, [String])]
solutions = (ArgParser a -> (Maybe a, [String]))
-> [ArgParser a] -> [(Maybe a, [String])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
unnamedArgs VarLookup
namedArgs) [ArgParser a]
branches
        merge :: forall a. (Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String])
        merge :: (Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String])
merge a :: (Maybe a, [String])
a@(Just a
_, []) (Maybe a, [String])
_ = (Maybe a, [String])
a
        merge (Maybe a, [String])
_ b :: (Maybe a, [String])
b@(Just a
_, []) = (Maybe a, [String])
b
        merge a :: (Maybe a, [String])
a@(Just a
_, [String]
_) (Maybe a, [String])
_ = (Maybe a, [String])
a
        merge (Maybe a
Nothing, [String]
_)  (Maybe a, [String])
a = (Maybe a, [String])
a

-- FIXME: don't use delete directly here, wrap it in StateC.hs
-- FIXME: generate a warning.
argMap2 [OVal]
unnamedArgs (VarLookup Map Symbol OVal
namedArgs) (AP Symbol
name Maybe OVal
fallback Text
_ OVal -> ArgParser a
f) =
    case Symbol -> Map Symbol OVal -> Maybe OVal
forall k a. Ord k => k -> Map k a -> Maybe a
lookup Symbol
name Map Symbol OVal
namedArgs of
        Just OVal
a -> [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2
            [OVal]
unnamedArgs
            (Map Symbol OVal -> VarLookup
VarLookup (Map Symbol OVal -> VarLookup) -> Map Symbol OVal -> VarLookup
forall a b. (a -> b) -> a -> b
$ Symbol -> Map Symbol OVal -> Map Symbol OVal
forall k a. Ord k => k -> Map k a -> Map k a
delete Symbol
name Map Symbol OVal
namedArgs)
            (OVal -> ArgParser a
f OVal
a)
        Maybe OVal
Nothing -> case [OVal]
unnamedArgs of
            OVal
x:[OVal]
xs -> [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
xs (Map Symbol OVal -> VarLookup
VarLookup Map Symbol OVal
namedArgs) (OVal -> ArgParser a
f OVal
x)
            []   -> case Maybe OVal
fallback of
                Just OVal
b  -> [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [] (Map Symbol OVal -> VarLookup
VarLookup Map Symbol OVal
namedArgs) (OVal -> ArgParser a
f OVal
b)
                Maybe OVal
Nothing -> (Maybe a
forall a. Maybe a
Nothing, [String
"No value and no default for argument " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Symbol -> String
forall a. Show a => a -> String
show Symbol
name])

-- FIXME: don't use map.null here, wrap it in StateC.hs.
-- FIXME: generate a warning.
argMap2 [OVal]
a (VarLookup Map Symbol OVal
b) (APTerminator a
val) =
    (a -> Maybe a
forall a. a -> Maybe a
Just a
val, [String
"Unused arguments" | Bool -> Bool
not ([OVal] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [OVal]
a Bool -> Bool -> Bool
&& Map Symbol OVal -> Bool
forall k a. Map k a -> Bool
DM.null Map Symbol OVal
b)])

argMap2 [OVal]
_ VarLookup
_ (APFail Text
err) = (Maybe a
forall a. Maybe a
Nothing, [Text -> String
unpack Text
err])

argMap2 [OVal]
a VarLookup
b (APExample Text
_ ArgParser a
child) = [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
a VarLookup
b ArgParser a
child

argMap2 [OVal]
a VarLookup
b (APTest Text
_ [TestInvariant]
_ ArgParser a
child) = [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
a VarLookup
b ArgParser a
child