diff --git a/Data/AdobeSwatchExchange.hs b/Data/AdobeSwatchExchange.hs new file mode 100644 --- /dev/null +++ b/Data/AdobeSwatchExchange.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} +module Data.AdobeSwatchExchange where + +import Control.Applicative ((<$>)) +import Control.Monad (replicateM) +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Char (chr, ord) +import Data.Data (Data, Typeable) +import Data.Word (Word16) +import Data.Binary.IEEE754 (getFloat32be, putFloat32be) +import Numeric (showHex) +import Data.Binary (Binary(..)) +import Data.Binary.Get ( Get, getByteString, getWord8, getWord16be, getWord32be, runGet ) +import Data.Binary.Put ( Put, putByteString, putWord8, putWord16be, putWord32be, runPut ) + +{- +But to summarize, look for the following elements (in no particular order): +- header +- version +- "block count" +- blocks +- color group start +- color group end +- swatches +- "zero block" + +- strings + +For swatch "blocks" +- swatch header +- block length +- swatch name +- color space +- color component values (single-precision floats) +- swatch attributes + +The only thing to really watch out for is that the count near the beginning is *not* the swatch count, but the number of "blocks" in the file, which also includes color group information. + +File signature 4*char (ASEF) +Version 2*int8 (1.0) +Number of blocks 1*int16 +Blocks +Block type (0xc001 ⇒ Group start, 0xc002 ⇒ Group end, 0x0001 ⇒ Color entry) +Block length 1*int16 +Group/Color name 0-terminated string of length (int16) double-byte characters +Color model 4*char (CMYK, RGB, LAB or Gray) +Color values CMYK ⇒ 4*float16 / RGB & LAB ⇒ 3*float16 / Gray ⇒ 1*float16 +Color type 1*int8 (0 ⇒ Global, 1 ⇒ Spot, 2 ⇒ Normal) + +-} + +data Color + = CYMK Float Float Float Float + | RGB Float Float Float + | LAB Float Float Float + | Gray Float + deriving (Eq, Ord, Read, Show, Data, Typeable) + +data ColorType + = Global + | Spot + | Normal + deriving (Eq, Ord, Read, Show, Data, Typeable) + +data ColorEntry = ColorEntry + { colorName :: String + , color :: Color + , colorType :: ColorType + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +data ASEBlock + = GroupStart { groupName :: String } + | GroupEnd + | CE ColorEntry + deriving (Eq, Ord, Read, Show, Data, Typeable) + +data AdobeSwatchExchange = AdobeSwatchExchange + { version :: (Word16, Word16) + , blocks :: [ASEBlock] + } + deriving (Eq, Ord, Read, Show, Data, Typeable) + +getFileSig :: Get () +getFileSig = + do bs <- getByteString 4 + case bs of + "ASEF" -> return () + _ -> fail $ "Invalid file signature: " ++ show bs + +putFileSig :: Put +putFileSig = putByteString "ASEF" + +getVersion :: Get (Word16, Word16) +getVersion = + do maj <- getWord16be + min <- getWord16be + return (maj, min) + +putVersion :: (Word16, Word16) -> Put +putVersion (maj, min) = + do putWord16be maj + putWord16be min + +getBlock :: Get ASEBlock +getBlock = + do blockType <- getWord16be + case blockType of + 0xc001 -> do bl <- getWord32be + n <- getName + return (GroupStart n) + 0xc002 -> do bl <- getWord32be + return GroupEnd + 0x0001 -> CE <$> getColorEntry + _ -> fail $ "Unknown block type: " ++ (showHex blockType "") + +putBlock :: ASEBlock -> Put +putBlock (GroupStart groupName) = + do putWord16be 0xc001 + putWord32be $ blName groupName + putName groupName +putBlock GroupEnd = + do putWord16be 0xc002 + putWord32be 0 +putBlock (CE colorEntry) = + do putWord16be 0x0001 + putColorEntry colorEntry + +getName :: Get String +getName = + do nameLength <- getWord16be + doubleChars <- replicateM ((fromIntegral nameLength) - 1) getWord16be + _ <- getWord16be + return $ map (chr . fromIntegral) doubleChars + +putName :: String -> Put +putName nm = + do putWord16be $ (fromIntegral (length nm) + 1) + mapM_ (putWord16be . fromIntegral . ord) nm + putWord16be 0 + +blName :: (Integral a) => String -> a +blName nm = + fromIntegral (2 + (length nm * 2) + 2) + +getColor :: Get Color +getColor = + do modelString <- map (chr . fromIntegral) <$> replicateM 4 getWord8 + case modelString of + "CYMK" -> do c <- getFloat32be + y <- getFloat32be + m <- getFloat32be + k <- getFloat32be + return $ CYMK c y m k + "RGB " -> do r <- getFloat32be + g <- getFloat32be + b <- getFloat32be + return $ RGB r g b + "LAB " -> do l <- getFloat32be + a <- getFloat32be + b <- getFloat32be + return $ LAB l a b + "Gray" -> do g <- getFloat32be + return $ Gray g + _ -> fail $ "Unknown color model: " ++ modelString + +putColor :: Color -> Put +putColor (CYMK c y m k) = + do mapM_ (putWord8 . fromIntegral . ord) "CYMK" + putFloat32be c + putFloat32be y + putFloat32be m + putFloat32be k +putColor (RGB r g b) = + do mapM_ (putWord8 . fromIntegral . ord) "RGB " + putFloat32be r + putFloat32be g + putFloat32be b +putColor (LAB l a b) = + do mapM_ (putWord8 . fromIntegral . ord) "LAB " + putFloat32be l + putFloat32be a + putFloat32be b +putColor (Gray g) = + do mapM_ (putWord8 . fromIntegral . ord) "Gray" + putFloat32be g + +blColor :: (Integral a) => Color -> a +blColor (CYMK {}) = 20 +blColor (RGB {}) = 16 +blColor (LAB {}) = 16 +blColor (Gray {}) = 8 + +getColorType :: Get ColorType +getColorType = + do ct <- getWord16be + case ct of + 0 -> return Global + 1 -> return Spot + 2 -> return Normal + _ -> fail $ "Unknown color type: " ++ show ct + +putColorType :: ColorType -> Put +putColorType Global = putWord16be 0 +putColorType Spot = putWord16be 1 +putColorType Normal = putWord16be 2 + +instance Binary ColorType where + put = putColorType + get = getColorType + +blColorType :: (Integral a) => a +blColorType = fromIntegral 2 + +getColorEntry :: Get ColorEntry +getColorEntry = + do bl <- getWord32be + nm <- getName + color <- getColor + typ <- getColorType + return $ ColorEntry { colorName = nm + , color = color + , colorType = typ + } + +putColorEntry :: ColorEntry -> Put +putColorEntry (ColorEntry cn c ct) = + do putWord32be (blName cn + blColor c + blColorType) + putName cn + putColor c + putColorType ct + +instance Binary ColorEntry where + put = putColorEntry + get = getColorEntry + +getASE :: Get AdobeSwatchExchange +getASE = + do getFileSig + v <- getVersion + numBlocks <- getWord32be + bs <- replicateM (fromIntegral numBlocks) getBlock -- unsafe-ish if there are billions of blocks + return $ AdobeSwatchExchange { version = v + , blocks = bs + } + +putASE :: AdobeSwatchExchange -> Put +putASE (AdobeSwatchExchange v blks) = + do putFileSig + putVersion v + putWord32be (fromIntegral $ length blks) + mapM_ putBlock blks + +instance Binary AdobeSwatchExchange where + put = putASE + get = getASE + +test = + do c <- B.readFile "Yellow rose.ase" + print $ runGet getASE c + return () + +test_2 = + do c <- B.readFile "Yellow rose.ase" + print c + let ase = runGet getASE c + print ase + let c' = runPut (put ase) + print c' + print (c == c') diff --git a/Data/AdobeSwatchExchange/CSS.hs b/Data/AdobeSwatchExchange/CSS.hs new file mode 100644 --- /dev/null +++ b/Data/AdobeSwatchExchange/CSS.hs @@ -0,0 +1,32 @@ +module Data.AdobeSwatchExchange.CSS where + +import Data.AdobeSwatchExchange as ASE (ASEBlock(CE), ColorEntry(color), AdobeSwatchExchange, Color(RGB), blocks, getASE) +import qualified Data.ByteString.Lazy as B +import Language.Css.Build ((<:>), (/.), cword, ruleSets, star) +import Language.Css.Build.Idents as CSS (backgroundColor, color) +import Language.Css.Syntax (Expr, RuleSet, StyleSheet) +import Numeric (showHex) + +ase2css :: [ColorEntry] -> StyleSheet +ase2css colorEntries = + ruleSets (concatMap genColor (zip [1..] colorEntries)) + +genColor :: (Int, ColorEntry) -> [RuleSet] +genColor (n, colorEntry) = + [ (star /. ("fg-color-ase-" ++ Prelude.show n)) [ CSS.color <:> (colorToHex (ASE.color colorEntry)) + ] + , (star /. ("bg-color-ase-" ++ Prelude.show n)) [ backgroundColor <:> (colorToHex (ASE.color colorEntry)) + ] + ] + +colorToHex :: Color -> Expr +colorToHex (RGB r g b) = + cword $ + showString "#" . + showHex' (round (r * 255)) . + showHex' (round (g * 255)) . + showHex' (round (b * 255)) $ "" + where + showHex' n + | n < 10 = showString "0" . showHex n + | otherwise = showHex n diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2013, Jeremy Shaw, SeeReason Partners, LLC + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Jeremy Shaw, SeeReason Partners, LLC, nor + the names of other contributors may be used to endorse or + promote products derived from this software without specific + prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/adobe-swatch-exchange.cabal b/adobe-swatch-exchange.cabal new file mode 100644 --- /dev/null +++ b/adobe-swatch-exchange.cabal @@ -0,0 +1,29 @@ +name: adobe-swatch-exchange +version: 0.1.0.0 +synopsis: parse Adobe Swatch Exchange files and (optionally) output .css files with the colors +homepage: https://github.com/stepcut/ase2css +license: BSD3 +license-file: LICENSE +author: Jeremy Shaw +maintainer: jeremy@n-heptane.com +category: Web +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Data.AdobeSwatchExchange + Data.AdobeSwatchExchange.CSS + build-depends: base >= 4.5 && < 5, + bytestring == 0.10.*, + data-binary-ieee754 == 0.4.*, + binary == 0.5.*, + language-css == 0.0.* +executable ase2css + main-is: ase2css.hs + build-depends: base >= 4.5 && < 5, + binary == 0.5.*, + bytestring == 0.10.*, + data-binary-ieee754 == 0.4.*, + language-css == 0.0.*, + pretty == 1.1.* + diff --git a/ase2css.hs b/ase2css.hs new file mode 100644 --- /dev/null +++ b/ase2css.hs @@ -0,0 +1,22 @@ +module Main where + +import Data.AdobeSwatchExchange.CSS (ase2css) +import Data.AdobeSwatchExchange (ASEBlock(CE), ColorEntry(colorName), AdobeSwatchExchange, blocks, getASE) +import qualified Data.ByteString.Lazy as B +import Data.Binary.Get (runGet) +import Language.Css.Pretty (pretty) +import System.Environment (getArgs) +import Text.PrettyPrint.HughesPJ (($+$), (<+>), doubleQuotes, text) + +main :: IO () +main = + do args <- getArgs + case args of + [inFile, outFile] -> + do c <- B.readFile inFile + let ase = runGet getASE c + css = text "/* Generated from" <+> doubleQuotes (text inFile) <+> text "using ase2css */" $+$ + pretty (ase2css [ ce | (CE ce) <- blocks ase ]) + writeFile outFile $ show $ css + _ -> putStrLn "Usage: ase2css " +