{-# 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 Data.Registry.Solver
import Protolude as P hiding (Constructor)
import Type.Reflection
import qualified Prelude (error)

-- | 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
--   and check statically that the element can be built
makeSafe :: forall a ins out. (Typeable a, Solvable ins out) => Registry ins out -> a
makeSafe :: Registry ins out -> a
makeSafe = Registry ins out -> a
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make

-- | 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, StringConv [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, StringConv [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, StringConv [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, StringConv [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, StringConv [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, StringConv [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))