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

Try starting supporting inline functions 

Gets rid of UToken.
This commit is contained in:
Niels G. W. Serup 2024-10-14 20:41:42 +02:00
parent eae34707e9
commit f29dd6d299
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
7 changed files with 189 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
byg/src/DependencyGenerator.hs
View File

@ -26,10 +26,11 @@ module DependencyGenerator
) where ) where
import Types.Token (Token(..)) import Types.Token (Token(..))
import Types.Value (Valuable(..)) import Types.Value
import Types.Functions (IsFunction(), IsFunctionIO(..)) 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.State (MonadState, State, runState, put, get)
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell) import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
@ -47,7 +48,7 @@ evalDepGenM = snd . fst . runDepGenM 0
tellDep :: Dependency -> DepGenM () tellDep :: Dependency -> DepGenM ()
tellDep dep = tell [dep] tellDep dep = tell [dep]
newToken :: DepGenM (Token a) newToken :: (Typeable a, Show a) => DepGenM (Token a)
newToken = do newToken = do
top <- get top <- get
let top' = top + 1 let top' = top + 1
@ -55,17 +56,17 @@ newToken = do
put top' put top'
pure target 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 genDependencyM f = do
target <- newToken target <- newToken
result <- f target result <- f target
tellDep result tellDep result
pure target 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) 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))) inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b) 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_ :: IsFunctionIO f a () => f -> Token a -> DepGenM ()
runFunctionIO_ f input = tellDep $ makeDependency input (FunctionIO f) NoToken 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) 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 toToken = pure
tokenTypeRep _ = typeRep
instance TokenableTo [a] [Token a] where instance (Show a, Typeable a) => TokenableTo [a] [Token a] where
toToken = pure . ListToken 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 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 toToken = fmap ListToken . sequence
tokenTypeRep _ = typeRep
toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM (Token (ta, tb)) toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM (Token (ta, tb))
toTupleToken a b = TupleToken <$> toToken a <*> toToken b 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 mapDepGenM f input = do
input' <- toToken input input' <- toToken input
genDependencyM $ \target -> do genDependencyM $ \target -> do
@ -105,71 +111,87 @@ mapDepGenM f input = do
outp <- f inp outp <- f inp
pure (inp, outp) pure (inp, outp)
put top' 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_ f input = do
_ <- mapDepGenM (\x -> f x >> pure NoToken) input _ <- mapDepGenM (\x -> f x >> pure NoToken) input
pure () 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 = 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_ 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 filterDepGenM' mask input = do
tup <- toTupleToken input mask 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 filterDepGenM f input = do
mask <- mapDepGenM f input mask <- mapDepGenM f input
filterDepGenM' mask 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 zipDepGenM a b = do
a' <- toToken a a' <- toToken a
b' <- toToken b b' <- toToken b
pure $ ZipToken a' 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 untupleFstDepGenM t = do
t' <- toToken t t' <- toToken t
case t' of 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 untupleSndDepGenM t = do
t' <- toToken t t' <- toToken t
case t' of 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 untupleDepGenM t = do
t' <- toToken t t' <- toToken t
a <- untupleFstDepGenM t' a <- untupleFstDepGenM t'
b <- untupleSndDepGenM t' b <- untupleSndDepGenM t'
pure (a, b) 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 unzipFstDepGenM t = do
t' <- toToken t t' <- toToken t
case t' of 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 unzipSndDepGenM t = do
t' <- toToken t t' <- toToken t
case t' of 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 unzipDepGenM t = do
t' <- toToken t t' <- toToken t
a <- unzipFstDepGenM t' a <- unzipFstDepGenM t'

81
byg/src/DependencyRunner.hs
View File

@ -1,12 +1,18 @@
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PatternSynonyms #-}
module DependencyRunner module DependencyRunner
( DepRunM ( DepRunM
, runDeps , runDeps
, runDepRunMIO , runDepRunMIO
) where ) where
import Types (Value(..), fromValue, toValue, evalFunction, evalFunctionIO) import Types (evalFunction, evalFunctionIO)
import Types.Value
import Types.Token
import Types.Dependency import Types.Dependency
import Type.Reflection (Typeable, TypeRep, typeRep, pattern App)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Control.Monad (void, forM) import Control.Monad (void, forM)
@ -30,7 +36,7 @@ evaluate = \case
NotEvaluated m -> m NotEvaluated m -> m
runDep :: Dependency -> DepRunM () runDep :: Dependency -> DepRunM ()
runDep (Dependency a action b) = runDep (Dependency _ a action _ b) =
if actionTouchesFilesystem action if actionTouchesFilesystem action
then void m then void m
else putTokenValue b $ NotEvaluated m else putTokenValue b $ NotEvaluated m
@ -46,61 +52,64 @@ runDep (Dependency a action b) =
putStrLn "----------" putStrLn "----------"
pure result 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 m <- get
evaluate (m M.! i) evaluate (m M.! i)
UTupleToken a b -> do TupleToken a b -> do
va <- getTokenValue a va <- getTokenValue a
vb <- getTokenValue b 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 va <- getTokenValue a
vb <- getTokenValue b 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 vs <- mapM getTokenValue ts
pure $ toValue vs pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
UNoToken -> NoToken ->
pure $ toValue () pure $ toValue ()
putTokenValue :: UToken -> ValueExistence -> DepRunM () putTokenValue :: Token a -> ValueExistence -> DepRunM ()
putTokenValue t e = case t of putTokenValue t e = case t of
UToken i -> Token i ->
modify $ M.insert i e modify $ M.insert i e
UNoToken -> NoToken ->
pure () pure ()
_ -> _ ->
error "unexpected" 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 -> Value -> DepRunM Value
runAction action input = case action of runAction action input = case action of
Function f -> Function f ->
pure $ toValue $ evalFunction f $ fromValue input pure $ toValue $ evalFunction f $ fromValue input
InlineFunction ta tb (F f) ->
pure $ toValueRep tb $ f $ fromValueRep ta input
FunctionIO f -> FunctionIO f ->
liftIO (toValue <$> evalFunctionIO f (fromValue input)) liftIO (toValue <$> evalFunctionIO f (fromValue input))
Inject v -> Inject v ->
pure 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 runDeps subDeps
getTokenValue innerOutput fromValueRep tb <$> getTokenValue innerOutput

6
byg/src/Functions/General.hs
View File

@ -3,7 +3,7 @@ module Functions.General
( elemOf ( elemOf
) where ) where
import Types (Valuable, IsFunction(..), Token) import Types (IsFunction(..), Token)
import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction) import DependencyGenerator (DepGenM, TokenableTo(..), toTupleToken, runFunction)
import Type.Reflection (Typeable, TypeRep, typeRep) 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 data ElemOf a where ElemOf :: TypeRep a -> ElemOf a
deriving instance Show (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 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 elemOf a b = runFunction (ElemOf (typeRep :: TypeRep t)) =<< toTupleToken a b

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

@ -1,10 +1,11 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module Types.Dependency module Types.Dependency
( Action(..) ( Action(..)
, UToken(..) , F(..)
, Dependency(..) , Dependency(..)
, makeDependency , makeDependency
, makeUToken , unListType
, unTupleType
, actionTouchesFilesystem , actionTouchesFilesystem
, formatDependencyTrees , formatDependencyTrees
) where ) where
@ -13,102 +14,103 @@ import Types.Token (Token(..))
import Types.Value (Value) import Types.Value (Value)
import Types.Functions (IsFunction(), IsFunctionIO(..)) import Types.Functions (IsFunction(), IsFunctionIO(..))
import Type.Reflection (Typeable, TypeRep, typeRep)
import Text.Printf (printf) import Text.Printf (printf)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
data Action where data Action where
Function :: IsFunction f a b => f -> Action 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 FunctionIO :: IsFunctionIO f a b => f -> Action
Inject :: Value -> 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 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 :: Action -> Bool
actionTouchesFilesystem = \case actionTouchesFilesystem = \case
Function _ -> False Function _ -> False
InlineFunction _ _ _ -> False
FunctionIO f -> functionIOTouchesFilesystem f FunctionIO f -> functionIOTouchesFilesystem f
Inject _ -> False 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 actionTouchesFilesystem action
formatDependencyTrees :: [Dependency] -> Text formatDependencyTrees :: [Dependency] -> Text
formatDependencyTrees = T.concat . (formatDependencyTrees' "") formatDependencyTrees = T.concat . (formatDependencyTrees' "")
where formatDependencyTrees' indentation = concatMap (formatDependencyTree indentation) where formatDependencyTrees' indentation = concatMap (formatDependencyTree indentation)
formatDependencyTree indentation (Dependency a action b) = formatDependencyTree indentation (Dependency _ a action _ b) =
concat [ [ indentation ] concat [ [ indentation ]
, formatUToken a , formatToken a
, [ " -> " ] , [ " -> " ]
, formatUToken b , formatToken b
, [ ": " ] , [ ": " ]
, formatAction indentation action , formatAction indentation action
] ]
formatUToken = \case formatToken :: Token a -> [Text]
UToken i -> formatToken = \case
Token i ->
[ T.pack (printf "%03d" i) ] [ T.pack (printf "%03d" i) ]
UTupleToken a b -> TupleToken a b ->
concat [ [ "tup(" ] concat [ [ "tup(" ]
, formatUToken a , formatToken a
, [ ", " ] , [ ", " ]
, formatUToken b , formatToken b
, [ ")" ] , [ ")" ]
] ]
UZipToken a b -> ZipToken a b ->
concat [ [ "zip(" ] 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 formatAction indentation = \case
MapComp subDeps innerInput innerOutput -> MapComp _ _ subDeps innerInput innerOutput ->
concat [ [ "MapComp(" ] concat [ [ "MapComp(" ]
, formatUToken innerInput , formatToken innerInput
, [ " -> " ] , [ " -> " ]
, formatUToken innerOutput , formatToken innerOutput
, [ "):\n" ] , [ "):\n" ]
, formatDependencyTrees' (T.append indentation "| ") subDeps , formatDependencyTrees' (T.append indentation "| ") subDeps
] ]

6
byg/src/Types/Functions.hs
View File

@ -4,11 +4,11 @@ module Types.Functions
, IsFunctionIO(..) , IsFunctionIO(..)
) where ) 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 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 evalFunctionIO :: f -> a -> IO b
functionIOTouchesFilesystem :: f -> Bool functionIOTouchesFilesystem :: f -> Bool

14
byg/src/Types/Token.hs
View File

@ -1,13 +1,19 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
module Types.Token module Types.Token
( Token(..) ( Token(..)
, tokenTypeRep
) where ) where
import Type.Reflection (Typeable, TypeRep, typeRep)
data Token a where 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 () NoToken :: Token ()
deriving instance Show (Token a) deriving instance Show (Token a)
tokenTypeRep :: Typeable a => Token a -> TypeRep a
tokenTypeRep _ = typeRep

51
byg/src/Types/Value.hs
View File

@ -1,9 +1,14 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MonoLocalBinds #-}
module Types.Value module Types.Value
( Value(..) ( Value(..)
, Valuable(..) , toValue
, toValueRep
, fromValue
, fromValueRep
) where ) where
import Type.Reflection (TypeRep, typeRep, eqTypeRep)
import Data.Type.Equality ((:~~:)(HRefl))
import Data.Dynamic import Data.Dynamic
data Value = Value { valueDynamic :: Dynamic data Value = Value { valueDynamic :: Dynamic
@ -13,35 +18,21 @@ data Value = Value { valueDynamic :: Dynamic
instance Show Value where instance Show Value where
show = valueShow 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
toValueRep :: Show a => TypeRep a -> a -> Value
toValueRep tr a = Value { valueDynamic = Dynamic tr a
, valueShow = show a
} }
fromValueOnce :: Typeable a => Value -> a fromValue :: Typeable a => Value -> a
fromValueOnce = flip fromDyn (error "unexpected") . valueDynamic fromValue = fromValueRep typeRep
instance Valuable Value where fromValueRep :: TypeRep a -> Value -> a
toValue = id fromValueRep tr = fromDynRep tr . valueDynamic
fromValue = id
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