diff --git a/byg/src/Main.hs b/byg/src/Main.hs index 2e0e4d3..5eae78b 100644 --- a/byg/src/Main.hs +++ b/byg/src/Main.hs @@ -1,4 +1,219 @@ +{-# 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 Source a where + -- Void :: Source () + Data :: a -> Source a + +data Image = Image + deriving (Show) +data ImageConversion = ImageConversion + deriving (Show) + +data Function a b where + IsImageFilename :: Function FilePath Bool + ConvertedImageFilename :: Function FilePath FilePath + +deriving instance Show (Function a b) + +data FunctionIO a b where + ListDirectory :: FunctionIO FilePath [FilePath] + OpenImage :: FunctionIO FilePath Image + ConvertImage :: FunctionIO (Image, ImageConversion) Image + Save :: FunctionIO (a, FilePath) () + RunPandoc :: FunctionIO String String + +deriving instance Show (FunctionIO a b) + +data Computation a b where + Pipe :: Computation t u -> Computation u v -> Computation t v + Duplicate :: Computation t (t, t) + PairWith :: Computation t u -> Computation () u1 -> Computation t (u, u1) + TupleComputation :: Computation t0 u0 -> Computation t1 u1 -> Computation (t0, t1) (u0, u1) + -- OnFirst :: Computation t0 u0 -> Computation (t0, t1) (u0, u1) + -- OnSecond :: Computation t1 u1 -> Computation (t0, t1) (u0, u1) + MapComputation :: Computation t u -> Computation [t] [u] + MapUnit :: Computation [()] () + FilterComputation :: Computation t Bool -> Computation [t] [t] + Inject :: t -> Computation () t + Run :: Function t u -> Computation t u + RunIO :: FunctionIO t u -> Computation t u + +handleImages :: Computation () () +handleImages = + Inject "retter" + `Pipe` (RunIO ListDirectory) + `Pipe` FilterComputation (Run IsImageFilename) + `Pipe` MapComputation (Duplicate + `Pipe` (TupleComputation + (PairWith (RunIO OpenImage) (Inject ImageConversion) + `Pipe` RunIO ConvertImage) + (Run ConvertedImageFilename)) + `Pipe` RunIO Save) + `Pipe` MapUnit + + + +-- 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) + +class SourceState a where + stateOfSource :: a -> IO ByteString + -- makeChecker :: a -> IO (a -> Bool) + +instance SourceState FilePath where + stateOfSource = undefined + -- makeChecker = undefined + +class SourceState a => IsFIO f a b | f -> a b where + runFIO :: f -> a -> IO 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 + +--deriving instance Show DependencyUntyped + +-- showDU :: DependencyUntyped -> String +-- showDU (DependencyUntyped d) = show d + +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)) + +test :: ComputationM TokenNotTraversable () +test = do + dir <- inject "retter" + dirContents <- runIO ListDirectory dir + let dirContents' = makeTraversable dirContents + 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 ""