Use fewer explicit TypeRep's

2024-10-14 22:15:27 +02:00
parent b23aa99b15
commit d85243b1ba
3 changed files with 50 additions and 70 deletions
--- a/byg/src/DependencyGenerator.hs
+++ b/byg/src/DependencyGenerator.hs
@@ -26,9 +26,8 @@ module DependencyGenerator
  ) where

 import Types.Token (Token(..))
-import Types.Value
 import Types.Functions (IsFunction(), IsFunctionIO(..))
-import Types.Dependency (Action(..), Dependency, makeDependency, unListType, unTupleType)
+import Types.Dependency (Action(..), Dependency, makeDependency)

 import Type.Reflection (Typeable, TypeRep, typeRep)
 import Control.Monad.State (MonadState, State, runState, put, get)
@@ -67,7 +66,7 @@ genDependency :: (Typeable a, Show a) => (Token a -> Dependency) -> DepGenM (Tok
 genDependency f = genDependencyM (pure . f)

 inject :: (Show a, Typeable a) => a -> DepGenM (Token a)
-inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
+inject x = genDependency (makeDependency NoToken (Inject x))

 runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b)
 runFunction f input = genDependency (makeDependency input (Function f))
@@ -111,7 +110,7 @@ mapDepGenM f input = do
          outp <- f inp
          pure (inp, outp)
    put top'
-    pure (makeDependency input' (MapComp typeRep typeRep subDeps innerInp innerOutp) target)
+    pure (makeDependency input' (MapComp subDeps innerInp innerOutp) target)

 mapDepGenM_ :: (TokenableTo [a] v, Typeable a, Show a) => (Token a -> DepGenM ()) -> v -> DepGenM ()
 mapDepGenM_ f input = do
@@ -127,7 +126,7 @@ forDepGenM_ = flip mapDepGenM_
 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 (unListType (tokenTypeRep input))))
+  genDependency (makeDependency tup FilterComp)

 filterDepGenM :: (TokenableTo [a] v, Typeable a, Show a) => (Token a -> DepGenM (Token Bool)) -> v -> DepGenM (Token [a])
 filterDepGenM f input = do
@@ -147,9 +146,7 @@ untupleFstDepGenM t = do
    TupleToken a _ ->
      pure a
    Token _ ->
-      let tr = tokenTypeRep t
-          (ta, tb) = unTupleType tr
-      in genDependency (makeDependency t' (UntupleFst ta tb))
+      genDependency (makeDependency t' UntupleFst)

 untupleSndDepGenM :: (TokenableTo (a, b) t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token b)
 untupleSndDepGenM t = do
@@ -158,9 +155,7 @@ untupleSndDepGenM t = do
    TupleToken _ b ->
      pure b
    Token _ ->
-      let tr = tokenTypeRep t
-          (ta, tb) = unTupleType tr
-      in genDependency (makeDependency t' (UntupleSnd ta tb))
+      genDependency (makeDependency t' UntupleSnd)

 untupleDepGenM :: (TokenableTo (a, b) t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token a, Token b)
 untupleDepGenM t = do
@@ -176,9 +171,7 @@ unzipFstDepGenM t = do
    ZipToken a _ ->
      pure a
    _ ->
-      let tr = tokenTypeRep t
-          (ta, tb) = unTupleType $ unListType tr
-      in genDependency (makeDependency t' (UnzipFst ta tb))
+      genDependency (makeDependency t' UnzipFst)

 unzipSndDepGenM :: (TokenableTo [(a, b)] t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token [b])
 unzipSndDepGenM t = do
@@ -187,9 +180,7 @@ unzipSndDepGenM t = do
    ZipToken _ b ->
      pure b
    _ ->
-      let tr = tokenTypeRep t
-          (ta, tb) = unTupleType $ unListType tr
-      in genDependency (makeDependency t' (UnzipSnd ta tb))
+      genDependency (makeDependency t' UnzipSnd)

 unzipDepGenM :: (TokenableTo [(a, b)] t, Typeable a, Show a, Typeable b, Show b) => t -> DepGenM (Token [a], Token [b])
 unzipDepGenM t = do
--- a/byg/src/DependencyRunner.hs
+++ b/byg/src/DependencyRunner.hs
@@ -1,6 +1,4 @@
 {-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE PatternSynonyms #-}
 module DependencyRunner
  ( DepRunM
  , runDeps
@@ -12,7 +10,6 @@ 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)
@@ -52,7 +49,7 @@ runDep (Dependency _ a action _ b) =
            putStrLn "----------"
          pure result

-getTokenValue :: (Typeable a, Show a) => Token a -> DepRunM Value
+getTokenValue :: Token a -> DepRunM Value
 getTokenValue token = case token of
  Token i -> do
    m <- get
@@ -80,36 +77,29 @@ putTokenValue t e = case t of
  _ ->
    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 a b -> 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
+  InlineFunction (F f) ->
+    pure $ toValue $ f $ fromValue input
  FunctionIO f ->
    liftIO (toValue <$> evalFunctionIO f (fromValue input))
-  Inject v ->
-    pure 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
+  Inject x ->
+    pure $ toValue x
+  FilterComp ->
+    let (vs, mask) = fromValue input
+    in pure $ toValueRep (actionTargetType action) $ map fst $ filter snd $ zip vs mask
+  UntupleFst ->
+    pure $ toValue $ fst $ fromValueRep (actionSourceType action) input
+  UntupleSnd ->
+    pure $ toValue $ snd $ fromValueRep (actionSourceType action) input
+  UnzipFst ->
+    pure $ toValue $ map fst $ fromValueRep (actionSourceType action) input
+  UnzipSnd ->
+    pure $ toValue $ map snd $ fromValueRep (actionSourceType action) input
+  MapComp subDeps innerInput innerOutput ->
+    (toValueRep (actionTargetType action) <$>) $ forM (fromValueRep (actionSourceType action) input) $ \x -> do
+      putTokenValue innerInput $ Evaluated $ toValue x
      runDeps subDeps
-      fromValueRep tb <$> getTokenValue innerOutput
+      fromValue <$> getTokenValue innerOutput
--- a/byg/src/Types/Dependency.hs
+++ b/byg/src/Types/Dependency.hs
@@ -4,14 +4,13 @@ module Types.Dependency
  , F(..)
  , Dependency(..)
  , makeDependency
-  , unListType
-  , unTupleType
+  , actionSourceType
+  , actionTargetType
  , actionTouchesFilesystem
  , formatDependencyTrees
  ) where

 import Types.Token (Token(..))
-import Types.Value (Value)
 import Types.Functions (IsFunction(), IsFunctionIO(..))

 import Type.Reflection (Typeable, TypeRep, typeRep)
@@ -21,15 +20,15 @@ import qualified Data.Text as T

 data Action a b where
  Function :: IsFunction f a b => f -> Action a b
-  InlineFunction :: Show b => TypeRep a -> TypeRep b -> F a b -> Action a b
+  InlineFunction :: (Typeable a, Typeable b, Show b) => F a b -> Action a b
  FunctionIO :: IsFunctionIO f a b => f -> Action a b
-  Inject :: Value -> Action () a
-  FilterComp :: Show a => TypeRep a -> Action ([a], [Bool]) [a]
-  UntupleFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action (a, b) a
-  UntupleSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action (a, b) b
-  UnzipFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action [(a, b)] [a]
-  UnzipSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action [(a, b)] [b]
-  MapComp :: (Typeable a, Show a, Typeable b, Show b) => TypeRep a -> TypeRep b -> [Dependency] -> Token a -> Token b -> Action [a] [b]
+  Inject :: (Typeable a, Show a) => a -> Action () a
+  FilterComp :: (Typeable a, Show a) => Action ([a], [Bool]) [a]
+  UntupleFst :: (Typeable a, Show a, Typeable b, Show b) => Action (a, b) a
+  UntupleSnd :: (Typeable a, Show a, Typeable b, Show b) => Action (a, b) b
+  UnzipFst :: (Typeable a, Show a, Typeable b, Show b) => Action [(a, b)] [a]
+  UnzipSnd :: (Typeable a, Show a, Typeable b, Show b) => Action [(a, b)] [b]
+  MapComp :: (Typeable a, Show a, Typeable b, Show b) => [Dependency] -> Token a -> Token b -> Action [a] [b]

 deriving instance Show (Action a b)

@@ -45,24 +44,24 @@ deriving instance Show Dependency
 makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action a b -> Token b -> Dependency
 makeDependency a action b = Dependency typeRep a action typeRep b

-unListType :: Typeable a => TypeRep [a] -> TypeRep a
-unListType _ = typeRep
+actionSourceType :: Typeable a => Action a b -> TypeRep a
+actionSourceType _ = typeRep

-unTupleType :: (Typeable a, Typeable b) => TypeRep (a, b) -> (TypeRep a, TypeRep b)
-unTupleType _ = (typeRep, typeRep)
+actionTargetType :: Typeable b => Action a b -> TypeRep b
+actionTargetType _ = typeRep

 actionTouchesFilesystem :: Action a b -> Bool
 actionTouchesFilesystem = \case
  Function _ -> False
-  InlineFunction _ _ _ -> False
+  InlineFunction _ -> False
  FunctionIO f -> functionIOTouchesFilesystem f
  Inject _ -> False
-  FilterComp _ -> False
-  UntupleFst _ _ -> False
-  UntupleSnd _ _ -> False
-  UnzipFst _ _ -> False
-  UnzipSnd _ _ -> False
-  MapComp _ _ subDeps _ _ -> any dependencyTouchesFilesystem subDeps
+  FilterComp -> False
+  UntupleFst -> False
+  UntupleSnd -> False
+  UnzipFst -> False
+  UnzipSnd -> False
+  MapComp subDeps _ _ -> any dependencyTouchesFilesystem subDeps
  where dependencyTouchesFilesystem (Dependency _ _ action _ _) =
          actionTouchesFilesystem action

@@ -107,7 +106,7 @@ formatDependencyTrees = T.concat . (formatDependencyTrees' "")

        formatAction :: Text -> Action a b -> [Text]
        formatAction indentation = \case
-          MapComp _ _ subDeps innerInput innerOutput ->
+          MapComp subDeps innerInput innerOutput ->
            concat [ [ "MapComp(" ]
                   , formatToken innerInput
                   , [ " -> " ]