mad/byg/src/DependencyGenerator.hs

{-# LANGUAGE FunctionalDependencies #-}
module DependencyGenerator
  ( DepGenM
  , DepGenM'
  , evalDepGenM
  , inject
  , runFunction
  , runFunctionIO
  , mapDepGenM
  , mapDepGenM_
  , filterDepGenM
  , untupleFstDepGenM
  , untupleSndDepGenM
  , untupleDepGenM
  , unzipFstDepGenM
  , unzipSndDepGenM
  , unzipDepGenM

  , appendStrings
  , concatStrings
  , appendTexts
  , concatTexts
  , joinPaths
  , fileComponents
  , isImageExtension
  , applyTemplate
  , toText
  , listDirectory
  , readTemplate
  , convertImage
  , saveFile
  , copyFile
  , copyFile'
  , makeDir
  , runPandoc
  ) where

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)

import Control.Monad.State (MonadState, State, runState, put, get)
import Control.Monad.Writer (MonadWriter, WriterT, execWriterT, 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)

evalDepGenM' :: Int -> DepGenM () -> ([Dependency], Int)
evalDepGenM' top m = runState (execWriterT (unDepGenM m)) top

evalDepGenM :: DepGenM () -> [Dependency]
evalDepGenM m = fst (evalDepGenM' 0 m)

tellDep :: Dependency -> DepGenM ()
tellDep dep = tell [dep]

genDependencyM :: (Token a -> DepGenM Dependency) -> DepGenM' a
genDependencyM f = do
  top <- get
  let top' = top + 1
      target = Token top'
  put top'
  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)))

getListElem :: Token [a] -> DepGenM' a
getListElem outer = genDependency (makeDependency outer GetListElem)

setListElem :: Token a -> Token [a] -> DepGenM ()
setListElem a outer = do
  tellDep (makeDependency a SetListElem outer)

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

mapDepGenM :: (Token a -> DepGenM' b) -> Token [a] -> DepGenM' [b]
mapDepGenM f input = genDependencyM $ \target -> do
  top <- get
  let (res, top') = evalDepGenM' top $ do
        inp <- getListElem input
        outp <- f inp
        setListElem outp target
  put top'
  pure (makeDependency input (MapComp res) target)

mapDepGenM_ :: (Token a -> DepGenM ()) -> Token [a] -> DepGenM ()
mapDepGenM_ f input = do
  _ <- mapDepGenM (\x -> f x >> pure NoToken) input
  pure ()

filterDepGenM :: Token [Bool] -> Token [a] -> DepGenM' [a]
filterDepGenM mask input = do
  genDependency (makeDependency (TupleToken (input, mask)) FilterComp)

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
    Token _ -> 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
    Token _ -> 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)

class TokenableTo t s | s -> t where
  toToken :: s -> DepGenM' t

instance TokenableTo a (Token a) where
  toToken = pure

instance TokenableTo a (DepGenM' a) where
  toToken = id

appendStrings :: (TokenableTo String a, TokenableTo String b) => (a, b) -> DepGenM' String
appendStrings (a, b) = do
  a' <- toToken a
  b' <- toToken b
  runFunction AppendStrings $ TupleToken (a', 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) = do
  a' <- toToken a
  b' <- toToken b
  runFunction AppendTexts $ TupleToken (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) = do
  a' <- toToken a
  b' <- toToken b
  runFunction JoinPaths $ TupleToken (a', b')

fileComponents :: TokenableTo FilePath a => a -> DepGenM' (String, String)
fileComponents a = runFunction FileComponents =<< toToken a

isImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
isImageExtension a = runFunction IsImageExtension =<< toToken a

applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => (a, b) -> DepGenM' Text
applyTemplate (a, b) = do
  a' <- toToken a
  b' <- toToken b
  runFunction ApplyTemplate $ TupleToken (a', b')

toText :: TokenableTo String a => a -> DepGenM' Text
toText a = runFunction ToText =<< toToken a

listDirectory :: TokenableTo FilePath a => a -> DepGenM' [FilePath]
listDirectory a = runFunctionIO ListDirectory =<< toToken a

readTemplate :: TokenableTo FilePath a => a -> DepGenM' Template
readTemplate a = runFunctionIO ReadTemplate =<< toToken a

convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => (a, b) -> DepGenM ()
convertImage (a, b) = do
  a' <- toToken a
  b' <- toToken b
  runFunctionIO' ConvertImage $ TupleToken (a', b')

saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => (a, b) -> DepGenM ()
saveFile (a, b) = do
  a' <- toToken a
  b' <- toToken b
  runFunctionIO' SaveFile $ TupleToken (a', b')

copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => (a, b) -> DepGenM ()
copyFile (a, b) = do
  a' <- toToken a
  b' <- toToken b
  runFunctionIO' CopyFile $ TupleToken (a', b')

copyFile' :: Token (FilePath, FilePath) -> DepGenM ()
copyFile' = runFunctionIO' CopyFile

makeDir :: TokenableTo FilePath a => a -> DepGenM ()
makeDir a = runFunctionIO' MakeDir =<< toToken a

runPandoc :: TokenableTo FilePath a => a -> DepGenM' Text
runPandoc a = runFunctionIO RunPandoc =<< toToken a