{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# 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 qualified Data.Text as T
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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> a
make Registry ins out
registry =
  -- if the registry is an unchecked one, built with +:
  -- this may fail
  case 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 -> forall a. HasCallStack => [Char] -> a
Prelude.error (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, Contains a out) => Registry ins out -> a
makeSafe :: forall a (ins :: [*]) (out :: [*]).
(Typeable a, Solvable ins out, Contains a out) =>
Registry ins out -> a
makeSafe = 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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out -> Either Text a
makeEither = forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a), 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 :: forall {k} (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
Registry ins out -> b
makeSpecialized Registry ins out
registry =
  case 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 -> forall a. HasCallStack => [Char] -> a
Prelude.error (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 :: forall (path :: [*]) b (ins :: [*]) (out :: [*]).
(PathToTypeReps path, Typeable b) =>
Registry ins out -> b
makeSpecializedPath Registry ins out
registry =
  case 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 -> forall a. HasCallStack => [Char] -> a
Prelude.error (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 :: forall {k} (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
Registry ins out -> Either Text b
makeSpecializedEither = forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a), forall a. Maybe a
Nothing), (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy b), 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 :: forall (path :: [*]) b (ins :: [*]) (out :: [*]).
(PathToTypeReps path, Typeable b) =>
Registry ins out -> Either Text b
makeSpecializedPathEither = forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context ((,forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> NonEmpty SomeTypeRep
someTypeReps (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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Context -> Registry ins out -> Either Text a
makeEitherWithContext Context
context Registry ins out
registry = do
  let values :: Values
values = forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Values
_values Registry ins out
registry
  let functions :: Functions
functions = forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Functions
_functions Registry ins out
registry
  let specializations :: Specializations
specializations = forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Specializations
_specializations Registry ins out
registry
  let modifiers :: Modifiers
modifiers = forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Modifiers
_modifiers Registry ins out
registry
  let targetType :: SomeTypeRep
targetType = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
  --  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 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 ->
      forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
showRegistry forall a b. (a -> b) -> a -> b
$
        Text
"\nCould not create a "
          forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show SomeTypeRep
targetType
          forall a. Semigroup a => a -> a -> a
<> Text
" out of the registry:"
          forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
          forall a. Semigroup a => a -> a -> a
<> Text
e
    Right Maybe Value
Nothing ->
      forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
showRegistry forall a b. (a -> b) -> a -> b
$
        Text
"\nCould not create a "
          forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show SomeTypeRep
targetType
          forall a. Semigroup a => a -> a -> a
<> Text
" out of the registry"
    Right (Just Value
result) ->
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"\nCould not cast the computed value to a " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show SomeTypeRep
targetType forall a. Semigroup a => a -> a -> a
<> Text
". The value is of type: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv [Char] b) => a -> b
show (Value -> SomeTypeRep
valueDynTypeRep Value
result))
        forall a b. b -> Either a b
Right (forall a. Typeable a => Dynamic -> Maybe a
fromDynamic (Value -> Dynamic
valueDyn Value
result))
  where
    showRegistry :: Text -> Text
showRegistry Text
message = do
      let r :: Text
r = forall a b. (Show a, StringConv [Char] b) => a -> b
show Registry ins out
registry
      -- this allows the display of registries of no more than ~ 30 functions
      -- which should fit on a laptop screen
      if (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall a b. (a -> b) -> a -> b
$ Text
r) forall a. Ord a => a -> a -> Bool
<= Int
35
        then
          Text
"\nThe registry is"
            forall a. Semigroup a => a -> a -> a
<> Text
"\n\n"
            forall a. Semigroup a => a -> a -> a
<> Text
r
            forall a. Semigroup a => a -> a -> a
<> Text
"=====================\n"
            forall a. Semigroup a => a -> a -> a
<> Text
message
            forall a. Semigroup a => a -> a -> a
<> Text
"\n\nYou can check the registry displayed above the ===== line to verify the current values and functions\n"
        else
          Text
message
            forall a. Semigroup a => a -> a -> a
<> Text
"\n\n (the registry is not displayed because it is too large)"