ArgParser.hs

-- 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 #-}

-- Allow us to display a target type.
{-# LANGUAGE TypeApplications #-}

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

-- imported twice, once qualified. null from Data.Map conflicts with null from Prelude.
import Prelude(String, Maybe(Just, Nothing), ($), (<>), concatMap, error, otherwise, 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, ContoursAreClosed, MeshIsWaterTight), Symbol, VarLookup(VarLookup))

import Graphics.Implicit.ExtOpenScad.Util.OVal (fromOObj, oTypeStr, 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 Type.Reflection (Typeable, typeRep)

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, Typeable desiredType) => Symbol -> ArgParser desiredType
argument name =
    AP name Nothing "" $ \oObjVal -> do
        let
            val :: Maybe desiredType
            val = fromOObj oObjVal
            errmsg :: Text
            errmsg = case oObjVal of
                OError err -> "error in computing value for argument " <> pack (show name)
                              <> ": " <>  err
                _ ->     "arg " <> pack (show name) <>
                  " expected "  <> pack (show $ typeRep @desiredType) <>
                  " but found " <> oTypeStr oObjVal
        maybe (APFail errmsg) APTerminator val
{-# INLINABLE argument #-}

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

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

-- | An inline example.
example :: Text -> ArgParser ()
example str = APExample str (return ())

-- * Our in-ArgParser unit test suite!

-- | Start an inline test.
test :: Text -> ArgParser ()
test str = APTest str Nothing [] (return ())

-- | Set the resolution for an inline test.
atResolution :: ArgParser a -> ℝ -> ArgParser a
atResolution (APTest str maybeRes tests child) res
  | isJust maybeRes = error "tried to set a resolution of a test twice."
  | otherwise = APTest str (Just res) tests child
atResolution _ _ = APFail "Impossible! atResolution"

-- | Give a euler characteristic that must be true for the given APTest.
eulerCharacteristic :: ArgParser a -> ℕ -> ArgParser a
eulerCharacteristic (APTest str maybeRes tests child) χ =
    APTest str maybeRes (EulerCharacteristic χ : tests) child
eulerCharacteristic _ _ = APFail "eulerCharacteristic called on an Argparser that isn't APTest"

-- | Indicate that the test should result in 2D contours, and they should be closed.
contoursAreClosed :: ArgParser a -> ArgParser a
contoursAreClosed (APTest str maybeRes tests child) = APTest str maybeRes (ContoursAreClosed:tests) child
contoursAreClosed _ = APFail  "contoursAreClosed called on an Argparser that isn't APTest"

meshIsWaterTight :: ArgParser a -> ArgParser a
meshIsWaterTight (APTest str maybeRes tests child) = APTest str maybeRes (MeshIsWaterTight:tests) child
meshIsWaterTight _ = APFail  "meshIsWaterTight called on an Argparser that isn't APTest"

-- * Tools for handeling ArgParsers

-- | Retrieve all of the tests
collectTests :: ArgParser a -> [(Text, Maybe ℝ, [TestInvariant])]
collectTests (APTest str maybeRes tests child) = (str, maybeRes, tests) : collectTests child
collectTests (APExample _ child)               = collectTests child
collectTests (APBranch branches)               = concatMap collectTests branches
-- For AP, we use a default value to run the argParser, since we need one.
collectTests (AP _ (Just defaultValue) _ fun)  = collectTests $ fun defaultValue
collectTests (AP _ (Nothing) _ _)              = []
collectTests _                                 = []

-- | Apply arguments to an ArgParser
argMap ::
    [(Maybe Symbol, OVal)]      -- ^ arguments
    -> ArgParser a              -- ^ ArgParser to apply them to
    -> (Maybe a, [String])      -- ^ (result, error messages)
argMap args = argMap2 unnamedArgs (VarLookup $ fromList namedArgs) where
    unnamedArgs = snd <$> filter (isNothing . fst) args
    namedArgs   = first fromJust <$> filter (isJust . fst) args

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

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

-- FIXME: don't use map.null here, wrap it in StateC.hs.
-- FIXME: generate a warning.
argMap2 a (VarLookup b) (APTerminator val) =
    (Just val, ["Unused arguments" | not (P.null a && DM.null b)])

argMap2 _ _ (APFail err) = (Nothing, [unpack err])

argMap2 a b (APExample _ child) = argMap2 a b child

argMap2 a b (APTest _ _ _ child) = argMap2 a b child