{- 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 :: forall desiredType.
OTypeMirror desiredType =>
Symbol -> ArgParser desiredType
argument Symbol
name =
    forall a.
Symbol
-> Maybe OVal -> Text -> (OVal -> ArgParser a) -> ArgParser a
AP Symbol
name forall a. Maybe a
Nothing Text
"" forall a b. (a -> b) -> a -> b
$ \OVal
oObjVal -> do
        let
            val :: Maybe desiredType
            val :: Maybe desiredType
val = 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 " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Symbol
name)
                              forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<>  Text
err
                OVal
_   ->  Text
"arg " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show OVal
oObjVal) forall a. Semigroup a => a -> a -> a
<> Text
" not compatible with " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall a. Show a => a -> String
show Symbol
name)
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Text -> ArgParser a
APFail Text
errmsg) forall a. a -> ArgParser a
APTerminator Maybe desiredType
val
{-# INLINABLE argument #-}

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

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

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

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

eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a
eulerCharacteristic :: forall a. ArgParser a -> ℕ -> ArgParser a
eulerCharacteristic (APTest Text
str [TestInvariant]
tests ArgParser a
child) ℕ
χ =
    forall a. Text -> [TestInvariant] -> ArgParser a -> ArgParser a
APTest Text
str (ℕ -> TestInvariant
EulerCharacteristic ℕ
χ forall a. a -> [a] -> [a]
: [TestInvariant]
tests) ArgParser a
child
eulerCharacteristic 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 :: forall a.
[(Maybe Symbol, OVal)] -> ArgParser a -> (Maybe a, [String])
argMap [(Maybe Symbol, OVal)]
args = forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
unnamedArgs (Map Symbol OVal -> VarLookup
VarLookup forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Symbol, OVal)]
namedArgs) where
    unnamedArgs :: [OVal]
unnamedArgs = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Symbol, OVal)]
args
    namedArgs :: [(Symbol, OVal)]
namedArgs   = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Maybe Symbol, OVal)]
args

argMap2 :: [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 :: forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
unnamedArgs VarLookup
namedArgs (APBranch [ArgParser a]
branches) =
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 forall a.
(Maybe a, [String]) -> (Maybe a, [String]) -> (Maybe a, [String])
merge [(Maybe a, [String])]
solutions where
        solutions :: [(Maybe a, [String])]
solutions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 :: forall a.
(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 forall k a. Ord k => k -> Map k a -> Maybe a
lookup Symbol
name Map Symbol OVal
namedArgs of
        Just OVal
a -> forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2
            [OVal]
unnamedArgs
            (Map Symbol OVal -> VarLookup
VarLookup forall a b. (a -> b) -> a -> b
$ 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 -> 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  -> 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 -> (forall a. Maybe a
Nothing, [String
"No value and no default for argument " forall a. Semigroup a => a -> a -> a
<> 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) =
    (forall a. a -> Maybe a
Just a
val, [String
"Unused arguments" | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [OVal]
a Bool -> Bool -> Bool
&& forall k a. Map k a -> Bool
DM.null Map Symbol OVal
b)])

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

argMap2 [OVal]
a VarLookup
b (APExample Text
_ ArgParser a
child) = 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) = forall a. [OVal] -> VarLookup -> ArgParser a -> (Maybe a, [String])
argMap2 [OVal]
a VarLookup
b ArgParser a
child