Try starting supporting inline functions

Gets rid of UToken.

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
+    TupleToken a _ ->
-    Token _ -> genDependency (makeDependency t' UntupleFst)
+      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
+    TupleToken _ b ->
-    Token _ -> genDependency (makeDependency t' UntupleSnd)
+      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
+    ZipToken a _ ->
-    _ -> genDependency (makeDependency t' UnzipFst)
+      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
+    ZipToken _ b ->
-    _ -> genDependency (makeDependency t' UnzipSnd)
+      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'

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)]
+getTokenValue :: (Typeable a, Show a) => Token a -> DepRunM Value
-foo' = zip
+getTokenValue token = case token of
-
+  Token i -> do
-foo :: Value -> Value -> Value
-foo va vb = toValue $ foo' (fromValue va) (fromValue vb)
-
-getTokenValue :: UToken -> DepRunM Value
-getTokenValue = \case
-  UToken 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)
+    pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb)
-  UZipToken a b -> do
+  ZipToken a b -> do
     va <- getTokenValue a
     vb <- getTokenValue b
-    pure $ foo va vb
+    pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb)
-  UListToken ts -> do
+  ListToken ts -> do
     vs <- mapM getTokenValue ts
-    pure $ toValue vs
+    pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
-  UNoToken ->
+  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 ->
+  FilterComp t ->
-    let (vs, mask) = fromValue input :: ([Value], [Value])
+    let tl = listApp t
-    in pure $ toValue $ map fst $ filter (fromValue . snd) $ zip vs mask
+        (vs, mask) = fromValueRep (tupApp tl (typeRep @[Bool])) input
-  UntupleFst ->
+    in pure $ toValueRep tl $ map fst $ filter snd $ zip vs mask
-    pure $ fst (fromValue input :: (Value, Value))
+  UntupleFst ta tb ->
-  UntupleSnd ->
+    pure $ toValueRep ta $ fst $ fromValueRep (tupApp ta tb) input
-    pure $ snd (fromValue input :: (Value, Value))
+  UntupleSnd ta tb ->
-  UnzipFst ->
+    pure $ toValueRep tb $ snd $ fromValueRep (tupApp ta tb) input
-    toValue <$> mapM (runAction UntupleFst) (fromValue input :: [Value])
+  UnzipFst ta tb ->
-  UnzipSnd ->
+    pure $ toValueRep (listApp ta) $ map fst $ fromValueRep (listApp (tupApp ta tb)) input
-    toValue <$> mapM (runAction UntupleSnd) (fromValue input :: [Value])
+  UnzipSnd ta tb ->
-  MapComp subDeps innerInput innerOutput ->
+    pure $ toValueRep (listApp tb) $ map snd $ fromValueRep (listApp (tupApp ta tb)) input
-    (toValue <$>) $ forM (fromValue input :: [Value]) $ \v -> do
+  MapComp ta tb subDeps innerInput innerOutput ->
-      putTokenValue innerInput $ Evaluated v
+    (toValueRep (listApp tb) <$>) $ forM (fromValueRep (listApp ta) input) $ \x -> do
+      putTokenValue innerInput $ Evaluated $ toValueRep ta x
       runDeps subDeps
-      getTokenValue innerOutput
+      fromValueRep tb <$> getTokenValue innerOutput

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

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
+  FilterComp :: Show a => TypeRep a -> Action
-  UntupleFst :: Action
+  UntupleFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
-  UntupleSnd :: Action
+  UntupleSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
-  UnzipFst :: Action
+  UnzipFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
-  UnzipSnd :: Action
+  UnzipSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
-  MapComp :: [Dependency] -> UToken -> UToken -> 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
+newtype F a b = F (a -> b)
-            | UTupleToken UToken UToken
-            | UZipToken UToken UToken
-            | UListToken [UToken]
-            | UNoToken
-  deriving (Show)
 
-data Dependency = Dependency UToken Action UToken
+instance Show (F a b) where
-  deriving (Show)
+  show = const "<function>"
 
-makeDependency :: Token a -> Action -> Token b -> Dependency
+data Dependency where
-makeDependency a action b = Dependency (makeUToken a) action (makeUToken b)
+  Dependency :: (Typeable a, Show a) => TypeRep a -> Token a -> Action -> TypeRep b -> Token b -> Dependency
+deriving instance Show Dependency
 
-makeUToken :: Token a -> UToken
+makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action -> Token b -> Dependency
-makeUToken = \case
+makeDependency a action b = Dependency typeRep a action typeRep b
-  Token i -> UToken i
+
-  TupleToken a b -> UTupleToken (makeUToken a) (makeUToken b)
+unListType :: Typeable a => TypeRep [a] -> TypeRep a
-  ZipToken a b -> UZipToken (makeUToken a) (makeUToken b)
+unListType _ = typeRep
-  ListToken ts -> UListToken (map makeUToken ts)
+
-  NoToken -> UNoToken
+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
+  FilterComp _ -> False
-  UntupleFst -> False
+  UntupleFst _ _ -> False
-  UntupleSnd -> False
+  UntupleSnd _ _ -> False
-  UnzipFst -> False
+  UnzipFst _ _ -> False
-  UnzipSnd -> False
+  UnzipSnd _ _ -> False
-  MapComp subDeps _ _ -> any dependencyTouchesFilesystem subDeps
+  MapComp _ _ subDeps _ _ -> any dependencyTouchesFilesystem subDeps
-  where dependencyTouchesFilesystem (Dependency _ action _) =
+  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
+        formatToken :: Token a -> [Text]
-          UToken i ->
+        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
                    ]

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

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
+  Token :: (Typeable a, Show a) => Int -> Token a
-  TupleToken :: Token a -> Token b -> Token (a, b)
+  TupleToken :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Token b -> Token (a, b)
-  ZipToken :: Token [a] -> Token [b] -> Token [(a, b)]
+  ZipToken :: (Typeable a, Show a, Typeable b, Show b) => Token [a] -> Token [b] -> Token [(a, b)]
-  ListToken :: [Token a] -> Token [a]
+  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

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
+fromDynRep :: TypeRep a -> Dynamic -> a
-  toValue :: a -> Value
+fromDynRep tr (Dynamic t v)
-  fromValue :: Value -> a
+  | Just HRefl <- t `eqTypeRep` tr = v
+  | otherwise = error ("unexpected; expected " ++ show tr ++ " but has " ++ show t)
 
-toValueOnce :: (Typeable a, Show a) => a -> Value
+toValue :: (Show a, Typeable a) => a -> Value
-toValueOnce x = Value { valueDynamic = toDyn x
+toValue = toValueRep typeRep
-                      , valueShow = show x
-                      }
 
-fromValueOnce :: Typeable a => Value -> a
+toValueRep :: Show a => TypeRep a -> a -> Value
-fromValueOnce = flip fromDyn (error "unexpected") . valueDynamic
+toValueRep tr a = Value { valueDynamic = Dynamic tr a
+                        , valueShow = show a
+                        }
 
-instance Valuable Value where
+fromValue :: Typeable a => Value -> a
-  toValue = id
+fromValue = fromValueRep typeRep
-  fromValue = id
 
-instance {-# OVERLAPPABLE #-} Valuable String where
+fromValueRep :: TypeRep a -> Value -> a
-  toValue = toValueOnce
+fromValueRep tr = fromDynRep tr . valueDynamic
-  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