mad/byg/src/DependencyGenerator.hs

{-# 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 = copyFile path (joinPaths targetDir path)