diff --git a/byg/byg.cabal b/byg/byg.cabal index 79f4032..7d051d9 100644 --- a/byg/byg.cabal +++ b/byg/byg.cabal @@ -16,6 +16,10 @@ common common executable byg import: common main-is: Main.hs + other-modules: + Sources + Functions + ComputationM hs-source-dirs: src build-depends: base diff --git a/byg/src/ComputationM.hs b/byg/src/ComputationM.hs new file mode 100644 index 0000000..6b40f6f --- /dev/null +++ b/byg/src/ComputationM.hs @@ -0,0 +1,84 @@ +module ComputationM where + +import Unsafe.Coerce (unsafeCoerce) +import Control.Monad.State +import Control.Monad.Writer + +import Functions +import Sources + + +data ComputationRun a b = ComputationRun (Function a b) + | ComputationRunIO (FunctionIO a b) + + + +data TypedRun a b where + F :: Function a b -> TypedRun a b + FIO' :: IsFIO f a b => f -> TypedRun a b + FIO :: FunctionIO a b -> TypedRun a b + TInject :: b -> TypedRun () b + InList :: ComputationM TokenNotTraversable b -> TypedRun [a] [b] + +testtr = FIO' ListDirectory' + +instance Show (ComputationM t a) where + show _ = "" + +deriving instance (Show a, Show b) => Show (TypedRun a b) + +data Token t a where + Token :: Int -> Token t a + NoToken :: Token t () + +deriving instance Show (Token t a) + +data TokenTraversable +data TokenNotTraversable + +instance Functor (Token TokenTraversable) where + fmap f (Token n) = Token n + +instance Foldable (Token TokenTraversable) where + foldr f z (Token n) = z + +instance Traversable (Token TokenTraversable) where + traverse f (Token n) = (const (Token 33) <$> f (unsafeCoerce (Token n))) + +data Dependency ta a tb b = Dependency (Token ta a) (TypedRun a b) (Token tb b) + deriving (Show) + +data DependencyUntyped where + DependencyUntyped :: Dependency ta a tb b -> String -> DependencyUntyped + +instance Show DependencyUntyped where + show (DependencyUntyped _ s) = s + +newtype ComputationM' a = ComputationM { unComputationM :: WriterT [DependencyUntyped] (State Int) a } + deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [DependencyUntyped]) + +type ComputationM ta a = ComputationM' (Token ta a) + +evalComputationM m = evalState (execWriterT (unComputationM m)) 0 + +genDependency :: (Show u, Show a) => (Token ta a -> Dependency tu u ta a) -> ComputationM ta a +genDependency g = do + top <- get + let top' = top + 1 + target = Token top' + put top' + let result = g target + tell [DependencyUntyped result (show result)] + pure target + +inject :: Show a => a -> ComputationM ta a +inject x = genDependency (Dependency NoToken (TInject x)) + +runIO :: (Show a, Show b) => FunctionIO a b -> Token t a -> ComputationM TokenNotTraversable b +runIO f input = genDependency (Dependency input (FIO f)) + +makeTraversable :: Token TokenNotTraversable [a] -> Token TokenTraversable (Token TokenNotTraversable a) +makeTraversable (Token n) = Token n + +mapListTaken :: (Show a, Show b) => ComputationM TokenNotTraversable b -> Token TokenNotTraversable [a] -> ComputationM TokenNotTraversable [b] +mapListTaken f input = genDependency (Dependency input (InList f)) diff --git a/byg/src/Functions.hs b/byg/src/Functions.hs index c49fbfa..550fcb7 100644 --- a/byg/src/Functions.hs +++ b/byg/src/Functions.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} module Functions where +import Sources + data Image = Image deriving (Show) data ImageConversion = ImageConversion @@ -20,3 +22,9 @@ data FunctionIO a b where RunPandoc :: FunctionIO String String deriving instance Show (FunctionIO a b) + + +data ListDirectory' = ListDirectory' + deriving (Show) +instance IsFIO ListDirectory' FilePath [FilePath] where + runFIO ListDirectory' path = undefined diff --git a/byg/src/Main.hs b/byg/src/Main.hs index 046d887..5c3d2c5 100644 --- a/byg/src/Main.hs +++ b/byg/src/Main.hs @@ -1,97 +1,7 @@ -{-# LANGUAGE GADTs #-} module Main where --- import Data.Maybe (fromMaybe) --- import Data.Typeable (cast) -import Unsafe.Coerce (unsafeCoerce) -import Control.Monad.State -import Control.Monad.Writer - - --- data FlatComputation = Flat - --- handleImagesFlatManuallyWritten = --- [ (FlatRunIO ListDirectory, FlatInject "retter", TargetList 0) --- , (FlatRun IsImageFilename, FilteredList 0, TargetList 1) --- , (FlatRunIO OpenImage, EachOfList 1, Target 2) --- , (FlatPairWith ImageConversion, Source 2, Target 3) --- , (FlatRunIO ConvertImage, Source 3, Target 4) --- , ... --- ] - -data ComputationRun a b = ComputationRun (Function a b) - | ComputationRunIO (FunctionIO a b) - - -data ListDirectory' = ListDirectory' -instance IsFIO ListDirectory' FilePath [FilePath] where - runFIO ListDirectory' path = undefined - -data TypedRun a b where - F :: Function a b -> TypedRun a b - FIO' :: IsFIO f a b => f -> TypedRun a b - FIO :: FunctionIO a b -> TypedRun a b - TInject :: b -> TypedRun () b - InList :: ComputationM TokenNotTraversable b -> TypedRun [a] [b] - -testtr = FIO' ListDirectory' - -instance Show (ComputationM t a) where - show _ = "" - -deriving instance (Show a, Show b) => Show (TypedRun a b) - -data Token t a where - Token :: Int -> Token t a - NoToken :: Token t () - -deriving instance Show (Token t a) - -data TokenTraversable -data TokenNotTraversable - -instance Functor (Token TokenTraversable) where - fmap f (Token n) = Token n - -instance Foldable (Token TokenTraversable) where - foldr f z (Token n) = z - -instance Traversable (Token TokenTraversable) where - traverse f (Token n) = (const (Token 33) <$> f (unsafeCoerce (Token n))) - -data Dependency ta a tb b = Dependency (Token ta a) (TypedRun a b) (Token tb b) - deriving (Show) - -data DependencyUntyped where - DependencyUntyped :: Dependency ta a tb b -> String -> DependencyUntyped - -instance Show DependencyUntyped where - show (DependencyUntyped _ s) = s - -newtype ComputationM ta a = ComputationM { unComputationM :: WriterT [DependencyUntyped] (State Int) (Token ta a) } - deriving (Monad) - -genDependency :: (Show u, Show a) => (Token ta a -> Dependency tu u ta a) -> ComputationM ta a -genDependency g = do - top <- get - let top' = top + 1 - target = Token top' - put top' - let result = g target - tell [DependencyUntyped result (show result)] - pure target - -inject :: Show a => a -> ComputationM ta a -inject x = genDependency (Dependency NoToken (TInject x)) - -runIO :: (Show a, Show b) => FunctionIO a b -> Token t a -> ComputationM TokenNotTraversable b -runIO f input = genDependency (Dependency input (FIO f)) - -makeTraversable :: Token TokenNotTraversable [a] -> Token TokenTraversable (Token TokenNotTraversable a) -makeTraversable (Token n) = Token n - -mapListTaken :: ComputationM TokenNotTraversable b -> Token TokenNotTraversable [a] -> ComputationM TokenNotTraversable [b] -mapListTaken f input = genDependency (Dependency input (InList f)) +import Functions +import ComputationM test :: ComputationM TokenNotTraversable () test = do @@ -101,52 +11,5 @@ test = do u <- mapM (runIO OpenImage) dirContents' pure $ NoToken -test1 = mapM_ print $ evalState (execWriterT (unComputationM test)) 0 - --- monadTestHandleImages :: ComputationM () --- monadTestHandleImages = do --- dir <- inject "retter" --- dirContents <- runIO ListDirectory dir --- dirImagePaths <- filterM (run IsImageFilename) dirContents --- forM_ dirImagePaths $ \path -> do --- image <- runIO OpenImage path --- conv <- inject ImageConversion --- imageConverted <- runIO ConvertImage (image, conv) --- saveFilename <- run ConvertedImageFilename path --- runIO Save (image, saveFilename) - - - - - --- listDirectory :: FilePath -> IO [FilePath] --- listDirectory = undefined - --- isImageFilename :: FilePath -> Bool --- isImageFilename = undefined - --- data Computation a b = Data b --- | Pipe (Source a) (Target b) - --- instance Computation ListDirectory where --- Target [Source String] - --- buildRecipe dir = do --- files <- listDirectory dir --- let imageFiles = filter isImageFilename files --- images <- mapM (resizeImage . loadImage) imageFiles --- mapM (\(image, filename) -> (save (imageData image) (filename ^ "resized")) (zip images imageFiles) - --- buildIndex = do --- listDirectory - --- gen = do --- -- build "index.html" --- recipeDirs <- listDirectory "retter" --- mapM_ buildRecipe recipeDirs - --- main :: IO () --- main = runBygM gen - main :: IO () -main = putStrLn "" +main = mapM_ print $ evalComputationM test diff --git a/byg/src/Sources.hs b/byg/src/Sources.hs index 3bd7de7..7d70fc4 100644 --- a/byg/src/Sources.hs +++ b/byg/src/Sources.hs @@ -12,5 +12,5 @@ class SourceState a where instance SourceState FilePath where stateOfSource = undefined -class SourceState a => IsFIO f a b | f -> a b where +class (SourceState a, Show f) => IsFIO f a b | f -> a b where runFIO :: f -> a -> IO b