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

Use fewer explicit TypeRep's

Browse Source
This commit is contained in:
Niels G. W. Serup 2024-10-14 22:15:27 +02:00
parent b23aa99b15
commit d85243b1ba
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
3 changed files with 50 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
byg/src/DependencyGenerator.hs
View File

@ -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

50
byg/src/DependencyRunner.hs
View File

@ -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

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

@ -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
, [ " -> " ]