{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE InstanceSigs              #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}

{- |
  This module provides functions to make values
  out of a registry. The general algorithm is the following

   1. for a given value type search in the existing list of values
      a value with the same type. If found return it

   2. if not found search a function having the desired output type
      if found, now try to recursively make all the input parameters.
      Keep a stack of the current types trying to be built.

   3. when trying to make an input parameter if the current input type
      is already in the types trying to be built then there is a cycle.
      Return an error in that case

   4. when a value has been constructed place it on top of the existing value
      list so that it can be reused by other functions

-}
module Data.Registry.Make where

import           Data.Dynamic
import           Data.Registry.Internal.Make
import           Data.Registry.Internal.Stack
import           Data.Registry.Internal.Types
import           Data.Registry.Registry
import qualified Prelude                         (error)
import           Protolude                       as P hiding (Constructor)
import           Type.Reflection

-- | Make an element of type 'a' out of the registry
make :: forall a ins out . (Typeable a) => Registry ins out -> a
make :: Registry ins out -> a
make Registry ins out
registry =
  -- if the registry is an unchecked one, built with +:
  -- this may fail
  case Registry ins out -> Either Text a
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> Either Text a
makeEither Registry ins out
registry of
    Right a
a -> a
a
    Left  Text
e -> [Char] -> a
forall a. HasCallStack => [Char] -> a
Prelude.error (Text -> [Char]
forall a b. ConvertText a b => a -> b
toS Text
e)

-- | Make an element of type 'a' out of the registry, for a registry
--   which was possibly created with +:
makeEither :: forall a ins out . (Typeable a) => Registry ins out -> Either Text a
makeEither :: Registry ins out -> Either Text a
makeEither = Context -> Registry ins out -> Either Text a
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a), Maybe SomeTypeRep
forall a. Maybe a
Nothing)])

-- * SPECIALIZED VALUES

-- | make for specialized values
makeSpecialized :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> b
makeSpecialized :: Registry ins out -> b
makeSpecialized Registry ins out
registry =
  case Registry ins out -> Either Text b
forall k (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
Registry ins out -> Either Text b
makeSpecializedEither @a @b Registry ins out
registry of
    Right b
a -> b
a
    Left  Text
e -> [Char] -> b
forall a. HasCallStack => [Char] -> a
Prelude.error (Text -> [Char]
forall a b. ConvertText a b => a -> b
toS Text
e)

-- | make for specialized values
makeSpecializedPath :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> b
makeSpecializedPath :: Registry ins out -> b
makeSpecializedPath Registry ins out
registry =
  case Registry ins out -> Either Text b
forall (path :: [*]) b (ins :: [*]) (out :: [*]).
(PathToTypeReps path, Typeable b) =>
Registry ins out -> Either Text b
makeSpecializedPathEither @path @b Registry ins out
registry of
    Right b
a -> b
a
    Left  Text
e -> [Char] -> b
forall a. HasCallStack => [Char] -> a
Prelude.error (Text -> [Char]
forall a b. ConvertText a b => a -> b
toS Text
e)

-- | makeEither for specialized values, in case you are using an unchecked registry
makeSpecializedEither :: forall a b ins out . (Typeable a, Typeable b) => Registry ins out -> Either Text b
makeSpecializedEither :: Registry ins out -> Either Text b
makeSpecializedEither = Context -> Registry ins out -> Either Text b
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a), Maybe SomeTypeRep
forall a. Maybe a
Nothing), (Proxy b -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b), Maybe SomeTypeRep
forall a. Maybe a
Nothing)])

-- | makeEither for specialized values along a path, in case you are using an unchecked registry
makeSpecializedPathEither :: forall path b ins out . (PathToTypeReps path, Typeable b) => Registry ins out -> Either Text b
makeSpecializedPathEither :: Registry ins out -> Either Text b
makeSpecializedPathEither = Context -> Registry ins out -> Either Text b
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context ((, Maybe SomeTypeRep
forall a. Maybe a
Nothing) (SomeTypeRep -> (SomeTypeRep, Maybe SomeTypeRep))
-> [SomeTypeRep] -> [(SomeTypeRep, Maybe SomeTypeRep)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty SomeTypeRep -> [SomeTypeRep]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Proxy path -> NonEmpty SomeTypeRep
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> NonEmpty SomeTypeRep
someTypeReps (Proxy path
forall k (t :: k). Proxy t
Proxy :: Proxy path))))

-- | This version of make only execute checks at runtime
--   this can speed-up compilation when writing tests or in ghci
makeEitherWithContext :: forall a ins out . (Typeable a) => Context -> Registry ins out -> Either Text a
makeEitherWithContext :: Context -> Registry ins out -> Either Text a
makeEitherWithContext Context
context Registry ins out
registry =
  let values :: Values
values          = Registry ins out -> Values
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Values
_values Registry ins out
registry
      functions :: Functions
functions       = Registry ins out -> Functions
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Functions
_functions Registry ins out
registry
      specializations :: Specializations
specializations = Registry ins out -> Specializations
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Specializations
_specializations Registry ins out
registry
      modifiers :: Modifiers
modifiers       = Registry ins out -> Modifiers
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Modifiers
_modifiers Registry ins out
registry
      targetType :: SomeTypeRep
targetType      = Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
  in
      --  use the makeUntyped function to create an element of the target type from a list of values and functions
      --  the list of values is kept as some State so that newly created values can be added to the current state
      case
        Values -> Stack (Maybe Value) -> Either Text (Maybe Value)
forall a. Values -> Stack a -> Either Text a
runStackWithValues Values
values
          (SomeTypeRep
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped SomeTypeRep
targetType Context
context Functions
functions Specializations
specializations Modifiers
modifiers)

      of
        Left Text
e ->
          Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$
             Text
"\nThe registry is"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Registry ins out -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Registry ins out
registry
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=====================\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nCould not create a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show SomeTypeRep
targetType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of the registry:"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n"


        Right Maybe Value
Nothing ->
          Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$
          Registry ins out -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Registry ins out
registry
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n could not create a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show SomeTypeRep
targetType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" out of the registry"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nYou can check the registry displayed above the ===== line to verify the current values and constructors\n"

        Right (Just Value
result) -> Either Text a -> Maybe (Either Text a) -> Either Text a
forall a. a -> Maybe a -> a
fromMaybe
          (Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"could not cast the computed value to a " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show SomeTypeRep
targetType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". The value is of type: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show (Value -> SomeTypeRep
valueDynTypeRep Value
result))
          (a -> Either Text a
forall a b. b -> Either a b
Right (a -> Either Text a) -> Maybe a -> Maybe (Either Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Value -> Dynamic
valueDyn Value
result))