flashblast 0.0.1.1 → 0.0.4.0
raw patch · 11 files changed
+588/−207 lines, 11 filesdep +aesondep +co-log-polysemydep +co-log-polysemy-formattingdep ~polysemy-video
Dependencies added: aeson, co-log-polysemy, co-log-polysemy-formatting, http-conduit, polysemy-plugin, polysemy-zoo, temporary
Dependency ranges changed: polysemy-video
Files
- ChangeLog.md +13/−0
- app/Main.hs +188/−176
- flashblast.cabal +26/−7
- src/FlashBlast/AnkiDB.hs +6/−6
- src/FlashBlast/ClozeParse.hs +7/−7
- src/FlashBlast/Config.hs +122/−0
- src/FlashBlast/Conventions.hs +40/−11
- src/FlashBlast/FBFileSystem.hs +32/−0
- src/FlashBlast/ForvoClient.hs +93/−0
- src/FlashBlast/JSONFileStore.hs +43/−0
- src/FlashBlast/YouTubeDL.hs +18/−0
ChangeLog.md view
@@ -1,5 +1,18 @@ # Changelog for flashblast +## (v0.0.4.0)++* Add basic Forvo Client.+* Add dhall prelude.++## (v0.0.3.0)++* Add crude logic for not doing things twice. You will need to delete things in out/ if you want it to rerun.++## (v0.0.2.0)++* Add `,` and `-` as valid characters for a cloze.+ ## (v0.0.1.0) * Rough draft.
app/Main.hs view
@@ -1,103 +1,82 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE UndecidableInstances #-} import Composite.Record-import qualified Data.Attoparsec.Text as A-import Dhall hiding (embed, string)+import qualified Data.Attoparsec.Text as A+import qualified Dhall as D+import Network.HTTP.Simple import Path-import Path.Dhall ()+import Path.Dhall () import Path.Utils import Polysemy-import Polysemy.Error as P-import Polysemy.Reader+import Polysemy.Error as P+import Polysemy.Input+import Polysemy.KVStore+import Polysemy.Trace import Polysemy.Video -import Data.Align-import RIO hiding (Reader, ask, asks, many,- runReader)-import RIO.List-import RIO.List.Partial-import qualified RIO.Map as Map-import qualified RIO.Text as T-import qualified Text.Subtitles.SRT as SR-import qualified Turtle as S-import FlashBlast.AnkiDB import FlashBlast.ClozeParse+import FlashBlast.Config+import FlashBlast.FBFileSystem import FlashBlast.Conventions+import FlashBlast.ForvoClient+import FlashBlast.JSONFileStore+import FlashBlast.YouTubeDL+import Polysemy.State+import RIO hiding (Reader, ask, asks, log, many,+ runReader, trace)+import RIO.List+import qualified RIO.Map as Map+import qualified RIO.Text as T+import qualified Text.Subtitles.SRT as SR -data MultiClozeSpec = MultiClozeSpec {- phrases :: [Text]-, images :: [Path Rel File]-} deriving (Eq, Generic, Show) -instance FromDhall MultiClozeSpec--data YDLInfo = YDLInfo {- url :: Text-, out :: Path Rel File-, format :: Text-} deriving (Eq, Generic, Show)--instance FromDhall YDLInfo-data VideoSource = LocalVideo (Path Rel File) | YouTubeDL YDLInfo- deriving (Eq, Generic, Show)--instance FromDhall VideoSource--data ExcerptSpec = ExcerptSpec {- source :: VideoSource-, subs :: Text-, clipf :: Text -> Text-, audiof :: Text -> Text-, framef :: Text -> Text-} deriving Generic--instance FromDhall ExcerptSpec--data Locale = Locale Text- deriving (Eq, Show, Generic)--data ExportDirs = ExportDirs {- audio :: Path Rel Dir-, clips :: Path Rel Dir-, images :: Path Rel Dir-, notes :: Path Rel Dir-} deriving (Eq, Show, Generic)--instance FromDhall ExportDirs- 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) -data YouTubeDL m a where- YouTubeDL' :: Text -> Path Rel File -> Text -> YouTubeDL m ()--makeSem ''YouTubeDL--interpretYouTubeDL :: Member (Embed IO) effs => Sem (YouTubeDL ': effs) a -> Sem effs a-interpretYouTubeDL = interpret \case- YouTubeDL' x k f -> S.sh $ S.inproc "youtube-dl" [x, "-o", toFilePathText k, "-f", f] mempty+interpretVideoSource :: Members '[Input ResourceDirs, YouTubeDL] m => VideoSource -> Sem m (Path Rel File)+interpretVideoSource = \case+ YouTubeDL (YDLInfo x y f) -> do+ ResourceDirs{..} <- input @ResourceDirs+ youTubeDL' x (video </> y) f+ return (video </> y)+ LocalVideo x -> do+ ResourceDirs{..} <- input @ResourceDirs+ return (video </> x) -genExcerpts :: Members '[Error SomeException, YouTubeDL, ClipProcess, Reader ExportDirs] m => Path Rel Dir -> ExcerptSpec -> Sem m [RExcerptNote]-genExcerpts dir (ExcerptSpec {..}) = do- t <- case source of- YouTubeDL (YDLInfo x y f) -> do- youTubeDL' x (dir </> y) f- return (dir </> y)- LocalVideo x -> return (dir </> x)- ExportDirs{..} <- ask @ExportDirs- s' <- either (throwM . SubtitleParseException) return $ A.parseOnly SR.parseSRT subs- cs <- mapM (parseRelFile . T.unpack . clipf . T.pack . show . SR.index) s'- es <- mapM (parseRelFile . T.unpack . audiof . T.pack . show . SR.index) s'- fs <- mapM (parseRelFile . T.unpack . framef . T.pack . show . SR.index) s'- extractClips t $ zip (fromRange . SR.range <$> s') (clips </$> cs)- extractAudio t $ zip (fromRange . SR.range <$> s') (audio </$> es)+runExcerptSpecIO :: Members '[Error SubtitleParseException+ , FBFileSystem+ , Input ExportDirs+ , Input ResourceDirs+ , YouTubeDL+ , ClipProcess] m+ => ExcerptSpec -> Sem m [RExcerptNote]+runExcerptSpecIO ExcerptSpec {..} = do+ ExportDirs{..} <- input @ExportDirs+ t <- interpretVideoSource source+ s' <- either (throw . SubtitleParseException) return $ A.parseOnly SR.parseSRT 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- extractFrames (clips </> c) $ [(Time 0 0 0 0, images </> f)]+ whenM (fmap not . doesFileExist $ images </> f) $+ extractFrames (clips </> c) [(Time 0 0 0 0, images </> f)] return $ val @"front" (fst . genClozePhrase . SR.dialog $ l) :& val @"extra" f :& val @"back" e@@ -108,117 +87,150 @@ instance Exception SubtitleParseException -instance Member (Error SomeException) r => MonadThrow (Sem r) where- throwM e = P.throw (toException e)+type FSPKVStore = KVStore (Locale, Text) ForvoStandardPronunciationResponseBody -runExcerptSpecIO :: ResourceDirs -> ExportDirs -> [ExcerptSpec] -> Path Rel File -> IO ()-runExcerptSpecIO (ResourceDirs{..}) x xs out = do- zs <- sequenceA <$> forM xs \k -> do- runM . runError . runReader x . interpretYouTubeDL . interpretFFMpegCli $ genExcerpts video k- case zs of- Right a -> do- S.mktree . S.decodeString . toFilePath $ (notes x)- writeFileUtf8 (toFilePath (notes x </> out)) $ T.intercalate "\n" $ renderExcerptNote <$> join a- Left (SomeException p) -> throwIO p+downloadMP3For :: Members [FSPKVStore, ForvoClient, Trace] r => Locale -> Text -> Sem r (Maybe ByteString)+downloadMP3For l t = do+ a <- lookupKV @(Locale, Text) @ForvoStandardPronunciationResponseBody (l, t)+ case a of+ Just x -> do+ trace $ "Response for " <> show (l, t) <> " found in cache."+ p x+ Nothing -> do+ x <- standardPronunciation l t+ updateKV @(Locale, Text) @ForvoStandardPronunciationResponseBody (l,t) $ Just x+ p x+ where+ p :: Members '[ForvoClient, Trace] r => ForvoStandardPronunciationResponseBody -> Sem r (Maybe ByteString)+ p x = case items x of+ [] -> return Nothing+ (x':_) -> Just <$> mP3For x' -genForvos :: MonadThrow m => Locale -> Text -> [Path Rel File] -> [Text] -> m RForvoNote-genForvos (Locale l) x zs as = do- ys' <- mapM (forvoConvention l) as- let ys = lpadZipWith (\a _ -> if isJust a then a else Nothing) ys' (replicate 16 ())- let k = ys !! 0 :*: ys !! 1 :*: ys !! 2 :*: ys !! 3 :*: ys !! 4 :*: ys !! 5 :*: ys !! 6 :*: ys !! 7 :*: ys !! 8 :*: ys !! 9 :*: ys !! 10 :*: ys !! 11 :*: ys !! 12 :*: ys !! 13 :*: ys !! 14 :*: ys !! 15 :*: RNil- return $ x :*: zs :*: k+getForvo :: Members '[Trace, FBFileSystem, FSPKVStore, ForvoClient] r => Locale -> Text -> Path Rel File -> Sem r ()+getForvo l t f = do+ z <- doesFileExist f+ case z of+ True -> trace $ show f <> " already exists in filesystem."+ False -> do+ trace $ show f <> " not found in filesystem."+ x <- downloadMP3For l t+ case x of+ Just x' -> do+ createDirectory (parent f)+ writeFileBS f x'+ Nothing -> return () -runMultiClozeSpecIO :: Locale -> ResourceDirs -> ExportDirs -> [MultiClozeSpec] -> Path Rel File -> IO ()-runMultiClozeSpecIO l _ x xs out = do- zs <- forM xs \(MultiClozeSpec p f) -> do- forM p \a -> let (b, c) = genClozePhrase a- in genForvos l b f c- S.mktree . S.decodeString . toFilePath $ (notes x)- writeFileUtf8 (toFilePath (notes x </> out)) $ (T.intercalate "\n" $ renderForvoNote <$> join zs)+data Toggle a = Toggle Bool+ deriving (Eq, Show, Generic) -data ResourceDirs = ResourceDirs {- audio :: Path Rel Dir-, video :: Path Rel Dir-, images :: Path Rel Dir-} deriving (Eq, Show, Generic)+data ToggleKilled a = ToggleKilled+ deriving (Eq, Show, Generic) -instance FromDhall ResourceDirs+data ForvoEnabled -data Deck = Deck {- resourceDirs :: ResourceDirs-, exportDirs :: ExportDirs-, parts :: [Part]-} deriving Generic+errorKillsForvoToggle :: forall a e r b. Members '[State (Toggle a), Trace] r => Sem (Error e ': r) b -> Sem r ()+errorKillsForvoToggle = runError >=> \case+ Left _ -> do+ trace $ "Something went wrong with forvo. Turning forvo off for remainer of run."+ put @(Toggle a) $ Toggle False+ Right _ -> return () -data Part = Part {- outfile :: Path Rel File-, spec :: Spec-} deriving Generic -instance FromDhall Deck--instance FromDhall Part--data BasicReversedSpec = BasicReversedSpec {- from :: VF-, from_extra :: VF-, to :: VF-, to_extra :: VF-} deriving (Eq, Show, Generic)--instance FromDhall BasicReversedSpec--instance FromDhall Locale--data ForvoSpec = ForvoSpec {- locale :: Locale-, spec :: [MultiClozeSpec]-} deriving (Eq, Show, Generic)--instance FromDhall ForvoSpec-data Spec =- Forvo ForvoSpec- | Excerpt [ExcerptSpec]- | BasicReversed [BasicReversedSpec]- | MinimalReversed [MinimalReversedSpec]- deriving Generic--instance FromDhall Spec--data WonkyConfig = WonkyConfig {- decks :: Map Text Deck-} deriving Generic--instance FromDhall WonkyConfig+runMultiClozeSpecIO :: Members '[ RemoteHttpRequest+ , Trace+ , Input ResourceDirs+ , FBFileSystem+ , FSPKVStore+ , ForvoClient+ , State (Toggle ForvoEnabled)] m+ => (Text -> Path Rel File)+ -> Maybe ForvoSpec+ -> MultiClozeSpec+ -> Sem m [RForvoNote]+runMultiClozeSpecIO f s (MultiClozeSpec p is) = do+ ResourceDirs{..} <- input @ResourceDirs+ forM p \a -> do+ let (bs, cs) = genClozePhrase a+ Toggle k <- get @(Toggle ForvoEnabled)+ when k $ do+ forM_ s $ \(ForvoSpec l) ->+ forM cs $ \t -> getForvo l t (audio </> f t)+ return $ genForvos bs is (map f cs) -data MinimalReversedSpec = MinimalReversedSpec {- from :: VF-, to :: VF-} deriving (Eq, Show, Generic)+runPronunciationSpecIO :: Members '[ FBFileSystem+ , Trace+ , Input ResourceDirs+ , FSPKVStore+ , ForvoClient+ , State (Toggle ForvoEnabled)+ , RemoteHttpRequest] m+ => PronunciationSpec+ -> Sem m [RForvoNote]+runPronunciationSpecIO (PronunciationSpec f ms a) = do+ zs <- forM ms $ runMultiClozeSpecIO f a+ return $ join zs -instance FromDhall MinimalReversedSpec+runMinimalReversed :: MinimalReversedSpec -> Sem m RMinimalNoteVF+runMinimalReversed MinimalReversedSpec{..} = return $ val @"from" from :& val @"to" to :& RNil -runMinimalReversedIO :: ResourceDirs -> ExportDirs -> [MinimalReversedSpec] -> Path Rel File -> IO ()-runMinimalReversedIO _ x xs out = do- zs <- forM xs \MinimalReversedSpec{..} -> return $ val @"from" from :& val @"to" to :& RNil- S.mktree . S.decodeString . toFilePath $ notes x- writeFileUtf8 (toFilePath (notes x </> out)) $ (T.intercalate "\n" $ renderMinimalNoteVF <$> zs)+runBasicReversed :: BasicReversedSpec -> Sem m RBasicReversedNoteVF+runBasicReversed BasicReversedSpec{..} = return $ val @"from" from :& val @"from-extra" from_extra :& val @"to" to :& val @"to-extra" to_extra :& RNil -runBasicReversedIO :: ResourceDirs -> ExportDirs -> [BasicReversedSpec] -> Path Rel File -> IO ()-runBasicReversedIO ResourceDirs{..} x xs out = do- zs <- forM xs \BasicReversedSpec{..} -> return $ val @"from" from :& val @"from-extra" from_extra :& val @"to" to :& val @"to-extra" to_extra :& RNil- S.mktree . S.decodeString . toFilePath $ notes x- writeFileUtf8 (toFilePath (notes x </> out)) $ T.intercalate "\n" (renderBasicReversedNoteVF <$> zs)+runSomeSpec :: Members [ RemoteHttpRequest+ , Trace+ , FBFileSystem+ , ClipProcess+ , ForvoClient+ , State (Toggle ForvoEnabled)+ , Input ResourceDirs+ , Error SubtitleParseException+ , Input ExportDirs+ , YouTubeDL+ , FSPKVStore] m => Spec -> Sem m [SomeNote]+runSomeSpec p = case p of+ Excerpt xs -> fmap SomeNote <$> (join <$> mapM runExcerptSpecIO xs)+ Pronunciation xs -> fmap (fmap SomeNote) . runPronunciationSpecIO $ xs+ MinimalReversed xs -> mapM (fmap SomeNote . runMinimalReversed) xs+ BasicReversed xs -> mapM (fmap SomeNote . runBasicReversed) xs -runMakeDeck :: Deck -> IO ()+runMakeDeck :: Members [ RemoteHttpRequest+ , Trace+ , Error JSONException+ , FBFileSystem+ , ClipProcess+ , ForvoClient+ , State (Toggle ForvoEnabled)+ , Error SubtitleParseException+ , Error SomeException+ , YouTubeDL+ , FSPKVStore] m => Deck -> Sem m () runMakeDeck Deck{..} = do- forM_ parts \(Part a p) -> case p of- Excerpt x -> runExcerptSpecIO resourceDirs exportDirs x a- Forvo (ForvoSpec l x) -> runMultiClozeSpecIO l resourceDirs exportDirs x a- MinimalReversed x -> runMinimalReversedIO resourceDirs exportDirs x a- BasicReversed x -> runBasicReversedIO resourceDirs exportDirs x a+ let ExportDirs{..} = exportDirs+ runInputConst @ResourceDirs resourceDirs $+ runInputConst @ExportDirs exportDirs $+ forM_ parts \(Part out p) -> do+ x <- runSomeSpec p+ writeFileUTF8 (notes </> out) $ T.intercalate "\n" $ renderNote <$> x main :: IO () main = do- x <- input auto "./index.dhall"- mapM_ runMakeDeck $ fmap snd . Map.toList . decks $ x+ FlashBlastConfig{..} <- D.input D.auto "./index.dhall"+ x <- runM+ . traceToIO+ . evalState @(Toggle ForvoEnabled) (Toggle True)+ . runError @SomeException+ . mapError @JSONException SomeException+ . mapError @JSONParseException SomeException+ . mapError @SubtitleParseException SomeException+ . interpretFBFileSystem+ . errorKillsForvoToggle @ForvoEnabled @JSONException+ . interpretRemoteHttpRequest+ . interpretYouTubeDL+ . runInputConst (JSONFileStore $(mkRelFile ".forvocache"))+ . runKVStoreAsJSONFileStore+ . interpretFFMpegCli+ . runInputConst @ForvoAPIKey (maybe (ForvoAPIKey "") RIO.id forvoApiKey)+ . interpretForvoClient $ mapM_ runMakeDeck $ fmap snd . Map.toList $ decks+ case x of+ Left e -> throwIO e+ Right x' -> return x'
flashblast.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: flashblast-version: 0.0.1.1+version: 0.0.4.0 synopsis: Generate language learning flashcards from video. author: Daniel Firth maintainer: dan.firth@homotopic.tech@@ -25,30 +25,42 @@ exposed-modules: FlashBlast.AnkiDB FlashBlast.ClozeParse+ FlashBlast.Config FlashBlast.Conventions+ FlashBlast.FBFileSystem+ FlashBlast.ForvoClient+ FlashBlast.JSONFileStore+ FlashBlast.YouTubeDL other-modules: Paths_flashblast hs-source-dirs: src default-extensions: BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fplugin=Polysemy.Plugin build-depends:- attoparsec+ aeson+ , attoparsec , base >=4.7 && <5+ , co-log-polysemy+ , co-log-polysemy-formatting , composite-base , dhall , formatting+ , http-conduit , lucid , megaparsec , path , path-dhall-instance , path-utils , polysemy- , polysemy-video+ , polysemy-plugin+ , polysemy-video >=0.1.1.0+ , polysemy-zoo , replace-megaparsec , rio , semialign , subtitleParser+ , temporary , these , turtle , unliftio-path@@ -62,25 +74,32 @@ hs-source-dirs: app default-extensions: BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances ViewPatterns- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N build-depends:- attoparsec+ aeson+ , attoparsec , base >=4.7 && <5+ , co-log-polysemy+ , co-log-polysemy-formatting , composite-base , dhall , flashblast , formatting+ , http-conduit , lucid , megaparsec , path , path-dhall-instance , path-utils , polysemy- , polysemy-video+ , polysemy-plugin+ , polysemy-video >=0.1.1.0+ , polysemy-zoo , replace-megaparsec , rio , semialign , subtitleParser+ , temporary , these , turtle , unliftio-path
src/FlashBlast/AnkiDB.hs view
@@ -1,12 +1,12 @@+{-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE PolyKinds #-} module FlashBlast.AnkiDB where -import Polysemy-import Polysemy.Reader-import RIO hiding (Reader, asks)-import UnliftIO.Path.Directory-import Path+import Path+import Polysemy+import Polysemy.Reader+import RIO hiding (Reader, asks)+import UnliftIO.Path.Directory data AnkiDB m a where CopyToCollections :: [Path Rel File] -> AnkiDB m ()
src/FlashBlast/ClozeParse.hs view
@@ -1,14 +1,14 @@ module FlashBlast.ClozeParse where -import RIO hiding (many)-import RIO.State-import qualified RIO.Text as T-import Replace.Megaparsec-import Text.Megaparsec hiding (State)-import Text.Megaparsec.Char+import Replace.Megaparsec+import RIO hiding (many)+import RIO.State+import qualified RIO.Text as T+import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char bracevar :: ParsecT Void Text m Text-bracevar = between (string "{{") (string "}}") (T.pack <$> many (alphaNumChar <|> spaceChar <|> char '\''))+bracevar = between (string "{{") (string "}}") (T.pack <$> many (alphaNumChar <|> spaceChar <|> char '\'' <|> char '-' <|> char ',')) addClozeNumbers :: Text -> State Int Text addClozeNumbers x = do
+ src/FlashBlast/Config.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module FlashBlast.Config where++import qualified Dhall as D+import FlashBlast.Conventions+import FlashBlast.ForvoClient+import Path+import Path.Dhall ()+import RIO+++data MultiClozeSpec = MultiClozeSpec {+ phrases :: [Text]+, images :: [Path Rel File]+} deriving (Eq, Generic, Show)++instance D.FromDhall MultiClozeSpec++data YDLInfo = YDLInfo {+ url :: Text+, out :: Path Rel File+, format :: Text+} deriving (Eq, Generic, Show)++instance D.FromDhall YDLInfo++data ResourceDirs = ResourceDirs {+ audio :: Path Rel Dir+, video :: Path Rel Dir+, images :: Path Rel Dir+} deriving (Eq, Show, Generic)++instance D.FromDhall ResourceDirs++data VideoSource = LocalVideo (Path Rel File) | YouTubeDL YDLInfo+ deriving (Eq, Generic, Show)++instance D.FromDhall VideoSource++data ExcerptSpec = ExcerptSpec {+ source :: VideoSource+, subs :: Text+, clipf :: Text -> Path Rel File+, audiof :: Text -> Path Rel File+, framef :: Text -> Path Rel File+} deriving Generic++instance D.FromDhall ExcerptSpec++data ExportDirs = ExportDirs {+ audio :: Path Rel Dir+, clips :: Path Rel Dir+, images :: Path Rel Dir+, notes :: Path Rel Dir+} deriving (Eq, Show, Generic)++instance D.FromDhall ExportDirs++instance D.FromDhall ForvoAPIKey++data Deck = Deck {+ resourceDirs :: ResourceDirs+, exportDirs :: ExportDirs+, parts :: [Part]+} deriving Generic++data Part = Part {+ outfile :: Path Rel File+, spec :: Spec+} deriving Generic++instance D.FromDhall Deck++instance D.FromDhall Part++data BasicReversedSpec = BasicReversedSpec {+ from :: VF+, from_extra :: VF+, to :: VF+, to_extra :: VF+} deriving (Eq, Show, Generic)++instance D.FromDhall BasicReversedSpec++instance D.FromDhall Locale++data ForvoSpec = ForvoSpec {+ locale :: Locale+} deriving (Eq, Show, Generic)++instance D.FromDhall ForvoSpec++data PronunciationSpec = PronunciationSpec {+ audiof :: Text -> Path Rel File+, multis :: [MultiClozeSpec]+, forvo :: Maybe ForvoSpec+} deriving Generic++instance D.FromDhall PronunciationSpec+data Spec =+ Pronunciation PronunciationSpec+ | Excerpt [ExcerptSpec]+ | BasicReversed [BasicReversedSpec]+ | MinimalReversed [MinimalReversedSpec]+ deriving Generic++instance D.FromDhall Spec++data FlashBlastConfig = FlashBlastConfig {+ decks :: Map Text Deck+, forvoApiKey :: Maybe ForvoAPIKey+} deriving Generic++instance D.FromDhall FlashBlastConfig++data MinimalReversedSpec = MinimalReversedSpec {+ from :: VF+, to :: VF+} deriving (Eq, Show, Generic)++instance D.FromDhall MinimalReversedSpec
src/FlashBlast/Conventions.hs view
@@ -2,18 +2,20 @@ {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module FlashBlast.Conventions where -import Dhall hiding (maybe)-import Composite.Record-import Composite.TH-import Formatting-import qualified RIO.Text as T-import qualified RIO.Text.Lazy as LT+import Composite.Record+import Composite.TH+import Data.Align+import Dhall hiding (maybe)+import Formatting+import Lucid+import Path+import Path.Dhall ()+import Path.Utils+import RIO+import RIO.List.Partial+import qualified RIO.Text as T+import qualified RIO.Text.Lazy as LT import qualified RIO.Text.Partial as T-import RIO-import Path-import Path.Dhall()-import Path.Utils-import Lucid data VF = Empty | Raw Text | Images [Path Rel File] | Audio (Path Rel File) deriving (Eq, Show ,Generic)@@ -90,3 +92,30 @@ renderVF (Raw x) = x renderVF (Images x) = T.intercalate "\n" $ LT.toStrict . renderText . ungroundedImage <$> x renderVF (Audio x) = soundEmbed x++genForvos :: Text -> [Path Rel File] -> [Path Rel File] -> RForvoNote+genForvos x zs ys' =+ let ys = lpadZipWith (\a _ -> if isJust a then a else Nothing) ys' (replicate 16 ())+ k = ys !! 0 :*: ys !! 1 :*: ys !! 2 :*: ys !! 3 :*: ys !! 4 :*: ys !! 5 :*: ys !! 6 :*: ys !! 7 :*: ys !! 8 :*: ys !! 9 :*: ys !! 10 :*: ys !! 11 :*: ys !! 12 :*: ys !! 13 :*: ys !! 14 :*: ys !! 15 :*: RNil+ in x :*: zs :*: k++class RenderNote f where+ renderNote :: f -> Text++data SomeNote = forall e. RenderNote e => SomeNote e++instance RenderNote RBasicReversedNoteVF where+ renderNote = renderBasicReversedNoteVF++instance RenderNote RMinimalNoteVF where+ renderNote = renderMinimalNoteVF++instance RenderNote RExcerptNote where+ renderNote = renderExcerptNote++instance RenderNote RForvoNote where+ renderNote = renderForvoNote++instance RenderNote SomeNote where+ renderNote (SomeNote e) = renderNote e+
+ src/FlashBlast/FBFileSystem.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}+module FlashBlast.FBFileSystem where++import Polysemy+import qualified UnliftIO.Path.Directory as U+import qualified System.IO.Temp as U+import Path+import RIO+import qualified RIO.ByteString as BS++data FBFileSystem m a where+ CreateTempDirectory :: FBFileSystem m (Path Abs Dir)+ CreateDirectory :: Path b Dir -> FBFileSystem m ()+ RemoveDirectory :: Path b Dir -> FBFileSystem m ()+ DoesFileExist :: Path b File -> FBFileSystem m Bool+ CopyFile :: Path b File -> Path b' File -> FBFileSystem m ()+ WriteFileBS :: Path b File -> BS.ByteString -> FBFileSystem m ()+ WriteFileUTF8 :: Path b File -> Text -> FBFileSystem m ()++makeSem ''FBFileSystem++interpretFBFileSystem :: Member (Embed IO) effs => Sem (FBFileSystem ': effs) a -> Sem effs a+interpretFBFileSystem = interpret \case+ CreateTempDirectory -> do+ x <- embed U.getCanonicalTemporaryDirectory+ embed $ U.createTempDirectory x "" >>= parseAbsDir+ CreateDirectory x -> U.createDirectoryIfMissing True x+ RemoveDirectory x -> U.removeDirectoryRecursive x+ DoesFileExist x -> U.doesFileExist x+ CopyFile x y -> U.copyFile x y+ WriteFileBS x y -> BS.writeFile (toFilePath x) y+ WriteFileUTF8 x y -> writeFileUtf8 (toFilePath x) y
+ src/FlashBlast/ForvoClient.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}+module FlashBlast.ForvoClient where++import Data.Aeson+import Polysemy+import Polysemy.Error+import Polysemy.Input+import RIO hiding (fromException)+import qualified RIO.Text as T+import Network.HTTP.Simple++newtype Locale = Locale Text+ deriving (Eq, Show, Generic, Ord)++instance ToJSON Locale+instance FromJSON Locale++newtype ForvoStandardPronunciationResponseBody = ForvoStandardPronunciationResponseBody {+ items :: [ForvoPronunciationJson]+} deriving (Eq, Show, Generic)++instance FromJSON ForvoStandardPronunciationResponseBody+instance ToJSON ForvoStandardPronunciationResponseBody++data ForvoPronunciationJson = ForvoPronunciationJson {+ id :: Int+, word :: Text+, original :: Text+, hits :: Int+, username:: Text+, sex:: Text+, country:: Text+, code :: Text+, langname :: Text+, pathmp3 ::Text+, pathogg :: Text+, rate:: Int+, num_votes :: Int+, num_positive_votes:: Int+} deriving (Eq, Show, Generic)++instance FromJSON ForvoPronunciationJson+instance ToJSON ForvoPronunciationJson++newtype MP3Url = MP3Url Text+ deriving (Eq, Show, Generic)++class HasMP3Url x where+ mp3Url :: Lens' x MP3Url++instance HasMP3Url ForvoPronunciationJson where+ mp3Url = lens (MP3Url . pathmp3) undefined++data ForvoClient m a where+ StandardPronunciation :: Locale -> Text -> ForvoClient m ForvoStandardPronunciationResponseBody+ MP3For :: HasMP3Url x => x -> ForvoClient m ByteString++makeSem ''ForvoClient++newtype ForvoAPIKey = ForvoAPIKey Text+ deriving (Eq, Show, Generic)++data RemoteHttpRequest m a where+ RequestJSON :: FromJSON a => Text -> RemoteHttpRequest m a+ RequestBS :: Text -> RemoteHttpRequest m ByteString++makeSem ''RemoteHttpRequest++interpretRemoteHttpRequest :: Members '[Embed IO, Error JSONException, Error SomeException] r => Sem (RemoteHttpRequest ': r) a -> Sem r a+interpretRemoteHttpRequest = interpret \case+ RequestJSON x -> do+ let k = parseRequest $ T.unpack x+ case k of+ Left e -> throw @SomeException e+ Right x' -> do+ j <- fromException @JSONException $ httpJSON x'+ return $ getResponseBody j+ RequestBS x -> do+ let k = parseRequest $ T.unpack x+ case k of+ Left e -> throw @SomeException e+ Right x' -> do+ j <- fromException @JSONException $ httpBS x'+ return $ getResponseBody j++interpretForvoClient :: Members '[RemoteHttpRequest, Input ForvoAPIKey] r => Sem (ForvoClient ': r) a -> Sem r a+interpretForvoClient = interpret \case+ StandardPronunciation (Locale l) t -> do+ ForvoAPIKey f <- input @ForvoAPIKey+ let k = "https://apifree.forvo.com/key/" <> f <> "/format/json/action/standard-pronunciation/word/" <> t <> "/language/" <> l+ requestJSON k+ MP3For x -> let (MP3Url x') = view mp3Url x+ in requestBS x'
+ src/FlashBlast/JSONFileStore.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE UndecidableInstances #-}+module FlashBlast.JSONFileStore where++import Data.Aeson+import RIO+import qualified RIO.Map as Map+import Polysemy+import Polysemy.Error+import Polysemy.Input+import Polysemy.KVStore+import Path+import qualified UnliftIO.Path.Directory as U++newtype JSONFileStore = JSONFileStore (Path Rel File)+ deriving (Eq, Show, Generic)++newtype JSONParseException = JSONParseException String+ deriving (Show, Eq, Generic)++instance Exception JSONParseException where+ displayException (JSONParseException x) = x++eitherDecodeOrCreate :: (ToJSON a, FromJSON a, MonadIO m) => Path Rel File -> a -> m (Either String a)+eitherDecodeOrCreate f x = do+ whenM (fmap not . U.doesFileExist $ f) $ liftIO $ encodeFile (toFilePath f) x+ liftIO $ eitherDecodeFileStrict' (toFilePath f)++runKVStoreAsJSONFileStore :: (Members '[Embed IO, Input JSONFileStore, Error JSONParseException] r,+ FromJSONKey k, ToJSONKey k, FromJSON v, ToJSON v, Ord k)+ => Sem (KVStore k v ': r) a -> Sem r a+runKVStoreAsJSONFileStore = interpret \case+ LookupKV k -> do+ JSONFileStore f <- input @JSONFileStore+ z <- embed $ eitherDecodeOrCreate f mempty+ case z of+ Left x -> throw @JSONParseException $ JSONParseException x+ Right x -> return $ Map.lookup k x+ UpdateKV k v -> do+ JSONFileStore f <- input @JSONFileStore+ z <- embed $ eitherDecodeOrCreate f mempty+ case z of+ Left x -> throw $ JSONParseException x+ Right (x :: Map k v) -> embed $ encodeFile (toFilePath f) (Map.alter (const v) k x)
+ src/FlashBlast/YouTubeDL.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE TemplateHaskell #-}+module FlashBlast.YouTubeDL where++import Polysemy+import RIO+import Path+import qualified Turtle as S+import Path.Utils+++data YouTubeDL m a where+ YouTubeDL' :: Text -> Path Rel File -> Text -> YouTubeDL m ()++makeSem ''YouTubeDL++interpretYouTubeDL :: Member (Embed IO) effs => Sem (YouTubeDL ': effs) a -> Sem effs a+interpretYouTubeDL = interpret \case+ YouTubeDL' x k f -> S.sh $ S.inproc "youtube-dl" [x, "-o", toFilePathText k, "-f", f] mempty