Add initial code approach exploration
For the historical record.
This commit is contained in:
215
byg/src/Main.hs
215
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 _ = "<computation>"
|
||||
|
||||
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 "<html>"
|
||||
|
||||
Reference in New Issue
Block a user