flashblast 0.0.8.0 → 0.0.9.0
raw patch · 7 files changed
+123/−75 lines, 7 filesdep +eitherdep +extra
Dependencies added: either, extra
Files
- app/Main.hs +56/−62
- flashblast.cabal +7/−1
- src/FlashBlast/Config.hs +3/−2
- src/FlashBlast/Conventions.hs +2/−6
- src/FlashBlast/ForvoClient.hs +4/−4
- src/FlashBlast/Messages.hs +11/−0
- src/FlashBlast/Subtitles.hs +40/−0
app/Main.hs view
@@ -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
flashblast.cabal view
@@ -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
src/FlashBlast/Config.hs view
@@ -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)
src/FlashBlast/Conventions.hs view
@@ -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
src/FlashBlast/ForvoClient.hs view
@@ -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
+ src/FlashBlast/Messages.hs view
@@ -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
+ src/FlashBlast/Subtitles.hs view
@@ -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)