packages feed

gtvm-hs (empty) → 1.0.0

raw patch · 18 files changed

+1944/−0 lines, 18 filesdep +aesondep +basedep +binrepsetup-changed

Dependencies added: aeson, base, binrep, bytestring, containers, exceptions, generic-data-functions, gtvm-hs, mtl, optparse-applicative, path, polysemy, rerefined, strongweak, symparsec, text, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,83 @@+## 1.0.0 (2024-10-03)+First Hackage release.++* get building with my new libraries+  * specifically rewrite SCP+* disable flowchart & SL01 features (need a bit more work)++Previously unreleased changes, now possibly (temporarily) disabled or+irrelevant:++* large binary representation refactor: SCP, flowchart now handled generically+  via binrep, strongweak, refined+* work on graphing SCP links++## 0.9.0 (2022-03-22)+  * new tool: SCP text replace (for translation)+  * new tool: SCPTL -- text replace made useful+  * remove patch feature: moved to own library+executable at+    https://github.com/raehik/bytepatch ,+    https://hackage.haskell.org/package/bytepatch+  * rewrite CLI, disabled some features while refactoring further+    * CSV feature temporarily disabled (need to bring bytepatch in again)+  * early SCPX functionality+  * rewrite flowchart handling code, schema+    * No more intermediate type. We get less and simpler code. If it were more+      useful (not just the index generation), I would add one again. That way+      we recover the original approach ("lexed" and "parsed" versions), but tons+      better behaviour, safety etc.+  * various cleanup, interesting ideas+    * pattern for using single type for binary and JSON (and Haskell) composed+      of two mini libraries, using for flowchart+  * more SCP format documentation++## 0.8.0 (2021-08-26)+  * patch offsets now work from a base offset+    * prompting story: by calculating the relevant base offset, a user patching+      an ELF can now write offsets as virtual addresses and have them translated+      to physical file offsets!+    * absolute offsets can also be specified to confirm correct offset+      calculation+  * further patcher refactoring: partially generic over patch/stream type,+    patch-time meta is reused instead of wrapped in pretty patch format++## 0.7.0 (2021-08-16)+  * fix patcher runtime checks+  * refactor patcher: internals more generic & useful, text/binary patch formats+    now the same (no "simplified" one offset format), better potential error+    reporting (not yet implemented)++## 0.6.0 (2021-08-09)+  * add CSV -> text patch file generator+  * bytestrings in JSON/YAML must now use format `00 01 EF FF` etc.+    *(I had no choice but to implement my own format, since JSON explicitly+    disallows encoding byte arrays.)*+  * refactor patcher internals (somewhat modular)++## 0.5.0 (2021-08-05)+I don't expect to alter the CLI in any more major ways, so go mad with scripts.++  * add binary/string patcher tool+  * some documentation; `sound_se.pak` repacking appears functional+  * partial CLI redesign (fewer options, more commands)++## 0.4.0 (2021-08-04)+  * CLI: partial redesign (internals overhauled)+  * add `SL01` LZO1x en/decoding tool (output not tested in game)+  * add initial `sound_se.pak` pack/unpack support (output not tested in game)++## 0.3.0 (2021-08-02)+Release primarily to ensure the latest version displayed on GitHub has the+correct executable name (`gtvm-hs`, not `gtvm`).++  * CLI: make prettify an option (still on by default)+  * CLI: fix: always allow printing text++## 0.2.0 (2021-08-02)+  * CLI interface to SCP manipulation++## 0.1.0 (2021-08-01)+Initial release.++  * various messy tools, primarily parsing/serializing+  * an initial CLI interface to `flow_chart.bin` manipulation
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2021-2024 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,20 @@+# Golden Time Vivid Memories: Haskell Toolset+Various Haskell tools for working with the Golden Time Vivid Memories Vita game,+like parsing and reserializing assets.++No copyrighted material from the game stored.++## Usage+Invoke on command line. The CLI is intended to be a discoverable "toolbox", so+try invoking different commands and viewing the help.++As of 0.9.0, patching (`gtvm-hs patch`) is handled by another tool. See+[bytepatch](https://github.com/raehik/bytepatch).++## Building+Cabal, GHC 9.10 or 9.6. (9.8 does not work due to a `blake3` bug.)++Comes with a Nix flake that raehik uses for development and CI.++## License+Provided under the MIT license. See `LICENSE` for license text.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Common/CLIOptions.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Common.CLIOptions where++import Common.Config+import GHC.TypeLits hiding ( Mod )+import Options.Applicative hiding ( str )+import GHC.Exts+import Data.Char qualified as Char++streamStdin :: forall s. Stream 'StreamIn s+streamStdin = StreamStd+streamStdout :: forall s. Stream 'StreamOut s+streamStdout = StreamStd++pStreamIn :: forall s. KnownSymbol s => Parser (Stream 'StreamIn s)+pStreamIn = (StreamFile' <$> pStreamFileIn) <|> pStdinOpt+  where+    pStdinOpt = flag' StreamStd $  long "stdin"+                                <> help ("Get "<>sym @s<>" from stdin")++pStreamOut :: forall s. KnownSymbol s => Parser (Stream 'StreamOut s)+pStreamOut = (StreamFile' <$> pStreamFileOut) <|> pure StreamStd+  where+    pStreamFileOut = StreamFile <$> strOption (modFileOut (sym @s))++pStreamFileIn :: forall s. KnownSymbol s => Parser (StreamFile 'StreamIn s)+pStreamFileIn = StreamFile <$> strArgument (modFileIn (sym @s))++pPrintBin :: Parser PrintBin+pPrintBin = flag NoPrintBin PrintBin $  long "print-binary"+                                     <> help "Allow printing binary to stdout"+++-- | More succint 'symbolVal' via type application.+sym :: forall s. KnownSymbol s => String+sym = symbolVal' (proxy# :: Proxy# s)++-- | Generate a base 'Mod' for a file type using the given descriptive+--   name (the "type" of input, e.g. file format) and the given direction.+modFile :: HasMetavar f => String -> String -> Mod f a+modFile dirStr descStr =  metavar "FILE"+                       <> help (dirStr<>" "<>descStr')+  where+    descStr' = descStr<>" file"++modFileIn :: HasMetavar f => String -> Mod f a+modFileIn = modFile "Input"++modFileOut :: (HasMetavar f, HasName f) => String -> Mod f a+modFileOut s = modFile "Output" s <> long "out-file" <> short 'o'++metavarify :: String -> String+metavarify = map $ Char.toUpper . spaceToUnderscore+  where spaceToUnderscore = \case ' ' -> '_'; ch -> ch
+ app/Common/Config.hs view
@@ -0,0 +1,25 @@+module Common.Config where++import GHC.Generics+import GHC.TypeLits++-- | "Single file" stream decorated with type information.+--+-- The rationale is that the representation is always the same, but we want to+-- treat in streams differently to out streams in the CLI help.+data Stream (d :: StreamDirection) (s :: Symbol)+  = StreamFile' (StreamFile d s)+  | StreamStd+    deriving (Eq, Show, Generic)++newtype StreamFile (d :: StreamDirection) (s :: Symbol)+  = StreamFile { streamFilePath :: FilePath }+    deriving (Eq, Show, Generic)++-- | Stream direction (in or out).+data StreamDirection = StreamIn | StreamOut deriving (Eq, Show, Generic)++data PrintBin+  = PrintBin+  | NoPrintBin+    deriving (Eq, Show, Generic)
+ app/Common/IO.hs view
@@ -0,0 +1,17 @@+module Common.IO where++import Data.Aeson+import Data.Yaml qualified as Yaml+import Data.ByteString qualified as BS+import Control.Monad.IO.Class++-- TODO: bad. decoding may fail, that's why we gotta do this.+badParseYAML :: forall a m. (MonadIO m, FromJSON a) => BS.ByteString -> m a+badParseYAML bs =+    case Yaml.decodeEither' bs of+      Left err      -> do+        liftIO $ putStrLn "error decoding YAML: "+        liftIO $ print err+        error "fucko"+        --liftIO $ Exit.exitWith (Exit.ExitFailure 1)+      Right decoded -> return decoded
+ app/Common/Util.hs view
@@ -0,0 +1,76 @@+module Common.Util where++import Common.Config+import Control.Monad.IO.Class+import Data.ByteString qualified as B+import System.Exit ( exitWith, ExitCode(ExitFailure) )+import Strongweak++readStreamBytes :: MonadIO m => Stream 'StreamIn s -> m B.ByteString+readStreamBytes = \case+  StreamFile' sf -> readStreamFileBytes sf+  StreamStd      -> readStdinBytes++readStreamFileBytes :: MonadIO m => StreamFile 'StreamIn s -> m B.ByteString+readStreamFileBytes = liftIO . B.readFile . streamFilePath++readStdinBytes :: MonadIO m => m B.ByteString+readStdinBytes = liftIO B.getContents++print' :: (MonadIO m, Show a) => a -> m ()+print' = liftIO . print++writeStreamTextualBytes :: MonadIO m => Stream 'StreamOut s -> B.ByteString -> m ()+writeStreamTextualBytes s bs =+    case s of+      StreamFile' sf -> liftIO $ B.writeFile (streamFilePath sf) bs+      StreamStd      -> liftIO $ B.putStr bs++writeStreamBin :: MonadIO m => PrintBin -> Stream 'StreamOut s -> B.ByteString -> m ()+writeStreamBin pb s bs =+    case s of+      StreamFile' sf -> liftIO $ B.writeFile (streamFilePath sf) bs+      StreamStd      ->+        case pb of+          PrintBin   -> liftIO $ B.putStr bs+          NoPrintBin -> do+            liftIO $ putStrLn "warning: refusing to print binary to stdout"+            liftIO $ putStrLn "(write to a file with --out-file FILE, or use --print-binary flag to override)"++badExit :: (MonadIO m, Show s) => String -> s -> m a+badExit errStr s = do+    liftIO $ putStrLn $ "error: while " <> errStr <> ": " <> show s+    liftIO $ exitWith $ ExitFailure 1++liftErr :: MonadIO m => (e -> String) -> Either e a -> m a+liftErr f = \case Left  e -> exit (f e)+                  Right a -> return a++exit :: MonadIO m => String -> m a+exit s = do liftIO $ putStrLn $ "error: "<>s+            liftIO $ exitWith $ ExitFailure 2++badParseStream+    :: MonadIO m+    => (FilePath -> B.ByteString -> Either String a)+    -> Stream 'StreamIn s+    -> m a+badParseStream f = \case+  StreamFile' sf -> do+    bs <- readStreamFileBytes sf+    case f (streamFilePath sf) bs of+      Left  err -> badExit "parsing input" err+      Right out -> return out+  StreamStd     -> do+    bs <- readStdinBytes+    case f "<stdin>" bs of+      Left  err -> badExit "parsing input" err+      Right out -> return out++liftStrengthen :: (MonadIO m, Strengthen a) => Weak a -> m a+liftStrengthen wa =+    case strengthen wa of+      Right sa  -> pure sa+      Left  err -> liftIO $ do+        print err -- TODO no strongweak prettifier yet. oops+        exitWith $ ExitFailure 3
+ app/Main.hs view
@@ -0,0 +1,118 @@+-- | TODO deforestize plz...++module Main where++import GHC.Generics+import Control.Monad.IO.Class+import Options.Applicative+import Tool.SCP.Code qualified+import Tool.SCP.TL qualified+--import Tool.SL01 qualified+--import Tool.Flowchart qualified++main :: IO ()+main = execParserWithDefaults desc pCmd >>= \case+  CmdSCP scpCmd ->+    case scpCmd of+      CmdSCPEncode  cfg -> Tool.SCP.Code.runEncode cfg+      CmdSCPDecode  cfg -> Tool.SCP.Code.runDecode cfg+      CmdSCPTL      scptlCmd ->+        case scptlCmd of+          CmdSCPTLGenerate cfg -> Tool.SCP.TL.runToSCPTL    cfg+          CmdSCPTLApply    cfg -> Tool.SCP.TL.runApplySCPTL cfg+{-+  CmdSL01 sl01Cmd ->+    case sl01Cmd of+      CmdSL01Compress   cfg -> Tool.SL01.runCompress   cfg+      CmdSL01Decompress cfg -> Tool.SL01.runDecompress cfg+  CmdFlowchart flowchartCmd ->+    case flowchartCmd of+      CmdFlowchartEncode cfg -> Tool.Flowchart.runEncode cfg+      CmdFlowchartDecode cfg -> Tool.Flowchart.runDecode cfg+-}+  where desc = "Various tools for working with GTVM assets."++data Cmd+  = CmdSCP       CmdSCP+  -- | CmdSL01      CmdSL01+  -- | CmdFlowchart CmdFlowchart+    deriving (Eq, Show, Generic)++data CmdSCP+  = CmdSCPEncode Tool.SCP.Code.CfgEncode+  | CmdSCPDecode Tool.SCP.Code.CfgDecode+  | CmdSCPTL     CmdSCPTL+    deriving (Eq, Show, Generic)++data CmdSCPTL+  = CmdSCPTLGenerate Tool.SCP.TL.CfgToSCPTL+  | CmdSCPTLApply    Tool.SCP.TL.CfgApplySCPTL+    deriving (Eq, Show, Generic)++{-+data CmdSL01+  = CmdSL01Compress   Tool.SL01.CfgCompress+  | CmdSL01Decompress Tool.SL01.CfgDecompress+    deriving (Eq, Show, Generic)++data CmdFlowchart+  = CmdFlowchartEncode Tool.Flowchart.CfgEncode+  | CmdFlowchartDecode Tool.Flowchart.CfgDecode+    deriving (Eq, Show, Generic)+-}++pCmd :: Parser Cmd+pCmd = hsubparser $+       cmd "scp"       descSCP       (CmdSCP       <$> pCmdSCP)+    -- <> cmd "sl01"      descSL01      (CmdSL01      <$> pCmdSL01)+    -- <> cmd "flowchart" descFlowchart (CmdFlowchart <$> pCmdFlowchart)+  where+    descSCP       = "Game script file (SCP, script/*.scp) tools."+    --descSL01      = "SL01 (LZO1x-compressed file) tools."+    --descFlowchart = "flow_chart.bin tools."++pCmdSCP :: Parser CmdSCP+pCmdSCP = hsubparser $+       cmd "encode"  descEncode  (CmdSCPEncode  <$> Tool.SCP.Code.parseCLIOptsEncode)+    <> cmd "decode"  descDecode  (CmdSCPDecode  <$> Tool.SCP.Code.parseCLIOptsDecode)+    <> cmd "tl"      descTL      (CmdSCPTL      <$> pCmdSCPTL)+  where+    descEncode  = "Encode YAML SCP to binary."+    descDecode  = "Decode binary SCP to YAML."+    descTL      = "SCPTL (SCP translation file) tools."++pCmdSCPTL :: Parser CmdSCPTL+pCmdSCPTL = hsubparser $+       cmd "generate" descGen   (CmdSCPTLGenerate <$> Tool.SCP.TL.parseCLIOptsToSCPTL)+    <> cmd "apply"    descApply (CmdSCPTLApply    <$> Tool.SCP.TL.parseCLIOptsApplySCPTL)+  where+    descGen   = "Generate a template SCPTL from a YAML SCP."+    descApply = "Apply a SCPTL to a given YAML SCP."++{-+pCmdSL01 :: Parser CmdSL01+pCmdSL01 = hsubparser $+       cmd "compress"   descCompress   (CmdSL01Compress   <$> Tool.SL01.parseCLIOptsCompress)+    <> cmd "decompress" descDecompress (CmdSL01Decompress <$> Tool.SL01.parseCLIOptsDecompress)+  where+    descCompress   = "Compress game data."+    descDecompress = "Decompress game data."++pCmdFlowchart :: Parser CmdFlowchart+pCmdFlowchart = hsubparser $+       cmd "encode" descEncode (CmdFlowchartEncode <$> Tool.Flowchart.parseCLIOptsEncode)+    <> cmd "decode" descDecode (CmdFlowchartDecode <$> Tool.Flowchart.parseCLIOptsDecode)+  where+    descEncode = "TODO encode"+    descDecode = "TODO decode"+-}++-- | Execute a 'Parser' with decent defaults.+execParserWithDefaults :: MonadIO m => String -> Parser a -> m a+execParserWithDefaults desc p = liftIO $ customExecParser+    (prefs showHelpOnError)+    (info (helper <*> p) (progDesc desc))++-- | Shorthand for the way I always write commands.+cmd :: String -> String -> Parser a -> Mod CommandFields a+cmd name desc p = command name (info p (progDesc desc))
+ app/Tool/SCP/Code.hs view
@@ -0,0 +1,64 @@+module Tool.SCP.Code where++import Common.Config+import Common.CLIOptions+import Common.Util+import Common.IO ( badParseYAML )+import Tool.SCP.Common ( scpPrettyYamlCfg )++import Options.Applicative+import GHC.Generics+import Control.Monad.IO.Class+import GTVM.SCP+import Binrep+import Binrep.Type.NullTerminated+import Data.Yaml.Pretty qualified as Yaml.Pretty+import Data.ByteString qualified as B+import Rerefined+import Strongweak+import Data.Text ( Text )+import Data.Text.Encoding qualified as Text++type SCPBin  = SCP Strong (NullTerminated B.ByteString)+type SCPText = SCP 'Weak Text++data CfgEncode = CfgEncode+  { cfgEncodeStreamIn  :: Stream 'StreamIn  "YAML SCP"+  , cfgEncodeStreamOut :: Stream 'StreamOut "binary SCP"+  , cfgEncodePrintBin  :: PrintBin+  } deriving (Eq, Show, Generic)++data CfgDecode = CfgDecode+  { cfgDecodeStreamIn  :: Stream 'StreamIn  "binary SCP"+  , cfgDecodeStreamOut :: Stream 'StreamOut "YAML SCP"+  } deriving (Eq, Show, Generic)++parseCLIOptsEncode :: Parser CfgEncode+parseCLIOptsEncode = CfgEncode <$> pStreamIn <*> pStreamOut <*> pPrintBin++parseCLIOptsDecode :: Parser CfgDecode+parseCLIOptsDecode = CfgDecode <$> pStreamIn <*> pStreamOut++runEncode :: MonadIO m => CfgEncode -> m ()+runEncode cfg = do+    scpYAMLBs <- readStreamBytes $ cfgEncodeStreamIn cfg+    scpYAML <- badParseYAML @SCPText scpYAMLBs+    scpBin' <- liftErr show $ scpTraverse (refine . Text.encodeUtf8) scpYAML+    scpBin :: SCPBin <- liftStrengthen scpBin'+    let scpBinBs = runPut scpBin+    writeStreamBin (cfgEncodePrintBin cfg) (cfgEncodeStreamOut cfg) scpBinBs++runDecode :: (MonadFail m, MonadIO m) => CfgDecode -> m ()+runDecode cfg = do+    scpBinBs <- readStreamBytes $ cfgDecodeStreamIn cfg+    (scpBin, bs) <- liftErr show $ runGet @SCPBin scpBinBs+    if not (B.null bs) then fail "dangling bytes"+    else do+        scpText :: SCPText <- liftErr id $ scpTraverse decodeUtf8 $ scpFmap unrefine $ weaken scpBin+        let scpYAMLBs = Yaml.Pretty.encodePretty scpPrettyYamlCfg scpText+        writeStreamTextualBytes (cfgDecodeStreamOut cfg) scpYAMLBs+  where+    decodeUtf8 bs =+        case Text.decodeUtf8' bs of+          Left  e -> Left $ show e+          Right t -> Right t
+ app/Tool/SCP/Common.hs view
@@ -0,0 +1,11 @@+module Tool.SCP.Common where++-- pretty YAML+import GTVM.SCP qualified as Scp+import Data.Yaml.Pretty qualified as Yaml.Pretty++scpPrettyYamlCfg :: Yaml.Pretty.Config+scpPrettyYamlCfg =+      Yaml.Pretty.setConfCompare Scp.scpSegFieldOrdering+    $ Yaml.Pretty.setConfDropNull True+    $ Yaml.Pretty.defConfig
+ app/Tool/SCP/TL.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}++module Tool.SCP.TL where++import Common.Config+import Common.CLIOptions+import Common.Util+import Common.IO ( badParseYAML )++import Tool.SCP.Common ( scpPrettyYamlCfg )++import GTVM.Internal.Json++import Options.Applicative++import GHC.Generics+import Control.Monad.IO.Class++import GTVM.SCP.TL++import Data.Text ( Text )+import Data.Yaml.Pretty qualified+import Data.Map qualified as Map++import Data.Yaml.Pretty qualified as Yaml.Pretty++import Numeric.Natural ( Natural )++data CfgToSCPTL = CfgToSCPTL+  { cfgToSCPTLStreamIn     :: Stream 'StreamIn  "YAML SCP"+  , cfgToSCPTLStreamOut    :: Stream 'StreamOut "SCPTL"+  , cfgToSCPTLSpeakerIDMap :: Maybe (StreamFile 'StreamIn "Speaker ID map YAML")+  } deriving (Eq, Show, Generic)++parseCLIOptsToSCPTL :: Parser CfgToSCPTL+parseCLIOptsToSCPTL =+    CfgToSCPTL <$> pStreamIn <*> pStreamOut <*> optional speakerIDMapOpt+  where+    speakerIDMapOpt =+        StreamFile <$> strOption (    long "speaker-ids"+                                   <> help "File containing speaker IDs" )++runToSCPTL :: MonadIO m => CfgToSCPTL -> m ()+runToSCPTL cfg = do+    speakerIDMap <- do+        case cfgToSCPTLSpeakerIDMap cfg of+          Nothing -> return $ const Nothing+          Just sidmapfp -> parseSpeakerMap sidmapfp+    let env = Env+                { envPendingPlaceholder = "TODO not yet translated"+                , envSpeakerIDMap       = speakerIDMap }+    let scpIn = cfgToSCPTLStreamIn cfg+    scpYAMLBs <- readStreamBytes scpIn+    scp <- badParseYAML @SCP' scpYAMLBs+    let scptl   = genTL env scp+        scptlBs = Data.Yaml.Pretty.encodePretty ycTLSeg scptl+    writeStreamTextualBytes (cfgToSCPTLStreamOut cfg) scptlBs++-- | Silly pretty config to get my preferred layout easily.+--+-- Looks silly, but gets the job done very smoothly. Snoyman's yaml library is+-- based for exposing this.+ycTLSeg :: Yaml.Pretty.Config+ycTLSeg =+      Yaml.Pretty.setConfDropNull True+    $ Yaml.Pretty.setConfCompare tlSegFieldOrdering+    $ Yaml.Pretty.defConfig++data SCPSpeakerData = SCPSpeakerData+  { scpSpeakerDataStringAtPointer :: Text+  } deriving (Generic, Eq, Show)++-- TODO previously was rejectUnknownFields = False, now True...+instance ToJSON   SCPSpeakerData where+    toJSON     = gtjg "scpSpeakerData"+    toEncoding = gteg "scpSpeakerData"+instance FromJSON SCPSpeakerData where+    parseJSON  = gpjg "scpSpeakerData"++parseSpeakerMap :: MonadIO m => StreamFile 'StreamIn s -> m (Natural -> Maybe Text)+parseSpeakerMap fp = do+    bs <- readStreamFileBytes fp+    speakers <- badParseYAML @[SCPSpeakerData] bs+    let speakerMap = Map.fromList $ zip [1..] speakers+    return $ \n -> scpSpeakerDataStringAtPointer <$> Map.lookup n speakerMap++data CfgApplySCPTL = CfgApplySCPTL+  { cfgApplySCPTLStreamIn  :: Stream     'StreamIn  "YAML SCP"+  , cfgApplySCPTLFileIn    :: StreamFile 'StreamIn  "SCPTL"+  , cfgApplySCPTLStreamOut :: Stream     'StreamOut "edited YAML SCP"+  } deriving (Eq, Show, Generic)++parseCLIOptsApplySCPTL :: Parser CfgApplySCPTL+parseCLIOptsApplySCPTL =+    CfgApplySCPTL <$> pStreamIn <*> pStreamFileIn <*> pStreamOut++runApplySCPTL :: MonadIO m => CfgApplySCPTL -> m ()+runApplySCPTL cfg = do+    scpYAMLBs <- readStreamBytes $ cfgApplySCPTLStreamIn cfg+    scp       <- badParseYAML @SCP' scpYAMLBs+    scptlYAMLBs <- readStreamFileBytes $ cfgApplySCPTLFileIn cfg+    scptl       <- badParseYAML @SCPTL' scptlYAMLBs+    case apply scp scptl of+      Left  err  -> error $ show err+      Right scp' ->+        let scpYAMLBs' = Yaml.Pretty.encodePretty scpPrettyYamlCfg scp'+         in writeStreamTextualBytes (cfgApplySCPTLStreamOut cfg) scpYAMLBs'
+ gtvm-hs.cabal view
@@ -0,0 +1,109 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.36.1.+--+-- see: https://github.com/sol/hpack++name:           gtvm-hs+version:        1.0.0+synopsis:       Various tools for reversing and using assets from Golden Time: Vivid Memories.+description:    Please see README.md.+category:       Data+homepage:       https://github.com/raehik/gtvm-hs#readme+bug-reports:    https://github.com/raehik/gtvm-hs/issues+author:         Ben Orchard+maintainer:     Ben Orchard <thefirstmuffinman@gmail.com>+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/raehik/gtvm-hs++library+  exposed-modules:+      GTVM.Internal.Json+      GTVM.SCP+      GTVM.SCP.TL+      GTVM.Studio+      Util.Text+  other-modules:+      Paths_gtvm_hs+  hs-source-dirs:+      src+  default-extensions:+      LambdaCase+      NoStarIsType+      DerivingVia+      DeriveAnyClass+      GADTs+      RoleAnnotations+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+  ghc-options: -Wall -Wno-unticked-promoted-constructors+  build-depends:+      aeson >=2.1 && <2.3+    , base >=4.18 && <5+    , binrep >=1.0.0 && <1.1+    , containers >=0.6 && <0.8+    , exceptions >=0.10.7 && <0.11+    , generic-data-functions >=0.6.0 && <0.7+    , mtl >=2.3.1 && <2.4+    , path >=0.9.5 && <0.10+    , polysemy >=1.9.2.0 && <1.10+    , strongweak >=0.9.1 && <0.10+    , symparsec >=1.1.1 && <1.2+    , text >=2.0.1 && <2.2+    , yaml >=0.11.11.2 && <0.12+  default-language: GHC2021++executable gtvm-hs+  main-is: Main.hs+  other-modules:+      Common.CLIOptions+      Common.Config+      Common.IO+      Common.Util+      Tool.SCP.Code+      Tool.SCP.Common+      Tool.SCP.TL+      Paths_gtvm_hs+  hs-source-dirs:+      app+  default-extensions:+      LambdaCase+      NoStarIsType+      DerivingVia+      DeriveAnyClass+      GADTs+      RoleAnnotations+      DefaultSignatures+      TypeFamilies+      DataKinds+      MagicHash+  ghc-options: -Wall -Wno-unticked-promoted-constructors -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson >=2.1 && <2.3+    , base >=4.18 && <5+    , binrep >=1.0.0 && <1.1+    , bytestring >=0.11 && <0.13+    , containers >=0.6 && <0.8+    , exceptions >=0.10.7 && <0.11+    , generic-data-functions >=0.6.0 && <0.7+    , gtvm-hs+    , mtl >=2.3.1 && <2.4+    , optparse-applicative >=0.18.1.0 && <0.19+    , path >=0.9.5 && <0.10+    , polysemy >=1.9.2.0 && <1.10+    , rerefined >=0.6.0 && <0.7+    , strongweak >=0.9.1 && <0.10+    , symparsec >=1.1.1 && <1.2+    , text >=2.0.1 && <2.2+    , yaml >=0.11.11.2 && <0.12+  default-language: GHC2021
+ src/GTVM/Internal/Json.hs view
@@ -0,0 +1,31 @@+module GTVM.Internal.Json+  ( module GTVM.Internal.Json+  , ToJSON(..), genericToEncoding, genericToJSON+  , FromJSON(..), genericParseJSON+  ) where++import Data.Aeson+import Data.Aeson.Types ( Parser )+import GHC.Generics ( Generic, Rep )++-- We cheat and use the same string for both the field label and constructor tag+-- modifier, because we figure that you'll only be using this on a product type+-- or an enum-like sum type (no inner fields).+jcGtvmhs :: String -> Options+jcGtvmhs x = defaultOptions+  { fieldLabelModifier     = labelMod+  , constructorTagModifier = labelMod+  , rejectUnknownFields    = True+  } where labelMod = camelTo2 '_' . drop (length x)++-- | Shortcut for genericParseJSON (gtvm-hs)+gpjg :: (Generic a, GFromJSON Zero (Rep a)) => String -> Value -> Parser a+gpjg = genericParseJSON . jcGtvmhs++-- | Shortcut for genericToJSON (gtvm-hs)+gtjg :: (Generic a, GToJSON' Value Zero (Rep a)) => String -> a -> Value+gtjg = genericToJSON . jcGtvmhs++-- | Shortcut for genericToEncoding (gtvm-hs)+gteg :: (Generic a, GToJSON' Encoding Zero (Rep a)) => String -> a -> Encoding+gteg = genericToEncoding . jcGtvmhs
+ src/GTVM/SCP.hs view
@@ -0,0 +1,528 @@+{-# LANGUAGE OverloadedStrings #-} -- for some strings+{-# LANGUAGE ApplicativeDo #-} -- for a Traversable instance+{-# LANGUAGE TemplateHaskell #-} -- for g-d-f workaround (search `$(pure [])`)+{-# LANGUAGE UndecidableInstances #-} -- for Symparsec++{- | Definitions for the SCP schema used in Golden Time: Vivid Memories.++This module doubles as a sort of showcase for raehik's zoo of high-performance+binary and generics libraries, and how one might use them to do some reverse+engineering.++The 'Seg' type and definitions following it are of primary interest.+-}++module GTVM.SCP where++import Binrep+import Binrep.Util.ByteOrder+import Binrep.Common.Via.Generically.NonSum+import Binrep.Type.Prefix.Count ( CountPrefixed )+import Numeric.Natural ( Natural )+import Data.Text ( Text )+import Data.Word ( Word8, Word32 )+import GHC.Generics ( Generic )+import Strongweak+import Strongweak.Generic++import Symparsec.Parsers qualified as Symparsec+import Symparsec.Run     qualified as Symparsec+import Generic.Data.MetaParse.Cstr+  ( CstrParser'(CstrParseResult), CstrParser(ParseCstr, ReifyCstrParseResult) )+import GHC.TypeLits ( KnownNat, natVal' )++import Data.Aeson qualified as Aeson++-- | Shorthand for a single byte.+type W8  = Word8++-- | Shorthand for a little-endian 4-byte word. (The SCP format solely uses+--   little-endian, so we simply hard-code it here.)+type W32 = ByteOrdered LittleEndian Word32++-- | Shorthand for a list of something, prefixed by its length as a single byte.+type PfxLenW8 = CountPrefixed Word8 []++newtype AW32Pairs s a = AW32Pairs+  { unAW32Pairs :: SW s (PfxLenW8 (a, SW s W32)) }+    deriving stock Generic++deriving stock instance Show a => Show (AW32Pairs 'Weak a)+deriving stock instance Eq   a => Eq   (AW32Pairs 'Weak a)++deriving stock instance Show a => Show (AW32Pairs 'Strong a)+deriving stock instance Eq   a => Eq   (AW32Pairs 'Strong a)++instance Functor (AW32Pairs 'Weak) where+    fmap f = AW32Pairs . map (\(a, b) -> (f a, b)) . unAW32Pairs++instance Foldable (AW32Pairs 'Weak) where+    foldMap f = mconcat . map (f . fst) . unAW32Pairs++instance Traversable (AW32Pairs 'Weak) where+    traverse f (AW32Pairs xs) = do+        xs' <- traverse (traverseFst f) xs+        return $ AW32Pairs xs'++traverseFst :: Applicative f => (a -> f b) -> (a, x) -> f (b, x)+traverseFst f (a, x) = do+    b <- f a+    return (b, x)++instance Weaken (AW32Pairs 'Strong a) where+    type Weak   (AW32Pairs 'Strong a) = AW32Pairs 'Weak a+    weaken (AW32Pairs x) = AW32Pairs $ map (\(l, r) -> (l, weaken r)) $ weaken x++instance Strengthen (AW32Pairs 'Strong a) where+    strengthen (AW32Pairs a) = do+        case traverse go a of+          Left  e -> Left e+          Right b -> do+            case strengthen b of+              Left  e -> Left e+              Right c -> Right $ AW32Pairs c+      where+        go (l, r) = do+            case strengthen r of+              Left  e  -> Left e+              Right r' -> Right (l, r')++deriving via (PfxLenW8 (a, W32)) instance BLen a => BLen (AW32Pairs 'Strong a)+deriving via (PfxLenW8 (a, W32)) instance Put  a => Put  (AW32Pairs 'Strong a)+deriving via (PfxLenW8 (a, W32)) instance Get  a => Get  (AW32Pairs 'Strong a)++-- TODO wtf do these look like? and shouldn't I do deriving via?+instance Aeson.ToJSON   a => Aeson.ToJSON   (AW32Pairs 'Weak a)+instance Aeson.FromJSON a => Aeson.FromJSON (AW32Pairs 'Weak a)++newtype W322Block (s :: Strength) = W322Block+    { unW322Block :: SW s (PfxLenW8 (SW s (PfxLenW8 (SW s W32)))) }+    deriving stock Generic++deriving stock instance Show (W322Block 'Weak)+deriving stock instance Eq   (W322Block 'Weak)++deriving stock instance Show (W322Block 'Strong)+deriving stock instance Eq   (W322Block 'Strong)++deriving via (PfxLenW8 (PfxLenW8 W32)) instance BLen (W322Block 'Strong)+deriving via (PfxLenW8 (PfxLenW8 W32)) instance Put  (W322Block 'Strong)+deriving via (PfxLenW8 (PfxLenW8 W32)) instance Get  (W322Block 'Strong)++deriving via [[Natural]] instance Aeson.ToJSON   (W322Block 'Weak)+deriving via [[Natural]] instance Aeson.FromJSON (W322Block 'Weak)++instance Weaken (W322Block 'Strong) where+    type Weak   (W322Block 'Strong) = W322Block 'Weak+    weaken (W322Block a) = W322Block $ map (map weaken . weaken) $ weaken a++instance Strengthen (W322Block 'Strong) where+    strengthen (W322Block a) = do+        case traverse (traverse strengthen) a of -- strengthen ints+          Left  e -> Left e+          Right b -> do+            case traverse strengthen b of -- strengthen inner lists+              Left e -> Left e+              Right c  -> do+                case strengthen c of -- strengthen outer list+                  Left e -> Left e+                  Right d -> Right $ W322Block d++data Seg05Text (s :: Strength) a = Seg05Text+  { seg05TextSpeakerUnkCharID :: SW s W8+  , seg05TextSpeakerID :: SW s W32+  , seg05TextText :: a+  , seg05TextVoiceLine :: a+  , seg05TextCounter :: SW s W32+  } deriving stock Generic++deriving stock instance Show a => Show (Seg05Text 'Strong a)+deriving stock instance Eq   a => Eq   (Seg05Text 'Strong a)++instance Weaken (Seg05Text 'Strong a) where+    type Weak   (Seg05Text 'Strong a) = Seg05Text 'Weak a+    weaken = weakenGeneric+instance Strengthen (Seg05Text 'Strong a) where+    strengthen = strengthenGeneric++deriving stock instance Show a => Show (Seg05Text 'Weak a)+deriving stock instance Eq   a => Eq   (Seg05Text 'Weak a)+deriving stock instance Functor     (Seg05Text 'Weak)+deriving stock instance Foldable    (Seg05Text 'Weak)+deriving stock instance Traversable (Seg05Text 'Weak)++-- These generic instances assert that the type has 1 constructor.+-- Try adding another constructor to enjoy an appropriate type error.+deriving via (GenericallyNonSum (Seg05Text Strong a))+    instance BLen a => BLen (Seg05Text Strong a)+deriving via (GenericallyNonSum (Seg05Text Strong a))+    instance  Put a =>  Put (Seg05Text Strong a)+deriving via (GenericallyNonSum (Seg05Text Strong a))+    instance  Get a =>  Get (Seg05Text Strong a)++instance Aeson.ToJSON   a => Aeson.ToJSON   (Seg05Text 'Weak a) where+    toJSON     = Aeson.genericToJSON     jcSeg05+    toEncoding = Aeson.genericToEncoding jcSeg05+instance Aeson.FromJSON a => Aeson.FromJSON (Seg05Text 'Weak a) where+    parseJSON  = Aeson.genericParseJSON  jcSeg05++-- | 'Seg05Text' JSON config.+--+-- If aeson were better, we would do this in types like binrep, but alas.+jcSeg05 :: Aeson.Options+jcSeg05 = Aeson.defaultOptions+  { Aeson.fieldLabelModifier =+        Aeson.camelTo2 '_' . drop (length ("seg05Text" :: String))+  , Aeson.rejectUnknownFields = True+  }++{- | A single SCP segment, or command.++In the binary schema, SCP segments are formed with a byte prefix, indicating+what segment follows, followed by the appropriate segment contents.+Further, segments are often made of individual fields, concatenated.+This is extremely convenient to define using a Haskell ADT!++* A single constructor defines a single segment type.+* Constructors encode their segment byte prefix in their name.+* Constructor fields indicate their contents, and field order.++binrep can use all of this information to derive generic serializers and parsers+with minimal extra effort, provided that /every type used inside defines a+precise binary schema/. For example, sized words like 'Word32' must be+accompanied by an endianness.++This is great... but now our type is rather unwieldy for using in Haskell land,+where endianness is irrelevant and we perhaps prefer to ignore word sizes.+This is where the 'SW' wrapper comes in. Wrap every type with extra, "unwanted"+information in a @'SW' (s :: 'Strength') a@:++* When @s ~ 'Strong'@, @a@ is used directly. This is the "exact" mode. Use this+  one for binrep instances.+* When @s ~ 'Weak'@, @'Weak' a@ is used. Use this one for aeson instances, easy+  transformation, and generally working with in handwritten Haskell.++The strongweak package is used to determine how types are weakened. Usually it's+stuff like removing newtype wrappers, turning words to 'Natural's (and signed+words to 'Integer's).++Furthermore, we can then derive our /own/ weakeners and strengtheners.+Provided you write the type as above, strongweak's generics simply do all the+work for you. With all this, a command-line interface for coding between JSON+and binary versions of the schema can be written in like 5 lines.+(Really. See "Tool.SCP.Code".)+-}+data Seg (s :: Strength) a+  = Seg00+  | Seg01BG a (SW s W8) (SW s W8)+  | Seg02SFX a (SW s W8)+  | Seg03 (SW s W8) a (SW s W8)+  | Seg04 (SW s W8) (SW s W8)++  | Seg05 (Seg05Text s a)+  -- ^ Includes player-facing text.++  -- no 0x06++  | Seg07SCP a+  | Seg08++  | Seg09Choice (SW s W8) (AW32Pairs s a)+  -- ^ Includes player-facing text. Choice selection. The 'W32's appear to be+  --   the same counter as textboxes!+  --+  -- The 'W8' seems to be an file-unique identifier for the choice selection.+  -- SCP files with multiple choices have 0, 1, 2 etc. in ascending order.++  | Seg0A (W322Block s)++  | Seg0B (SW s W8) (SW s W8)+  -- ^ Appears to indicate where a given choice jumps to.+  --+  -- First 'W8' appears to specify which choice selection it relates to.+  -- Second 'W8' appears to be the choice index in that choice selection+  -- (usually 0, 1). They may be highly separated, in cases where a choice+  -- changes lots of dialog.++  | Seg0CFlag (SW s W8) (SW s W8)+  | Seg0D (SW s W8)+  | Seg0E (SW s W8)+  | Seg0F+  | Seg10 (SW s W8) (SW s W8) (SW s W8)+  | Seg11EventCG a+  | Seg12++  | Seg13 (SW s W8) a (SW s W8) (SW s W32)+  -- ^ Possibly player-facing text. Registers words for the feast+  --   Danganronpa-style minigame, but using indices which correspond to+  --   textures with the text on. The usage of the text here is unknown.++  | Seg14 (SW s W8)+  | Seg15+  | Seg16Wadai+  | Seg17 (SW s W8) (SW s W8)+  | Seg18 (SW s W8) (SW s W8)+  | Seg19 (SW s W8) (SW s W8)+  -- no 0x1A+  -- no 0x1B+  -- no 0x1C+  | Seg1D+  | Seg1E (SW s W8)+  | Seg1FDelay+  | Seg20 (SW s W8)+  | Seg21++  | Seg22 a (AW32Pairs s a)+  -- ^ Includes player-facing text. Choice, plus an extra string. Seem to be+  --   used in the conversation events.++  | Seg23SFX++  | Seg24 a+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg25+  | Seg26++  | Seg27 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg28 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg29 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg2A (SW s W8) (SW s W8)++  | Seg2B (SW s W8) (SW s W8) (SW s W8) a (W322Block s)++  | Seg2CMap++  | Seg2D a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg2E (SW s W8) (SW s W8) (SW s W32) (SW s W32)+  | Seg2F (SW s W8)+  | Seg30 (SW s W8)+  | Seg31+  | Seg32 (SW s W32) (SW s W8)+  | Seg33 (SW s W8) (SW s W8)+  | Seg34 (SW s W32)++  | Seg35 a+  -- ^ Likely player-facing. Kinda sounds like it's a type of Banri choice.++  | Seg36 (SW s W8) (SW s W32)+  | Seg37 (SW s W8) (SW s W32)+  | Seg38 (SW s W8) (SW s W32)+  | Seg39+  | Seg3A (SW s W8) (SW s W8)+  | Seg3B (SW s W8)+  | Seg3C (SW s W8) (SW s W8)+  | Seg3D+  | Seg3E (SW s W8) (SW s W8)+  | Seg3F (SW s W8) (SW s W32) (SW s W32)+  | Seg40 (SW s W8)+  | Seg41 (SW s W8) (SW s W32) (SW s W32)+  | Seg42 (SW s W8)++  -- these don't appear very SFXy in code, but did in data+  | Seg43SFX a+  | Seg44SFX a+  | Seg45SFX a (SW s W8)++  | Seg46 (SW s W8) (SW s W8)+  | Seg47 (SW s W8) (SW s W8)+  | Seg48+  | Seg49+  | Seg4A+  | Seg4B++  | Seg4C a+  -- Unknown. Appears unused.++  | Seg4D+  | Seg4E++  | Seg4F a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg50 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg51 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg52 a+  -- ^ Text not user-facing. Refers to a @sound/voice@ file - all the uses I've+  --   seen are girls telling you 飲んで飲んで！++  | Seg53 a (SW s W8) (SW s W8)+  -- ^ Unknown. Text seems to correspond to MDL files in the @r2d@ directory.++  | Seg54 (SW s W8) (SW s W8)+  | Seg55 (SW s W8) (SW s W8)+  | Seg56 (SW s W8) (SW s W8)+  | Seg57 (SW s W8) (SW s W8)+  | Seg58 (SW s W8) (SW s W8)+  | Seg59 (SW s W8)+  | Seg5A (SW s W32) (SW s W8)+  | Seg5B (SW s W32)+  | Seg5C (SW s W8)+  | Seg5D (SW s W32)+  | Seg5E (SW s W32)+  | Seg5F (SW s W32)+  | Seg60 (SW s W32)+  | Seg61 (SW s W8) (SW s W8)+  | Seg62 (SW s W8) -- 0x01 <= w8 <= 0x11, no default+  | Seg63+  | Seg64+  | Seg65Trophy+  | Seg66+  | Seg67+  | Seg68+  | Seg69+  | Seg6A (SW s W8)+  | Seg6B (SW s W8)+  | Seg6CWipe (SW s W8) (SW s W32) (SW s W32) (SW s W32)+  | Seg6DWipe (SW s W8) (SW s W32) (SW s W32) (SW s W32)+  | Seg6E+  | Seg6F+  | Seg70 (SW s W8) (SW s W8)+  | Seg71 (SW s W8) (SW s W8)+  | Seg72+  | Seg73Kyoro (SW s W8) (SW s W32) -- 0x01 <= w8 <= 0x06, with default+  | Seg74+  | Seg75 (SW s W8)+  | Seg76+  | Seg77SCP (SW s W8)+    deriving stock Generic++deriving stock instance Show a => Show (Seg 'Weak a)+deriving stock instance Eq   a => Eq   (Seg 'Weak a)++deriving stock instance Show a => Show (Seg 'Strong a)+deriving stock instance Eq   a => Eq   (Seg 'Strong a)++{- | Parse @SegXX@, where @XX@ is a hexadecimal number.++This is a Symparsec type-level string parser.+We use it to parse the 'Seg' constructors on the type level,+when deriving generic binrep instances.+See the symparsec package for more details.+-}+type ParseSeg =+                   Symparsec.Literal "Seg"+    Symparsec.:*>: Symparsec.Isolate 2 Symparsec.NatHex++-- | First part of the 'Seg' constructor parser instance.+instance CstrParser' Seg where+    type CstrParseResult Seg = Natural++{- The below instance is dependent on the above instance.+As of GHC 9.10, this is a problem for GHC and hits a known bug:+https://gitlab.haskell.org/ghc/ghc/-/issues/22257+https://gitlab.haskell.org/ghc/ghc/-/issues/12088 underlying long-standing bug+A solution is to insert an empty Template Haskell splice between the instances.+-}+$(pure [])++-- | Second part of the 'Seg' constructor parser instance.+instance CstrParser  Seg where+    type ReifyCstrParseResult Seg n = KnownNat n+    type ParseCstr Seg cstr =+        Symparsec.Run'_ ParseSeg cstr++{- These instances derive performant binary codings for 'Seg'.+Unlike 'Seg05Text', 'Seg' is a sum type, having multiple constructors.+binrep's sum generics only support one method for handling sum types: a prefix+"constructor tag", which unambiguously defines which constructor follows.+The SCP schema follows this pattern, so we can leverage the sum generics.++But how do we tell binrep what to use for the constructor tag?+Using the constructor name seems sensible, and can be seen in e.g. aeson.+So we encode the constructor tag in the Haskell constructor name.+But now we have to /decode/ the constructor name to get at the tag!+We could do this at runtime with a 'String' parser, but we lose type safety+(what if the parser fails?), and have to rely on GHC to inline all that work.++binrep permits passing a /type-level string parser/ which is used to parse the+constructor to some types, which are then reified down to a binrep-compatible+value. The user must put in a little more work:++* we pass this parser via a type class+  * I suggest using the type itself 'Seg' as the instance, because why not?+    The type class is only for enumeration, and we stay simple & clean that way.+* we need to use a Template Haskell hack to work around a GHC limitation+  (existing as of GHC 9.10)+* the interface is currently messy, probably 'BLen' and 'Put' should look more+  like 'Get'++But in return, we receive a guarantee that our constructors are well-formed, and+likely better runtime performance (as GHC will have less code to inline and thus+hopefully an easier time to get it right).++Note how we don't write /anything else/ about how to parse or serialize the+type. That is fully described by the type itself. I have confidence that writing+the 'Put' and 'Get' instances in most other programming languages would take+some hundreds of lines, a couple for each constructor. Here, it's... one.+-}+instance BLen a => BLen (Seg 'Strong a) where+    blen = blenGenericSum @Seg (\_p -> 1)+instance Put  a => Put  (Seg 'Strong a) where+     put =  putGenericSum @Seg (\p -> put @Word8 (fromIntegral (natVal' p)))+instance Get  a => Get  (Seg 'Strong a) where+     get =  getGenericSum @Seg @Word8 (\p -> fromIntegral (natVal' p)) (==)++-- | 'Seg' JSON config.+--+-- If aeson were better, we would do this in types like binrep, but alas.+jcSeg :: Aeson.Options+jcSeg = Aeson.defaultOptions+  { Aeson.constructorTagModifier  = take 2 . drop (length ("Seg" :: String))+  , Aeson.rejectUnknownFields = True+  , Aeson.sumEncoding = Aeson.TaggedObject+    { Aeson.tagFieldName      = "command_byte"+    , Aeson.contentsFieldName = "arguments"+    }+  }++instance Aeson.ToJSON   a => Aeson.ToJSON   (Seg 'Weak a) where+    toJSON     = Aeson.genericToJSON     jcSeg+    toEncoding = Aeson.genericToEncoding jcSeg+instance Aeson.FromJSON a => Aeson.FromJSON (Seg 'Weak a) where+    parseJSON  = Aeson.genericParseJSON  jcSeg++++{- | The SCP format.++The SCP format is very simple: it is a concatenated list of segments.+There is no length indicator; EOF is used to indicate no more segments.+This is precisely how the binrep 'List' instance works, so we leverage it.+-}+type SCP s a = [Seg s a]++scpFmap :: (a -> b) -> SCP 'Weak a -> SCP 'Weak b+scpFmap = fmap . fmap++scpTraverse :: Applicative f => (a -> f b) -> SCP 'Weak a -> f (SCP 'Weak b)+scpTraverse = traverse . traverse++scpSegFieldOrdering :: Text -> Text -> Ordering+scpSegFieldOrdering = go+  where+    go "command_byte" _ = LT+    go _ "command_byte" = GT+    go k1 k2 = compare k1 k2++deriving stock instance Functor     (Seg 'Weak)+deriving stock instance Foldable    (Seg 'Weak)+deriving stock instance Traversable (Seg 'Weak)++instance Weaken (Seg 'Strong a) where+    type Weak   (Seg 'Strong a) = Seg 'Weak a+    weaken = weakenGeneric+instance Strengthen (Seg 'Strong a) where+    strengthen = strengthenGeneric
+ src/GTVM/SCP/TL.hs view
@@ -0,0 +1,375 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Intent: A sum type with a constructor corresponding to each SCP macro that+     stores user-facing text, with fields to allow checking & replacing such+     text.++We need sum types if we want to handle everything in one place. CSVs don't+support sum types. YAML does. And with sum types, we can also generate+comments from a source SCP -- to e.g. say when another SCP is loaded.++TODO+  * Aeson won't ever omit fields for generic parsing or serializing, except in+    the specific case where you have a concrete @'Maybe' a@. To work around+    that, I need to write a separate, structurally simplified type, which can be+    used for the JSON, and converted to the more powerful internal data type for+    operating on.+-}++module GTVM.SCP.TL where++import GTVM.SCP++import GTVM.Internal.Json+import Util.Text ( tshow )+import Data.Aeson qualified as Aeson++import Strongweak++import GHC.Generics ( Generic )++import Data.Text ( Text )+import Data.Text qualified as Text+import Data.Map ( Map )+import Data.Map qualified as Map+import Data.Char qualified+import Data.Maybe ( fromMaybe )+import Data.Functor.Identity+import Data.Functor.Const++import Control.Monad.State++import Numeric.Natural ( Natural )++type Seg' = Seg 'Weak Text+type SCP' = [Seg']++type SCPTL f a = [TLSeg f a]+type SCPTL' = SCPTL Identity Text++data Env = Env+  { envPendingPlaceholder :: Text++  , envSpeakerIDMap       :: Natural -> Maybe Text+  -- ^ Attempt to obtain a pretty speaker name from an ID.+  --+  -- This data isn't stored in the repo, and must instead be parsed at runtime.++  } deriving (Generic)++data TLSeg f a+  = TLSegTextbox'  (TLSegTextbox f a)+  | TLSegChoice'   [TLSegChoice f a]+  | TLSeg22Choice' (TLSeg22 f a)+  | TLSeg35Choice' (TLSegChoice f a)+  | TLSegComment'  TLSegComment+    deriving (Generic)++deriving instance (Eq   (f a), Eq   a) => Eq   (TLSeg f a)+deriving instance (Show (f a), Show a) => Show (TLSeg f a)++deriving instance Functor     f => Functor     (TLSeg f)+deriving instance Foldable    f => Foldable    (TLSeg f)+deriving instance Traversable f => Traversable (TLSeg f)++jcTLSeg :: Aeson.Options+jcTLSeg = Aeson.defaultOptions+  { Aeson.constructorTagModifier = map Data.Char.toLower . init . drop 5+  , Aeson.sumEncoding = Aeson.TaggedObject+    { Aeson.tagFieldName = "type"+    , Aeson.contentsFieldName = "contents" }}++instance (ToJSON   (f a), ToJSON   a) => ToJSON   (TLSeg f a) where+    toJSON     = genericToJSON     jcTLSeg+    toEncoding = genericToEncoding jcTLSeg+instance (FromJSON (f a), FromJSON a) => FromJSON (TLSeg f a) where+    parseJSON  = genericParseJSON  jcTLSeg++data TLSegComment = TLSegComment+  { scpTLCommentCommentary :: [Text]+  , scpTLCommentMeta       :: Map Text Text+  } deriving stock (Generic, Eq, Show)++instance ToJSON   TLSegComment where+    toJSON     = gtjg "scpTLComment"+    toEncoding = gteg "scpTLComment"+instance FromJSON TLSegComment where+    parseJSON  = gpjg "scpTLComment"++data TLSegTextbox f a = TLSegTextbox+  { tlSegTextboxSource      :: f a+  , tlSegTextboxTranslation :: a+  , tlSegTextboxOverflow    :: Maybe a+  } deriving (Generic)++deriving instance (Eq   (f a), Eq   a) => Eq   (TLSegTextbox f a)+deriving instance (Show (f a), Show a) => Show (TLSegTextbox f a)++deriving instance Functor     f => Functor     (TLSegTextbox f)+deriving instance Foldable    f => Foldable    (TLSegTextbox f)+deriving instance Traversable f => Traversable (TLSegTextbox f)++instance (ToJSON   (f a), ToJSON   a) => ToJSON   (TLSegTextbox f a) where+    toJSON     = gtjg "tlSegTextbox"+    toEncoding = gteg "tlSegTextbox"+instance (FromJSON (f a), FromJSON a) => FromJSON (TLSegTextbox f a) where+    parseJSON  = gpjg "tlSegTextbox"++data TLSegChoice f a = TLSegChoice+  { tlSegChoiceSource :: f a+  , tlSegChoiceTranslation :: a+  } deriving (Generic)++deriving instance (Eq   (f a), Eq   a) => Eq   (TLSegChoice f a)+deriving instance (Show (f a), Show a) => Show (TLSegChoice f a)++deriving instance Functor     f => Functor     (TLSegChoice f)+deriving instance Foldable    f => Foldable    (TLSegChoice f)+deriving instance Traversable f => Traversable (TLSegChoice f)++instance (ToJSON   (f a), ToJSON   a) => ToJSON   (TLSegChoice f a) where+    toJSON     = gtjg "tlSegChoice"+    toEncoding = gteg "tlSegChoice"+instance (FromJSON (f a), FromJSON a) => FromJSON (TLSegChoice f a) where+    parseJSON  = gpjg "tlSegChoice"++data TLSeg22 f a = TLSeg22+  { tlSeg22TopicSource      :: f a+  , tlSeg22TopicTranslation :: a+  , tlSeg22Choices          :: [TLSegChoice f a]+  } deriving (Generic)++deriving instance (Eq   (f a), Eq   a) => Eq   (TLSeg22 f a)+deriving instance (Show (f a), Show a) => Show (TLSeg22 f a)++deriving instance Functor     f => Functor     (TLSeg22 f)+deriving instance Foldable    f => Foldable    (TLSeg22 f)+deriving instance Traversable f => Traversable (TLSeg22 f)++instance (ToJSON   (f a), ToJSON   a) => ToJSON   (TLSeg22 f a) where+    toJSON     = gtjg "tlSeg22"+    toEncoding = gteg "tlSeg22"+instance (FromJSON (f a), FromJSON a) => FromJSON (TLSeg22 f a) where+    parseJSON  = gpjg "tlSeg22"++genTL :: Env -> SCP' -> [TLSeg Identity Text]+genTL env = concatMap go+  where+    go = \case+      -- Segments that contain text to translate. Some generation functions also+      -- handle the commentary, some are plain combinators.+      Seg05 tb  -> genTLTextbox env tb+      Seg09Choice csi (AW32Pairs cs) -> genTLChoiceOuter env csi (map fst cs)+      Seg22 s (AW32Pairs cs) -> [TLSeg22Choice' $ genTL22Choices env s (map fst cs)]+      Seg35 c -> [TLSeg35Choice' $ genTLChoice env c]++      -- Extra segments that are useful to know the presence of.+      Seg0B csi ci ->+        [ meta [ "Choice jump below. Check which choice & choice selection this corresponds to." ]+               [ ("choice_selection_index", tshow csi)+               , ("choice_index", tshow ci) ] ]+      Seg07SCP scp ->+        [ meta [ "Script jump. Any following text is likely accessed by a choice." ]+               [ ("scp_jump_target", scp) ] ]+      Seg0CFlag{} ->+        [ meta [ "0C command here. Alters flow (perhaps checks a flag)." ]+               [] ]++      -- Don't care about the rest.+      _ -> []++genTLTextbox :: Env -> Seg05Text 'Weak Text -> [TLSeg Identity Text]+genTLTextbox env tb =+  [ TLSegComment' ( TLSegComment+    { scpTLCommentCommentary = []+    , scpTLCommentMeta       =+        let speakerName = fromMaybe "N/A" $ envSpeakerIDMap env $ seg05TextSpeakerID tb+         in Map.singleton "speaker" speakerName } )+  , TLSegTextbox'+    ( TLSegTextbox+      { tlSegTextboxSource      = Identity $ seg05TextText tb+      , tlSegTextboxTranslation = envPendingPlaceholder env+      , tlSegTextboxOverflow    = Nothing } )+  ]++genTLChoiceOuter :: Env -> Natural -> [Text] -> [TLSeg Identity Text]+genTLChoiceOuter env csi cs =+  [ meta [ "Choice selection below. Script flow jumps depending on selection." ]+         [ ("choice_selection_index", tshow csi) ]+  , TLSegChoice' $ map (genTLChoice env) cs ]++genTLChoice :: Env -> Text -> TLSegChoice Identity Text+genTLChoice env c = TLSegChoice+                      { tlSegChoiceTranslation = envPendingPlaceholder env+                      , tlSegChoiceSource      = Identity c }++genTL22Choices :: Env -> Text -> [Text] -> TLSeg22 Identity Text+genTL22Choices env s ss = TLSeg22+  { tlSeg22TopicSource = Identity s+  , tlSeg22TopicTranslation = envPendingPlaceholder env+  , tlSeg22Choices = map (genTLChoice env) ss }++meta :: [Text] -> [(Text, Text)] -> TLSeg c s+meta cms kvs = TLSegComment' $ TLSegComment+    { scpTLCommentCommentary = cms+    , scpTLCommentMeta = Map.fromList kvs }++data Error+  = ErrorTLSegOverlong+  | ErrorSourceMismatch+  | ErrorTLSegTooShort+  | ErrorTypeMismatch+  | ErrorUnimplemented+    deriving (Generic, Eq, Show)++apply :: SCP' -> [TLSeg Identity Text] -> Either Error SCP'+apply scp scptl =+    let (scpSegsTled, scptl') = runState (traverseM applySeg scp) scptl+     in case scpSegsTled of+          Left err -> Left err+          Right scpSegsTled' ->+            let scptl'' = skipToNextTL scptl'+             in case scptl'' of+                  _:_ -> Left ErrorTLSegOverlong+                  [] -> Right $ concat scpSegsTled'++skipToNextTL :: [TLSeg c a] -> [TLSeg c a]+skipToNextTL = \case []   -> []+                     a:as -> case a of+                               TLSegComment'{} -> skipToNextTL as+                               _ -> a:as++-- Using highly explicit/manual prisms here. Could clean up.+applySeg+    :: MonadState [TLSeg Identity Text] m+    => Seg' -> m (Either Error [Seg'])+applySeg = \case+  Seg05 tb -> tryApplySeg tryExtractTextbox (tryApplySegTextbox tb)+  Seg09Choice n (AW32Pairs cs) -> tryApplySeg tryExtractChoice (tryApplySegChoice n cs)+  Seg22 topic (AW32Pairs cs) -> tryApplySeg tryExtract22 (tryApplySeg22 topic cs)+  Seg35 a -> tryApplySeg tryExtract35 (tryApplySeg35 a)+  seg -> return $ Right [seg]++tryExtractTextbox :: TLSeg c a -> Maybe (TLSegTextbox c a)+tryExtractTextbox = \case TLSegTextbox' a -> Just a+                          _               -> Nothing++tryExtractChoice :: TLSeg c a -> Maybe [TLSegChoice c a]+tryExtractChoice = \case TLSegChoice' a -> Just a+                         _              -> Nothing++tryExtract22 :: TLSeg c a -> Maybe (TLSeg22 c a)+tryExtract22 = \case TLSeg22Choice' a -> Just a+                     _                -> Nothing++tryExtract35 :: TLSeg c a -> Maybe (TLSegChoice c a)+tryExtract35 = \case TLSeg35Choice' a -> Just a+                     _                -> Nothing++tryApplySeg+    :: MonadState [TLSeg Identity Text] m+    => (TLSeg Identity Text -> Maybe a)+    -> (a -> Either Error [Seg'])+    -> m (Either Error [Seg'])+tryApplySeg f1 f2 = do+    (skipToNextTL <$> get) >>= \case+      []     -> return $ Left ErrorTLSegTooShort+      tl:tls -> do+        put tls+        case f1 tl of+          Nothing -> return $ Left ErrorTypeMismatch+          Just a  -> return $ f2 a++tryApplySegTextbox+    :: Seg05Text 'Weak Text -> TLSegTextbox Identity Text+    -> Either Error [Seg']+tryApplySegTextbox tb tbTL+  | seg05TextText tb /= runIdentity (tlSegTextboxSource tbTL) = Left ErrorSourceMismatch+  | otherwise = Right $ Seg05 tb' : overflow+  where+    tb' = tb { seg05TextText = tlSegTextboxTranslation tbTL }+    overflow = maybe [] fakeTextboxSeg $ tlSegTextboxOverflow tbTL+    fakeTextboxSeg text =+        [Seg05 $ tb { seg05TextVoiceLine = Text.empty+                        , seg05TextText      = text } ]++tryApplySegChoice+    :: Natural -> [(Text, Natural)] -> [TLSegChoice Identity Text]+    -> Either Error [Seg']+tryApplySegChoice n cs csTL+  | length cs /= length csTL = Left ErrorSourceMismatch+  -- lol whatever XD+  | not (and (map (uncurry (==)) checks)) = Left ErrorSourceMismatch+  | otherwise = Right [Seg09Choice n (AW32Pairs edited)]+  where+    checks = zip (map (runIdentity . tlSegChoiceSource) csTL) (map fst cs)+    edited = zip (map tlSegChoiceTranslation csTL) (map snd cs)++tryApplySeg22+    :: Text -> [(Text, Natural)] -> (TLSeg22 Identity Text)+    -> Either Error [Seg']+tryApplySeg22 topic cs segTL+  | topic /= runIdentity (tlSeg22TopicSource segTL) = Left ErrorSourceMismatch+  | length cs /= length csTL = Left ErrorSourceMismatch+  -- lol whatever XD+  | not (and (map (uncurry (==)) checks)) = Left ErrorSourceMismatch+  | otherwise = Right [Seg22 (tlSeg22TopicTranslation segTL) (AW32Pairs edited)]+  where+    csTL = tlSeg22Choices segTL+    checks = zip (map (runIdentity . tlSegChoiceSource) csTL) (map fst cs)+    edited = zip (map tlSegChoiceTranslation csTL) (map snd cs)++tryApplySeg35+    :: Text -> TLSegChoice Identity Text+    -> Either Error [Seg']+tryApplySeg35 a aTL+  | a /= runIdentity (tlSegChoiceSource aTL) = Left ErrorSourceMismatch+  | otherwise = Right [Seg35 (tlSegChoiceTranslation aTL)]++-- lol. ty hw-kafka-client+traverseM+    :: (Traversable t, Applicative f, Monad m)+    => (v -> m (f v'))+    -> t v+    -> m (f (t v'))+traverseM f xs = sequenceA <$> traverse f xs++-- | Field ordering. To be used for pretty printing 'TLSeg's.+--+-- TODO use \cases on GHC 9.4+tlSegFieldOrdering :: Text -> Text -> Ordering+tlSegFieldOrdering = go+  where+    go "type" _ = LT+    go _ "type" = GT+    go "source" _ = LT+    go _ "source" = GT+    go "translation" _ = LT+    go _ "translation" = GT+    go "meta" _ = LT+    go _ "meta" = GT+    go s1 s2 = compare s1 s2++--------------------------------------------------------------------------------++segIsTlTarget :: Seg f a -> Bool+segIsTlTarget = \case+  Seg05{}       -> True+  Seg09Choice{} -> True+  Seg22{}       -> True+  Seg35{}       -> True+  _             -> False++-- TODO isn't there an easier way to define this??? natural transformation????+segDropMeta :: TLSeg f a -> TLSeg (Const ()) a+segDropMeta = \case+  TLSegTextbox'  (TLSegTextbox _ t o) ->+    TLSegTextbox' $ TLSegTextbox (Const ()) t o+  TLSegChoice'   cs -> TLSegChoice' $ map handleChoice cs+  TLSeg22Choice' (TLSeg22 _ t cs) ->+    TLSeg22Choice' $ TLSeg22 (Const ()) t $ map handleChoice cs+  TLSeg35Choice' c ->+    TLSeg35Choice' $ handleChoice c+  TLSegComment' x -> TLSegComment' x+  where+    handleChoice (TLSegChoice _ t) = TLSegChoice (Const ()) t
+ src/GTVM/Studio.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}++{- Notes+  * SCPTL comments are fully ignored. They aren't indexable. They should be+    inside the constructors instead.+  * We ignore SCPTL source fields! Use the SCP instead. We can fill them all in+    in a separate pass e.g. before exporting.++TODO++  * handling unexpected index errors with runtime errors. Perhaps upgrade to+    explicitly handled ones via effect. (Impurely, they can be propagated simply+    with the final IO interpreter.)+-}++module GTVM.Studio where++import GTVM.SCP.TL+import GTVM.SCP.TL qualified as Scptl+import GTVM.SCP+import Strongweak++import Polysemy+import Polysemy.State+import Polysemy.State qualified as Polysemy+import Polysemy.Output+import Polysemy.Output qualified as Polysemy++import Path qualified+import Path ( Path, Rel, Abs, File, Dir, (</>) )++import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Data.Text ( Text )+import Numeric.Natural+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Functor.Const+import Data.Yaml qualified as Yaml+import GHC.Generics ( Generic )+import Data.String ( IsString )++newtype ScpId = ScpId { getScpId :: Text }+    deriving (Eq, IsString) via Text+    deriving stock Show++-- | Yes, we're ignoring the source fields. We'll fill them in during an export+--   pass. Easier on the brain.+type TLSeg' = TLSeg (Const ()) Text++data Studio m a where+    WriteTl :: TLSeg' -> Studio m ()++    ReadTl :: Studio m (Maybe TLSeg')+    -- ^ 'Nothing' if no entry yet. (Perhaps upgrade 'Data.Text.empty' to+    --   'Nothing'.)++    JumpTlInit :: Studio m ()+    -- ^ Jump to the first translation target SCP command and reset.++    NextTl :: Studio m ()+    -- ^ Step to the next translation target SCP command.++    PrevTl :: Studio m ()+    -- ^ Step to the previous translation target SCP command.++    LoadScp :: ScpId -> Studio m ()+    -- ^ Load the requested SCP.++    GenerateFreshScpTl :: Path Rel Dir -> Studio m ()+    -- ^ Generate a fresh SCPTL for the currently loaded SCP and place in the+    --   the requested studio folder.++    LoadScpTl :: Path Rel Dir -> Studio m ()+    -- ^ Load the SCPTL for the currently loaded SCP, stored at the requested+    --   studio folder.++    SaveScpTl :: Path Rel Dir -> Studio m ()+    -- ^ Save the currently loaded SCPTL to disk.++makeSem ''Studio++-- | Resets and steps to the translation target SCP command with the requested+--   index.+--+-- TODO better behaviour if we jump too far (don't keep spamming 'nextTl')? but+-- this should be prefaced with a UI check that the index exists+jumpTl :: Members '[Studio] r => Natural -> Sem r ()+jumpTl n = do+    jumpTlInit+    replicateM_ (fromIntegral n) nextTl++-- | Generate a fresh SCPTL for the currently loaded SCP, place in the requested+--   studio folder and load immediately.+loadFreshScpTl :: Members '[Studio] r => Path Rel Dir -> Sem r ()+loadFreshScpTl d = generateFreshScpTl d >> loadScpTl d++data St = St+  { stScp      :: [Seg 'Weak Text]+  , stScpIdx   :: Int+  , stScptl    :: Maybe [TLSeg']+  , stScptlIdx :: Int+  , stScpId :: ScpId+  } deriving stock (Generic, Show, Eq)++setAt :: Int -> a -> [a] -> [a]+setAt i a ls+  | i < 0 = ls+  | otherwise = go i ls+  where+    go 0 (_:xs) = a : xs+    go n (x:xs) = x : go (n-1) xs+    go _ []     = []++runStudio+    :: Members '[State St, Output Text, Embed IO] r+    => Path Abs Dir -> Sem (Studio ': r) a -> Sem r a+runStudio baseDir = interpret $ \case++  WriteTl tlseg -> do+    st <- get+    case stScptl st of+      Nothing ->+        studioLog "no SCPTL loaded, can't write segment TL"+      Just scptl -> do+        let scptl' = setAt (stScptlIdx st) tlseg scptl+        put st { stScptl = Just scptl' }++  ReadTl -> do+    st <- get+    case stScptl st of+      Nothing -> do+        studioLog "no SCPTL loaded, can't read current segment TL"+        pure Nothing+      Just scptl ->+        let tlSeg = scptl !! stScptlIdx st+        in  if tlSegIsEmpty tlSeg then pure Nothing else pure (Just tlSeg)++  JumpTlInit -> do+    st <- get+    put st { stScpIdx = 0, stScptlIdx = 0 }++  NextTl -> do -- TODO would benefit from lenses+    st <- get+    let scp = stScp st+        scpIdx = stScpIdx st+    if scpIdx >= length scp - 1 then+        -- need more than check to handle length 0,1 cases+        studioLog "at SCP end, can't step any further"+    else do+        let scptlIdx = stScptlIdx st+            (scpIdx', scptlIdx') =+                case scpNextTlIdx scp (scpIdx+1) of+                    Left  scpIdx'' -> (scpIdx'', scptlIdx)+                    Right scpIdx'' -> (scpIdx'', scptlIdx+1)+            st' = st { stScpIdx   = scpIdx'+                     , stScptlIdx = scptlIdx' }+        put st'++  PrevTl -> do -- TODO would benefit from lenses+    st <- get+    let scp = stScp st+        scpIdx = stScpIdx st+    if scpIdx == 0 then+        studioLog "at SCP start, can't rewind any further"+    else do+        let scptlIdx = stScptlIdx st+            (scpIdx', scptlIdx') =+                case scpPrevTlIdx scp (scpIdx-1) of+                    Nothing -> (0, scptlIdx)+                    Just scpIdx'' -> (scpIdx'', scptlIdx-1)+            st' = st { stScpIdx   = scpIdx'+                     , stScptlIdx = scptlIdx' }+        put st'++  LoadScp scpId -> do+    scpFName <- liftIO $ studioYamlRes ".scp" $ getScpId scpId+    let scpFPath = $(Path.mkRelDir "scp") </> scpFName+        fpath = baseDir </> scpFPath+        fpath' = Path.fromAbsFile fpath+    scp <- Yaml.decodeFileThrow fpath'+    modify $ \st -> st { stScpIdx = 0, stScp = scp, stScpId = scpId }++  GenerateFreshScpTl d -> do+    scp <- gets stScp++    scpId <- gets stScpId+    scptlFName <- liftIO $ studioYamlRes ".scptl" $ getScpId scpId+    let scptlFPath = $(Path.mkRelDir "scptl") </> d </> scptlFName+        fpath = baseDir </> scptlFPath+        fpath' = Path.fromAbsFile fpath++    let scptl = genEmptyScptl scp+    liftIO $ Yaml.encodeFile fpath' scptl++  LoadScpTl d -> do++    scpId <- gets stScpId+    scptlFName <- liftIO $ studioYamlRes ".scptl" $ getScpId scpId+    let scptlFPath = $(Path.mkRelDir "scptl") </> d </> scptlFName+        fpath = baseDir </> scptlFPath+        fpath' = Path.fromAbsFile fpath++    scptl <- Yaml.decodeFileThrow fpath'+    modify $ \st -> st { stScptl = Just scptl }++  SaveScpTl d -> do+    st <- get+    case stScptl st of+      Nothing -> pure () -- TODO notify+      Just scptl -> do++        scpId <- gets stScpId+        scptlFName <- liftIO $ studioYamlRes ".scptl" $ getScpId scpId+        let scptlFPath = $(Path.mkRelDir "scptl") </> d </> scptlFName+            fpath = baseDir </> scptlFPath+            fpath' = Path.fromAbsFile fpath++        liftIO $ Yaml.encodeFile fpath' scptl+++studioYamlRes :: MonadThrow m => FilePath -> Text -> m (Path Rel File)+studioYamlRes ext res = Path.parseRelFile $ Text.unpack res<>ext<>".yaml"++scpPrevTlIdx :: SCP f a -> Int -> Maybe Int+scpPrevTlIdx scp = go+  where+    go = \case+      -1     -> Nothing+      scpIdx -> if   segIsTlTarget (scp !! scpIdx)+                then Just scpIdx+                else go $ scpIdx-1++scpNextTlIdx :: SCP f a -> Int -> Either Int Int+scpNextTlIdx scp = go+  where+    l = length scp+    go scpIdx =+        if   scpIdx >= l-1+        then Left $ scpIdx-1+        else if   segIsTlTarget (scp !! scpIdx)+             then Right scpIdx+             else go $ scpIdx+1++tlSegIsEmpty :: (Eq a, Monoid a) => TLSeg f a -> Bool+tlSegIsEmpty = \case+  TLSegTextbox' x -> tlSegTextboxTranslation x == mempty -- TODO check overflow+  _ -> False++-- | Required to avoid lots of type annotation, that's life Jim+studioLog :: Member (Output Text) r => Text -> Sem r ()+studioLog = Polysemy.output++genEmptyScptl :: SCP 'Weak Text -> [TLSeg']+genEmptyScptl = map Scptl.segDropMeta . filter (not . isComment) . Scptl.genTL env+  where+    env = Scptl.Env mempty (const Nothing)+    isComment = \case TLSegComment'{} -> True; _ -> False++rLoadAndGenFirstScript :: IO ()+rLoadAndGenFirstScript =+      Polysemy.runFinal+    . Polysemy.embedToFinal @IO+    . runStudioLog Text.putStrLn+    . Polysemy.evalState (St [] 0 Nothing 0 "")+    . runStudio $(Path.mkAbsDir "/home/raehik/sh/gtvm-tl/tooling/gtvm-hs/tmp/studio")+    $ pLoadAndGenFirstScript++--------------------------------------------------------------------------------++runStudioLog+    :: Member (Embed IO) r+    => (o -> IO ()) -> Sem (Output o ': r) a -> Sem r a+runStudioLog f = interpret $ \case+  Output o -> liftIO $ f o++--------------------------------------------------------------------------------++pLoadAndGenFirstScript :: Members '[Studio, Embed IO] r => Sem r ()+pLoadAndGenFirstScript = do+    loadScp "00120zzz0"+    generateFreshScpTl $(Path.mkRelDir "tmp")+    loadScpTl $(Path.mkRelDir "tmp")+    readTl >>= liftIO . print+    writeTl $ tlsegTextbox "ayy lmao"+    readTl >>= liftIO . print+    nextTl+    nextTl+    writeTl $ tlsegTextbox "two ahead"+    saveScpTl $(Path.mkRelDir "tmp")+++tlsegTextbox :: a -> TLSeg (Const ()) a+tlsegTextbox a = Scptl.TLSegTextbox' $ Scptl.TLSegTextbox (Const ()) a Nothing
+ src/Util/Text.hs view
@@ -0,0 +1,7 @@+module Util.Text where++import Data.Text qualified as Text+import Data.Text ( Text )++tshow :: Show a => a -> Text+tshow = Text.pack . show