diff --git a/byg/src/DependencyGenerator.hs b/byg/src/DependencyGenerator.hs index d80d1f1..ccbff84 100644 --- a/byg/src/DependencyGenerator.hs +++ b/byg/src/DependencyGenerator.hs @@ -7,6 +7,7 @@ module DependencyGenerator , toTupleToken , evalDepGenM , inject + , onToken , runFunction , runFunctionIO , runFunctionIO_ @@ -27,7 +28,7 @@ module DependencyGenerator import Types.Token (Token(..)) import Types.Functions (IsFunction(), IsFunctionIO(..)) -import Types.Dependency (Action(..), Dependency, makeDependency) +import Types.Dependency (Action(..), F(..), Dependency, makeDependency) import Type.Reflection (Typeable, TypeRep, typeRep) import Control.Monad.State (MonadState, State, runState, put, get) @@ -68,6 +69,11 @@ genDependency f = genDependencyM (pure . f) inject :: (Show a, Typeable a) => a -> DepGenM (Token a) inject x = genDependency (makeDependency NoToken (Inject x)) +onToken :: (TokenableTo a t, Show a, Typeable a, Show b, Typeable b) => (a -> b) -> t -> DepGenM (Token b) +onToken f input = do + input' <- toToken input + genDependency (makeDependency input' (InlineFunction (F f))) + runFunction :: IsFunction f a b => f -> Token a -> DepGenM (Token b) runFunction f input = genDependency (makeDependency input (Function f)) diff --git a/byg/src/DependencyRunner.hs b/byg/src/DependencyRunner.hs index 6de640d..4ac2b6d 100644 --- a/byg/src/DependencyRunner.hs +++ b/byg/src/DependencyRunner.hs @@ -10,6 +10,7 @@ import Types.Value import Types.Token import Types.Dependency +import Type.Reflection (Typeable) import Data.Map (Map) import qualified Data.Map as M import Control.Monad (void, forM) @@ -49,24 +50,38 @@ runDep (Dependency _ a action _ b) = putStrLn "----------" pure result +getTokenValueByIndex :: Int -> DepRunM Value +getTokenValueByIndex i = do + m <- get + evaluate (m M.! i) + +getTokenValueRaw :: Token a -> DepRunM a +getTokenValueRaw token = case token of + Token i -> + fromValue <$> getTokenValueByIndex i + TupleToken a b -> do + (,) <$> getTokenValueRaw a <*> getTokenValueRaw b + ZipToken a b -> do + zip <$> getTokenValueRaw a <*> getTokenValueRaw b + ListToken ts -> do + mapM getTokenValueRaw ts + NoToken -> + pure () + getTokenValue :: Token a -> DepRunM Value getTokenValue token = case token of - Token i -> do - m <- get - evaluate (m M.! i) - TupleToken a b -> do - va <- getTokenValue a - vb <- getTokenValue b - pure $ toValueRep (tokenTypeRep token) (fromValue va, fromValue vb) - ZipToken a b -> do - va <- getTokenValue a - vb <- getTokenValue b - pure $ toValueRep (tokenTypeRep token) $ zip (fromValue va) (fromValue vb) - ListToken ts -> do - vs <- mapM getTokenValue ts - pure $ toValueRep (tokenTypeRep token) (map fromValue vs) + Token i -> + getTokenValueByIndex i + TupleToken _ _ -> + fromRaw token + ZipToken _ _ -> + fromRaw token + ListToken _ -> + fromRaw token NoToken -> - pure $ toValue () + fromRaw token + where fromRaw :: (Typeable a, Show a) => Token a -> DepRunM Value + fromRaw = fmap toValue . getTokenValueRaw putTokenValue :: Token a -> ValueExistence -> DepRunM () putTokenValue t e = case t of @@ -77,29 +92,34 @@ putTokenValue t e = case t of _ -> error "unexpected" -runAction :: Action a b -> Value -> DepRunM Value +runAction :: forall a b. Action a b -> Value -> DepRunM Value runAction action input = case action of Function f -> - pure $ toValue $ evalFunction f $ fromValue input + calc (evalFunction f) InlineFunction (F f) -> - pure $ toValue $ f $ fromValue input + calc f FunctionIO f -> - liftIO (toValue <$> evalFunctionIO f (fromValue input)) + calcM (liftIO . evalFunctionIO f) Inject x -> pure $ toValue x FilterComp -> - let (vs, mask) = fromValue input - in pure $ toValueRep (actionTargetType action) $ map fst $ filter snd $ zip vs mask + calc (\(vs, mask) -> map fst $ filter snd $ zip vs mask) UntupleFst -> - pure $ toValue $ fst $ fromValueRep (actionSourceType action) input + calc fst UntupleSnd -> - pure $ toValue $ snd $ fromValueRep (actionSourceType action) input + calc snd UnzipFst -> - pure $ toValue $ map fst $ fromValueRep (actionSourceType action) input + calc (map fst) UnzipSnd -> - pure $ toValue $ map snd $ fromValueRep (actionSourceType action) input + calc (map snd) MapComp subDeps innerInput innerOutput -> - (toValueRep (actionTargetType action) <$>) $ forM (fromValueRep (actionSourceType action) input) $ \x -> do + (toValueRep (actionTargetType action) <$>) + $ forM (fromValueRep (actionSourceType action) input) $ \x -> do putTokenValue innerInput $ Evaluated $ toValue x runDeps subDeps fromValue <$> getTokenValue innerOutput + where calcM :: (Typeable a, Typeable b, Show b) => (a -> DepRunM b) -> DepRunM Value + calcM f = toValue <$> (f $ fromValueRep (actionSourceType action) input) + + calc :: (Typeable a, Typeable b, Show b) => (a -> b) -> DepRunM Value + calc f = calcM (pure . f) diff --git a/byg/src/Functions/Pandoc.hs b/byg/src/Functions/Pandoc.hs index 0d121d3..f2bd9bf 100644 --- a/byg/src/Functions/Pandoc.hs +++ b/byg/src/Functions/Pandoc.hs @@ -4,8 +4,8 @@ module Functions.Pandoc , extractTitle ) where -import Types (IsFunction(..), Token) -import DependencyGenerator (DepGenM, TokenableTo(..), runFunction) +import Types (Token) +import DependencyGenerator (DepGenM, TokenableTo(..), onToken) import Data.Text (Text) import Text.Pandoc.Definition (Pandoc) @@ -18,31 +18,15 @@ runPandoc m = case P.runPure m of Left e -> error ("unexpected pandoc error: " ++ show e) Right result -> result -data ReadMarkdown = ReadMarkdown deriving Show -instance IsFunction ReadMarkdown Text Pandoc where - evalFunction ReadMarkdown contents = - let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] } - in runPandoc $ P.readMarkdown settings contents - readMarkdown :: TokenableTo Text a => a -> DepGenM (Token Pandoc) -readMarkdown a = runFunction ReadMarkdown =<< toToken a - - -data WriteHtml = WriteHtml deriving Show -instance IsFunction WriteHtml Pandoc Text where - evalFunction WriteHtml pandoc = - runPandoc - $ P.writeHtml5String P.def pandoc +readMarkdown = onToken $ \contents -> + let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] } + in runPandoc $ P.readMarkdown settings contents writeHtml :: TokenableTo Pandoc a => a -> DepGenM (Token Text) -writeHtml a = runFunction WriteHtml =<< toToken a - - -data ExtractTitle = ExtractTitle deriving Show -instance IsFunction ExtractTitle Pandoc Text where - evalFunction ExtractTitle (PD.Pandoc _ blocks) = case blocks of - (PD.Header 1 _ inlines : _) -> PS.stringify inlines - _ -> error "unexpected" +writeHtml = onToken $ \pandoc -> runPandoc $ P.writeHtml5String P.def pandoc extractTitle :: TokenableTo Pandoc a => a -> DepGenM (Token Text) -extractTitle a = runFunction ExtractTitle =<< toToken a +extractTitle = onToken $ \(PD.Pandoc _ blocks) -> case blocks of + (PD.Header 1 _ inlines : _) -> PS.stringify inlines + _ -> error "unexpected" diff --git a/byg/src/Types/Dependency.hs b/byg/src/Types/Dependency.hs index 9c9fe24..d8d5a1b 100644 --- a/byg/src/Types/Dependency.hs +++ b/byg/src/Types/Dependency.hs @@ -38,7 +38,7 @@ instance Show (F a b) where show = const "" data Dependency where - Dependency :: (Typeable a, Show a) => TypeRep a -> Token a -> Action a b -> TypeRep b -> Token b -> Dependency + Dependency :: TypeRep a -> Token a -> Action a b -> TypeRep b -> Token b -> Dependency deriving instance Show Dependency makeDependency :: (Typeable a, Show a, Typeable b, Show b) => Token a -> Action a b -> Token b -> Dependency diff --git a/byg/src/Types/Token.hs b/byg/src/Types/Token.hs index db3b3ab..31d8481 100644 --- a/byg/src/Types/Token.hs +++ b/byg/src/Types/Token.hs @@ -1,10 +1,9 @@ {-# LANGUAGE GADTs #-} module Types.Token ( Token(..) - , tokenTypeRep ) where -import Type.Reflection (Typeable, TypeRep, typeRep) +import Type.Reflection (Typeable) data Token a where Token :: (Typeable a, Show a) => Int -> Token a @@ -14,6 +13,3 @@ data Token a where NoToken :: Token () deriving instance Show (Token a) - -tokenTypeRep :: Typeable a => Token a -> TypeRep a -tokenTypeRep _ = typeRep