Make compile
This commit is contained in:
parent
2549d5af1b
commit
111fe3cee5
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 _ = "<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
|
||||
|
||||
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))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
143
byg/src/Main.hs
143
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 _ = "<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
|
||||
|
||||
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 "<html>"
|
||||
main = mapM_ print $ evalComputationM test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue