flashblast 0.0.4.0 → 0.0.7.0
raw patch · 11 files changed
+760/−455 lines, 11 filesdep +comonaddep +first-class-familiesdep +generic-monoid
Dependencies added: comonad, first-class-families, generic-monoid, ghc-clippy-plugin, optics, optics-extra, polysemy-extra, polysemy-fs, polysemy-fskvstore, polysemy-http, polysemy-methodology, polysemy-methodology-composite, polysemy-vinyl, relude, text
Files
- ChangeLog.md +12/−0
- app/Main.hs +264/−182
- flashblast.cabal +37/−7
- src/FlashBlast/AnkiDB.hs +0/−14
- src/FlashBlast/Config.hs +116/−76
- src/FlashBlast/Conventions.hs +100/−69
- src/FlashBlast/Domain.hs +53/−0
- src/FlashBlast/FBFileSystem.hs +0/−32
- src/FlashBlast/ForvoClient.hs +131/−32
- src/FlashBlast/JSONFileStore.hs +0/−43
- src/FlashBlast/VF.hs +47/−0
ChangeLog.md view
@@ -1,5 +1,17 @@ # Changelog for flashblast +## (v0.0.7.0)++* Depend on polysemy-fs.++## (v0.0.6.0)++* Add basic colog via methodology transformations.++## (v0.0.5.0)++* Introduce polysemy-methodology.+ ## (v0.0.4.0) * Add basic Forvo Client.
app/Main.hs view
@@ -1,35 +1,52 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} +import Colog.Polysemy import Composite.Record-import qualified Data.Attoparsec.Text as A-import qualified Dhall as D-import Network.HTTP.Simple+import qualified Data.Attoparsec.Text as A+import Fcf hiding (Map, Error)+import Fcf.Class.Functor hiding (Map)+import Data.Monoid.Generic+import qualified Dhall as D import Path-import Path.Dhall ()+import Path.Dhall () import Path.Utils import Polysemy-import Polysemy.Error as P+import Polysemy.Error as P import Polysemy.Input+import Polysemy.Resource import Polysemy.KVStore-import Polysemy.Trace-import Polysemy.Video+import Polysemy.Output+import Polysemy.Video hiding (to)+import Polysemy.FSKVStore import FlashBlast.ClozeParse-import FlashBlast.Config-import FlashBlast.FBFileSystem+import Control.Comonad.Env+import qualified FlashBlast.Config as Config+import Polysemy.Methodology.Composite import FlashBlast.Conventions-import FlashBlast.ForvoClient-import FlashBlast.JSONFileStore+import FlashBlast.Domain+import FlashBlast.ForvoClient hiding (id) import FlashBlast.YouTubeDL-import Polysemy.State-import RIO hiding (Reader, ask, asks, log, many,- runReader, trace)+import Polysemy.FS+import Composite.CoRecord+import Optics+import Polysemy.Methodology+import Polysemy.Tagged+import Polysemy.Http hiding (Path)+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-+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@@ -37,49 +54,55 @@ fromRange :: SR.Range -> Range fromRange (SR.Range f t) = Range (fromTime f) (fromTime t) -interpretVideoSource :: Members '[Input ResourceDirs, YouTubeDL] m => VideoSource -> Sem m (Path Rel File)+interpretVideoSource :: Members '[Input Config.ResourceDirs, YouTubeDL] m+ => Config.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)+ 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 '[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+runExcerptSpecIO :: Members '[ Error SubtitleParseException+ , 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+ 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+ 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)+ 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)+ 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" (fst . genClozePhrase . SR.dialog $ l)- :& val @"extra" f- :& val @"back" e+ 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 newtype SubtitleParseException = SubtitleParseException String@@ -87,150 +110,209 @@ instance Exception SubtitleParseException -type FSPKVStore = KVStore (Locale, Text) ForvoStandardPronunciationResponseBody--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+downloadMP3For :: Members '[ForvoClient] r => Locale -> Text -> Sem r (Maybe ByteString)+downloadMP3For l@(Locale l') t = do+ ForvoStandardPronunciationResponseBody {..} <- standardPronunciation l t+ case items of+ [] -> return Nothing (x':_) -> Just <$> mP3For x' -getForvo :: Members '[Trace, FBFileSystem, FSPKVStore, ForvoClient] r => Locale -> Text -> Path Rel File -> Sem r ()+getForvo :: Members '[ FSKVStore Rel ByteString+ , ForvoClient] r+ => Locale -> Text -> Path Rel File -> Sem r () getForvo l t f = do- z <- doesFileExist f+ z <- lookupKV 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 ()+ Just _ -> return ()+ Nothing -> do+ x' <- downloadMP3For l t+ updateKV f x' -data Toggle a = Toggle Bool- deriving (Eq, Show, Generic)+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 -> let (bs, cs) = genClozePhrase a+ in do+ 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+ return $ genForvos bs (Multi $ map Image is) (map (Audio . f) cs) -data ToggleKilled a = ToggleKilled- deriving (Eq, Show, Generic)+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 ForvoEnabled+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 -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 ()+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 -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)+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+ ) -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+type FileMap b = Map (Path b File) -runMinimalReversed :: MinimalReversedSpec -> Sem m RMinimalNoteVF-runMinimalReversed MinimalReversedSpec{..} = return $ val @"from" from :& val @"to" to :& RNil+renderNotes :: RenderNote a => [a] -> Text+renderNotes = T.intercalate "\n" . fmap renderNote -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+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 -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+renderDeck :: forall p. (HasMedia p, RenderNote p) => Path Rel File -> [p] -> Deck+renderDeck x as = Deck [(x, renderNotes as)] (join $ fmap getMedia as) -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- 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+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- 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'+ 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+ & 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 . fmap (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 @SubtitleParseException+ & runError @SomeException+ & runError @HttpError+ & interpretLogNull+ & resourceToIO+ & runM
flashblast.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: flashblast-version: 0.0.4.0+version: 0.0.7.0 synopsis: Generate language learning flashcards from video. author: Daniel Firth maintainer: dan.firth@homotopic.tech@@ -27,40 +27,55 @@ FlashBlast.ClozeParse FlashBlast.Config FlashBlast.Conventions- FlashBlast.FBFileSystem+ FlashBlast.Domain FlashBlast.ForvoClient- FlashBlast.JSONFileStore+ FlashBlast.VF 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 -fplugin=Polysemy.Plugin+ default-extensions: AllowAmbiguousTypes 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 OverloadedLists 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 -fplugin=Polysemy.Plugin -fplugin=Clippy build-depends: aeson , attoparsec , base >=4.7 && <5 , co-log-polysemy , co-log-polysemy-formatting+ , comonad , composite-base , dhall+ , first-class-families , formatting+ , generic-monoid+ , ghc-clippy-plugin , http-conduit , lucid , megaparsec+ , optics+ , optics-extra , path , path-dhall-instance , path-utils , polysemy+ , polysemy-extra >=0.1.4.0+ , polysemy-fs+ , polysemy-fskvstore+ , polysemy-http+ , polysemy-methodology >=0.1.6.0+ , polysemy-methodology-composite >=0.1.2.0 , polysemy-plugin , polysemy-video >=0.1.1.0+ , polysemy-vinyl >=0.1.2.0 , polysemy-zoo+ , relude , replace-megaparsec , rio , semialign , subtitleParser , temporary+ , text , these , turtle , unliftio-path@@ -73,33 +88,48 @@ Paths_flashblast 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 -fplugin=Polysemy.Plugin -threaded -rtsopts -with-rtsopts=-N+ default-extensions: AllowAmbiguousTypes 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 OverloadedLists 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 -fplugin=Polysemy.Plugin -fplugin=Clippy -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , attoparsec , base >=4.7 && <5 , co-log-polysemy , co-log-polysemy-formatting+ , comonad , composite-base , dhall+ , first-class-families , flashblast , formatting+ , generic-monoid+ , ghc-clippy-plugin , http-conduit , lucid , megaparsec+ , optics+ , optics-extra , path , path-dhall-instance , path-utils , polysemy+ , polysemy-extra >=0.1.4.0+ , polysemy-fs+ , polysemy-fskvstore+ , polysemy-http+ , polysemy-methodology >=0.1.6.0+ , polysemy-methodology-composite >=0.1.2.0 , polysemy-plugin , polysemy-video >=0.1.1.0+ , polysemy-vinyl >=0.1.2.0 , polysemy-zoo+ , relude , replace-megaparsec , rio , semialign , subtitleParser , temporary+ , text , these , turtle , unliftio-path
src/FlashBlast/AnkiDB.hs view
@@ -7,17 +7,3 @@ import Polysemy.Reader import RIO hiding (Reader, asks) import UnliftIO.Path.Directory--data AnkiDB m a where- CopyToCollections :: [Path Rel File] -> AnkiDB m ()--makeSem ''AnkiDB--newtype UserProfile = UserProfile { unUserProfile :: Path Abs Dir }--interpretAnkiDBIO :: (Member (Embed IO) effs,- Member (Reader UserProfile) effs) => Sem (AnkiDB ': effs) a -> Sem effs a-interpretAnkiDBIO = interpret $ \case- CopyToCollections xs -> forM_ xs $ \x -> do- f <- asks unUserProfile- copyFile x (f </> $(mkRelDir "collections.media") </> filename x)
src/FlashBlast/Config.hs view
@@ -1,122 +1,162 @@ {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module FlashBlast.Config where import qualified Dhall as D-import FlashBlast.Conventions+import qualified Dhall.Deriving as D import FlashBlast.ForvoClient+import FlashBlast.VF import Path import Path.Dhall ()+import Optics.TH import RIO - data MultiClozeSpec = MultiClozeSpec {- phrases :: [Text]-, images :: [Path Rel File]-} deriving (Eq, Generic, Show)+ _phrases :: [Text]+, _images :: [Path Rel File]+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) MultiClozeSpec -instance D.FromDhall MultiClozeSpec+makeFieldsNoPrefix ''MultiClozeSpec data YDLInfo = YDLInfo {- url :: Text-, out :: Path Rel File-, format :: Text-} deriving (Eq, Generic, Show)+ _url :: Text+, _out :: Path Rel File+, _format :: Text+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) YDLInfo -instance D.FromDhall YDLInfo+makeFieldsNoPrefix ''YDLInfo data ResourceDirs = ResourceDirs {- audio :: Path Rel Dir-, video :: Path Rel Dir-, images :: Path Rel Dir-} deriving (Eq, Show, Generic)+ _audio :: Path Rel Dir+, _video :: Path Rel Dir+, _images :: Path Rel Dir+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) ResourceDirs -instance D.FromDhall ResourceDirs+makeFieldsNoPrefix ''ResourceDirs data VideoSource = LocalVideo (Path Rel File) | YouTubeDL YDLInfo- deriving (Eq, Generic, Show)+ deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) VideoSource -instance D.FromDhall VideoSource+makePrisms ''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+ _source :: VideoSource+, _subs :: Text+, _clipf :: Text -> Path Rel File+, _audiof :: Text -> Path Rel File+, _framef :: Text -> Path Rel File+} deriving stock Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) ExcerptSpec -instance D.FromDhall ExcerptSpec+makeFieldsNoPrefix ''ExcerptSpec data ExportDirs = ExportDirs {- audio :: Path Rel Dir-, clips :: Path Rel Dir-, images :: Path Rel Dir-, notes :: Path Rel Dir-} deriving (Eq, Show, Generic)+ _audio :: Path Rel Dir+, _clips :: Path Rel Dir+, _images :: Path Rel Dir+, _notes :: Path Rel Dir+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) ExportDirs -instance D.FromDhall ExportDirs+makeFieldsNoPrefix ''ExportDirs -instance D.FromDhall ForvoAPIKey+newtype Speaker = Speaker Text+ deriving (Eq, Show, Generic) -data Deck = Deck {- resourceDirs :: ResourceDirs-, exportDirs :: ExportDirs-, parts :: [Part]-} deriving Generic+instance D.FromDhall Locale+instance D.ToDhall Locale -data Part = Part {- outfile :: Path Rel File-, spec :: Spec-} deriving Generic+instance D.FromDhall Speaker+instance D.ToDhall Speaker -instance D.FromDhall Deck+data ForvoSpec = ForvoSpec {+ _locale :: Locale+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) ForvoSpec -instance D.FromDhall Part+makeFieldsNoPrefix ''ForvoSpec -data BasicReversedSpec = BasicReversedSpec {- from :: VF-, from_extra :: VF-, to :: VF-, to_extra :: VF-} deriving (Eq, Show, Generic)+data PronunciationSpec = PronunciationSpec {+ _audiof :: Text -> Path Rel File+, _multis :: [MultiClozeSpec]+, _forvo :: Maybe ForvoSpec+} deriving stock Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) PronunciationSpec -instance D.FromDhall BasicReversedSpec+makeFieldsNoPrefix ''PronunciationSpec -instance D.FromDhall Locale+data BasicReversedCard = BasicReversedCard {+ _front :: VF+, _front_extra :: VFC+, _back :: VF+, _back_extra :: VFC+} deriving stock (Eq, Generic, Show)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) BasicReversedCard -data ForvoSpec = ForvoSpec {- locale :: Locale-} deriving (Eq, Show, Generic)+makeFieldsNoPrefix ''BasicReversedCard -instance D.FromDhall ForvoSpec+data MinimalReversedCard = MinimalReversedCard {+ _front :: VF+, _back :: VF+} deriving stock (Eq, Show, Generic)+ deriving (D.FromDhall, D.ToDhall)+ via D.Codec (D.Field (D.DropPrefix "_")) MinimalReversedCard -data PronunciationSpec = PronunciationSpec {- audiof :: Text -> Path Rel File-, multis :: [MultiClozeSpec]-, forvo :: Maybe ForvoSpec-} deriving Generic+makeFieldsNoPrefix ''MinimalReversedCard -instance D.FromDhall PronunciationSpec data Spec =- Pronunciation PronunciationSpec- | Excerpt [ExcerptSpec]- | BasicReversed [BasicReversedSpec]- | MinimalReversed [MinimalReversedSpec]- deriving Generic+ Pronunciation [PronunciationSpec]+ | Excerpt [ExcerptSpec]+ | BasicReversed [BasicReversedCard]+ | MinimalReversed [MinimalReversedCard]+ deriving stock Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) Spec -instance D.FromDhall Spec+makePrisms ''Spec -data FlashBlastConfig = FlashBlastConfig {- decks :: Map Text Deck-, forvoApiKey :: Maybe ForvoAPIKey+instance D.FromDhall ForvoAPIKey++data Part = Part {+ _outfile :: Path Rel File+, _spec :: Spec } deriving Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) Part -instance D.FromDhall FlashBlastConfig+makeFieldsNoPrefix ''Part -data MinimalReversedSpec = MinimalReversedSpec {- from :: VF-, to :: VF-} deriving (Eq, Show, Generic)+data Deck = Deck {+ _resourceDirs :: ResourceDirs+, _exportDirs :: ExportDirs+, _parts :: [Part]+} deriving stock Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) Deck -instance D.FromDhall MinimalReversedSpec+makeFieldsNoPrefix ''Deck++type Deckname = Text++data FlashBlast = FlashBlast {+ _decks :: Map Deckname Deck+, _forvoApiKey :: Maybe ForvoAPIKey+} deriving stock Generic+ deriving D.FromDhall+ via D.Codec (D.Field (D.DropPrefix "_")) FlashBlast++makeFieldsNoPrefix ''FlashBlast
src/FlashBlast/Conventions.hs view
@@ -5,11 +5,10 @@ import Composite.Record import Composite.TH import Data.Align-import Dhall hiding (maybe)+import FlashBlast.VF import Formatting import Lucid import Path-import Path.Dhall () import Path.Utils import RIO import RIO.List.Partial@@ -17,55 +16,43 @@ import qualified RIO.Text.Lazy as LT import qualified RIO.Text.Partial as T -data VF = Empty | Raw Text | Images [Path Rel File] | Audio (Path Rel File)- deriving (Eq, Show ,Generic)--instance FromDhall VF- withLensesAndProxies [d|- type FFront a = "front" :-> a- type FExtra a = "extra" :-> a- type FBack a = "back" :-> a- type FFrom a = "from" :-> a- type FFromExtra a = "from-extra" :-> a- type FTo a = "to" :-> a- type FToExtra a = "to-extra" :-> a- type FAudio1 = "audio1" :-> Maybe (Path Rel File)- type FAudio2 = "audio2" :-> Maybe (Path Rel File)- type FAudio3 = "audio3" :-> Maybe (Path Rel File)- type FAudio4 = "audio4" :-> Maybe (Path Rel File)- type FAudio5 = "audio5" :-> Maybe (Path Rel File)- type FAudio6 = "audio6" :-> Maybe (Path Rel File)- type FAudio7 = "audio7" :-> Maybe (Path Rel File)- type FAudio8 = "audio8" :-> Maybe (Path Rel File)- type FAudio9 = "audio9" :-> Maybe (Path Rel File)- type FAudio10 = "audio10" :-> Maybe (Path Rel File)- type FAudio11 = "audio11" :-> Maybe (Path Rel File)- type FAudio12 = "audio12" :-> Maybe (Path Rel File)- type FAudio13 = "audio13" :-> Maybe (Path Rel File)- type FAudio14 = "audio14" :-> Maybe (Path Rel File)- type FAudio15 = "audio15" :-> Maybe (Path Rel File)- type FAudio16 = "audio16" :-> Maybe (Path Rel File)+ type FFront = "front" :-> VF+ type FExtra = "extra" :-> VFC+ type FBack = "back" :-> VF+ type FFrontExtra = "front-extra" :-> VFC+ type FBackExtra = "back-extra" :-> VFC+ type FAudio1 = "audio1" :-> VF+ type FAudio2 = "audio2" :-> VF+ type FAudio3 = "audio3" :-> VF+ type FAudio4 = "audio4" :-> VF+ type FAudio5 = "audio5" :-> VF+ type FAudio6 = "audio6" :-> VF+ type FAudio7 = "audio7" :-> VF+ type FAudio8 = "audio8" :-> VF+ type FAudio9 = "audio9" :-> VF+ type FAudio10 = "audio10" :-> VF+ type FAudio11 = "audio11" :-> VF+ type FAudio12 = "audio12" :-> VF+ type FAudio13 = "audio13" :-> VF+ type FAudio14 = "audio14" :-> VF+ type FAudio15 = "audio15" :-> VF+ type FAudio16 = "audio16" :-> VF |] -type RBasicNote a b c = Record (FFront a : FExtra b : FBack c : '[])--type RBasicReversedNote a b c d = Record (FFrom a : FFromExtra b : FTo c : FToExtra d : '[])--type RMinimalNote a b = Record (FFrom a : FTo b : '[])--type RMultiAudioNote a b = Record (FFront a : FExtra b : FAudio1 : FAudio2 : FAudio3 : FAudio4 : FAudio5 : FAudio6 : FAudio7 : FAudio8 : FAudio9 : FAudio10 : FAudio11 : FAudio12 : FAudio13 : FAudio14 : FAudio15 : FAudio16 : '[])--type RExcerptNote = RBasicNote Text (Path Rel File) (Path Rel File)--type RForvoNote = RMultiAudioNote Text [Path Rel File]+type RBasicNote = Record (FFront : FFrontExtra : FBack : FBackExtra : '[]) -type RMinimalNoteVF = RMinimalNote VF VF+type RMinimalNote = Record (FFront : FBack : '[]) -type RBasicReversedNoteVF = RBasicReversedNote VF VF VF VF+type RExcerptNote = Record (FFront : FExtra : FBack : '[] ) -forvoConvention :: MonadThrow m => Text -> Text -> m (Path Rel File)-forvoConvention locale word = parseRelFile . T.unpack $ sformat ("pronunciation_" % stext % "_" % stext % ".mp3") locale (T.replace " " "_" (T.toLower word))+type RPronunciationNote = Record+ ( FFront : FExtra+ : FAudio1 : FAudio2 : FAudio3 : FAudio4+ : FAudio5 : FAudio6 : FAudio7 : FAudio8+ : FAudio9 : FAudio10 : FAudio11 : FAudio12+ : FAudio13 : FAudio14 : FAudio15 : FAudio16+ : '[]) ungroundedImage :: Path Rel File -> Html () ungroundedImage x = img_ [src_ $ toFilePathText x]@@ -73,49 +60,93 @@ soundEmbed :: Path Rel File -> Text soundEmbed = sformat ("[sound:" % stext % "]") . toFilePathText --- TODO: do this as an interpretation renderExcerptNote :: RExcerptNote -> Text-renderExcerptNote (a :*: b :*: c :*: RNil) = T.intercalate "\t" [a, LT.toStrict $ renderText $ ungroundedImage (filename b), soundEmbed c]+renderExcerptNote (a :*: b :*: c :*: RNil) =+ T.intercalate "\t" [renderVF a, renderVF b, renderVF c] -renderForvoNote :: RForvoNote -> Text-renderForvoNote (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j :*: k :*: l :*: m :*: n :*: o :*: p :*: q :*: r :*: RNil)- = T.intercalate "\t" $ [a, T.intercalate "\n" (LT.toStrict . renderText . ungroundedImage . filename <$> b)] ++ fmap (maybe "" soundEmbed) [c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]+renderPronunciationNote :: RPronunciationNote -> Text+renderPronunciationNote (a :*: b :*: c :*: d :*: e :*: f :*: g :*: h :*: i :*: j :*: k :*: l :*: m :*: n :*: o :*: p :*: q :*: r :*: RNil)+ = T.intercalate "\t" $ [renderVF a, renderVF b] ++ (renderVF <$> [c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r]) -renderMinimalNoteVF :: RMinimalNoteVF -> Text-renderMinimalNoteVF (a :*: b :*: RNil) = T.intercalate "\t" $ renderVF <$> [a, b]+renderMinimalNote :: RMinimalNote -> Text+renderMinimalNote (a :*: b :*: RNil) = T.intercalate "\t" $ renderVF <$> [a, b] -renderBasicReversedNoteVF :: RBasicReversedNoteVF -> Text-renderBasicReversedNoteVF (a :*: b :*: c :*: d :*: RNil) = T.intercalate "\t" $ renderVF <$> [a,b,c,d]+renderBasicReversedNote :: RBasicNote -> Text+renderBasicReversedNote (a :*: b :*: c :*: d :*: RNil)+ = T.intercalate "\t" $ [renderVF a,renderVF b,renderVF c,renderVF d] -renderVF :: VF -> Text-renderVF Empty = ""-renderVF (Raw x) = x-renderVF (Images x) = T.intercalate "\n" $ LT.toStrict . renderText . ungroundedImage <$> x-renderVF (Audio x) = soundEmbed x+class RenderVF a where+ renderVF :: a -> Text -genForvos :: Text -> [Path Rel File] -> [Path Rel File] -> RForvoNote+instance RenderVF VF where+ renderVF Blank = ""+ renderVF (RawText x) = x+ renderVF (Image x) = LT.toStrict . renderText . ungroundedImage $ x+ renderVF (Audio x) = soundEmbed x+ renderVF (Video x) = undefined++instance RenderVF VFC where+ renderVF (Single x) = renderVF x+ renderVF (Multi xs) = mconcat $ fmap renderVF xs++genForvos :: Text -> VFC -> [VF] -> RPronunciationNote 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+ let ys = lpadZipWith (\a _ -> case a of+ Nothing -> Blank+ Just a -> a+ ) 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+ :*: ys !! 12 :*: ys !! 13 :*: ys !! 14 :*: ys !! 15+ :*: RNil+ in RawText x :*: zs :*: ks class RenderNote f where renderNote :: f -> Text data SomeNote = forall e. RenderNote e => SomeNote e -instance RenderNote RBasicReversedNoteVF where- renderNote = renderBasicReversedNoteVF+instance RenderNote RBasicNote where+ renderNote = renderBasicReversedNote -instance RenderNote RMinimalNoteVF where- renderNote = renderMinimalNoteVF+instance RenderNote RMinimalNote where+ renderNote = renderMinimalNote instance RenderNote RExcerptNote where renderNote = renderExcerptNote -instance RenderNote RForvoNote where- renderNote = renderForvoNote+instance RenderNote RPronunciationNote where+ renderNote = renderPronunciationNote instance RenderNote SomeNote where renderNote (SomeNote e) = renderNote e +class HasMedia f where+ getMedia :: f -> [Path Rel File]++instance HasMedia VF where+ getMedia (Image x) = [x]+ getMedia (Audio x) = [x]+ getMedia (Video x) = [x]+ getMedia _ = []++instance HasMedia VFC where+ getMedia (Single x) = getMedia x+ getMedia (Multi xs) = foldMap getMedia xs++instance HasMedia RBasicNote where+ getMedia f = getMedia (view fFront f) <> getMedia (view fBack f) <> getMedia (view fFrontExtra f) <> getMedia (view fBackExtra f)++instance HasMedia RMinimalNote where+ getMedia f = getMedia (view fFront f) <> getMedia (view fBack f)++instance HasMedia RExcerptNote where+ getMedia f = getMedia (view fExtra f) <> getMedia (view fBack f)++instance HasMedia RPronunciationNote where+ getMedia f = mconcat $ getMedia <$>+ [ view fAudio1 f, view fAudio2 f, view fAudio3 f, view fAudio4 f+ , view fAudio5 f, view fAudio6 f, view fAudio7 f, view fAudio8 f+ , view fAudio9 f, view fAudio10 f, view fAudio11 f, view fAudio12 f+ , view fAudio13 f, view fAudio14 f, view fAudio15 f, view fAudio16 f]
+ src/FlashBlast/Domain.hs view
@@ -0,0 +1,53 @@+{- |+ Module : FlashBlast.Domain+ License : MIT+ Stability : experimental++Top level domain specification for FlashBlast.+-}+module FlashBlast.Domain where++import Data.Kind+import Fcf+import RIO+import Polysemy+import Polysemy.Input+import Polysemy.Tagged+import Polysemy.Methodology+import Polysemy.Output++-- | A `DeckConfiguration` indicates how we create cards.+data DeckConfiguration++-- | A `CollectionsPackage` indicates.+data CollectionsPackage++-- | The Construction Methodology for flashblast.+data ConstructionMethodology++-- | `flashblast` is a program that takes a `DeckConfiguration` and outputs a `CollectionsPackage`.+flashblast :: Members '[ Tagged DeckConfiguration (Input a)+ , Tagged ConstructionMethodology (Methodology a b)+ , Tagged CollectionsPackage (Output b)] r+ => Sem r ()+flashblast = do+ x <- tag @DeckConfiguration input+ k <- tag @ConstructionMethodology $ process x+ tag @CollectionsPackage $ output k++-- | Cards can be of the following types.+data CardType = Minimal | Basic | Excerpt | Pronunciation++-- | They have a way to configure them.+type family ConfigFor (a :: CardType) :: Type++-- | And a concrete product.+type family ResultFor (a :: CardType) :: Type++-- | Fcf mapping for CardType to its Config.+data ConfigFor' :: CardType -> Exp Type+type instance Eval (ConfigFor' x) = ConfigFor x++-- | Fcf mapping for CardType to its product.+data ResultFor' :: CardType -> Exp Type+type instance Eval (ResultFor' x) = ResultFor x
− src/FlashBlast/FBFileSystem.hs
@@ -1,32 +0,0 @@-{-# 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
@@ -1,13 +1,15 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DuplicateRecordFields #-} 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+import RIO hiding (fromException, try)+import qualified RIO.ByteString.Lazy as LBS+import qualified RIO.ByteString as BS+import Polysemy.Http as Http newtype Locale = Locale Text deriving (Eq, Show, Generic, Ord)@@ -28,20 +30,40 @@ , original :: Text , hits :: Int , username:: Text-, sex:: Text+, sex :: Text , country:: Text , code :: Text , langname :: Text , pathmp3 ::Text , pathogg :: Text-, rate:: Int+, rate :: Int , num_votes :: Int-, num_positive_votes:: Int+, num_positive_votes :: Int } deriving (Eq, Show, Generic) instance FromJSON ForvoPronunciationJson instance ToJSON ForvoPronunciationJson +data ForvoAttributeCount = ForvoAttributeCount {+ total :: Int+} deriving (Eq, Show, Generic)++instance FromJSON ForvoAttributeCount++data ForvoLanguageListResponseBody = ForvoLanguageListResponseBody {+ attributes :: ForvoAttributeCount+, items :: [ForvoLanguageCode]+} deriving (Eq, Show, Generic)++instance FromJSON ForvoLanguageListResponseBody++data ForvoLanguageCode = ForvoLanguageCode {+ code :: Text+, language :: Text+} deriving (Eq, Show, Generic)++instance FromJSON ForvoLanguageCode+ newtype MP3Url = MP3Url Text deriving (Eq, Show, Generic) @@ -51,43 +73,120 @@ instance HasMP3Url ForvoPronunciationJson where mp3Url = lens (MP3Url . pathmp3) undefined +newtype OggUrl = OggUrl Text+ deriving (Eq, Show, Generic)++class HasOggUrl x where+ oggUrl :: Lens' x OggUrl++instance HasOggUrl ForvoPronunciationJson where+ oggUrl = lens (OggUrl . pathogg) undefined+ data ForvoClient m a where StandardPronunciation :: Locale -> Text -> ForvoClient m ForvoStandardPronunciationResponseBody- MP3For :: HasMP3Url x => x -> ForvoClient m ByteString+ LanguageList :: ForvoClient m ForvoLanguageListResponseBody+ MP3For :: HasMP3Url x => x -> ForvoClient m ByteString+ OggFor :: HasOggUrl 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+data ForvoLimitReachedException = ForvoLimitReachedException+ deriving (Eq, Show, Generic) -makeSem ''RemoteHttpRequest+data ForvoLimitText = ForvoLimitText -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+instance FromJSON ForvoLimitText where+ parseJSON = withText "ForvoLimitText" $ \case+ "Limit/day reached." -> return ForvoLimitText+ _ -> fail "Unknown response." -interpretForvoClient :: Members '[RemoteHttpRequest, Input ForvoAPIKey] r => Sem (ForvoClient ': r) a -> Sem r a-interpretForvoClient = interpret \case+instance Exception ForvoLimitReachedException where+ displayException = show++data ForvoLimitResponse = ForvoLimitResponse [ForvoLimitText]+ deriving Generic++instance FromJSON ForvoLimitResponse++data ForvoAPIKeyIncorrectException = ForvoAPIKeyIncorrectException+ deriving (Eq, Show, Generic)++instance Exception ForvoAPIKeyIncorrectException where+ displayException = show++data ForvoIncorrectDomainText = ForvoIncorrectDomainText+ deriving (Eq, Show, Generic)++instance FromJSON ForvoIncorrectDomainText where+ parseJSON = withText "ForvoIncorrectDomainText" $ \case+ "Calling from incorrect domain." -> return ForvoIncorrectDomainText+ _ -> fail "Unknown response."++data ForvoIncorrectDomainResponse = ForvoIncorrectDomainResponse [ForvoIncorrectDomainText]+ deriving Generic++instance FromJSON ForvoIncorrectDomainResponse++data ForvoResponseNotUnderstood = ForvoResponseNotUnderstood ByteString+ deriving (Show, Eq, Generic)++instance Exception ForvoResponseNotUnderstood where+ displayException (ForvoResponseNotUnderstood x) = show x++throwIfLimitReached :: Member (Error ForvoLimitReachedException) r => ByteString -> Sem r ByteString+throwIfLimitReached z = let (z' :: Either String ForvoLimitResponse) = eitherDecodeStrict z+ in case z' of+ Left _ -> return z+ Right _ -> throw ForvoLimitReachedException++throwIfIncorrectDomain :: Member (Error ForvoAPIKeyIncorrectException) r => ByteString -> Sem r ByteString+throwIfIncorrectDomain z = let (z' :: Either String ForvoIncorrectDomainResponse) = eitherDecodeStrict z+ in case z' of+ Left _ -> return z+ Right _ -> throw ForvoAPIKeyIncorrectException++validate :: forall r. Members [Error ForvoLimitReachedException+ , Error ForvoAPIKeyIncorrectException+ , Error HttpError] r+ => Either HttpError (Response LBS.ByteString) -> Sem r ByteString+validate z = do+ z' <- either throw (return . LBS.toStrict . body) z+ _ <- throwIfLimitReached z'+ _ <- throwIfIncorrectDomain z'+ return z'++analyse :: forall a r. (FromJSON a,+ Members '[Error ForvoResponseNotUnderstood] r)+ => BS.ByteString -> Sem r a+analyse z = do+ either+ (const $ throw @ForvoResponseNotUnderstood . ForvoResponseNotUnderstood $ z)+ return+ (eitherDecodeStrict z :: Either String a)++runForvoClient :: Members '[ Input ForvoAPIKey+ , Error ForvoLimitReachedException+ , Error ForvoAPIKeyIncorrectException+ , Error HttpError+ , Error ForvoResponseNotUnderstood+ , Http (IO ByteString)] r => Sem (ForvoClient ': r) a -> Sem r a+runForvoClient = 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+ z <- Http.request (Http.get "apifree.forvo.com" $ Path $ "key/" <> f <> "/format/json/action/standard-pronunciation/word/" <> t <> "/language/" <> l)+ validate z >>= analyse+ LanguageList -> do+ ForvoAPIKey f <- input @ForvoAPIKey+ z <- Http.request (Http.get "apifree.forvo.com" $ Path $ "key/" <> f <> "/format/json/action/language-list/order/name")+ validate z >>= analyse MP3For x -> let (MP3Url x') = view mp3Url x- in requestBS x'+ in do+ let Right k = getUrl x'+ request k >>= validate+ OggFor x -> let (OggUrl x') = view oggUrl x+ in do+ let Right k = getUrl x'+ request k >>= validate
− src/FlashBlast/JSONFileStore.hs
@@ -1,43 +0,0 @@-{-# 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/VF.hs view
@@ -0,0 +1,47 @@+{- |+ Module : FlashBlast.VF+ License : MIT+ Stability : experimental++Variable mediafield for dhall.+-}+{-# LANGUAGE TemplateHaskell #-}+module FlashBlast.VF (+ VF(..)+, VFC(..)+) where++import Optics+import Dhall+import Path+import Path.Dhall()+import RIO++data VF where+ Blank :: VF+ RawText :: Text -> VF+ Image :: Path Rel File -> VF+ Audio :: Path Rel File -> VF+ Video :: Path Rel File -> VF++makePrisms ''VF++deriving instance Generic VF+deriving instance Eq VF+deriving instance Show VF++instance FromDhall VF+instance ToDhall VF++data VFC where+ Single :: VF -> VFC+ Multi :: [VF] -> VFC++makePrisms ''VFC++deriving instance Generic VFC+deriving instance Eq VFC+deriving instance Show VFC++instance FromDhall VFC+instance ToDhall VFC