From d85243b1bab914aed081ea8dd90bbc000d875af4 Mon Sep 17 00:00:00 2001 From: "Niels G. W. Serup" Date: Mon, 14 Oct 2024 22:15:27 +0200 Subject: [PATCH] Use fewer explicit TypeRep's --- byg/src/DependencyGenerator.hs | 25 ++++++----------- byg/src/DependencyRunner.hs | 50 ++++++++++++++-------------------- byg/src/Types/Dependency.hs | 45 +++++++++++++++--------------- 3 files changed, 50 insertions(+), 70 deletions(-) diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs index cb23085..d80d1f1 100644 --- 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 diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index 832b08d..6de640d 100644 --- 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 diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs index 263a585..9c9fe24 100644 --- 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 , [ " -> " ]