mad/byg/src/DependencyGenerator.hs

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

  , appendStrings
  , concatStrings
  , appendTexts
  , concatTexts
  , joinPaths
  , fileComponents
  , hasImageExtension
  , 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, 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

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 ()

filterDepGenM :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
filterDepGenM mask input = do
  mask' <- toToken mask
  input' <- toToken input
  genDependency (makeDependency (TupleToken (input', mask')) FilterComp)

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
    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

hasImageExtension :: TokenableTo FilePath a => a -> DepGenM' Bool
hasImageExtension a = runFunction HasImageExtension =<< 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