mad/byg/src/DependencyGenerator.hs

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

  , appendStrings
  , concatStrings
  , appendTexts
  , concatTexts
  , joinPaths
  , fileComponents
  , lowerString
  , elemOf
  , makeTemplate
  , applyTemplate
  , toText
  , listDirectory
  , isDirectory
  , readTextFile
  , convertImage
  , saveFile
  , copyFile
  , copyFile'
  , makeDir
  , runPandoc
  ) 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 ()

filterDepGenM :: (TokenableTo [Bool] v, TokenableTo [a] u) => v -> u -> DepGenM' [a]
filterDepGenM mask input = do
  tup <- toTupleToken input mask
  genDependency (makeDependency tup 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
    _ -> 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

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

convertImage :: (TokenableTo (FilePath, FilePath) a, TokenableTo ImageConversionSettings b) => a -> b -> DepGenM ()
convertImage a b = runFunctionIO' ConvertImage =<< toTupleToken a b

saveFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGenM ()
saveFile a b = runFunctionIO' SaveFile =<< 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