diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -2,38 +2,45 @@ {-# LANGUAGE TemplateHaskell #-} import Colog.Polysemy +import Colog.Polysemy.Formatting +import Composite.CoRecord import Composite.Record -import qualified Data.Attoparsec.Text as A +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.Resource import Polysemy.KVStore -import Polysemy.Output -import Polysemy.Video hiding (to) -import Polysemy.FSKVStore - -import FlashBlast.ClozeParse -import Control.Comonad.Env -import qualified FlashBlast.Config as Config -import Polysemy.Methodology.Composite -import FlashBlast.Conventions -import FlashBlast.Domain -import FlashBlast.ForvoClient hiding (id) -import FlashBlast.YouTubeDL -import Polysemy.FS -import Composite.CoRecord -import Optics import Polysemy.Methodology +import Polysemy.Methodology.Composite +import Polysemy.Output +import Polysemy.Resource import Polysemy.Tagged -import Polysemy.Http hiding (Path) +import Polysemy.Video hiding (to) +import Polysemy.Vinyl import RIO hiding (Builder, trace, log, Display, logInfo, over, to, view, @@ -43,17 +50,7 @@ import qualified RIO.Map as Map import qualified RIO.Text as T import qualified Text.Subtitles.SRT as SR -import Data.Vinyl.Functor -import Polysemy.Vinyl -import Data.Vinyl -import FlashBlast.VF -fromTime :: SR.Time -> Time -fromTime (SR.Time h m s f) = Time h m s f - -fromRange :: SR.Range -> Range -fromRange (SR.Range f t) = Range (fromTime f) (fromTime t) - interpretVideoSource :: Members '[Input Config.ResourceDirs, YouTubeDL] m => Config.VideoSource -> Sem m (Path Rel File) @@ -66,8 +63,7 @@ Config.ResourceDirs{..} <- input @Config.ResourceDirs return (_video x) -runExcerptSpecIO :: Members '[ Error SubtitleParseException - , FSExist +runExcerptSpecIO :: Members '[ FSExist , FSTemp , FSCopy , FSDir @@ -80,7 +76,7 @@ runExcerptSpecIO Config.ExcerptSpec {..} = do Config.ExportDirs{..} <- input @Config.ExportDirs t <- interpretVideoSource _source - s' <- either (throw . SubtitleParseException) return $ A.parseOnly SR.parseSRT _subs + 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' @@ -105,17 +101,10 @@ :& val @"back" (Audio e) :& RNil -newtype SubtitleParseException = SubtitleParseException String - deriving (Eq, Show, Generic) - -instance Exception SubtitleParseException - downloadMP3For :: Members '[ForvoClient] r => Locale -> Text -> Sem r (Maybe ByteString) -downloadMP3For l@(Locale l') t = do +downloadMP3For l t = do ForvoStandardPronunciationResponseBody {..} <- standardPronunciation l t - case items of - [] -> return Nothing - (x':_) -> Just <$> mP3For x' + traverse mP3For . headMaybe $ items getForvo :: Members '[ FSKVStore Rel ByteString , ForvoClient] r @@ -124,9 +113,7 @@ z <- lookupKV f case z of Just _ -> return () - Nothing -> do - x' <- downloadMP3For l t - updateKV f x' + Nothing -> downloadMP3For l t >>= updateKV f runMultiClozeSpecIO :: Members '[ Input Config.ResourceDirs , FSKVStore Rel ByteString @@ -140,24 +127,28 @@ -> Config.MultiClozeSpec -> Sem m [RPronunciationNote] runMultiClozeSpecIO f y s (Config.MultiClozeSpec p is) = do - forM p \a -> let (bs, cs) = genClozePhrase a - in do + forM p \a -> do + let (bs, cs) = genClozePhrase a Config.ResourceDirs {..} <- input - case (liftA2 (,) s y) of - Nothing -> return () - Just (Config.ForvoSpec l, k) -> do - (forM_ cs $ \x -> getForvo l x (_audio f x)) - & runForvoClient - & mapError @ForvoResponseNotUnderstood SomeException - & mapError @ForvoLimitReachedException SomeException - & mapError @ForvoAPIKeyIncorrectException SomeException - & runInputConst @ForvoAPIKey k + 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 +runPronunciationSpecIO :: Members '[ FSKVStore Rel ByteString + , Error HttpError + , Input Config.ResourceDirs + , Http (IO ByteString) + , Error SomeException] m => Maybe ForvoAPIKey - -> Config.PronunciationSpec - -> Sem m [RPronunciationNote] + -> Config.PronunciationSpec + -> Sem m [RPronunciationNote] runPronunciationSpecIO k (Config.PronunciationSpec f ms a) = fmap join $ forM ms $ runMultiClozeSpecIO f k a @@ -201,7 +192,7 @@ 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)] (join $ fmap getMedia as) +renderDeck x as = Deck [(x, renderNotes as)] (getMedia =<< as) type CardTypes = ['Minimal, 'Basic, 'Excerpt, 'Pronunciation] @@ -222,8 +213,8 @@ 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 +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)] @@ -241,6 +232,9 @@ & 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' @@ -251,7 +245,7 @@ & endRecInput & cutMethodology' @(Rec AnalysisF PartTypes) @(Rec StagingF PartTypes) - & runMethodologyRmap (onCompose (fmap Compose . fmap (uncurry env) . Map.toList)) + & runMethodologyRmap (onCompose (fmap (Compose . uncurry env) . Map.toList)) & stripRecTerminal & stripRecTerminal & stripRecTerminal @@ -310,9 +304,9 @@ & interpretFFMpegCli & interpretHttpNative & runFSKVStoreRelBS $(mkRelDir ".") - & runError @SubtitleParseException & runError @SomeException & runError @HttpError + & runLogAction (logTextStderr) & interpretLogNull & resourceToIO & runM diff --git a/flashblast.cabal b/flashblast.cabal --- a/flashblast.cabal +++ b/flashblast.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: flashblast -version: 0.0.8.0 +version: 0.0.9.0 synopsis: Generate language learning flashcards from video. author: Daniel Firth maintainer: dan.firth@homotopic.tech @@ -29,6 +29,8 @@ FlashBlast.Conventions FlashBlast.Domain FlashBlast.ForvoClient + FlashBlast.Messages + FlashBlast.Subtitles FlashBlast.VF FlashBlast.YouTubeDL other-modules: @@ -46,6 +48,8 @@ , comonad , composite-base , dhall + , either + , extra , first-class-families , formatting , generic-monoid @@ -99,6 +103,8 @@ , comonad , composite-base , dhall + , either + , extra , first-class-families , flashblast , formatting diff --git a/src/FlashBlast/Config.hs b/src/FlashBlast/Config.hs --- a/src/FlashBlast/Config.hs +++ b/src/FlashBlast/Config.hs @@ -6,6 +6,7 @@ import qualified Dhall as D import qualified Dhall.Deriving as D import FlashBlast.ForvoClient +import FlashBlast.Subtitles import FlashBlast.VF import Path import Path.Dhall () @@ -50,7 +51,7 @@ data ExcerptSpec = ExcerptSpec { _source :: VideoSource -, _subs :: Text +, _subs :: SRT , _clipf :: Text -> Path Rel File , _audiof :: Text -> Path Rel File , _framef :: Text -> Path Rel File @@ -80,7 +81,7 @@ instance D.FromDhall Speaker instance D.ToDhall Speaker -data ForvoSpec = ForvoSpec { +newtype ForvoSpec = ForvoSpec { _locale :: Locale } deriving stock (Eq, Generic, Show) deriving (D.FromDhall, D.ToDhall) diff --git a/src/FlashBlast/Conventions.hs b/src/FlashBlast/Conventions.hs --- a/src/FlashBlast/Conventions.hs +++ b/src/FlashBlast/Conventions.hs @@ -14,7 +14,6 @@ import RIO.List.Partial import qualified RIO.Text as T import qualified RIO.Text.Lazy as LT -import qualified RIO.Text.Partial as T withLensesAndProxies [d| type FFront = "front" :-> VF @@ -73,7 +72,7 @@ renderBasicReversedNote :: RBasicNote -> Text renderBasicReversedNote (a :*: b :*: c :*: d :*: RNil) - = T.intercalate "\t" $ [renderVF a,renderVF b,renderVF c,renderVF d] + = T.intercalate "\t" [renderVF a,renderVF b,renderVF c,renderVF d] class RenderVF a where renderVF :: a -> Text @@ -91,10 +90,7 @@ genForvos :: Text -> VFC -> [VF] -> RPronunciationNote genForvos x zs ys' = - let ys = lpadZipWith (\a _ -> case a of - Nothing -> Blank - Just a -> a - ) ys' (replicate 16 ()) + let ys = lpadZipWith (const . fromMaybe Blank) ys' (replicate 16 ()) ks = ys !! 0 :*: ys !! 1 :*: ys !! 2 :*: ys !! 3 :*: ys !! 4 :*: ys !! 5 :*: ys !! 6 :*: ys !! 7 :*: ys !! 8 :*: ys !! 9 :*: ys !! 10 :*: ys !! 11 diff --git a/src/FlashBlast/ForvoClient.hs b/src/FlashBlast/ForvoClient.hs --- a/src/FlashBlast/ForvoClient.hs +++ b/src/FlashBlast/ForvoClient.hs @@ -44,7 +44,7 @@ instance FromJSON ForvoPronunciationJson instance ToJSON ForvoPronunciationJson -data ForvoAttributeCount = ForvoAttributeCount { +newtype ForvoAttributeCount = ForvoAttributeCount { total :: Int } deriving (Eq, Show, Generic) @@ -106,7 +106,7 @@ instance Exception ForvoLimitReachedException where displayException = show -data ForvoLimitResponse = ForvoLimitResponse [ForvoLimitText] +newtype ForvoLimitResponse = ForvoLimitResponse [ForvoLimitText] deriving Generic instance FromJSON ForvoLimitResponse @@ -125,12 +125,12 @@ "Calling from incorrect domain." -> return ForvoIncorrectDomainText _ -> fail "Unknown response." -data ForvoIncorrectDomainResponse = ForvoIncorrectDomainResponse [ForvoIncorrectDomainText] +newtype ForvoIncorrectDomainResponse = ForvoIncorrectDomainResponse [ForvoIncorrectDomainText] deriving Generic instance FromJSON ForvoIncorrectDomainResponse -data ForvoResponseNotUnderstood = ForvoResponseNotUnderstood ByteString +newtype ForvoResponseNotUnderstood = ForvoResponseNotUnderstood ByteString deriving (Show, Eq, Generic) instance Exception ForvoResponseNotUnderstood where diff --git a/src/FlashBlast/Messages.hs b/src/FlashBlast/Messages.hs new file mode 100644 --- /dev/null +++ b/src/FlashBlast/Messages.hs @@ -0,0 +1,11 @@ +module FlashBlast.Messages where + +import Formatting +import RIO +import RIO.Text + +msgBuildingDeck :: Format r' (Text -> r') +msgBuildingDeck = "Building Deck: " % stext + +msgDeckComplete :: Format r' (Text -> r') +msgDeckComplete = "Deck Complete: " % stext diff --git a/src/FlashBlast/Subtitles.hs b/src/FlashBlast/Subtitles.hs new file mode 100644 --- /dev/null +++ b/src/FlashBlast/Subtitles.hs @@ -0,0 +1,40 @@ +module FlashBlast.Subtitles where + +import Dhall +import Text.Subtitles.SRT +import qualified Data.Attoparsec.Text as A +import RIO +import Data.Either.Validation +import qualified RIO.Text as T +import qualified Polysemy.Video as V + +newtype SRT = SRT [Line] + deriving (Eq, Show, Ord) + +instance FromDhall SRT where + autoWith options = srtDecoder options + +srtDecoder :: InputNormalizer -> Decoder SRT +srtDecoder opts = + Decoder + { extract = extractSrt + , expected = expectedSrt + } + where + textDecoder :: Decoder Text + textDecoder = autoWith opts + + extractSrt expression = + case extract textDecoder expression of + Success x -> case A.parseOnly parseSRT x of + Left exception -> Dhall.extractError (T.pack $ show exception) + Right path -> Success (SRT path) + Failure e -> Failure e + + expectedSrt = expected textDecoder + +fromTime :: Time -> V.Time +fromTime (Time h m s f) = V.Time h m s f + +fromRange :: Range -> V.Range +fromRange (Range f t) = V.Range (fromTime f) (fromTime t)