flashblast-0.0.9.0: app/Main.hs
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TemplateHaskell #-}
import Colog.Polysemy
import Colog.Polysemy.Formatting
import Composite.CoRecord
import Composite.Record
import Control.Comonad.Env
import Control.Monad.Extra hiding (whenM)
import Data.Vinyl
import Data.Vinyl.Functor
import Fcf hiding (Map, Error)
import Fcf.Class.Functor hiding (Map)
import FlashBlast.ClozeParse
import qualified FlashBlast.Config as Config
import FlashBlast.Conventions
import FlashBlast.Domain
import FlashBlast.ForvoClient hiding (id)
import FlashBlast.Messages
import FlashBlast.Subtitles
import FlashBlast.VF
import FlashBlast.YouTubeDL
import qualified Formatting as F
import Data.Monoid.Generic
import qualified Dhall as D
import Optics
import Path
import Path.Dhall ()
import Path.Utils
import Polysemy
import Polysemy.Error as P
import Polysemy.FS
import Polysemy.FSKVStore
import Polysemy.Http hiding (Path)
import Polysemy.Input
import Polysemy.KVStore
import Polysemy.Methodology
import Polysemy.Methodology.Composite
import Polysemy.Output
import Polysemy.Resource
import Polysemy.Tagged
import Polysemy.Video hiding (to)
import Polysemy.Vinyl
import RIO hiding (Builder, trace, log, Display,
logInfo, over, to,
view,
writeFileUtf8,
(^.))
import RIO.List
import qualified RIO.Map as Map
import qualified RIO.Text as T
import qualified Text.Subtitles.SRT as SR
interpretVideoSource :: Members '[Input Config.ResourceDirs, YouTubeDL] m
=> Config.VideoSource
-> Sem m (Path Rel File)
interpretVideoSource = \case
Config.YouTubeDL (Config.YDLInfo x y f) -> do
Config.ResourceDirs{..} <- input @Config.ResourceDirs
youTubeDL' x (_video </> y) f
return (_video </> y)
Config.LocalVideo x -> do
Config.ResourceDirs{..} <- input @Config.ResourceDirs
return (_video </> x)
runExcerptSpecIO :: Members '[ FSExist
, FSTemp
, FSCopy
, FSDir
, Input Config.ExportDirs
, Input Config.ResourceDirs
, YouTubeDL
, ClipProcess] m
=> Config.ExcerptSpec
-> Sem m [RExcerptNote]
runExcerptSpecIO Config.ExcerptSpec {..} = do
Config.ExportDirs{..} <- input @Config.ExportDirs
t <- interpretVideoSource _source
let (SRT s') = _subs
let cs = map (_clipf . T.pack . show . SR.index) s'
let es = map (_audiof . T.pack . show . SR.index) s'
let fs = map (_framef . T.pack . show . SR.index) s'
cs' <- filterM (fmap not . doesFileExist . (_clips </>)) cs
es' <- filterM (fmap not . doesFileExist . (_audio </>)) es
h <- createTempDirectory
createDirectory _clips
createDirectory _audio
createDirectory _images
unless (null cs') $ do
extractClips t $ zip (fromRange . SR.range <$> s') (h </$> cs')
forM_ cs' $ \x -> copyFile (h </> x) (_clips </> x)
unless (null es') $ do
extractAudio t $ zip (fromRange . SR.range <$> s') (h </$> es)
forM_ es' $ \x -> copyFile (h </> x) (_audio </> x)
removeDirectory h
forM (zip4 s' cs es fs) $ \(l, c, e, f) -> do
whenM (fmap not . doesFileExist $ _images </> f) $
extractFrames (_clips </> c) [(Time 0 0 0 0, _images </> f)]
return $ val @"front" (RawText (fst . genClozePhrase . SR.dialog $ l))
:& val @"extra" (Multi [Image f])
:& val @"back" (Audio e)
:& RNil
downloadMP3For :: Members '[ForvoClient] r => Locale -> Text -> Sem r (Maybe ByteString)
downloadMP3For l t = do
ForvoStandardPronunciationResponseBody {..} <- standardPronunciation l t
traverse mP3For . headMaybe $ items
getForvo :: Members '[ FSKVStore Rel ByteString
, ForvoClient] r
=> Locale -> Text -> Path Rel File -> Sem r ()
getForvo l t f = do
z <- lookupKV f
case z of
Just _ -> return ()
Nothing -> downloadMP3For l t >>= updateKV f
runMultiClozeSpecIO :: Members '[ Input Config.ResourceDirs
, FSKVStore Rel ByteString
, Http (IO ByteString)
, Error HttpError
, Error SomeException
] m
=> (Text -> Path Rel File)
-> Maybe ForvoAPIKey
-> Maybe Config.ForvoSpec
-> Config.MultiClozeSpec
-> Sem m [RPronunciationNote]
runMultiClozeSpecIO f y s (Config.MultiClozeSpec p is) = do
forM p \a -> do
let (bs, cs) = genClozePhrase a
Config.ResourceDirs {..} <- input
P.catch (
whenJust (liftA2 (,) s y) \(Config.ForvoSpec l, k) ->
forM_ cs $ \x -> getForvo l x (_audio </> f x)
& runForvoClient
& mapError @ForvoResponseNotUnderstood SomeException
& mapError @ForvoLimitReachedException SomeException
& mapError @ForvoAPIKeyIncorrectException SomeException
& runInputConst @ForvoAPIKey k
) (\(_ :: SomeException) -> return ())
return $ genForvos bs (Multi $ map Image is) (map (Audio . f) cs)
runPronunciationSpecIO :: Members '[ FSKVStore Rel ByteString
, Error HttpError
, Input Config.ResourceDirs
, Http (IO ByteString)
, Error SomeException] m
=> Maybe ForvoAPIKey
-> Config.PronunciationSpec
-> Sem m [RPronunciationNote]
runPronunciationSpecIO k (Config.PronunciationSpec f ms a) =
fmap join $ forM ms $ runMultiClozeSpecIO f k a
data Deck = Deck {
notes :: Map (Path Rel File) Text
, media :: [Path Rel File]
} deriving stock (Eq, Show, Generic)
deriving Semigroup via GenericSemigroup Deck
deriving Monoid via GenericMonoid Deck
generateMinimalReversedNoteVF :: Config.MinimalReversedCard -> RMinimalNote
generateMinimalReversedNoteVF Config.MinimalReversedCard{..} = val @"front" _front
:& val @"back" _back
:& RNil
generateBasicReversed :: Config.BasicReversedCard -> RBasicNote
generateBasicReversed Config.BasicReversedCard{..} = val @"front" _front
:& val @"front-extra" _front_extra
:& val @"back" _back
:& val @"back-extra" _back_extra
:& RNil
extractParts :: Prism' Config.Spec x -> Config.Deck -> Map (Path Rel File) x
extractParts x = Map.fromList . itoListOf
( Config.parts
% itraversed
%> reindexed (view Config.outfile) selfIndex
% Config.spec
% x
)
type FileMap b = Map (Path b File)
renderNotes :: RenderNote a => [a] -> Text
renderNotes = T.intercalate "\n" . fmap renderNote
writeOutDeck :: Members '[Input Config.ExportDirs, FSDir, FSWrite] r => Deck -> Sem r ()
writeOutDeck Deck{..} = do
Config.ExportDirs{..} <- input @Config.ExportDirs
createDirectory _notes
forM_ (Map.toList notes) $ \(x, k) -> writeFileUtf8 (_notes </> x) k
renderDeck :: forall p. (HasMedia p, RenderNote p) => Path Rel File -> [p] -> Deck
renderDeck x as = Deck [(x, renderNotes as)] (getMedia =<< as)
type CardTypes = ['Minimal, 'Basic, 'Excerpt, 'Pronunciation]
type instance ConfigFor 'Minimal = Config.MinimalReversedCard
type instance ConfigFor 'Basic = Config.BasicReversedCard
type instance ConfigFor 'Excerpt = Config.ExcerptSpec
type instance ConfigFor 'Pronunciation = Config.PronunciationSpec
type instance ResultFor 'Minimal = RMinimalNote
type instance ResultFor 'Basic = RBasicNote
type instance ResultFor 'Excerpt = RExcerptNote
type instance ResultFor 'Pronunciation = RPronunciationNote
type PartTypes = Eval (FMap ConfigFor' CardTypes)
type NoteTypes = Eval (FMap ResultFor' CardTypes)
type AnalysisF = FileMap Rel :. []
type StagingF = [] :. Env (Path Rel File) :. []
type DiffractF = Env (Path Rel File) :. []
reduceStaging :: forall (c :: CardType) r a. ResultFor c ∈ NoteTypes
=> Sem (Methodology (StagingF (ConfigFor c)) [CoRec DiffractF NoteTypes] ': r) a
-> Sem (Methodology (DiffractF (ConfigFor c)) (DiffractF (ResultFor c)) ': r) a
reduceStaging = cutMethodology' @(StagingF (ConfigFor c))
@[DiffractF (ConfigFor c)]
>>> runMethodologyPure getCompose
>>> fmapMethodology'
>>> pickCoRecConstructor @(ResultFor c)
main :: IO ()
main = do
Config.FlashBlast{..} <- D.input D.auto "./index.dhall"
forM_ (Map.toList _decks) $ \(n, x) -> do
flashblast @Config.Deck @Deck
& untag @DeckConfiguration
& runInputConst x
& untag @CollectionsPackage
& runOutputSem writeOutDeck
& untag @ConstructionMethodology
& logMethodologyAround @Config.Deck @Deck
(const $ F.sformat msgBuildingDeck n)
(const $ F.sformat msgDeckComplete n)
& diffractMethodology' @Config.Deck @DiffractF @NoteTypes @Deck
& cutMethodology' @Config.Deck @(Rec AnalysisF PartTypes)
& runRecInitialAsInputCompose'
& stripRecInput
& stripRecInput
& stripRecInput
& stripRecInput
& endRecInput
& cutMethodology' @(Rec AnalysisF PartTypes)
@(Rec StagingF PartTypes)
& runMethodologyRmap (onCompose (fmap (Compose . uncurry env) . Map.toList))
& stripRecTerminal
& stripRecTerminal
& stripRecTerminal
& stripRecTerminal
& endRecTerminal
& stripRecInput
& stripRecInput
& stripRecInput
& stripRecInput
& endRecInput
& runInputCase' @RMinimalNote
(uncurry renderDeck . runEnv . getCompose)
& runInputCase' @RBasicNote
(uncurry renderDeck . runEnv . getCompose)
& runInputCase' @RExcerptNote
(uncurry renderDeck . runEnv . getCompose)
& runInputCase' @RPronunciationNote
(uncurry renderDeck . runEnv . getCompose)
& subsume
& runInputConstFC @Config.MinimalReversedCard
(Compose . extractParts Config._MinimalReversed)
& runInputConstFC @Config.BasicReversedCard
(Compose . extractParts Config._BasicReversed)
& runInputConstFC @Config.ExcerptSpec
(Compose . extractParts Config._Excerpt)
& runInputConstFC @Config.PronunciationSpec
(Compose . extractParts Config._Pronunciation)
& reduceStaging @'Minimal
& fmapMethodology' @DiffractF
& runMethodologyPure generateMinimalReversedNoteVF
& reduceStaging @'Basic
& fmapMethodology' @DiffractF
& runMethodologyPure generateBasicReversed
& reduceStaging @'Excerpt
& fmapCMethodology
& bindMethodology'
& runMethodologySem runExcerptSpecIO
& reduceStaging @'Pronunciation
& fmapCMethodology
& bindMethodology'
& runMethodologySem (runPronunciationSpecIO _forvoApiKey)
& runInputConst @Config.ExportDirs (view Config.exportDirs x)
& runInputConst @Config.ResourceDirs (view Config.resourceDirs x)
& runFSDir
& runFSCopy
& runFSTemp
& runFSExist
& runFSRead
& runFSWrite
& interpretYouTubeDL
& interpretFFMpegCli
& interpretHttpNative
& runFSKVStoreRelBS $(mkRelDir ".")
& runError @SomeException
& runError @HttpError
& runLogAction (logTextStderr)
& interpretLogNull
& resourceToIO
& runM