{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
module Anitomata.Aseprite.Preprocessor
  ( preprocessor
  , preprocessorWith
  , PreprocessorOpts(..)
  ) where

import Prelude

import Control.Applicative ((<**>))
import Data.Aeson (FromJSON)
import Data.Kind (Type)
import GHC.Generics (Generic)
import GHC.Records (HasField(getField))
import ModuleMunging
  ( DeclBody(..), DeclName(..), ModuleDeclaration(..), ModuleFragment(..), ModuleImport(..)
  , ModuleImportStyle(..), ModuleName(..), buildModule, displayModule
  )
import Text.ParserCombinators.ReadP (ReadP)
import Text.Printf (printf)
import Type.Reflection (Typeable, typeRep)

import Control.Monad qualified as Monad
import Data.Aeson qualified as Aeson
import Data.Aeson.Types qualified as Aeson.Types
import Data.Char qualified as Char
import Data.List qualified as List
import Data.Maybe qualified as Maybe
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text.IO
import Options.Applicative qualified as Opt
import System.Directory qualified as Directory
import System.Exit qualified as Exit
import System.FilePath qualified as FilePath
import Text.Read qualified as Read
import Text.ParserCombinators.ReadP qualified as ReadP

preprocessor :: IO ()
preprocessor :: IO ()
preprocessor = do
  PreprocessorOpts
opts <- ParserInfo PreprocessorOpts -> IO PreprocessorOpts
forall a. ParserInfo a -> IO a
Opt.execParser ParserInfo PreprocessorOpts
optsParser
  PreprocessorOpts -> IO ()
preprocessorWith PreprocessorOpts
opts

preprocessorWith :: PreprocessorOpts -> IO ()
preprocessorWith :: PreprocessorOpts -> IO ()
preprocessorWith PreprocessorOpts
opts = do
  [Char]
sourceFile' <- [Char] -> IO [Char]
Directory.makeRelativeToCurrentDirectory [Char]
sourceFile
  [Char]
atlasPath <- do
    let dir :: [Char]
dir = [Char] -> [Char]
FilePath.dropFileName [Char]
sourceFile'
    let baseName :: [Char]
baseName = [Char] -> [Char]
FilePath.takeBaseName [Char]
sourceFile'
    let atlasPath :: [Char]
atlasPath = [Char]
dir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char] -> [Char]
FilePath.addExtension [Char]
baseName [Char]
".json"
    Bool
atlasExists <- [Char] -> IO Bool
Directory.doesFileExist [Char]
atlasPath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless Bool
atlasExists do
      [Char] -> IO ()
forall a. [Char] -> IO a
Exit.die ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"aseprite2haskell: Aseprite atlas JSON does not exist at %s" [Char]
atlasPath
    pure [Char]
atlasPath
  Atlas
atlas <- [Char] -> IO (Either [Char] Atlas)
forall a. FromJSON a => [Char] -> IO (Either [Char] a)
Aeson.eitherDecodeFileStrict [Char]
atlasPath IO (Either [Char] Atlas)
-> (Either [Char] Atlas -> IO Atlas) -> IO Atlas
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left [Char]
decodeErr -> [Char] -> IO Atlas
forall a. [Char] -> IO a
Exit.die ([Char] -> IO Atlas) -> [Char] -> IO Atlas
forall a b. (a -> b) -> a -> b
$ [Char]
"aseprite2haskell: failed to parse JSON - " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
decodeErr
    Right Atlas
x -> Atlas -> IO Atlas
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Atlas
x
  [Char] -> Text -> IO ()
Text.IO.writeFile [Char]
outputFile (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ Module -> [Char]
displayModule (Module -> [Char]) -> Module -> [Char]
forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleFragment -> Module
buildModule ([Char] -> ModuleName
ModuleNameFromFilePath [Char]
sourceFile') (ModuleFragment -> Module) -> ModuleFragment -> Module
forall a b. (a -> b) -> a -> b
$ [ModuleFragment] -> ModuleFragment
forall a. Monoid a => [a] -> a
mconcat
    [ Atlas -> ModuleFragment
mkBuildersAndSlices Atlas
atlas
    , [FrameInfo] -> ModuleFragment
mkFrames ([FrameInfo] -> ModuleFragment) -> [FrameInfo] -> ModuleFragment
forall a b. (a -> b) -> a -> b
$ Atlas -> [FrameInfo]
frames Atlas
atlas
    , [FrameInfo] -> ModuleFragment
mkDurations ([FrameInfo] -> ModuleFragment) -> [FrameInfo] -> ModuleFragment
forall a b. (a -> b) -> a -> b
$ Atlas -> [FrameInfo]
frames Atlas
atlas
    ]
  where
  PreprocessorOpts
    { $sel:preprocessorOptsOrigSourceFile:PreprocessorOpts :: PreprocessorOpts -> [Char]
preprocessorOptsOrigSourceFile = [Char]
sourceFile
    , $sel:preprocessorOptsOutputFile:PreprocessorOpts :: PreprocessorOpts -> [Char]
preprocessorOptsOutputFile = [Char]
outputFile
    } = PreprocessorOpts
opts

mkBuildersAndSlices :: Atlas -> ModuleFragment
mkBuildersAndSlices :: Atlas -> ModuleFragment
mkBuildersAndSlices Atlas { [FrameInfo]
$sel:frames:Atlas :: Atlas -> [FrameInfo]
frames :: [FrameInfo]
frames, $sel:meta:Atlas :: Atlas -> Meta
meta = Meta { $sel:frameTags:Meta :: Meta -> [FrameTag]
frameTags = [FrameTag]
tags } }
  | [FrameInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FrameInfo]
frames = ModuleFragment
forall a. Monoid a => a
mempty
  | Bool
otherwise = [ModuleFragment] -> ModuleFragment
forall a. Monoid a => [a] -> a
mconcat ([ModuleFragment] -> ModuleFragment)
-> [ModuleFragment] -> ModuleFragment
forall a b. (a -> b) -> a -> b
$ [[(FrameInfo, Int)]] -> [ModuleFragment]
flattenFrameInfo ([[(FrameInfo, Int)]] -> [ModuleFragment])
-> [[(FrameInfo, Int)]] -> [ModuleFragment]
forall a b. (a -> b) -> a -> b
$ ((FrameInfo, Int) -> (FrameInfo, Int) -> Bool)
-> [(FrameInfo, Int)] -> [[(FrameInfo, Int)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
List.groupBy (FrameInfo, Int) -> (FrameInfo, Int) -> Bool
groupFrameInfo ([(FrameInfo, Int)] -> [[(FrameInfo, Int)]])
-> [(FrameInfo, Int)] -> [[(FrameInfo, Int)]]
forall a b. (a -> b) -> a -> b
$ [FrameInfo] -> [Int] -> [(FrameInfo, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [FrameInfo]
frames [Int
0 :: Int ..]
  where
  flattenFrameInfo :: [[(FrameInfo, Int)]] -> [ModuleFragment]
  flattenFrameInfo :: [[(FrameInfo, Int)]] -> [ModuleFragment]
flattenFrameInfo = ([(FrameInfo, Int)] -> [ModuleFragment])
-> [[(FrameInfo, Int)]] -> [ModuleFragment]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap \case
    [] -> []
    (FrameInfo { FilenameField
filename :: FilenameField
$sel:filename:FrameInfo :: FrameInfo -> FilenameField
filename }, Int
frameIdx) : [(FrameInfo, Int)]
xs ->
      let builderName :: [Char]
builderName = FilenameField -> [Char]
mkBuilderName FilenameField
filename
          sliceName :: [Char]
sliceName = [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s_slice" [Char]
builderName :: String
          (Direction
dir, Maybe TagRepeat
mTagRepeat) = FilenameField -> (Direction, Maybe TagRepeat)
dirAndRepeatFromTags FilenameField
filename
       in [ ModuleFragment
              { moduleFragmentImports :: [ModuleImport]
moduleFragmentImports =
                  [ ModuleImport
                      { moduleImportName :: [Char]
moduleImportName = [Char]
"Prelude"
                      , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = ModuleImportStyle
ModuleImportStyleOpen
                      }
                  , ModuleImport
                      { moduleImportName :: [Char]
moduleImportName = [Char]
"Anitomata"
                      , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = [[Char]] -> ModuleImportStyle
ModuleImportStyleExplicit
                          ([[Char]] -> ModuleImportStyle) -> [[Char]] -> ModuleImportStyle
forall a b. (a -> b) -> a -> b
$ [Char]
"AnimBuilder"
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"AnimDir(..)"
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"AnimSlice"
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"AnimSlice_(..)"
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: Direction -> [Char]
builderFn Direction
dir
                          [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]
x | Maybe TagRepeat -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe TagRepeat
mTagRepeat, [Char]
x <- [[Char]
"AnimRepeat(..)", [Char]
"repeatAnim"]]
                      }
                  , ModuleImport
                      { moduleImportName :: [Char]
moduleImportName = [Char]
"Data.Vector.Unboxed"
                      , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = Maybe [Char] -> ModuleImportStyle
ModuleImportStyleQualified (Maybe [Char] -> ModuleImportStyle)
-> Maybe [Char] -> ModuleImportStyle
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"U"
                      }
                  ]
              , moduleFragmentDeclarations :: [ModuleDeclaration]
moduleFragmentDeclarations =
                  [ Bool -> DeclName -> DeclBody -> ModuleDeclaration
ModuleDeclaration Bool
True ([Char] -> DeclName
DeclName [Char]
builderName) (DeclBody -> ModuleDeclaration) -> DeclBody -> ModuleDeclaration
forall a b. (a -> b) -> a -> b
$ [Char] -> DeclBody
DeclBody
                      case Maybe TagRepeat
mTagRepeat of
                        Maybe TagRepeat
Nothing ->
                          [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n"
                            [ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s :: AnimBuilder" [Char]
builderName
                            , [Char] -> [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s = %s %s" [Char]
builderName (Direction -> [Char]
builderFn Direction
dir) [Char]
sliceName
                            ]
                        Just (TagRepeat Int
n) ->
                          [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n"
                            [ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s :: AnimBuilder" [Char]
builderName
                            , [Char] -> [Char] -> Int -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s = repeatAnim (AnimRepeatCount %d) $ %s %s" [Char]
builderName Int
n (Direction -> [Char]
builderFn Direction
dir) [Char]
sliceName
                            ]
                  , Bool -> DeclName -> DeclBody -> ModuleDeclaration
ModuleDeclaration Bool
True ([Char] -> DeclName
DeclName [Char]
sliceName) (DeclBody -> ModuleDeclaration) -> DeclBody -> ModuleDeclaration
forall a b. (a -> b) -> a -> b
$ [Char] -> DeclBody
DeclBody ([Char] -> DeclBody) -> [Char] -> DeclBody
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n"
                      [ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s :: AnimSlice" [Char]
sliceName
                      , [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s =" [Char]
sliceName
                      ,        [Char]
"  AnimSlice"
                      , [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"    { animSliceDir = %s" (Direction -> [Char]
toAnimDir Direction
dir)
                      , [Char] -> Int -> Int -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"    , animSliceFrameDurs = U.slice %d %d %s" Int
frameIdx (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(FrameInfo, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FrameInfo, Int)]
xs) [Char]
durationsVecName
                      , [Char] -> Int -> Int -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"    , animSliceFrames = U.slice %d %d %s" Int
frameIdx (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(FrameInfo, Int)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(FrameInfo, Int)]
xs) [Char]
framesVecName
                      ,        [Char]
"    }"
                      ]
                  ]
              }
          ]

  groupFrameInfo :: (FrameInfo, Int) -> (FrameInfo, Int) -> Bool
  groupFrameInfo :: (FrameInfo, Int) -> (FrameInfo, Int) -> Bool
groupFrameInfo (FrameInfo { $sel:filename:FrameInfo :: FrameInfo -> FilenameField
filename = FilenameField
x }, Int
_) (FrameInfo { $sel:filename:FrameInfo :: FrameInfo -> FilenameField
filename = FilenameField
y }, Int
_) =
    forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"file" FilenameField
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"file" FilenameField
y Bool -> Bool -> Bool
&& forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"tag" FilenameField
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"tag" FilenameField
y

  dirAndRepeatFromTags :: FilenameField -> (Direction, Maybe TagRepeat)
  dirAndRepeatFromTags :: FilenameField -> (Direction, Maybe TagRepeat)
dirAndRepeatFromTags FilenameField { Text
file :: Text
$sel:file:FilenameField :: FilenameField -> Text
file, Text
tag :: Text
$sel:tag:FilenameField :: FilenameField -> Text
tag } =
    (Direction, Maybe TagRepeat)
-> (FrameTag -> (Direction, Maybe TagRepeat))
-> Maybe FrameTag
-> (Direction, Maybe TagRepeat)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Direction
Forward, Maybe TagRepeat
forall a. Maybe a
Nothing) ((,) (Direction -> Maybe TagRepeat -> (Direction, Maybe TagRepeat))
-> (FrameTag -> Direction)
-> FrameTag
-> Maybe TagRepeat
-> (Direction, Maybe TagRepeat)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FrameTag -> Direction
direction (FrameTag -> Maybe TagRepeat -> (Direction, Maybe TagRepeat))
-> (FrameTag -> Maybe TagRepeat)
-> FrameTag
-> (Direction, Maybe TagRepeat)
forall a b.
(FrameTag -> a -> b) -> (FrameTag -> a) -> FrameTag -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"repeat")
      (Maybe FrameTag -> (Direction, Maybe TagRepeat))
-> Maybe FrameTag -> (Direction, Maybe TagRepeat)
forall a b. (a -> b) -> a -> b
$ ((FrameTag -> Bool) -> [FrameTag] -> Maybe FrameTag)
-> [FrameTag] -> (FrameTag -> Bool) -> Maybe FrameTag
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FrameTag -> Bool) -> [FrameTag] -> Maybe FrameTag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find [FrameTag]
tags \case
          FrameTag { $sel:name:FrameTag :: FrameTag -> TagNameField
name = TagNameField
nameField } ->
            Text
file Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"file" TagNameField
nameField Bool -> Bool -> Bool
&& Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== forall {k} (x :: k) r a. HasField x r a => r -> a
forall (x :: Symbol) r a. HasField x r a => r -> a
getField @"tag" TagNameField
nameField

  toAnimDir :: Direction -> String
  toAnimDir :: Direction -> [Char]
toAnimDir = \case
    Direction
Forward -> [Char]
"AnimDirForward"
    Direction
Reverse -> [Char]
"AnimDirBackward"
    Direction
Pingpong -> [Char]
"AnimDirForward"
    Direction
PingpongReverse -> [Char]
"AnimDirBackward"

  builderFn :: Direction -> String
  builderFn :: Direction -> [Char]
builderFn = \case
    Direction
Forward -> [Char]
"fromAnimSlice"
    Direction
Reverse -> [Char]
"fromAnimSlice"
    Direction
Pingpong -> [Char]
"pingpongAnimSlice"
    Direction
PingpongReverse -> [Char]
"pingpongAnimSlice"

mkFrames :: [FrameInfo] -> ModuleFragment
mkFrames :: [FrameInfo] -> ModuleFragment
mkFrames = \case
  [] -> ModuleFragment
forall a. Monoid a => a
mempty
  [FrameInfo]
xs ->
    ModuleFragment
      { moduleFragmentImports :: [ModuleImport]
moduleFragmentImports =
          [ ModuleImport
              { moduleImportName :: [Char]
moduleImportName = [Char]
"Prelude"
              , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = ModuleImportStyle
ModuleImportStyleOpen
              }
          , ModuleImport
              { moduleImportName :: [Char]
moduleImportName = [Char]
"Data.Vector.Unboxed"
              , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = Maybe [Char] -> ModuleImportStyle
ModuleImportStyleQualified (Maybe [Char] -> ModuleImportStyle)
-> Maybe [Char] -> ModuleImportStyle
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"U"
              }
          , ModuleImport
              { moduleImportName :: [Char]
moduleImportName = [Char]
"Anitomata"
              , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = [[Char]] -> ModuleImportStyle
ModuleImportStyleExplicit [[Char]
"AnimFrame", [Char]
"AnimFrame_(..)"]
              }
          ]
      , moduleFragmentDeclarations :: [ModuleDeclaration]
moduleFragmentDeclarations =
          [ Bool -> DeclName -> DeclBody -> ModuleDeclaration
ModuleDeclaration Bool
False ([Char] -> DeclName
DeclName [Char]
framesVecName) (DeclBody -> ModuleDeclaration) -> DeclBody -> ModuleDeclaration
forall a b. (a -> b) -> a -> b
$ [Char] -> DeclBody
DeclBody ([Char] -> DeclBody) -> [Char] -> DeclBody
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n"
              [ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s :: U.Vector AnimFrame" [Char]
framesVecName
              , [Char] -> [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s = U.fromListN %d" [Char]
framesVecName (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [FrameInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FrameInfo]
xs
              , [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"  [ %s" ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n  , " (Frame -> [Char]
sourceRect (Frame -> [Char]) -> (FrameInfo -> Frame) -> FrameInfo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameInfo -> Frame
frame (FrameInfo -> [Char]) -> [FrameInfo] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FrameInfo]
xs)
              ,        [Char]
"  ]"
              ]
          ]
      }
  where
  sourceRect :: Frame -> String
  sourceRect :: Frame -> [Char]
sourceRect Frame { Int
x :: Int
$sel:x:Frame :: Frame -> Int
x, Int
y :: Int
$sel:y:Frame :: Frame -> Int
y, Int
w :: Int
$sel:w:Frame :: Frame -> Int
w, Int
h :: Int
$sel:h:Frame :: Frame -> Int
h } =
    [Char] -> Int -> Int -> Int -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"AnimFrame { animFrameX = %d, animFrameY = %d, animFrameW = %d, animFrameH = %d }" Int
x Int
y Int
w Int
h

mkDurations :: [FrameInfo] -> ModuleFragment
mkDurations :: [FrameInfo] -> ModuleFragment
mkDurations = \case
  [] -> ModuleFragment
forall a. Monoid a => a
mempty
  [FrameInfo]
xs ->
    ModuleFragment
      { moduleFragmentImports :: [ModuleImport]
moduleFragmentImports =
          [ ModuleImport
              { moduleImportName :: [Char]
moduleImportName = [Char]
"Prelude"
              , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = ModuleImportStyle
ModuleImportStyleOpen
              }
          , ModuleImport
              { moduleImportName :: [Char]
moduleImportName = [Char]
"Data.Vector.Unboxed"
              , moduleImportStyle :: ModuleImportStyle
moduleImportStyle = Maybe [Char] -> ModuleImportStyle
ModuleImportStyleQualified (Maybe [Char] -> ModuleImportStyle)
-> Maybe [Char] -> ModuleImportStyle
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"U"
              }
          ]
      , moduleFragmentDeclarations :: [ModuleDeclaration]
moduleFragmentDeclarations =
          [ Bool -> DeclName -> DeclBody -> ModuleDeclaration
ModuleDeclaration Bool
False ([Char] -> DeclName
DeclName [Char]
durationsVecName) (DeclBody -> ModuleDeclaration) -> DeclBody -> ModuleDeclaration
forall a b. (a -> b) -> a -> b
$ [Char] -> DeclBody
DeclBody ([Char] -> DeclBody) -> [Char] -> DeclBody
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n"
              [ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s :: U.Vector Double" [Char]
durationsVecName
              , [Char] -> [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s = U.fromListN %d" [Char]
durationsVecName (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [FrameInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FrameInfo]
xs
              , [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"  [ %s" ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
List.intercalate [Char]
"\n  , " (Double -> [Char]
forall a. Show a => a -> [Char]
show (Double -> [Char]) -> (FrameInfo -> Double) -> FrameInfo -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
toSeconds (Int -> Double) -> (FrameInfo -> Int) -> FrameInfo -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FrameInfo -> Int
duration (FrameInfo -> [Char]) -> [FrameInfo] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FrameInfo]
xs)
              ,        [Char]
"  ]"
              ]
          ]
      }
  where
  toSeconds :: Int -> Double
  toSeconds :: Int -> Double
toSeconds Int
ms = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ms Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000

type Atlas :: Type
data Atlas = Atlas
  { Atlas -> [FrameInfo]
frames :: [FrameInfo]
  , Atlas -> Meta
meta :: Meta
  } deriving stock ((forall x. Atlas -> Rep Atlas x)
-> (forall x. Rep Atlas x -> Atlas) -> Generic Atlas
forall x. Rep Atlas x -> Atlas
forall x. Atlas -> Rep Atlas x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Atlas -> Rep Atlas x
from :: forall x. Atlas -> Rep Atlas x
$cto :: forall x. Rep Atlas x -> Atlas
to :: forall x. Rep Atlas x -> Atlas
Generic)
    deriving anyclass (Maybe Atlas
Value -> Parser [Atlas]
Value -> Parser Atlas
(Value -> Parser Atlas)
-> (Value -> Parser [Atlas]) -> Maybe Atlas -> FromJSON Atlas
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Atlas
parseJSON :: Value -> Parser Atlas
$cparseJSONList :: Value -> Parser [Atlas]
parseJSONList :: Value -> Parser [Atlas]
$comittedField :: Maybe Atlas
omittedField :: Maybe Atlas
FromJSON)

type Meta :: Type
newtype Meta = Meta
  { Meta -> [FrameTag]
frameTags :: [FrameTag]
  } deriving stock ((forall x. Meta -> Rep Meta x)
-> (forall x. Rep Meta x -> Meta) -> Generic Meta
forall x. Rep Meta x -> Meta
forall x. Meta -> Rep Meta x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Meta -> Rep Meta x
from :: forall x. Meta -> Rep Meta x
$cto :: forall x. Rep Meta x -> Meta
to :: forall x. Rep Meta x -> Meta
Generic)
    deriving anyclass (Maybe Meta
Value -> Parser [Meta]
Value -> Parser Meta
(Value -> Parser Meta)
-> (Value -> Parser [Meta]) -> Maybe Meta -> FromJSON Meta
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Meta
parseJSON :: Value -> Parser Meta
$cparseJSONList :: Value -> Parser [Meta]
parseJSONList :: Value -> Parser [Meta]
$comittedField :: Maybe Meta
omittedField :: Maybe Meta
FromJSON)

type FrameTag :: Type
data FrameTag = FrameTag
  { FrameTag -> TagNameField
name :: TagNameField
  , FrameTag -> Int
from :: Int
  , FrameTag -> Int
to :: Int
  , FrameTag -> Direction
direction :: Direction
  , FrameTag -> Maybe TagRepeat
repeat :: Maybe TagRepeat
  } deriving stock ((forall x. FrameTag -> Rep FrameTag x)
-> (forall x. Rep FrameTag x -> FrameTag) -> Generic FrameTag
forall x. Rep FrameTag x -> FrameTag
forall x. FrameTag -> Rep FrameTag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FrameTag -> Rep FrameTag x
from :: forall x. FrameTag -> Rep FrameTag x
$cto :: forall x. Rep FrameTag x -> FrameTag
to :: forall x. Rep FrameTag x -> FrameTag
Generic)
    deriving anyclass (Maybe FrameTag
Value -> Parser [FrameTag]
Value -> Parser FrameTag
(Value -> Parser FrameTag)
-> (Value -> Parser [FrameTag])
-> Maybe FrameTag
-> FromJSON FrameTag
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FrameTag
parseJSON :: Value -> Parser FrameTag
$cparseJSONList :: Value -> Parser [FrameTag]
parseJSONList :: Value -> Parser [FrameTag]
$comittedField :: Maybe FrameTag
omittedField :: Maybe FrameTag
FromJSON)

type TagNameField :: Type
data TagNameField = TagNameField
  { TagNameField -> Text
file :: Text
  , TagNameField -> Text
tag :: Text
  } deriving stock (Int -> TagNameField -> [Char] -> [Char]
[TagNameField] -> [Char] -> [Char]
TagNameField -> [Char]
(Int -> TagNameField -> [Char] -> [Char])
-> (TagNameField -> [Char])
-> ([TagNameField] -> [Char] -> [Char])
-> Show TagNameField
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TagNameField -> [Char] -> [Char]
showsPrec :: Int -> TagNameField -> [Char] -> [Char]
$cshow :: TagNameField -> [Char]
show :: TagNameField -> [Char]
$cshowList :: [TagNameField] -> [Char] -> [Char]
showList :: [TagNameField] -> [Char] -> [Char]
Show)

instance FromJSON TagNameField where
  parseJSON :: Aeson.Value -> Aeson.Types.Parser TagNameField
  parseJSON :: Value -> Parser TagNameField
parseJSON = ReadP TagNameField -> Value -> Parser TagNameField
forall a. (Show a, Typeable a) => ReadP a -> Value -> Parser a
parseJSONViaReadP ReadP TagNameField
tagnameFieldParser

tagnameFieldParser :: ReadP TagNameField
tagnameFieldParser :: ReadP TagNameField
tagnameFieldParser = do
  Text
file <- [Char] -> Text
Text.pack ([Char] -> Text) -> ReadP [Char] -> ReadP Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP [Char]
ReadP.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|')
  Char
_ <- Char -> ReadP Char
ReadP.char Char
'|'
  Text
tag <- [Char] -> Text
Text.pack ([Char] -> Text) -> ReadP [Char] -> ReadP Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP [Char]
ReadP.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|')
  ReadP ()
ReadP.eof
  pure TagNameField { Text
$sel:file:TagNameField :: Text
file :: Text
file, Text
$sel:tag:TagNameField :: Text
tag :: Text
tag }

type TagRepeat :: Type
newtype TagRepeat = TagRepeat Int
  deriving stock (Int -> TagRepeat -> [Char] -> [Char]
[TagRepeat] -> [Char] -> [Char]
TagRepeat -> [Char]
(Int -> TagRepeat -> [Char] -> [Char])
-> (TagRepeat -> [Char])
-> ([TagRepeat] -> [Char] -> [Char])
-> Show TagRepeat
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> TagRepeat -> [Char] -> [Char]
showsPrec :: Int -> TagRepeat -> [Char] -> [Char]
$cshow :: TagRepeat -> [Char]
show :: TagRepeat -> [Char]
$cshowList :: [TagRepeat] -> [Char] -> [Char]
showList :: [TagRepeat] -> [Char] -> [Char]
Show)

instance FromJSON TagRepeat where
  parseJSON :: Aeson.Value -> Aeson.Types.Parser TagRepeat
  parseJSON :: Value -> Parser TagRepeat
parseJSON = ReadP TagRepeat -> Value -> Parser TagRepeat
forall a. (Show a, Typeable a) => ReadP a -> Value -> Parser a
parseJSONViaReadP ReadP TagRepeat
tagRepeatParser

tagRepeatParser :: ReadP TagRepeat
tagRepeatParser :: ReadP TagRepeat
tagRepeatParser = do
  Int
count <- ReadP Int
intParser
  ReadP ()
ReadP.eof
  pure $ Int -> TagRepeat
TagRepeat Int
count

type Direction :: Type
data Direction
  = Forward
  | Reverse
  | Pingpong
  | PingpongReverse

instance FromJSON Direction where
  parseJSON :: Aeson.Value -> Aeson.Types.Parser Direction
  parseJSON :: Value -> Parser Direction
parseJSON = [Char] -> (Text -> Parser Direction) -> Value -> Parser Direction
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
"FromJSON Direction" \case
    Text
"forward" -> Direction -> Parser Direction
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Direction
Forward
    Text
"reverse" -> Direction -> Parser Direction
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Direction
Reverse
    Text
"pingpong" -> Direction -> Parser Direction
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Direction
Pingpong
    Text
"pingpong_reverse" -> Direction -> Parser Direction
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Direction
PingpongReverse
    Text
other -> [Char] -> Parser Direction
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser Direction) -> [Char] -> Parser Direction
forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid direction: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. Show a => a -> [Char]
show Text
other

type FrameInfo :: Type
data FrameInfo = FrameInfo
  { FrameInfo -> FilenameField
filename :: FilenameField
  , FrameInfo -> Frame
frame :: Frame
  , FrameInfo -> Int
duration :: Int
  } deriving stock ((forall x. FrameInfo -> Rep FrameInfo x)
-> (forall x. Rep FrameInfo x -> FrameInfo) -> Generic FrameInfo
forall x. Rep FrameInfo x -> FrameInfo
forall x. FrameInfo -> Rep FrameInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FrameInfo -> Rep FrameInfo x
from :: forall x. FrameInfo -> Rep FrameInfo x
$cto :: forall x. Rep FrameInfo x -> FrameInfo
to :: forall x. Rep FrameInfo x -> FrameInfo
Generic, Int -> FrameInfo -> [Char] -> [Char]
[FrameInfo] -> [Char] -> [Char]
FrameInfo -> [Char]
(Int -> FrameInfo -> [Char] -> [Char])
-> (FrameInfo -> [Char])
-> ([FrameInfo] -> [Char] -> [Char])
-> Show FrameInfo
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FrameInfo -> [Char] -> [Char]
showsPrec :: Int -> FrameInfo -> [Char] -> [Char]
$cshow :: FrameInfo -> [Char]
show :: FrameInfo -> [Char]
$cshowList :: [FrameInfo] -> [Char] -> [Char]
showList :: [FrameInfo] -> [Char] -> [Char]
Show)
    deriving anyclass (Maybe FrameInfo
Value -> Parser [FrameInfo]
Value -> Parser FrameInfo
(Value -> Parser FrameInfo)
-> (Value -> Parser [FrameInfo])
-> Maybe FrameInfo
-> FromJSON FrameInfo
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser FrameInfo
parseJSON :: Value -> Parser FrameInfo
$cparseJSONList :: Value -> Parser [FrameInfo]
parseJSONList :: Value -> Parser [FrameInfo]
$comittedField :: Maybe FrameInfo
omittedField :: Maybe FrameInfo
FromJSON)

framesVecName :: String
framesVecName :: [Char]
framesVecName = [Char]
"frames"

durationsVecName :: String
durationsVecName :: [Char]
durationsVecName = [Char]
"durations"

type FilenameField :: Type
data FilenameField = FilenameField
  { FilenameField -> Text
file :: Text
  , FilenameField -> Text
tag :: Text
    -- | This is the frame index in the specific .aseprite file, NOT the frame
    -- index in the overall texture atlas frames. It is only parsed here for
    -- debugging's sake to cross-reference individual .aseprite files.
  , FilenameField -> Int
frameIndex :: Int
  } deriving stock (Int -> FilenameField -> [Char] -> [Char]
[FilenameField] -> [Char] -> [Char]
FilenameField -> [Char]
(Int -> FilenameField -> [Char] -> [Char])
-> (FilenameField -> [Char])
-> ([FilenameField] -> [Char] -> [Char])
-> Show FilenameField
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> FilenameField -> [Char] -> [Char]
showsPrec :: Int -> FilenameField -> [Char] -> [Char]
$cshow :: FilenameField -> [Char]
show :: FilenameField -> [Char]
$cshowList :: [FilenameField] -> [Char] -> [Char]
showList :: [FilenameField] -> [Char] -> [Char]
Show)

mkBuilderName :: FilenameField -> String
mkBuilderName :: FilenameField -> [Char]
mkBuilderName FilenameField { Text
$sel:file:FilenameField :: FilenameField -> Text
file :: Text
file, Text
$sel:tag:FilenameField :: FilenameField -> Text
tag :: Text
tag } = [Char] -> Text -> Text -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s_%s" Text
file Text
tag

instance FromJSON FilenameField where
  parseJSON :: Aeson.Value -> Aeson.Types.Parser FilenameField
  parseJSON :: Value -> Parser FilenameField
parseJSON = ReadP FilenameField -> Value -> Parser FilenameField
forall a. (Show a, Typeable a) => ReadP a -> Value -> Parser a
parseJSONViaReadP ReadP FilenameField
filenameFieldParser

filenameFieldParser :: ReadP FilenameField
filenameFieldParser :: ReadP FilenameField
filenameFieldParser = do
  Text
file <- [Char] -> Text
Text.pack ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
sanitize ([Char] -> Text) -> ReadP [Char] -> ReadP Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP [Char]
ReadP.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|')
  Char
_ <- Char -> ReadP Char
ReadP.char Char
'|'
  Text
tag <- [Char] -> Text
Text.pack ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
sanitize ([Char] -> Text) -> ReadP [Char] -> ReadP Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> ReadP [Char]
ReadP.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|')
  Char
_ <- Char -> ReadP Char
ReadP.char Char
'|'
  Int
frameIndex <- ReadP Int
intParser
  ReadP ()
ReadP.eof
  pure FilenameField { Text
$sel:file:FilenameField :: Text
file :: Text
file, Text
$sel:tag:FilenameField :: Text
tag :: Text
tag, Int
$sel:frameIndex:FilenameField :: Int
frameIndex :: Int
frameIndex }
  where
  sanitize :: Char -> Char
  sanitize :: Char -> Char
sanitize = \case
    Char
'-' -> Char
'_'
    Char
c -> Char
c

type Frame :: Type
data Frame = Frame
  { Frame -> Int
x :: Int
  , Frame -> Int
y :: Int
  , Frame -> Int
w :: Int
  , Frame -> Int
h :: Int
  } deriving stock ((forall x. Frame -> Rep Frame x)
-> (forall x. Rep Frame x -> Frame) -> Generic Frame
forall x. Rep Frame x -> Frame
forall x. Frame -> Rep Frame x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Frame -> Rep Frame x
from :: forall x. Frame -> Rep Frame x
$cto :: forall x. Rep Frame x -> Frame
to :: forall x. Rep Frame x -> Frame
Generic, Int -> Frame -> [Char] -> [Char]
[Frame] -> [Char] -> [Char]
Frame -> [Char]
(Int -> Frame -> [Char] -> [Char])
-> (Frame -> [Char]) -> ([Frame] -> [Char] -> [Char]) -> Show Frame
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Frame -> [Char] -> [Char]
showsPrec :: Int -> Frame -> [Char] -> [Char]
$cshow :: Frame -> [Char]
show :: Frame -> [Char]
$cshowList :: [Frame] -> [Char] -> [Char]
showList :: [Frame] -> [Char] -> [Char]
Show)
    deriving anyclass (Maybe Frame
Value -> Parser [Frame]
Value -> Parser Frame
(Value -> Parser Frame)
-> (Value -> Parser [Frame]) -> Maybe Frame -> FromJSON Frame
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Frame
parseJSON :: Value -> Parser Frame
$cparseJSONList :: Value -> Parser [Frame]
parseJSONList :: Value -> Parser [Frame]
$comittedField :: Maybe Frame
omittedField :: Maybe Frame
FromJSON)

optsParser :: Opt.ParserInfo PreprocessorOpts
optsParser :: ParserInfo PreprocessorOpts
optsParser = Parser PreprocessorOpts
-> InfoMod PreprocessorOpts -> ParserInfo PreprocessorOpts
forall a. Parser a -> InfoMod a -> ParserInfo a
Opt.info (Parser PreprocessorOpts
preprocessorOptsParser Parser PreprocessorOpts
-> Parser (PreprocessorOpts -> PreprocessorOpts)
-> Parser PreprocessorOpts
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (PreprocessorOpts -> PreprocessorOpts)
forall a. Parser (a -> a)
Opt.helper) (InfoMod PreprocessorOpts -> ParserInfo PreprocessorOpts)
-> InfoMod PreprocessorOpts -> ParserInfo PreprocessorOpts
forall a b. (a -> b) -> a -> b
$ [InfoMod PreprocessorOpts] -> InfoMod PreprocessorOpts
forall a. Monoid a => [a] -> a
mconcat
  [ InfoMod PreprocessorOpts
forall a. InfoMod a
Opt.fullDesc
  , [Char] -> InfoMod PreprocessorOpts
forall a. [Char] -> InfoMod a
Opt.progDesc [Char]
"Convert an Aseprite texture atlas JSON into Haskell code"
  , [Char] -> InfoMod PreprocessorOpts
forall a. [Char] -> InfoMod a
Opt.header [Char]
"aseprite2haskell - Aseprite -> Haskell preprocessor"
  ]

type PreprocessorOpts :: Type
data PreprocessorOpts = PreprocessorOpts
  { PreprocessorOpts -> [Char]
preprocessorOptsOrigSourceFile :: FilePath
  , PreprocessorOpts -> [Char]
preprocessorOptsOutputFile :: FilePath
  } deriving stock (Int -> PreprocessorOpts -> [Char] -> [Char]
[PreprocessorOpts] -> [Char] -> [Char]
PreprocessorOpts -> [Char]
(Int -> PreprocessorOpts -> [Char] -> [Char])
-> (PreprocessorOpts -> [Char])
-> ([PreprocessorOpts] -> [Char] -> [Char])
-> Show PreprocessorOpts
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> PreprocessorOpts -> [Char] -> [Char]
showsPrec :: Int -> PreprocessorOpts -> [Char] -> [Char]
$cshow :: PreprocessorOpts -> [Char]
show :: PreprocessorOpts -> [Char]
$cshowList :: [PreprocessorOpts] -> [Char] -> [Char]
showList :: [PreprocessorOpts] -> [Char] -> [Char]
Show)

preprocessorOptsParser :: Opt.Parser PreprocessorOpts
preprocessorOptsParser :: Parser PreprocessorOpts
preprocessorOptsParser = do
  [Char]
preprocessorOptsOrigSourceFile <- ReadM [Char] -> Mod ArgumentFields [Char] -> Parser [Char]
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opt.argument ReadM [Char]
forall s. IsString s => ReadM s
Opt.str (Mod ArgumentFields [Char] -> Parser [Char])
-> Mod ArgumentFields [Char] -> Parser [Char]
forall a b. (a -> b) -> a -> b
$ [Mod ArgumentFields [Char]] -> Mod ArgumentFields [Char]
forall a. Monoid a => [a] -> a
mconcat
    [ [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
Opt.metavar [Char]
"SOURCE"
    , [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
Opt.help [Char]
"Original source filepath (passed by GHC)"
    ]
  -- It seems this positional argument only matters when multiple preprocessors
  -- are stacked (e.g. CPP and this custom one). It is ignored here.
  [Char]
_ <- forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opt.argument @String ReadM [Char]
forall s. IsString s => ReadM s
Opt.str (Mod ArgumentFields [Char] -> Parser [Char])
-> Mod ArgumentFields [Char] -> Parser [Char]
forall a b. (a -> b) -> a -> b
$ [Mod ArgumentFields [Char]] -> Mod ArgumentFields [Char]
forall a. Monoid a => [a] -> a
mconcat
    [ [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
Opt.metavar [Char]
"INPUT"
    , [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
Opt.help [Char]
"Input filepath (passed by GHC)"
    ]
  [Char]
preprocessorOptsOutputFile <- ReadM [Char] -> Mod ArgumentFields [Char] -> Parser [Char]
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
Opt.argument ReadM [Char]
forall s. IsString s => ReadM s
Opt.str (Mod ArgumentFields [Char] -> Parser [Char])
-> Mod ArgumentFields [Char] -> Parser [Char]
forall a b. (a -> b) -> a -> b
$ [Mod ArgumentFields [Char]] -> Mod ArgumentFields [Char]
forall a. Monoid a => [a] -> a
mconcat
    [ [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
Opt.metavar [Char]
"OUTPUT"
    , [Char] -> Mod ArgumentFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
Opt.help [Char]
"Output filepath (passed by GHC)"
    ]
  pure PreprocessorOpts
    { [Char]
$sel:preprocessorOptsOrigSourceFile:PreprocessorOpts :: [Char]
preprocessorOptsOrigSourceFile :: [Char]
preprocessorOptsOrigSourceFile
    , [Char]
$sel:preprocessorOptsOutputFile:PreprocessorOpts :: [Char]
preprocessorOptsOutputFile :: [Char]
preprocessorOptsOutputFile
    }

parseJSONViaReadP
  :: forall a
   . (Show a, Typeable a)
  => ReadP a
  -> Aeson.Types.Value
  -> Aeson.Types.Parser a
parseJSONViaReadP :: forall a. (Show a, Typeable a) => ReadP a -> Value -> Parser a
parseJSONViaReadP ReadP a
parser =
  [Char] -> (Text -> Parser a) -> Value -> Parser a
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"FromJSON %s" ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ TypeRep a -> [Char]
forall a. Show a => a -> [Char]
show (TypeRep a -> [Char]) -> TypeRep a -> [Char]
forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a) \case
    Text
t -> case ReadP a -> ReadS a
forall a. ReadP a -> ReadS a
ReadP.readP_to_S ReadP a
parser [Char]
s of
      [] -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Parse failed on input: %s" [Char]
s
      [(a
x, [Char]
_)] -> a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      [(a, [Char])]
xs -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Produced too many parses - input: %s, parses: %s" [Char]
s ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [(a, [Char])] -> [Char]
forall a. Show a => a -> [Char]
show [(a, [Char])]
xs
      where
      s :: [Char]
s = Text -> [Char]
Text.unpack Text
t

intParser :: ReadP Int
intParser :: ReadP Int
intParser = do
  [Char]
digitChars <- ReadP Char -> ReadP [Char]
forall a. ReadP a -> ReadP [a]
ReadP.many1 ReadP Char
digitParser
  case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
Read.readMaybe [Char]
digitChars of
    Maybe Int
Nothing -> [Char] -> ReadP Int
forall a. [Char] -> ReadP a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> ReadP Int) -> [Char] -> ReadP Int
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Failed to read digits as Int: %s" [Char]
digitChars
    Just Int
x -> Int -> ReadP Int
forall a. a -> ReadP a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
x

digitParser :: ReadP Char
digitParser :: ReadP Char
digitParser = (Char -> Bool) -> ReadP Char
ReadP.satisfy Char -> Bool
Char.isDigit