{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Registry.Internal.Types where
import Data.Dynamic
import Data.Hashable
import Data.List (elemIndex, intersect)
import Data.List.NonEmpty
import Data.List.NonEmpty as NonEmpty (head, last)
import Data.Registry.Internal.Reflection
import Data.Text as T hiding (last)
import Prelude (show)
import Protolude as P hiding (show)
import qualified Protolude as P
import Type.Reflection
data Value =
CreatedValue Dynamic ValueDescription (Maybe Context) (Maybe Specialization) Dependencies
| ProvidedValue Dynamic ValueDescription
deriving (Show)
instance Hashable Value where
hash value = hash (valDescription value)
hashWithSalt n value = hashWithSalt n (valDescription value)
data ValueDescription = ValueDescription {
_valueType :: Text
, _valueValue :: Maybe Text
} deriving (Eq, Show)
instance Hashable ValueDescription where
hash (ValueDescription d v) = hash (d, v)
hashWithSalt n (ValueDescription d v) = hashWithSalt n (d, v)
describeValue :: (Typeable a, Show a) => a -> ValueDescription
describeValue a = ValueDescription (showFullValueType a) (Just . toS $ show a)
describeTypeableValue :: (Typeable a) => a -> ValueDescription
describeTypeableValue a = ValueDescription (showFullValueType a) Nothing
showValue :: Value -> Text
showValue = valDescriptionToText . valDescription
createValue :: (Typeable a, Show a) => a -> Value
createValue a = makeProvidedValue (toDyn a) (describeValue a)
makeProvidedValue :: Dynamic -> ValueDescription -> Value
makeProvidedValue = ProvidedValue
makeCreatedValue :: Dynamic -> ValueDescription -> Dependencies -> Value
makeCreatedValue d desc = CreatedValue d desc Nothing Nothing
createTypeableValue :: Typeable a => a -> Value
createTypeableValue a = ProvidedValue (toDyn a) (describeTypeableValue a)
createDynValue :: Dynamic -> Text -> Value
createDynValue dyn desc = ProvidedValue dyn (ValueDescription desc Nothing)
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep = dynTypeRep . valueDyn
valueDyn :: Value -> Dynamic
valueDyn (CreatedValue d _ _ _ _) = d
valueDyn (ProvidedValue d _) = d
valDescription :: Value -> ValueDescription
valDescription (CreatedValue _ d _ _ _ ) = d
valDescription (ProvidedValue _ d) = d
valDependencies :: Value -> Dependencies
valDependencies (CreatedValue _ _ _ _ ds) = ds
valDependencies (ProvidedValue _ _) = mempty
valDescriptionToText :: ValueDescription -> Text
valDescriptionToText (ValueDescription t Nothing) = t
valDescriptionToText (ValueDescription t (Just v)) = t <> ": " <> v
specializationContext :: Value -> Maybe Context
specializationContext (CreatedValue _ _ context _ _) = context
specializationContext _ = Nothing
usedSpecialization :: Value -> Maybe Specialization
usedSpecialization (CreatedValue _ _ _ specialization _) = specialization
usedSpecialization _ = Nothing
isInSpecializationContext :: SomeTypeRep -> Value -> Bool
isInSpecializationContext target value =
case specializationContext value of
Just context -> target `elem` (contextTypes context)
Nothing -> False
hasSpecializedDependencies :: Specializations -> Value -> Bool
hasSpecializedDependencies (Specializations ss) v =
let DependenciesTypes ds = dependenciesTypes $ valDependencies v
targetTypes = specializationTargetType <$> ss
in not . P.null $ targetTypes `intersect` ds
data Function = Function Dynamic FunctionDescription deriving (Show)
createFunction :: (Typeable f) => f -> Function
createFunction f =
let dynType = toDyn f
in Function dynType (describeFunction f)
data FunctionDescription = FunctionDescription {
_inputTypes :: [Text]
, _outputType :: Text
} deriving (Eq, Show)
describeFunction :: Typeable a => a -> FunctionDescription
describeFunction = uncurry FunctionDescription . showFullFunctionType
showFunction :: Function -> Text
showFunction = funDescriptionToText . funDescription
funDescription :: Function -> FunctionDescription
funDescription (Function _ t) = t
funDyn :: Function -> Dynamic
funDyn (Function d _) = d
funDynTypeRep :: Function -> SomeTypeRep
funDynTypeRep = dynTypeRep . funDyn
funDescriptionToText :: FunctionDescription -> Text
funDescriptionToText (FunctionDescription ins out) = T.intercalate " -> " (ins <> [out])
hasParameters :: Function -> Bool
hasParameters = isFunction . funDynTypeRep
data Typed a =
TypedValue Value
| TypedFunction Function
newtype Functions = Functions [Function] deriving (Show, Semigroup, Monoid)
describeFunctions :: Functions -> Text
describeFunctions (Functions fs) =
if P.null fs then
""
else
unlines (funDescriptionToText . funDescription <$> fs)
addFunction :: Function -> Functions -> Functions
addFunction f (Functions fs) = Functions (f : fs)
newtype Values = Values { unValues :: [Value] } deriving (Show, Semigroup, Monoid)
describeValues :: Values -> Text
describeValues (Values vs) =
if P.null vs then
""
else
unlines (valDescriptionToText . valDescription <$> vs)
addValue :: Value -> Values -> Values
addValue v (Values vs) = Values (v : vs)
data Context = Context {
_contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)]
} deriving (Eq, Show)
instance Semigroup Context where
Context c1 <> Context c2 = Context (c1 <> c2)
instance Monoid Context where
mempty = Context mempty
mappend = (<>)
contextTypes :: Context -> [SomeTypeRep]
contextTypes (Context cs) = fmap fst cs
newtype Dependencies = Dependencies {
unDependencies :: [Value]
} deriving (Show, Semigroup, Monoid)
newtype DependenciesTypes = DependenciesTypes {
unDependenciesTypes :: [SomeTypeRep]
} deriving (Eq, Show, Semigroup, Monoid)
dependenciesTypes :: Dependencies -> DependenciesTypes
dependenciesTypes (Dependencies ds) = DependenciesTypes (valueDynTypeRep <$> ds)
dependenciesOn :: Value -> Dependencies
dependenciesOn value = Dependencies $
value : (unDependencies . valDependencies $ value)
newtype Specializations = Specializations {
unSpecializations :: [Specialization]
} deriving (Show, Semigroup, Monoid)
data Specialization = Specialization {
_specializationPath :: SpecializationPath
, _specializationValue :: Value
} deriving (Show)
type SpecializationPath = NonEmpty SomeTypeRep
specializationPaths :: Value -> Maybe [SpecializationPath]
specializationPaths v =
case catMaybes $ usedSpecialization <$> (v : (unDependencies . valDependencies $ v)) of
[] -> Nothing
ss -> Just (_specializationPath <$> ss)
specializationStart :: Specialization -> SomeTypeRep
specializationStart = NonEmpty.head . _specializationPath
specializationEnd :: Specialization -> SomeTypeRep
specializationEnd = NonEmpty.last . _specializationPath
specializationTargetType :: Specialization -> SomeTypeRep
specializationTargetType = valueDynTypeRep . _specializationValue
isContextApplicable :: Context -> Specialization -> Bool
isContextApplicable context (Specialization specializationPath _) =
P.all (`elem` (contextTypes context)) specializationPath
applicableTo :: Specializations -> Context -> Specializations
applicableTo (Specializations ss) context =
Specializations (P.filter (isContextApplicable context) ss)
specializedContext :: Context -> Specialization -> SpecializedContext
specializedContext context specialization =
SpecializedContext
(specializationStart specialization `elemIndex` (contextTypes context))
(specializationEnd specialization `elemIndex` (contextTypes context))
data SpecializedContext = SpecializedContext {
_startRange :: Maybe Int
, _endRange :: Maybe Int
} deriving (Eq, Show)
instance Ord SpecializedContext where
SpecializedContext s1 e1 <= SpecializedContext s2 e2
| e1 /= s1 && e2 /= s2 = e1 <= e2 || (e1 == e2 && s1 <= s2)
| e1 == s1 && e2 /= s2 = e1 < e2
| otherwise = e1 <= e2
createValueFromSpecialization :: Context -> Specialization -> Value
createValueFromSpecialization context specialization@(Specialization _ (ProvidedValue d desc)) =
CreatedValue d desc (Just context) (Just specialization) mempty
createValueFromSpecialization _ v = _specializationValue v
describeSpecializations :: Specializations -> Text
describeSpecializations (Specializations ss) =
if P.null ss then
""
else
"specializations\n" <> unlines (P.show <$> ss)
newtype Modifiers = Modifiers [(SomeTypeRep, ModifierFunction)] deriving (Semigroup, Monoid)
type ModifierFunction = Maybe [SpecializationPath] -> Function
createConstModifierFunction :: (Typeable f) => f -> ModifierFunction
createConstModifierFunction f = const (createFunction f)
instance Show Modifiers where
show = toS . describeModifiers
describeModifiers :: Modifiers -> Text
describeModifiers (Modifiers ms) =
if P.null ms then
""
else
"modifiers for types\n" <> unlines (P.show . fst <$> ms)