{-# 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 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, 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 = 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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
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 :: forall {k} (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
Registry ins out -> b
makeSpecialized Registry ins out
registry =
  case forall (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
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 :: 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 -> [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 :: forall {k} (a :: k) b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b) =>
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 :: forall (path :: [*]) b (ins :: [*]) (out :: [*]).
(PathToTypeReps path, Typeable b) =>
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 a. NonEmpty a -> [a]
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 :: 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 = Values
forall a. Monoid a => a
mempty
  let entries :: Entries
entries = Registry ins out -> Entries
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Entries
_entries Registry ins out
registry
  let specializations :: Specializations
specializations = Registry ins out -> Specializations
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Specializations
_specializations Registry ins out
registry
  let modifiers :: Modifiers
modifiers = Registry ins out -> Modifiers
forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Modifiers
_modifiers Registry ins out
registry
  let 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)
  --  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
-> Entries
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped SomeTypeRep
targetType Context
context Entries
entries 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 -> Text) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
showRegistry (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$
        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
    Right Maybe Value
Nothing ->
      Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> (Text -> Text) -> Text -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
showRegistry (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$
        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"
    Right (Just Value
result) ->
      Either Text a -> (a -> Either Text a) -> Maybe a -> Either Text a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (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
"\nCould 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 (Dynamic -> Maybe a
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 = Registry ins out -> Text
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 entries
      -- which should fit on a laptop screen
      if ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> (Text -> [Text]) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Text
r) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
35
        then
          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
<> Text
r
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=====================\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
message
            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 entries\n"
        else
          Text
message
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n (the registry is not displayed because it is too large)"