diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs index 16f42b5..cb23085 100644 --- a/byg/src/DependencyGenerator.hs +++ b/byg/src/DependencyGenerator.hs @@ -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' diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index 1d36ea7..2e48a6f 100644 --- a/byg/src/DependencyRunner.hs +++ b/byg/src/DependencyRunner.hs @@ -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 diff --git a/byg/src/Functions/General.hs b/byg/src/Functions/General.hs index f6ab01c..5b40ae3 100644 --- a/byg/src/Functions/General.hs +++ b/byg/src/Functions/General.hs @@ -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 diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs index 48ed13d..878107f 100644 --- a/byg/src/Types/Dependency.hs +++ b/byg/src/Types/Dependency.hs @@ -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 "" -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 ] diff --git a/byg/src/Types/Functions.hs b/byg/src/Types/Functions.hs index 0c903e4..b346421 100644 --- a/byg/src/Types/Functions.hs +++ b/byg/src/Types/Functions.hs @@ -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 diff --git a/byg/src/Types/Token.hs b/byg/src/Types/Token.hs index c6b5fb5..db3b3ab 100644 --- a/byg/src/Types/Token.hs +++ b/byg/src/Types/Token.hs @@ -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 diff --git a/byg/src/Types/Value.hs b/byg/src/Types/Value.hs index 3412f07..794158f 100644 --- a/byg/src/Types/Value.hs +++ b/byg/src/Types/Value.hs @@ -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