Try starting supporting inline functions
Gets rid of UToken.
This commit is contained in:
parent
eae34707e9
commit
f29dd6d299
|
|
@ -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
|
||||
Token _ -> genDependency (makeDependency t' UntupleFst)
|
||||
TupleToken a _ ->
|
||||
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
|
||||
Token _ -> genDependency (makeDependency t' UntupleSnd)
|
||||
TupleToken _ b ->
|
||||
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
|
||||
_ -> genDependency (makeDependency t' UnzipFst)
|
||||
ZipToken a _ ->
|
||||
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
|
||||
_ -> genDependency (makeDependency t' UnzipSnd)
|
||||
ZipToken _ b ->
|
||||
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'
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
foo' = zip
|
||||
|
||||
foo :: Value -> Value -> Value
|
||||
foo va vb = toValue $ foo' (fromValue va) (fromValue vb)
|
||||
|
||||
getTokenValue :: UToken -> DepRunM Value
|
||||
getTokenValue = \case
|
||||
UToken i -> do
|
||||
getTokenValue :: (Typeable a, Show a) => Token a -> DepRunM Value
|
||||
getTokenValue token = case token of
|
||||
Token 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)
|
||||
UZipToken a b -> do
|
||||
pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb)
|
||||
ZipToken a b -> do
|
||||
va <- getTokenValue a
|
||||
vb <- getTokenValue b
|
||||
pure $ foo va vb
|
||||
UListToken ts -> do
|
||||
pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb)
|
||||
ListToken ts -> do
|
||||
vs <- mapM getTokenValue ts
|
||||
pure $ toValue vs
|
||||
UNoToken ->
|
||||
pure $ toValueRep (tokenTypeRep token) (map fromValue vs)
|
||||
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 ->
|
||||
let (vs, mask) = fromValue input :: ([Value], [Value])
|
||||
in pure $ toValue $ map fst $ filter (fromValue . snd) $ zip vs mask
|
||||
UntupleFst ->
|
||||
pure $ fst (fromValue input :: (Value, Value))
|
||||
UntupleSnd ->
|
||||
pure $ snd (fromValue input :: (Value, Value))
|
||||
UnzipFst ->
|
||||
toValue <$> mapM (runAction UntupleFst) (fromValue input :: [Value])
|
||||
UnzipSnd ->
|
||||
toValue <$> mapM (runAction UntupleSnd) (fromValue input :: [Value])
|
||||
MapComp subDeps innerInput innerOutput ->
|
||||
(toValue <$>) $ forM (fromValue input :: [Value]) $ \v -> do
|
||||
putTokenValue innerInput $ Evaluated 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
|
||||
runDeps subDeps
|
||||
getTokenValue innerOutput
|
||||
fromValueRep tb <$> getTokenValue innerOutput
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
UntupleFst :: Action
|
||||
UntupleSnd :: Action
|
||||
UnzipFst :: Action
|
||||
UnzipSnd :: Action
|
||||
MapComp :: [Dependency] -> UToken -> UToken -> Action
|
||||
FilterComp :: Show a => TypeRep a -> Action
|
||||
UntupleFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
|
||||
UntupleSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
|
||||
UnzipFst :: (Show a, Show b) => TypeRep a -> TypeRep b -> Action
|
||||
UnzipSnd :: (Show a, Show b) => TypeRep a -> TypeRep b -> 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
|
||||
| UTupleToken UToken UToken
|
||||
| UZipToken UToken UToken
|
||||
| UListToken [UToken]
|
||||
| UNoToken
|
||||
deriving (Show)
|
||||
newtype F a b = F (a -> b)
|
||||
|
||||
data Dependency = Dependency UToken Action UToken
|
||||
deriving (Show)
|
||||
instance Show (F a b) where
|
||||
show = const "<function>"
|
||||
|
||||
makeDependency :: Token a -> Action -> Token b -> Dependency
|
||||
makeDependency a action b = Dependency (makeUToken a) action (makeUToken b)
|
||||
data Dependency where
|
||||
Dependency :: (Typeable a, Show a) => TypeRep a -> Token a -> Action -> TypeRep b -> Token b -> Dependency
|
||||
deriving instance Show Dependency
|
||||
|
||||
makeUToken :: Token a -> UToken
|
||||
makeUToken = \case
|
||||
Token i -> UToken i
|
||||
TupleToken a b -> UTupleToken (makeUToken a) (makeUToken b)
|
||||
ZipToken a b -> UZipToken (makeUToken a) (makeUToken b)
|
||||
ListToken ts -> UListToken (map makeUToken ts)
|
||||
NoToken -> UNoToken
|
||||
makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action -> Token b -> Dependency
|
||||
makeDependency a action b = Dependency typeRep a action typeRep b
|
||||
|
||||
unListType :: Typeable a => TypeRep [a] -> TypeRep a
|
||||
unListType _ = typeRep
|
||||
|
||||
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
|
||||
UntupleFst -> False
|
||||
UntupleSnd -> False
|
||||
UnzipFst -> False
|
||||
UnzipSnd -> False
|
||||
MapComp subDeps _ _ -> any dependencyTouchesFilesystem subDeps
|
||||
where dependencyTouchesFilesystem (Dependency _ action _) =
|
||||
FilterComp _ -> False
|
||||
UntupleFst _ _ -> False
|
||||
UntupleSnd _ _ -> False
|
||||
UnzipFst _ _ -> False
|
||||
UnzipSnd _ _ -> False
|
||||
MapComp _ _ subDeps _ _ -> any dependencyTouchesFilesystem subDeps
|
||||
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
|
||||
UToken i ->
|
||||
formatToken :: Token a -> [Text]
|
||||
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
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
TupleToken :: Token a -> Token b -> Token (a, b)
|
||||
ZipToken :: Token [a] -> Token [b] -> Token [(a, b)]
|
||||
ListToken :: [Token a] -> Token [a]
|
||||
Token :: (Typeable a, Show a) => Int -> Token a
|
||||
TupleToken :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Token b -> Token (a, b)
|
||||
ZipToken :: (Typeable a, Show a, Typeable b, Show b) => Token [a] -> Token [b] -> Token [(a, b)]
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
toValue :: a -> Value
|
||||
fromValue :: Value -> a
|
||||
fromDynRep :: TypeRep a -> Dynamic -> a
|
||||
fromDynRep tr (Dynamic t v)
|
||||
| Just HRefl <- t `eqTypeRep` tr = v
|
||||
| otherwise = error ("unexpected; expected " ++ show tr ++ " but has " ++ show t)
|
||||
|
||||
toValueOnce :: (Typeable a, Show a) => a -> Value
|
||||
toValueOnce x = Value { valueDynamic = toDyn x
|
||||
, valueShow = show x
|
||||
toValue :: (Show a, Typeable a) => a -> Value
|
||||
toValue = toValueRep typeRep
|
||||
|
||||
toValueRep :: Show a => TypeRep a -> a -> Value
|
||||
toValueRep tr a = Value { valueDynamic = Dynamic tr a
|
||||
, valueShow = show a
|
||||
}
|
||||
|
||||
fromValueOnce :: Typeable a => Value -> a
|
||||
fromValueOnce = flip fromDyn (error "unexpected") . valueDynamic
|
||||
fromValue :: Typeable a => Value -> a
|
||||
fromValue = fromValueRep typeRep
|
||||
|
||||
instance Valuable Value where
|
||||
toValue = id
|
||||
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
|
||||
fromValueRep :: TypeRep a -> Value -> a
|
||||
fromValueRep tr = fromDynRep tr . valueDynamic
|
||||
|
|
|
|||
Loading…
Reference in New Issue