comic 0 → 0.0.1

raw patch · 5 files changed

+331/−31 lines, 5 filesdep +deepseqdep +hashabledep +hashable-orphansdep ~aesondep ~basedep ~textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, hashable, hashable-orphans, lens, sorted-list, time, uuid

Dependency ranges changed: aeson, base, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−1
• comic.cabal +13/−5
• src/Data/Comic.hs +2/−25
• src/Data/Comic/Flip.hs +247/−0
• src/Data/Comic/Types.hs +64/−0

@@ -1,5 +1,9 @@ # Revision history for comic -## 0  -- YYYY-mm-dd+## 0  -- 2019-04-30++* Added Semigroup instance for Segment to satisfy new 'base' requirements.++## 0  -- 2017-03-23  * First version. Released on an unsuspecting world.

@@ -1,7 +1,6 @@ name:                comic-version:             0+version:             0.0.1 synopsis:            A format for describing comics.--- description:          homepage:            https://oss.xkcd.com/ license:             BSD3 license-file:        LICENSE@@ -16,13 +15,22 @@ source-repository head   type: git   location: https://code.xkrd.net/xkcd/comic.git-                     + library   hs-source-dirs:      src   default-language:    Haskell2010   exposed-modules:           Data.Comic+        , Data.Comic.Types+        , Data.Comic.Flip   build-depends:-        base >=4.9 && <4.11+        base >=4.9 && <4.13       , text >= 1.2 && < 1.3-      , aeson >= 1.1 && < 1.2+      , aeson == 1.4.*+      , time >= 1.6 && < 1.10+      , sorted-list >= 0.2 && < 0.3+      , hashable >= 1.2 && < 1.3+      , hashable-orphans == 0+      , uuid > 1.3 && < 1.4+      , deepseq >= 1.4 && < 1.5+      , lens > 4.15 && < 4.18

@@ -12,30 +12,7 @@ import qualified Data.Aeson as JS import qualified Data.Aeson.Types as JS import Data.Aeson (ToJSON(..), FromJSON(..), (.:))--type ImageName = Text-type FontName = Text-type FontSize = Int-type HintSize = Int-type RGBA = (Float, Float, Float, Float)--blackRGBA :: RGBA-blackRGBA = (0, 0, 0, 1)--data Font =-    Font FontName FontSize RGBA-  deriving (Show, Eq, Ord)--data Position =-    Pos Int Int-  deriving (Show, Eq, Ord)--instance ToJSON Position where-  toJSON (Pos x y) = JS.object [("x", toJSON x), ("y", toJSON y)]--instance FromJSON Position where-  parseJSON (JS.Object v) = Pos <$> v .: "x" <*> v .: "y"-  parseJSON _ = mzero+import Data.Comic.Types  data Hint =     ZoneHint {@@ -90,7 +67,7 @@             , ("txt", toJSON t) ]  json2text :: JS.Value -> JS.Parser ((Position, Position), Font, Text)-json2text (JS.Object v1) = +json2text (JS.Object v1) =         (\tl br fn fs c t -> ((tl, br), Font fn fs c, t)) <$>           v1 .: "tl" <*> v1 .: "br" <*>           v1 .: "font" <*> v1 .: "size" <*> v1 .: "color" <*>

@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedStrings, DeriveGeneric, DeriveAnyClass, TemplateHaskell #-}+module Data.Comic.Flip (+   Segment(..), ScheduledSegment(..)+ , FrameSplice(..), TextType(..)+ , OnScreen(..), Box(..)+ , RelPosition(..), Font(..), blackRGBA, whiteRGBA+ , TextLayout(..), HAlignment(..), VAlignment(..)+ , osStart, osEnd+ , fsWhen, fsDepth, fsBackground, fsFont, fsTxt, fsTxtType, fsTextLayout, fsWhere+ , tlHorizontal, tlVertical, tlShrink+ , sDuration, sSplice+ ) where++import Control.Applicative+import Control.DeepSeq+import Control.Lens+import Control.Monad+import qualified Data.Aeson as JS+import Data.Aeson (ToJSON(..), FromJSON(..), (.:))+import Data.Comic.Types+import Data.Foldable+import Data.Hashable (Hashable(hashWithSalt))+import Data.Hashable.Orphans ()+import Data.SortedList hiding (map)+import qualified Data.SortedList as Sorted+import Data.Text (Text)+import Data.Time+import Data.UUID (UUID)+import GHC.Generics (Generic)++type StartTime = Float+type EndTime = Float++data OnScreen =+    OnScreen+    { _osStart :: {-# UNPACK #-} !StartTime+    , _osEnd :: {-# UNPACK #-} !EndTime+    }+  deriving (Read, Show, Eq, Ord, Generic, NFData)++makeLenses ''OnScreen++instance Hashable OnScreen where+  hashWithSalt s (OnScreen strt end) = hashWithSalt s (strt, end)++data Box =+    Box+    { _bTl :: {-# UNPACK #-} !RelPosition+    , _bBr :: {-# UNPACK #-} !RelPosition+    }+  deriving (Read, Show, Eq, Ord, Generic, NFData)++instance Hashable Box where+  hashWithSalt s (Box tl br) = hashWithSalt s (tl, br)++data HAlignment =+    HALeft+  | HACenter+  | HARight+  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)++instance ToJSON HAlignment where+  toJSON HALeft = JS.String "left"+  toJSON HACenter = JS.String "center"+  toJSON HARight = JS.String "right"++instance FromJSON HAlignment where+  parseJSON (JS.String "left") = pure HALeft+  parseJSON (JS.String "center") = pure HACenter+  parseJSON (JS.String "right") = pure HARight+  parseJSON _ = mzero++data VAlignment =+    VATop+  | VACenter+  | VABottom+  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)++instance ToJSON VAlignment where+  toJSON VATop = JS.String "top"+  toJSON VACenter = JS.String "center"+  toJSON VABottom = JS.String "bottom"++instance FromJSON VAlignment where+  parseJSON (JS.String "top") = pure VATop+  parseJSON (JS.String "center") = pure VACenter+  parseJSON (JS.String "bottom") = pure VABottom+  parseJSON _ = mzero++data TextLayout =+    TextLayout+    { _tlHorizontal :: !HAlignment+    , _tlVertical :: !VAlignment+    , _tlShrink :: !Bool+    }+  deriving (Read, Show, Eq, Ord, Generic, NFData, Hashable)++makeLenses ''TextLayout++data TextType =+    TxtStatic+  | TxtScroll+  | TxtSpeech+  | TxtBreaking+  deriving (Read, Show, Eq, Ord, Generic, NFData, Enum, Hashable)++instance ToJSON TextType where+    toJSON TxtStatic = JS.String "static"+    toJSON TxtScroll = JS.String "scroll"+    toJSON TxtSpeech = JS.String "speech"+    toJSON TxtBreaking = JS.String "breaking"++instance FromJSON TextType where+    parseJSON (JS.String "static") = return TxtStatic+    parseJSON (JS.String "scroll") = return TxtScroll+    parseJSON (JS.String "speech") = return TxtSpeech+    parseJSON (JS.String "breaking") = return TxtBreaking+    parseJSON _ = mzero++data FrameSplice =+    FSBackground+    { _fsWhen :: {-# UNPACK #-} !OnScreen+    , _fsDepth :: {-# UNPACK #-} !Int+    , _fsBackground :: {-# UNPACK #-} !ImageName+    }+  | FSText+    { _fsWhen :: {-# UNPACK #-} !OnScreen+    , _fsWhere :: {-# UNPACK #-} !Box+    , _fsTxt :: {-# UNPACK #-} !Text+    , _fsFont :: {-# UNPACK #-} !Font+    , _fsTxtType :: !TextType+    , _fsTextLayout :: !TextLayout+    }+   deriving (Read, Show, Eq, Ord, Generic, NFData)++makeLenses ''FrameSplice++instance Hashable FrameSplice where+  hashWithSalt s (FSBackground o d i) = hashWithSalt s (o, d, i)+  hashWithSalt s (FSText o w t f tt a) =+    hashWithSalt s (o, w, t, f, tt, a)++instance ToJSON FrameSplice where+    toJSON (FSBackground (OnScreen strt end) d img) =+      JS.object $+        [ ("start", toJSON strt), ("end", toJSON end)+        , ("depth", toJSON d)+        , ("panel", toJSON img)+        ]+    toJSON (FSText (OnScreen strt end) (Box tl br) txt (Font fn fs c) tt (TextLayout h v s)) =+      JS.object $+        [ ("start", toJSON strt), ("end", toJSON end)+        , ("tl", toJSON tl), ("br", toJSON br)+        , ("font", toJSON fn), ("size", toJSON fs), ("color", toJSON c)+        , ("txt", toJSON txt)+        , ("txt_type", toJSON tt)+        , ("align", toJSON h), ("valign", toJSON v), ("shrink_fit", toJSON s)+        ]++instance FromJSON FrameSplice where+    parseJSON (JS.Object v) =+          (FSBackground <$> (OnScreen <$> v .: "start" <*> v .: "end")+                        <*> v .: "depth"+                        <*> v .: "panel")+      <|> (FSText <$> (OnScreen <$> v .: "start" <*> v .: "end")+                  <*> (Box <$> v .: "tl" <*> v .: "br")+                  <*> v .: "txt"+                  <*> (Font <$>  v .: "font" <*> v .: "size" <*> v .: "color")+                  <*> v .: "txt_type"+                  <*> (TextLayout <$> v .: "align" <*> v .: "valign" <*> v .: "shrink_fit"))+    parseJSON _ = mzero++data Segment =+    Segment+    { _sDuration :: !DiffTime+      -- ^ This is how long, ideally, the segment would air for.+    , _sSplice :: SortedList FrameSplice+      -- ^ The actual stage directions for playing the content.+      --   Times are [0, 1] of the Duration.+      --   We keep sorting for a stable Ord instance.+    }+  deriving (Show, Eq, Ord, Generic, NFData)++makeLenses ''Segment++instance Semigroup Segment where+  (<>) a b = mconcat [a, b]++instance Monoid Segment where+  mempty = Segment 0 mempty+  mappend a b = mconcat [a, b]+  mconcat os =+    let totTime = fromRational . toRational  . foldl (\a s -> a + _sDuration s) 0 $ os+     in Segment (fromRational . toRational $ totTime)+                (snd . foldl (\(c, fs) s ->+                   let sdur = fromRational . toRational $ s ^. sDuration+                       timePrev = c+sdur+                       segPercent = sdur / totTime+                    in (timePrev+                       ,fs `mappend` (Sorted.map (\f ->+                          -- We rescale the [0-1] time range into the percent that this+                          -- Segment forms of the overal, and shift it into position.+                          ((f & fsWhen.osStart %~ (\st -> (st*sdur+c)/totTime))+                              & fsWhen.osEnd %~ (\se -> (se*sdur+c)/totTime))) (_sSplice $ s))+                        )) (0, mempty) $ os)++instance Hashable Segment where+  hashWithSalt s (Segment dur spl) =+    hashWithSalt s (dur, spl)++instance ToJSON Segment where+    toJSON (Segment dur splcs) =+      JS.object $+        [ ("duration", toJSON (realToFrac dur::Float))+        , ("splices", toJSON . toList $ splcs)+        ]++instance FromJSON Segment where+    parseJSON (JS.Object v) =+      Segment <$> ((realToFrac::Float -> DiffTime) <$> v .: "duration")+              <*> (toSortedList <$> v .: "splices")+    parseJSON _ = mzero++data ScheduledSegment =+    ScheduledSegment+    { _ssSegment :: {-# UNPACK #-} !Segment+    , _ssSegID :: {-# UNPACK #-} !UUID+    , _ssPlayTill :: !DiffTime+      -- ^ This is how long in the future this segment should end,+      --   from the time it is transmited to the client.+    }+  deriving (Show, Eq, Ord, Generic, NFData)++instance ToJSON ScheduledSegment where+    toJSON (ScheduledSegment seg segid till) =+      JS.object+        [ ("till", toJSON (realToFrac till::Float))+        , ("id", toJSON segid)+        , ("segment", toJSON seg)+        ]++instance FromJSON ScheduledSegment where+    parseJSON (JS.Object v) =+        ScheduledSegment <$> v .: "segment"+                         <*> v .: "id"+                         <*> ((realToFrac::Float -> DiffTime) <$> v .: "till")+    parseJSON _ = mzero

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings, DeriveGeneric, DeriveAnyClass #-}+module Data.Comic.Types (+   ImageName+ , Font(..), FontName, FontSize, HintSize+ , RGBA, blackRGBA, whiteRGBA+ , Position (..), RelPosition (..)+ ) where++import Control.DeepSeq+import Control.Monad+import qualified Data.Aeson as JS+import Data.Aeson (ToJSON(..), FromJSON(..), (.:))+import Data.Hashable (Hashable(hashWithSalt))+import Data.Text (Text)+import Data.Word+import GHC.Generics (Generic)++type ImageName = Text+type FontName = Text+type FontSize = Int+type HintSize = Int+type RGBA = (Word8, Word8, Word8, Word8)++blackRGBA :: RGBA+blackRGBA = (0, 0, 0, 255)++whiteRGBA :: RGBA+whiteRGBA = (255, 255, 255, 255)++data Font =+    Font {-# UNPACK #-} !FontName {-# UNPACK #-} !FontSize {-# UNPACK #-} !RGBA+  deriving (Read, Show, Eq, Ord, Generic, NFData)++instance Hashable Font where+  hashWithSalt s (Font fn fs rgba) =+    hashWithSalt s (fn, fs, rgba)++data Position =+    Pos { _pX :: {-# UNPACK #-} !Int, _pY :: {-# UNPACK #-} !Int }+  deriving (Read, Show, Eq, Ord, Generic, NFData)++instance Hashable Position where+  hashWithSalt s (Pos x y) = hashWithSalt s (x, y)++instance ToJSON Position where+  toJSON (Pos x y) = JS.object [("x", toJSON x), ("y", toJSON y)]++instance FromJSON Position where+  parseJSON (JS.Object v) = Pos <$> v .: "x" <*> v .: "y"+  parseJSON _ = mzero++data RelPosition =+    RPos { _rX :: {-# UNPACK #-} !Float, _rY :: {-# UNPACK #-} !Float }+  deriving (Read, Show, Eq, Ord, Generic, NFData)++instance Hashable RelPosition where+  hashWithSalt s (RPos x y) = hashWithSalt s (x, y)++instance ToJSON RelPosition where+  toJSON (RPos x y) = JS.object [("x", toJSON x), ("y", toJSON y)]++instance FromJSON RelPosition where+  parseJSON (JS.Object v) = RPos <$> v .: "x" <*> v .: "y"+  parseJSON _ = mzero