ngws/mad
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Try starting supporting inline functions

Browse Source 
Gets rid of UToken.
This commit is contained in:
Niels G. W. Serup
2024-10-14 20:41:42 +02:00
parent eae34707e9
commit f29dd6d299
7 changed files with 189 additions and 159 deletions
Download Patch File Download Diff File Expand all files Collapse all files

90
byg/src/DependencyGenerator.hs
View File

@@ -26,10 +26,11 @@ module DependencyGenerator
) where
import Types.Token (Token(..))
import Types.Value (Valuable(..))
import Types.Value
import Types.Functions (IsFunction(), IsFunctionIO(..))
import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken)
import Types.Dependency (Action(..), Dependency, makeDependency, unListType, unTupleType)
import Type.Reflection (Typeable, TypeRep, typeRep)
import Control.Monad.State (MonadState, State, runState, put, get)
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
@@ -47,7 +48,7 @@ evalDepGenM = snd . fst . runDepGenM 0
tellDep :: Dependency -> DepGenM ()
tellDep dep = tell [dep]
newToken :: DepGenM (Token a)
newToken :: (Typeable a, Show a) => DepGenM (Token a)
newToken = do
top <- get
let top' = top + 1
@@ -55,17 +56,17 @@ newToken = do
put top'
pure target
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM (Token a)
genDependencyM :: (Typeable a, Show a) => (Token a -> DepGenM Dependency) -> DepGenM (Token a)
genDependencyM f = do
target <- newToken
result <- f target
tellDep result
pure target
genDependency :: (Token a -> Dependency) -> DepGenM (Token a)
genDependency :: (Typeable a, Show a) => (Token a -> Dependency) -> DepGenM (Token a)
genDependency f = genDependencyM (pure . f)
inject :: Valuable a => a -> DepGenM (Token a)
inject :: (Show a, Typeable a) => a -> DepGenM (Token a)
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b)
@@ -77,25 +78,30 @@ runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
runFunctionIO_ :: IsFunctionIO f a () => f -> Token a -> DepGenM ()
runFunctionIO_ f input = tellDep $ makeDependency input (FunctionIO f) NoToken
class TokenableTo t s | s -> t where
class (Show t, Typeable t) => TokenableTo t s | s -> t where
toToken :: s -> DepGenM (Token t)
tokenTypeRep :: s -> TypeRep t
instance TokenableTo a (Token a) where
instance (Show a, Typeable a) => TokenableTo a (Token a) where
toToken = pure
tokenTypeRep _ = typeRep
instance TokenableTo [a] [Token a] where
instance (Show a, Typeable a) => TokenableTo [a] [Token a] where
toToken = pure . ListToken
tokenTypeRep _ = typeRep
instance TokenableTo a (DepGenM (Token a)) where
instance (Show a, Typeable a) => TokenableTo a (DepGenM (Token a)) where
toToken = id
tokenTypeRep _ = typeRep
instance TokenableTo [a] [DepGenM (Token a)] where
instance (Show a, Typeable a) => TokenableTo [a] [DepGenM (Token a)] where
toToken = fmap ListToken . sequence
tokenTypeRep _ = typeRep
toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM (Token (ta, tb))
toTupleToken a b = TupleToken <$> toToken a <*> toToken b
mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM (Token b)) -> v -> DepGenM (Token [b])
mapDepGenM :: (TokenableTo [a] v, Typeable a, Show a, Typeable b, Show b) => (Token a -> DepGenM (Token b)) -> v -> DepGenM (Token [b])
mapDepGenM f input = do
input' <- toToken input
genDependencyM $ \target -> do
@@ -105,71 +111,87 @@ mapDepGenM f input = do
outp <- f inp
pure (inp, outp)
put top'
pure (makeDependency input' (MapComp subDeps (makeUToken innerInp) (makeUToken innerOutp)) target)
pure (makeDependency input' (MapComp typeRep typeRep subDeps innerInp innerOutp) target)
mapDepGenM_ :: TokenableTo [a] v => (Token a -> DepGenM ()) -> v -> DepGenM ()
mapDepGenM_ :: (TokenableTo [a] v, Typeable a, Show a) => (Token a -> DepGenM ()) -> v -> DepGenM ()
mapDepGenM_ f input = do
_ <- mapDepGenM (\x -> f x >> pure NoToken) input
pure ()
forDepGenM :: TokenableTo [a] v => v -> (Token a -> DepGenM (Token b)) -> DepGenM (Token [b])
forDepGenM :: (TokenableTo [a] v, Typeable a, Show a, Typeable b, Show b) => v -> (Token a -> DepGenM (Token b)) -> DepGenM (Token [b])
forDepGenM = flip mapDepGenM
forDepGenM_ :: TokenableTo [a] v => v -> (Token a -> DepGenM ()) -> DepGenM ()
forDepGenM_ :: (TokenableTo [a] v, Typeable a, Show a) => v -> (Token a -> DepGenM ()) -> DepGenM ()
forDepGenM_ = flip mapDepGenM_
filterDepGenM' :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM (Token [a])
filterDepGenM' :: (TokenableTo [Bool] v, TokenableTo [a] u, Typeable a, Show a) => v -> u -> DepGenM (Token [a])
filterDepGenM' mask input = do
tup <- toTupleToken input mask
genDependency (makeDependency tup FilterComp)
genDependency (makeDependency tup (FilterComp (unListType (tokenTypeRep input))))
filterDepGenM :: TokenableTo [a] v => (Token a -> DepGenM (Token Bool)) -> v -> DepGenM (Token [a])
filterDepGenM :: (TokenableTo [a] v, Typeable a, Show a) => (Token a -> DepGenM (Token Bool)) -> v -> DepGenM (Token [a])
filterDepGenM f input = do
mask <- mapDepGenM f input
filterDepGenM' mask input
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u) => v -> u -> DepGenM (Token [(a, b)])
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u, Typeable a, Show a, Typeable b, Show b) => v -> u -> DepGenM (Token [(a, b)])
zipDepGenM a b = do
a' <- toToken a
b' <- toToken b
pure $ ZipToken a' b'
untupleFstDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a)
untupleFstDepGenM :: (TokenableTo (a, b) t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token a)
untupleFstDepGenM t = do
t' <- toToken t
case t' of
TupleToken a _ -> pure a
Token _ -> genDependency (makeDependency t' UntupleFst)
TupleToken a _ ->
pure a
Token _ ->
let tr = tokenTypeRep t
(ta, tb) = unTupleType tr
in genDependency (makeDependency t' (UntupleFst ta tb))
untupleSndDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token b)
untupleSndDepGenM :: (TokenableTo (a, b) t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token b)
untupleSndDepGenM t = do
t' <- toToken t
case t' of
TupleToken _ b -> pure b
Token _ -> genDependency (makeDependency t' UntupleSnd)
TupleToken _ b ->
pure b
Token _ ->
let tr = tokenTypeRep t
(ta, tb) = unTupleType tr
in genDependency (makeDependency t' (UntupleSnd ta tb))
untupleDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a, Token b)
untupleDepGenM :: (TokenableTo (a, b) t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token a, Token b)
untupleDepGenM t = do
t' <- toToken t
a <- untupleFstDepGenM t'
b <- untupleSndDepGenM t'
pure (a, b)
unzipFstDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [a])
unzipFstDepGenM :: (TokenableTo [(a, b)] t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token [a])
unzipFstDepGenM t = do
t' <- toToken t
case t' of
ZipToken a _ -> pure a
_ -> genDependency (makeDependency t' UnzipFst)
ZipToken a _ ->
pure a
_ ->
let tr = tokenTypeRep t
(ta, tb) = unTupleType $ unListType tr
in genDependency (makeDependency t' (UnzipFst ta tb))
unzipSndDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [b])
unzipSndDepGenM :: (TokenableTo [(a, b)] t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token [b])
unzipSndDepGenM t = do
t' <- toToken t
case t' of
ZipToken _ b -> pure b
_ -> genDependency (makeDependency t' UnzipSnd)
ZipToken _ b ->
pure b
_ ->
let tr = tokenTypeRep t
(ta, tb) = unTupleType $ unListType tr
in genDependency (makeDependency t' (UnzipSnd ta tb))
unzipDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [a], Token [b])
unzipDepGenM :: (TokenableTo [(a, b)] t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token [a], Token [b])
unzipDepGenM t = do
t' <- toToken t
a <- unzipFstDepGenM t'

81
byg/src/DependencyRunner.hs
View File

@@ -1,12 +1,18 @@
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
module DependencyRunner
( DepRunM
, runDeps
, runDepRunMIO
) where
import Types (Value(..), fromValue, toValue, evalFunction, evalFunctionIO)
import Types (evalFunction, evalFunctionIO)
import Types.Value
import Types.Token
import Types.Dependency
import Type.Reflection (Typeable, TypeRep, typeRep, pattern App)
import Data.Map (Map)
import qualified Data.Map as M
import Control.Monad (void, forM)
@@ -30,7 +36,7 @@ evaluate = \case
NotEvaluated m -> m
runDep :: Dependency -> DepRunM ()
runDep (Dependency a action b) =
runDep (Dependency _ a action _ b) =
if actionTouchesFilesystem action
then void m
else putTokenValue b $ NotEvaluated m
@@ -46,61 +52,64 @@ runDep (Dependency a action b) =
putStrLn "----------"
pure result
foo' :: [Value] -> [Value] -> [(Value, Value)]
foo' = zip
foo :: Value -> Value -> Value
foo va vb = toValue $ foo' (fromValue va) (fromValue vb)
getTokenValue :: UToken -> DepRunM Value
getTokenValue = \case
UToken i -> do
getTokenValue :: (Typeable a, Show a) => Token a -> DepRunM Value
getTokenValue token = case token of
Token i -> do
m <- get
evaluate (m M.! i)
UTupleToken a b -> do
TupleToken a b -> do
va <- getTokenValue a
vb <- getTokenValue b
pure $ toValue (va, vb)
UZipToken a b -> do
pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb)
ZipToken a b -> do
va <- getTokenValue a
vb <- getTokenValue b
pure $ foo va vb
UListToken ts -> do
pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb)
ListToken ts -> do
vs <- mapM getTokenValue ts
pure $ toValue vs
UNoToken ->
pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
NoToken ->
pure $ toValue ()
putTokenValue :: UToken -> ValueExistence -> DepRunM ()
putTokenValue :: Token a -> ValueExistence -> DepRunM ()
putTokenValue t e = case t of
UToken i ->
Token i ->
modify $ M.insert i e
UNoToken ->
NoToken ->
pure ()
_ ->
error "unexpected"
tupApp :: TypeRep a -> TypeRep b -> TypeRep (a, b)
tupApp ta tb = App (App (typeRep @(,)) ta) tb
listApp :: TypeRep a -> TypeRep [a]
listApp ta = App (typeRep @[]) ta
runAction :: Action -> Value -> DepRunM Value
runAction action input = case action of
Function f ->
pure $ toValue $ evalFunction f $ fromValue input
InlineFunction ta tb (F f) ->
pure $ toValueRep tb $ f $ fromValueRep ta input
FunctionIO f ->
liftIO (toValue <$> evalFunctionIO f (fromValue input))
Inject v ->
pure v
FilterComp ->
let (vs, mask) = fromValue input :: ([Value], [Value])
in pure $ toValue $ map fst $ filter (fromValue . snd) $ zip vs mask
UntupleFst ->
pure $ fst (fromValue input :: (Value, Value))
UntupleSnd ->
pure $ snd (fromValue input :: (Value, Value))
UnzipFst ->
toValue <$> mapM (runAction UntupleFst) (fromValue input :: [Value])
UnzipSnd ->
toValue <$> mapM (runAction UntupleSnd) (fromValue input :: [Value])
MapComp subDeps innerInput innerOutput ->
(toValue <$>) $ forM (fromValue input :: [Value]) $ \v -> do
putTokenValue innerInput $ Evaluated v
FilterComp t ->
let tl = listApp t
(vs, mask) = fromValueRep (tupApp tl (typeRep @[Bool])) input
in pure $ toValueRep tl $ map fst $ filter snd $ zip vs mask
UntupleFst ta tb ->
pure $ toValueRep ta $ fst $ fromValueRep (tupApp ta tb) input
UntupleSnd ta tb ->
pure $ toValueRep tb $ snd $ fromValueRep (tupApp ta tb) input
UnzipFst ta tb ->
pure $ toValueRep (listApp ta) $ map fst $ fromValueRep (listApp (tupApp ta tb)) input
UnzipSnd ta tb ->
pure $ toValueRep (listApp tb) $ map snd $ fromValueRep (listApp (tupApp ta tb)) input
MapComp ta tb subDeps innerInput innerOutput ->
(toValueRep (listApp tb) <$>) $ forM (fromValueRep (listApp ta) input) $ \x -> do
putTokenValue innerInput $ Evaluated $ toValueRep ta x
runDeps subDeps
getTokenValue innerOutput
fromValueRep tb <$> getTokenValue innerOutput

6
byg/src/Functions/General.hs
View File

@@ -3,7 +3,7 @@ module Functions.General
( elemOf
) where
import Types (Valuable, IsFunction(..), Token)
import Types (IsFunction(..), Token)
import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction)
import Type.Reflection (Typeable, TypeRep, typeRep)
@@ -11,8 +11,8 @@ import Type.Reflection (Typeable, TypeRep, typeRep)
data ElemOf a where ElemOf :: TypeRep a -> ElemOf a
deriving instance Show (ElemOf a)
instance (Show a, Valuable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where
instance (Show a, Typeable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where
evalFunction (ElemOf _) (y, ys) = y `elem` ys
elemOf :: forall t a b. (Show t, Valuable t, Eq t, TokenableTo t a, TokenableTo [t] b, Typeable t) => a -> b -> DepGenM (Token Bool)
elemOf :: forall t a b. (Show t, Typeable t, Eq t, TokenableTo t a, TokenableTo [t] b, Typeable t) => a -> b -> DepGenM (Token Bool)
elemOf a b = runFunction (ElemOf (typeRep :: TypeRep t)) =<< toTupleToken a b

100
byg/src/Types/Dependency.hs
View File

@@ -1,10 +1,11 @@
{-# LANGUAGE GADTs #-}
module Types.Dependency
( Action(..)
, UToken(..)
, F(..)
, Dependency(..)
, makeDependency
, makeUToken
, unListType
, unTupleType
, actionTouchesFilesystem
, formatDependencyTrees
) where
@@ -13,102 +14,103 @@ import Types.Token (Token(..))
import Types.Value (Value)
import Types.Functions (IsFunction(), IsFunctionIO(..))
import Type.Reflection (Typeable, TypeRep, typeRep)
import Text.Printf (printf)
import Data.Text (Text)
import qualified Data.Text as T
data Action where
Function :: IsFunction f a b => f -> Action
InlineFunction :: Show b => TypeRep a -> TypeRep b -> F a b -> Action
FunctionIO :: IsFunctionIO f a b => f -> Action
Inject :: Value -> Action
FilterComp :: Action
UntupleFst :: Action
UntupleSnd :: Action
UnzipFst :: Action
UnzipSnd :: Action
MapComp :: [Dependency] -> UToken -> UToken -> Action
FilterComp :: Show a => TypeRep a -> Action
UntupleFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
UntupleSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
UnzipFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
UnzipSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
MapComp :: (Typeable a, Show a, Typeable b, Show b) => TypeRep a -> TypeRep b -> [Dependency] -> Token a -> Token b -> Action
deriving instance Show Action
data UToken = UToken Int
| UTupleToken UToken UToken
| UZipToken UToken UToken
| UListToken [UToken]
| UNoToken
deriving (Show)
newtype F a b = F (a -> b)
data Dependency = Dependency UToken Action UToken
deriving (Show)
instance Show (F a b) where
show = const "<function>"
makeDependency :: Token a -> Action -> Token b -> Dependency
makeDependency a action b = Dependency (makeUToken a) action (makeUToken b)
data Dependency where
Dependency :: (Typeable a, Show a) => TypeRep a -> Token a -> Action -> TypeRep b -> Token b -> Dependency
deriving instance Show Dependency
makeUToken :: Token a -> UToken
makeUToken = \case
Token i -> UToken i
TupleToken a b -> UTupleToken (makeUToken a) (makeUToken b)
ZipToken a b -> UZipToken (makeUToken a) (makeUToken b)
ListToken ts -> UListToken (map makeUToken ts)
NoToken -> UNoToken
makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action -> Token b -> Dependency
makeDependency a action b = Dependency typeRep a action typeRep b
unListType :: Typeable a => TypeRep [a] -> TypeRep a
unListType _ = typeRep
unTupleType :: (Typeable a, Typeable b) => TypeRep (a, b) -> (TypeRep a, TypeRep b)
unTupleType _ = (typeRep, typeRep)
actionTouchesFilesystem :: Action -> Bool
actionTouchesFilesystem = \case
Function _ -> False
InlineFunction _ _ _ -> False
FunctionIO f -> functionIOTouchesFilesystem f
Inject _ -> False
FilterComp -> False
UntupleFst -> False
UntupleSnd -> False
UnzipFst -> False
UnzipSnd -> False
MapComp subDeps _ _ -> any dependencyTouchesFilesystem subDeps
where dependencyTouchesFilesystem (Dependency _ action _) =
FilterComp _ -> False
UntupleFst _ _ -> False
UntupleSnd _ _ -> False
UnzipFst _ _ -> False
UnzipSnd _ _ -> False
MapComp _ _ subDeps _ _ -> any dependencyTouchesFilesystem subDeps
where dependencyTouchesFilesystem (Dependency _ _ action _ _) =
actionTouchesFilesystem action
formatDependencyTrees :: [Dependency] -> Text
formatDependencyTrees = T.concat . (formatDependencyTrees' "")
where formatDependencyTrees' indentation = concatMap (formatDependencyTree indentation)
formatDependencyTree indentation (Dependency a action b) =
formatDependencyTree indentation (Dependency _ a action _ b) =
concat [ [ indentation ]
, formatUToken a
, formatToken a
, [ " -> " ]
, formatUToken b
, formatToken b
, [ ": " ]
, formatAction indentation action
]
formatUToken = \case
UToken i ->
formatToken :: Token a -> [Text]
formatToken = \case
Token i ->
[ T.pack (printf "%03d" i) ]
UTupleToken a b ->
TupleToken a b ->
concat [ [ "tup(" ]
, formatUToken a
, formatToken a
, [ ", " ]
, formatUToken b
, formatToken b
, [ ")" ]
]
UZipToken a b ->
ZipToken a b ->
concat [ [ "zip(" ]
, formatUToken a
, formatToken a
, [ ", " ]
, formatUToken b
, formatToken b
, [ ")" ]
]
UListToken ts ->
ListToken ts ->
[ "["
, T.intercalate ", " (map (T.concat . formatUToken) ts)
, T.intercalate ", " (map (T.concat . formatToken) ts)
, "]"
]
UNoToken ->
NoToken ->
[ "--" ]
formatAction indentation = \case
MapComp subDeps innerInput innerOutput ->
MapComp _ _ subDeps innerInput innerOutput ->
concat [ [ "MapComp(" ]
, formatUToken innerInput
, formatToken innerInput
, [ " -> " ]
, formatUToken innerOutput
, formatToken innerOutput
, [ "):\n" ]
, formatDependencyTrees' (T.append indentation "| ") subDeps
]

6
byg/src/Types/Functions.hs
View File

@@ -4,11 +4,11 @@ module Types.Functions
, IsFunctionIO(..)
) where
import Types.Value (Valuable)
import Type.Reflection (Typeable)
class (Show f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where
class (Show f, Show a, Typeable a, Show b, Typeable b) => IsFunction f a b | f -> a b where
evalFunction :: f -> a -> b
class (Show f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where
class (Show f, Show a, Typeable a, Show b, Typeable b) => IsFunctionIO f a b | f -> a b where
evalFunctionIO :: f -> a -> IO b
functionIOTouchesFilesystem :: f -> Bool

14
byg/src/Types/Token.hs
View File

@@ -1,13 +1,19 @@
{-# LANGUAGE GADTs #-}
module Types.Token
( Token(..)
, tokenTypeRep
) where
import Type.Reflection (Typeable, TypeRep, typeRep)
data Token a where
Token :: Int -> Token a
TupleToken :: Token a -> Token b -> Token (a, b)
ZipToken :: Token [a] -> Token [b] -> Token [(a, b)]
ListToken :: [Token a] -> Token [a]
Token :: (Typeable a, Show a) => Int -> Token a
TupleToken :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Token b -> Token (a, b)
ZipToken :: (Typeable a, Show a, Typeable b, Show b) => Token [a] -> Token [b] -> Token [(a, b)]
ListToken :: (Typeable a, Show a) => [Token a] -> Token [a]
NoToken :: Token ()
deriving instance Show (Token a)
tokenTypeRep :: Typeable a => Token a -> TypeRep a
tokenTypeRep _ = typeRep

51
byg/src/Types/Value.hs
View File

@@ -1,9 +1,14 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
module Types.Value
( Value(..)
, Valuable(..)
, toValue
, toValueRep
, fromValue
, fromValueRep
) where
import Type.Reflection (TypeRep, typeRep, eqTypeRep)
import Data.Type.Equality ((:~~:)(HRefl))
import Data.Dynamic
data Value = Value { valueDynamic :: Dynamic
@@ -13,35 +18,21 @@ data Value = Value { valueDynamic :: Dynamic
instance Show Value where
show = valueShow
class Typeable a => Valuable a where
toValue :: a -> Value
fromValue :: Value -> a
fromDynRep :: TypeRep a -> Dynamic -> a
fromDynRep tr (Dynamic t v)
| Just HRefl <- t `eqTypeRep` tr = v
| otherwise = error ("unexpected; expected " ++ show tr ++ " but has " ++ show t)
toValueOnce :: (Typeable a, Show a) => a -> Value
toValueOnce x = Value { valueDynamic = toDyn x
, valueShow = show x
}
toValue :: (Show a, Typeable a) => a -> Value
toValue = toValueRep typeRep
fromValueOnce :: Typeable a => Value -> a
fromValueOnce = flip fromDyn (error "unexpected") . valueDynamic
toValueRep :: Show a => TypeRep a -> a -> Value
toValueRep tr a = Value { valueDynamic = Dynamic tr a
, valueShow = show a
}
instance Valuable Value where
toValue = id
fromValue = id
fromValue :: Typeable a => Value -> a
fromValue = fromValueRep typeRep
instance {-# OVERLAPPABLE #-} Valuable String where
toValue = toValueOnce
fromValue = fromValueOnce
instance {-# OVERLAPPABLE #-} Valuable a => Valuable [a] where
toValue = toValueOnce . map toValue
fromValue = map fromValue . fromValueOnce
instance {-# OVERLAPPABLE #-} (Valuable a, Valuable b) => Valuable (a, b) where
toValue (a, b) = toValueOnce (toValue a, toValue b)
fromValue v = let (va, vb) = fromValueOnce v
in (fromValue va, fromValue vb)
instance {-# OVERLAPPABLE #-} (Typeable a, Show a) => Valuable a where
toValue = toValueOnce
fromValue = fromValueOnce
fromValueRep :: TypeRep a -> Value -> a
fromValueRep tr = fromDynRep tr . valueDynamic