285 lines
8.8 KiB
Haskell
285 lines
8.8 KiB
Haskell
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
module DependencyGenerator
|
|
( DepGenM
|
|
, DepGenM'
|
|
, evalDepGenM
|
|
, TokenableTo(..)
|
|
, inject
|
|
, runFunction
|
|
, runFunctionIO
|
|
, mapDepGenM
|
|
, mapDepGenM_
|
|
, forDepGenM
|
|
, forDepGenM_
|
|
, filterDepGenM
|
|
, filterDepGenM'
|
|
, zipDepGenM
|
|
, untupleFstDepGenM
|
|
, untupleSndDepGenM
|
|
, untupleDepGenM
|
|
, unzipFstDepGenM
|
|
, unzipSndDepGenM
|
|
, unzipDepGenM
|
|
|
|
, appendStrings
|
|
, concatStrings
|
|
, appendTexts
|
|
, concatTexts
|
|
, joinPaths
|
|
, fileComponents
|
|
, lowerString
|
|
, elemOf
|
|
, makeTemplate
|
|
, applyTemplate
|
|
, toText
|
|
, convertImage
|
|
|
|
, listDirectory
|
|
, isDirectory
|
|
, readTextFile
|
|
, openImage
|
|
, saveImage
|
|
, saveTextFile
|
|
, copyFile
|
|
, copyFile'
|
|
, makeDir
|
|
, runPandoc
|
|
|
|
, hasExtension
|
|
, copyTo
|
|
) where
|
|
|
|
import Prelude hiding (String, FilePath)
|
|
|
|
import Types.Token (Token(..))
|
|
import Types.Values
|
|
import Types.Value (Valuable(..))
|
|
import Types.Function (Function(..))
|
|
import Types.FunctionIO (FunctionIO(..))
|
|
import Types.Dependency (Action(..), Dependency, makeDependency, makeUToken)
|
|
|
|
import Control.Monad.State (MonadState, State, runState, put, get)
|
|
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
|
|
import Data.Text (Text)
|
|
|
|
newtype DepGenM a = DepGenM { unDepGenM :: WriterT [Dependency] (State Int) a }
|
|
deriving (Functor, Applicative, Monad, MonadState Int, MonadWriter [Dependency])
|
|
|
|
type DepGenM' a = DepGenM (Token a)
|
|
|
|
runDepGenM :: Int -> DepGenM a -> ((a, [Dependency]), Int)
|
|
runDepGenM top m = runState (runWriterT (unDepGenM m)) top
|
|
|
|
evalDepGenM :: DepGenM () -> [Dependency]
|
|
evalDepGenM = snd . fst . runDepGenM 0
|
|
|
|
tellDep :: Dependency -> DepGenM ()
|
|
tellDep dep = tell [dep]
|
|
|
|
newToken :: DepGenM' a
|
|
newToken = do
|
|
top <- get
|
|
let top' = top + 1
|
|
target = Token top'
|
|
put top'
|
|
pure target
|
|
|
|
genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM' a
|
|
genDependencyM f = do
|
|
target <- newToken
|
|
result <- f target
|
|
tellDep result
|
|
pure target
|
|
|
|
genDependency :: (Token a -> Dependency) -> DepGenM' a
|
|
genDependency f = genDependencyM (pure . f)
|
|
|
|
inject :: Valuable a => a -> DepGenM' a
|
|
inject x = genDependency (makeDependency NoToken (Inject (toValue x)))
|
|
|
|
runFunction :: Function -> Token a -> DepGenM' b
|
|
runFunction f input = genDependency (makeDependency input (Function f))
|
|
|
|
runFunctionIO :: FunctionIO -> Token a -> DepGenM' b
|
|
runFunctionIO f input = genDependency (makeDependency input (FunctionIO f))
|
|
|
|
runFunctionIO' :: FunctionIO -> Token a -> DepGenM ()
|
|
runFunctionIO' f input = tellDep $ makeDependency input (FunctionIO f) NoToken
|
|
|
|
class TokenableTo t s | s -> t where
|
|
toToken :: s -> DepGenM' t
|
|
|
|
instance TokenableTo a (Token a) where
|
|
toToken = pure
|
|
|
|
instance TokenableTo [a] [Token a] where
|
|
toToken = pure . ListToken
|
|
|
|
instance TokenableTo [a] [DepGenM' a] where
|
|
toToken = fmap ListToken . sequence
|
|
|
|
instance TokenableTo a (DepGenM' a) where
|
|
toToken = id
|
|
|
|
toTupleToken :: (TokenableTo ta a, TokenableTo tb b) => a -> b -> DepGenM' (ta, tb)
|
|
toTupleToken a b = TupleToken <$> toToken a <*> toToken b
|
|
|
|
mapDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' b) -> v -> DepGenM' [b]
|
|
mapDepGenM f input = do
|
|
input' <- toToken input
|
|
genDependencyM $ \target -> do
|
|
top <- get
|
|
let (((innerInp, innerOutp), subDeps), top') = runDepGenM top $ do
|
|
inp <- newToken
|
|
outp <- f inp
|
|
pure (inp, outp)
|
|
put top'
|
|
pure (makeDependency input' (MapComp subDeps (makeUToken innerInp) (makeUToken innerOutp)) target)
|
|
|
|
mapDepGenM_ :: TokenableTo [a] v => (Token a -> DepGenM ()) -> v -> DepGenM ()
|
|
mapDepGenM_ f input = do
|
|
_ <- mapDepGenM (\x -> f x >> pure NoToken) input
|
|
pure ()
|
|
|
|
forDepGenM :: TokenableTo [a] v => v -> (Token a -> DepGenM' b) -> DepGenM' [b]
|
|
forDepGenM = flip mapDepGenM
|
|
|
|
forDepGenM_ :: TokenableTo [a] v => v -> (Token a -> DepGenM ()) -> DepGenM ()
|
|
forDepGenM_ = flip mapDepGenM_
|
|
|
|
filterDepGenM' :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
|
|
filterDepGenM' mask input = do
|
|
tup <- toTupleToken input mask
|
|
genDependency (makeDependency tup FilterComp)
|
|
|
|
filterDepGenM :: TokenableTo [a] v => (Token a -> DepGenM' Bool) -> v -> DepGenM' [a]
|
|
filterDepGenM f input = do
|
|
mask <- mapDepGenM f input
|
|
filterDepGenM' mask input
|
|
|
|
zipDepGenM :: (TokenableTo [a] v, TokenableTo [b] u) => v -> u -> DepGenM' [(a, b)]
|
|
zipDepGenM a b = do
|
|
a' <- toToken a
|
|
b' <- toToken b
|
|
pure $ ZipToken a' b'
|
|
|
|
untupleFstDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a)
|
|
untupleFstDepGenM t = do
|
|
t' <- toToken t
|
|
case t' of
|
|
TupleToken a _ -> pure a
|
|
Token _ -> genDependency (makeDependency t' UntupleFst)
|
|
|
|
untupleSndDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token b)
|
|
untupleSndDepGenM t = do
|
|
t' <- toToken t
|
|
case t' of
|
|
TupleToken _ b -> pure b
|
|
Token _ -> genDependency (makeDependency t' UntupleSnd)
|
|
|
|
untupleDepGenM :: TokenableTo (a, b) t => t -> DepGenM (Token a, Token b)
|
|
untupleDepGenM t = do
|
|
t' <- toToken t
|
|
a <- untupleFstDepGenM t'
|
|
b <- untupleSndDepGenM t'
|
|
pure (a, b)
|
|
|
|
unzipFstDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [a])
|
|
unzipFstDepGenM t = do
|
|
t' <- toToken t
|
|
case t' of
|
|
ZipToken a _ -> pure a
|
|
_ -> genDependency (makeDependency t' UnzipFst)
|
|
|
|
unzipSndDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [b])
|
|
unzipSndDepGenM t = do
|
|
t' <- toToken t
|
|
case t' of
|
|
ZipToken _ b -> pure b
|
|
_ -> genDependency (makeDependency t' UnzipSnd)
|
|
|
|
unzipDepGenM :: TokenableTo [(a, b)] t => t -> DepGenM (Token [a], Token [b])
|
|
unzipDepGenM t = do
|
|
t' <- toToken t
|
|
a <- unzipFstDepGenM t'
|
|
b <- unzipSndDepGenM t'
|
|
pure (a, b)
|
|
|
|
appendStrings :: (TokenableTo String a, TokenableTo String b) => a -> b -> DepGenM' String
|
|
appendStrings a b = runFunction AppendStrings =<< TupleToken <$> toToken a <*> toToken b
|
|
|
|
concatStrings :: TokenableTo [String] a => a -> DepGenM' String
|
|
concatStrings a = runFunction ConcatStrings =<< toToken a
|
|
|
|
appendTexts :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM' Text
|
|
appendTexts a b = runFunction AppendTexts =<< toTupleToken a b
|
|
|
|
concatTexts :: TokenableTo [Text] a => a -> DepGenM' Text
|
|
concatTexts a = runFunction ConcatTexts =<< toToken a
|
|
|
|
joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM' FilePath
|
|
joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b
|
|
|
|
fileComponents :: TokenableTo FilePath a => a -> DepGenM' (String, String)
|
|
fileComponents a = runFunction FileComponents =<< toToken a
|
|
|
|
lowerString :: TokenableTo String a => a -> DepGenM' String
|
|
lowerString a = runFunction LowerString =<< toToken a
|
|
|
|
elemOf :: (TokenableTo String a, TokenableTo [String] b) => a -> b -> DepGenM' Bool
|
|
elemOf a b = runFunction ElemOf =<< toTupleToken a b
|
|
|
|
makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM' Template
|
|
makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b
|
|
|
|
applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGenM' Text
|
|
applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b
|
|
|
|
toText :: TokenableTo String a => a -> DepGenM' Text
|
|
toText a = runFunction ToText =<< toToken a
|
|
|
|
convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM' Image
|
|
convertImage a b = runFunction ConvertImage =<< toTupleToken a b
|
|
|
|
listDirectory :: TokenableTo FilePath a => a -> DepGenM' [FilePath]
|
|
listDirectory a = runFunctionIO ListDirectory =<< toToken a
|
|
|
|
isDirectory :: TokenableTo FilePath a => a -> DepGenM' Bool
|
|
isDirectory a = runFunctionIO IsDirectory =<< toToken a
|
|
|
|
readTextFile :: TokenableTo FilePath a => a -> DepGenM' Text
|
|
readTextFile a = runFunctionIO ReadTextFile =<< toToken a
|
|
|
|
openImage :: TokenableTo FilePath a => a -> DepGenM' Image
|
|
openImage a = runFunctionIO OpenImage =<< toToken a
|
|
|
|
saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
|
saveImage a b = runFunctionIO' SaveImage =<< toTupleToken a b
|
|
|
|
saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
|
saveTextFile a b = runFunctionIO' SaveTextFile =<< toTupleToken a b
|
|
|
|
copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
|
copyFile a b = runFunctionIO' CopyFile =<< toTupleToken a b
|
|
|
|
copyFile' :: Token (FilePath, FilePath) -> DepGenM ()
|
|
copyFile' = runFunctionIO' CopyFile
|
|
|
|
makeDir :: TokenableTo FilePath a => a -> DepGenM ()
|
|
makeDir a = runFunctionIO' MakeDir =<< toToken a
|
|
|
|
runPandoc :: TokenableTo Text a => a -> DepGenM' Text
|
|
runPandoc a = runFunctionIO RunPandoc =<< toToken a
|
|
|
|
|
|
hasExtension :: (TokenableTo [String] a, TokenableTo FilePath b) => a -> b -> DepGenM' Bool
|
|
hasExtension exts filename = do
|
|
ext <- lowerString $ untupleSndDepGenM $ fileComponents filename
|
|
ext `elemOf` exts
|
|
|
|
copyTo :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGenM ()
|
|
copyTo path targetDir = do
|
|
pathToken <- toToken path
|
|
copyFile pathToken (joinPaths targetDir pathToken)
|