barrier (empty) → 0.1.0

raw patch · 26 files changed

+1352/−0 lines, 26 filesdep +barrierdep +basedep +blaze-svgsetup-changed

Dependencies added: barrier, base, blaze-svg, bytestring, freetype2, lens-family-core, tasty, tasty-golden, template-haskell, text, unordered-containers

Files

LICENSE +20/−0
Setup.hs +2/−0
barrier.cabal +108/−0
data-generator.hs +72/−0
data/advance.txt +738/−0
examples/example.hs +9/−0
examples/make-test-data.hs +21/−0
src/Graphics/Badge/Barrier.hs +37/−0
src/Graphics/Badge/Barrier/Color.hs +46/−0
src/Graphics/Badge/Barrier/Internal.hs +63/−0
src/Graphics/Badge/Barrier/Style/Flat.hs +56/−0
src/Graphics/Badge/Barrier/Style/FlatSquare.hs +46/−0
src/Graphics/Badge/Barrier/Style/Plastic.hs +58/−0
tests/data/flat/1.svg +4/−0
tests/data/flat/2.svg +4/−0
tests/data/flat/3.svg +4/−0
tests/data/flat/4.svg +4/−0
tests/data/flatSquare/1.svg +4/−0
tests/data/flatSquare/2.svg +4/−0
tests/data/flatSquare/3.svg +4/−0
tests/data/flatSquare/4.svg +4/−0
tests/data/plastic/1.svg +4/−0
tests/data/plastic/2.svg +4/−0
tests/data/plastic/3.svg +4/−0
tests/data/plastic/4.svg +4/−0
tests/tasty.hs +28/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2015 Hirotomo Moriwaki++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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ barrier.cabal view

@@ -0,0 +1,108 @@+name:                barrier+version:             0.1.0+synopsis:            Shield.io style badge generator+description:         see example: <https://github.com/philopon/barrier/blob/master/examples/example.hs>+license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage:            https://github.com/philopon/barrier+Bug-reports:         https://github.com/philopon/barrier/issues+copyright:           (c) 2015 Hirotomo Moriwaki+category:            Graphics+build-type:          Simple+data-files:          data/advance.txt+                   , tests/data/flat/1.svg+                   , tests/data/flat/2.svg+                   , tests/data/flat/3.svg+                   , tests/data/flat/4.svg+                   , tests/data/flatSquare/1.svg+                   , tests/data/flatSquare/2.svg+                   , tests/data/flatSquare/3.svg+                   , tests/data/flatSquare/4.svg+                   , tests/data/plastic/1.svg+                   , tests/data/plastic/2.svg+                   , tests/data/plastic/3.svg+                   , tests/data/plastic/4.svg+cabal-version:       >=1.10++flag example+  default: False+  description: build example++flag generator+  default: False+  description: build font advance generator++flag test-results+  default: False+  description: build test results generator++library+  exposed-modules:     Graphics.Badge.Barrier+                       Graphics.Badge.Barrier.Color+                       Graphics.Badge.Barrier.Internal+                       Graphics.Badge.Barrier.Style.Flat+                       Graphics.Badge.Barrier.Style.FlatSquare+                       Graphics.Badge.Barrier.Style.Plastic+  build-depends:       base                 >=4.6  && <4.8+                     , template-haskell+                     , unordered-containers >=0.2  && <0.3+                     , blaze-svg            >=0.3  && <0.4+                     , text                 >=1.1  && <1.3+                     , bytestring           >=0.10 && <0.11+  hs-source-dirs:      src+  ghc-options:         -Wall -O2+  default-language:    Haskell2010++executable barrier-data-generator+  main-is:             data-generator.hs+  if flag(generator)+    buildable:         True+    build-depends:     base      >=4.6 && <4.8+                     , freetype2 >=0.1 && <0.2+  else+    buildable:         False+  ghc-options:         -Wall -O2+  default-language:    Haskell2010++executable barrier-example+  main-is:             example.hs+  if flag(example)+    buildable:         True+    build-depends:     base             >=4.6  && <4.8+                     , bytestring       >=0.10 && <0.11+                     , lens-family-core >=1.2  && <1.3+                     , barrier+  else+    buildable:         False+  hs-source-dirs:      examples+  ghc-options:         -Wall -O2+  default-language:    Haskell2010++executable barrier-test-result-generator+  main-is:             make-test-data.hs+  if flag(test-results)+    buildable:         True+    build-depends:     base             >=4.6  && <4.8+                     , bytestring       >=0.10 && <0.11+                     , lens-family-core >=1.2  && <1.3+                     , barrier+  else+    buildable:         False+  hs-source-dirs:      examples+  ghc-options:         -Wall -O2+  default-language:    Haskell2010++test-suite tasty+  type:                exitcode-stdio-1.0+  main-is:             tasty.hs+  build-depends:       base             >=4.6  && <4.8+                     , bytestring       >=0.10 && <0.11+                     , lens-family-core >=1.2  && <1.3+                     , tasty            >=0.10 && <0.11+                     , tasty-golden     >=2.2  && <2.3+                     , barrier+  hs-source-dirs:      tests+  ghc-options:         -Wall -O2+  default-language:    Haskell2010

+ data-generator.hs view

@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}++import System.Environment++import Control.Monad+import Control.Applicative+import Control.Exception++import Foreign.Storable+import Foreign.Marshal+import Foreign.Ptr+import Foreign.C++import Graphics.Rendering.FreeType.Internal+import Graphics.Rendering.FreeType.Internal.Face(glyph, FT_Face)+import Graphics.Rendering.FreeType.Internal.Vector(FT_Vector(FT_Vector))+import Graphics.Rendering.FreeType.Internal.Library(FT_Library)+import Graphics.Rendering.FreeType.Internal.GlyphSlot(advance)+import Graphics.Rendering.FreeType.Internal.PrimitiveTypes(FT_ULong)++import Data.Typeable++data FTError = FTError String CInt deriving(Show, Typeable)+instance Exception FTError++ft :: String -> IO CInt -> IO ()+ft n f = do+    e <- f+    unless (e == 0) $ throwIO (FTError n e)++withFreeType :: (FT_Library -> IO a) -> IO a+withFreeType = bracket bra ket+  where+    bra = alloca $ \p -> ft "Init_FreeType" (ft_Init_FreeType p) >> peek p+    ket = ft "Done_FreeType" . ft_Done_FreeType++withFontFace :: FilePath -> (FT_Face -> IO a) -> FT_Library -> IO a+withFontFace fn m lib = bracket bra ket m+  where+    bra = alloca $ \p -> withCString fn $ \f ->+        ft "New_Face" (ft_New_Face lib f 0 p) >> peek p+    ket = ft "Done_Face" . ft_Done_Face++firstChar :: FT_Face -> IO FT_ULong+firstChar face = fromIntegral <$> ft_Get_First_Char face nullPtr++nextChar :: FT_Face -> FT_ULong -> IO FT_ULong+nextChar face c = ft_Get_Next_Char face c nullPtr++forCharM_ :: FT_Face -> (FT_ULong -> IO ()) -> IO ()+forCharM_ face m = firstChar face >>= go+  where+    go 0 = return ()+    go i = m i >> nextChar face i >>= go+++main :: IO ()+main = getArgs >>= \case+    [fontPath] -> withFreeType $ withFontFace fontPath $ \face -> do+        ft "Set_Pixel_Sizes" $ ft_Set_Pixel_Sizes face 0 11+        slot <- peek $ glyph face+        forCharM_ face $ \c -> do+            ft "Load_Char" $ ft_Load_Char face c 0+            FT_Vector x _ <- peek $ advance slot+            case quotRem x 64 of+                (s, 0) -> putStrLn $ show c ++ '\t': show s+                _      -> fail "rem font size"++    _ -> do+        p <- getProgName+        putStrLn $ "Usage: " ++ p ++ " FONT_FILE"

+ data/advance.txt view

@@ -0,0 +1,738 @@+32	4+33	4+34	5+35	9+36	7+37	12+38	8+39	3+40	5+41	5+42	7+43	9+44	4+45	5+46	4+47	5+48	7+49	7+50	7+51	7+52	7+53	7+54	7+55	7+56	7+57	7+58	5+59	5+60	9+61	9+62	9+63	6+64	10+65	8+66	8+67	9+68	9+69	7+70	6+71	9+72	8+73	5+74	5+75	8+76	6+77	9+78	8+79	9+80	7+81	9+82	8+83	8+84	7+85	8+86	8+87	11+88	8+89	7+90	8+91	5+92	5+93	5+94	9+95	7+96	7+97	7+98	7+99	6+100	7+101	7+102	4+103	7+104	7+105	3+106	4+107	7+108	3+109	11+110	7+111	7+112	7+113	7+114	5+115	6+116	4+117	7+118	7+119	9+120	7+121	7+122	6+123	7+124	5+125	7+126	9+160	4+161	4+162	7+163	7+164	7+165	7+166	5+167	7+168	7+169	11+170	6+171	7+172	9+173	5+174	11+175	7+176	6+177	9+178	6+179	6+180	7+181	7+182	7+183	4+184	7+185	6+186	6+187	7+188	11+189	11+190	11+191	6+192	8+193	8+194	8+195	8+196	8+197	8+198	11+199	9+200	7+201	7+202	7+203	7+204	5+205	5+206	5+207	5+208	9+209	8+210	9+211	9+212	9+213	9+214	9+215	9+216	9+217	8+218	8+219	8+220	8+221	7+222	7+223	7+224	7+225	7+226	7+227	7+228	7+229	7+230	11+231	6+232	7+233	7+234	7+235	7+236	3+237	3+238	3+239	3+240	7+241	7+242	7+243	7+244	7+245	7+246	7+247	9+248	7+249	7+250	7+251	7+252	7+253	7+254	7+255	7+256	8+257	7+258	8+259	7+260	8+261	7+262	9+263	6+264	9+265	6+266	9+267	6+268	9+269	6+270	9+271	7+272	9+273	7+274	7+275	7+276	7+277	7+278	7+279	7+280	7+281	7+282	7+283	7+284	9+285	7+286	9+287	7+288	9+289	7+290	9+291	7+292	8+293	7+294	8+295	7+296	5+297	3+298	5+299	3+300	5+301	3+302	5+303	3+304	5+305	3+306	10+307	7+308	5+309	4+310	8+311	7+312	7+313	6+314	3+315	6+316	3+317	6+318	3+319	6+320	5+321	6+322	3+323	8+324	7+325	8+326	7+327	8+328	7+329	8+330	8+331	7+332	9+333	7+334	9+335	7+336	9+337	7+338	12+339	11+340	8+341	5+342	8+343	5+344	8+345	5+346	8+347	6+348	8+349	6+350	8+351	6+352	8+353	6+354	7+355	4+356	7+357	4+358	7+359	4+360	8+361	7+362	8+363	7+364	8+365	7+366	8+367	7+368	8+369	7+370	8+371	7+372	11+373	9+374	7+375	7+376	7+377	8+378	6+379	8+380	6+381	8+382	6+383	3+399	8+402	7+416	9+417	7+431	8+432	7+506	8+507	7+508	11+509	11+510	9+511	7+536	8+537	6+538	7+539	4+601	7+710	7+711	7+713	7+728	7+729	7+730	7+731	7+732	7+733	7+768	0+769	0+771	0+777	0+803	0+894	5+900	7+901	7+902	8+903	5+904	8+905	9+906	6+908	10+910	9+911	9+912	3+913	8+914	8+915	6+916	8+917	7+918	8+919	8+920	9+921	5+922	8+923	8+924	9+925	8+926	7+927	9+928	8+929	7+931	7+932	7+933	7+934	9+935	8+936	9+937	9+938	5+939	7+940	7+941	6+942	7+943	3+944	7+945	7+946	7+947	7+948	7+949	6+950	5+951	7+952	7+953	3+954	7+955	7+956	7+957	7+958	6+959	7+960	7+961	7+962	6+963	7+964	5+965	7+966	9+967	7+968	9+969	9+970	3+971	7+972	7+973	7+974	9+1025	7+1026	9+1027	6+1028	9+1029	8+1030	5+1031	5+1032	5+1033	13+1034	12+1035	9+1036	8+1037	8+1038	8+1039	8+1040	8+1041	8+1042	8+1043	6+1044	8+1045	7+1046	11+1047	7+1048	8+1049	8+1050	8+1051	8+1052	9+1053	8+1054	9+1055	8+1056	7+1057	9+1058	7+1059	8+1060	9+1061	8+1062	9+1063	8+1064	11+1065	12+1066	9+1067	10+1068	7+1069	9+1070	11+1071	8+1072	7+1073	7+1074	7+1075	5+1076	8+1077	7+1078	9+1079	6+1080	7+1081	7+1082	7+1083	7+1084	7+1085	7+1086	7+1087	7+1088	7+1089	6+1090	5+1091	7+1092	9+1093	7+1094	8+1095	7+1096	9+1097	10+1098	8+1099	9+1100	7+1101	7+1102	10+1103	7+1105	7+1106	7+1107	5+1108	7+1109	6+1110	3+1111	3+1112	4+1113	10+1114	11+1115	7+1116	7+1117	7+1118	7+1119	7+1168	6+1169	5+1170	6+1171	5+1174	11+1175	9+1178	8+1179	7+1180	8+1181	7+1186	8+1187	7+1198	7+1199	7+1200	7+1201	7+1202	8+1203	7+1208	8+1209	7+1210	8+1211	7+1240	8+1241	7+1256	9+1257	7+1380	7+1408	7+3647	8+7808	11+7809	9+7810	11+7811	9+7812	11+7813	9+7840	8+7841	7+7842	8+7843	7+7844	8+7845	7+7846	8+7847	7+7848	8+7849	7+7850	8+7851	7+7852	8+7853	7+7854	8+7855	7+7856	8+7857	7+7858	8+7859	7+7860	8+7861	7+7862	8+7863	7+7864	7+7865	7+7866	7+7867	7+7868	7+7869	7+7870	7+7871	7+7872	7+7873	7+7874	7+7875	7+7876	7+7877	7+7878	7+7879	7+7880	5+7881	3+7882	5+7883	3+7884	9+7885	7+7886	9+7887	7+7888	9+7889	7+7890	9+7891	7+7892	9+7893	7+7894	9+7895	7+7896	9+7897	7+7898	9+7899	7+7900	9+7901	7+7902	9+7903	7+7904	9+7905	7+7906	9+7907	7+7908	8+7909	7+7910	8+7911	7+7912	8+7913	7+7914	8+7915	7+7916	8+7917	7+7918	8+7919	7+7920	8+7921	7+7922	7+7923	7+7924	7+7925	7+7926	7+7927	7+7928	7+7929	7+8210	7+8211	7+8212	11+8213	11+8215	7+8216	3+8217	3+8218	3+8219	3+8220	5+8221	5+8222	5+8223	5+8224	7+8225	7+8226	6+8230	9+8240	17+8242	4+8243	6+8244	6+8249	5+8250	5+8252	7+8254	7+8260	4+8308	6+8309	6+8311	6+8312	6+8319	6+8352	7+8353	8+8354	8+8355	7+8356	7+8357	11+8358	8+8359	13+8360	13+8361	11+8362	9+8363	7+8364	7+8365	8+8366	7+8367	11+8368	6+8369	7+8370	9+8371	8+8372	8+8373	8+8453	12+8467	4+8470	13+8480	12+8482	11+8486	9+8494	8+8539	11+8540	11+8541	11+8542	11+8706	7+8710	8+8719	9+8721	8+8722	9+8725	4+8729	4+8730	9+8734	11+8747	7+8776	9+8800	9+8801	9+8804	9+8805	9+9472	8+9474	8+9484	8+9488	8+9492	8+9496	8+9633	7+9642	4+9643	4+9674	9+9679	7+9702	4+9834	6+64257	7+64258	7+65509	7+65510	11

+ examples/example.hs view

@@ -0,0 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+import Lens.Family+import Graphics.Badge.Barrier+import qualified Data.ByteString.Lazy.Char8 as L++main :: IO ()+main = do+    L.writeFile "passing.svg" $ renderBadge flat "build" "passing"+    L.writeFile "failing.svg" $ renderBadge (flat & right .~ red) "build" "failing"

+ examples/make-test-data.hs view

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}+import Lens.Family+import Graphics.Badge.Barrier+import qualified Data.ByteString.Lazy.Char8 as L++main :: IO ()+main = do+    L.writeFile "flat/1.svg" $ renderBadge flat "build" "success"+    L.writeFile "flat/2.svg" $ renderBadge (flat & right .~ red) "build" "failing"+    L.writeFile "flat/3.svg" $ renderBadge (flat & left .~ green) "leaf" "leaf"+    L.writeFile "flat/4.svg" $ renderBadge flat "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"++    L.writeFile "flatSquare/1.svg" $ renderBadge flatSquare "build" "success"+    L.writeFile "flatSquare/2.svg" $ renderBadge (flatSquare & right .~ red) "build" "failing"+    L.writeFile "flatSquare/3.svg" $ renderBadge (flatSquare & left .~ green) "leaf" "leaf"+    L.writeFile "flatSquare/4.svg" $ renderBadge flatSquare "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"++    L.writeFile "plastic/1.svg" $ renderBadge plastic "build" "success"+    L.writeFile "plastic/2.svg" $ renderBadge (plastic & right .~ red) "build" "failing"+    L.writeFile "plastic/3.svg" $ renderBadge (plastic & left .~ green) "leaf" "leaf"+    L.writeFile "plastic/4.svg" $ renderBadge plastic "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"

+ src/Graphics/Badge/Barrier.hs view

@@ -0,0 +1,37 @@+module Graphics.Badge.Barrier+    ( -- * badge+      Badge+    , flat+    , flatSquare+    , plastic++    -- * render function+    , renderBadge++      -- * lens+    , HasLeftColor(..)+    , HasRightColor(..)++    , module Graphics.Badge.Barrier.Color+    ) where++import Graphics.Badge.Barrier.Internal+import Graphics.Badge.Barrier.Color++import Graphics.Badge.Barrier.Style.Flat+import Graphics.Badge.Barrier.Style.FlatSquare+import Graphics.Badge.Barrier.Style.Plastic++import Text.Blaze.Svg.Renderer.Utf8++import Data.Text(Text)+import Data.ByteString.Lazy(ByteString)++-- | @+-- renderBadge flat "left" "right"+-- @+renderBadge :: Badge b => b+            -> Text -- ^ left text+            -> Text -- ^ right text+            -> ByteString -- ^ svg string+renderBadge b l r = renderSvg $ makeBadge b l r

+ src/Graphics/Badge/Barrier/Color.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module Graphics.Badge.Barrier.Color where++import Data.Text(Text)+import Data.String(IsString)++newtype Color = Color Text+    deriving(Show, Eq, IsString)++-- | #4c1+brightgreen :: Color+brightgreen = "#4c1"++-- | #97CA00+green :: Color+green = "#97CA00"++-- | #dfb317+yellow :: Color+yellow = "#dfb317"++-- | #a4a61d+yellowgreen :: Color+yellowgreen = "#a4a61d"++-- | #fe7d37+orange :: Color+orange = "#fe7d37"++-- | #e05d44+red :: Color+red = "#e05d44" ++-- | #007ec6+blue :: Color+blue = "#007ec6" ++-- | #555+gray :: Color+gray = "#555"++-- | #9f9f9f+lightgray :: Color+lightgray = "#9f9f9f"

+ src/Graphics/Badge/Barrier/Internal.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Rank2Types #-}++module Graphics.Badge.Barrier.Internal+    ( BadgeConfig(..)+    , Badge(..)+    , makeBadge+    , Lens'+    +    , HasLeftColor(..)+    , HasRightColor(..)+    ) where++import Language.Haskell.TH++import Control.Arrow(second, (***))++import Text.Blaze.Svg11(Svg)++import qualified Data.Text as T+import qualified Data.HashMap.Strict as S++import Graphics.Badge.Barrier.Color++advanceDict :: S.HashMap Char Int+advanceDict = $( do+    dat <- runIO $ readFile "data/advance.txt"+    let convI = litE . integerL . read+        convC = litE . charL . toEnum . read+    let kvs = flip map (lines dat) $ tupE . (\(a,b) -> [a,b]) .+            (convC *** convI) . second tail . break (== '\t')+    [|S.fromList $(listE kvs)|]+    )++advance :: Char -> Int+advance c = S.lookupDefault 11 c advanceDict++measureText :: T.Text -> Int+measureText = T.foldl' (\i c -> advance c + i) 0++data BadgeConfig = BadgeConfig+    { textLeft   :: T.Text+    , textRight  :: T.Text+    , widthLeft  :: Int+    , widthRight :: Int+    }++badge' :: T.Text -> T.Text -> BadgeConfig+badge' l r = BadgeConfig l r (measureText l + 10) (measureText r + 10)++makeBadge :: Badge b => b -> T.Text -> T.Text -> Svg+makeBadge b l r = badge b (badge' l r)++class Badge a where+    badge :: a -> BadgeConfig -> Svg++type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s++class HasLeftColor a where+    left :: Lens' a Color++class HasRightColor a where+    right :: Lens' a Color

+ src/Graphics/Badge/Barrier/Style/Flat.hs view

@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Graphics.Badge.Barrier.Style.Flat+    ( Flat(..)+    , flat+    ) where++import Graphics.Badge.Barrier.Internal+import Graphics.Badge.Barrier.Color++import Text.Blaze.Svg11(Svg, AttributeValue, toValue, (!))+import qualified Text.Blaze.Svg11 as S+import qualified Text.Blaze.Svg11.Attributes as A++data Flat = Flat+    { leftColor  :: Color+    , rightColor :: Color+    }++instance Badge Flat where+    badge Flat{..} = flat' leftColor rightColor++instance HasLeftColor Flat where+    left f (Flat l r) = fmap (\l' -> Flat l' r) (f l)++instance HasRightColor Flat where+    right f (Flat l r) = fmap (\r' -> Flat l r') (f r)++flat :: Flat+flat = Flat gray brightgreen++flat' :: Color -> Color -> BadgeConfig -> Svg+flat' (Color colorA) (Color colorB) BadgeConfig{..} = S.docTypeSvg ! A.width (toValue svgWidth) ! A.height "20" $ do+    S.lineargradient ! A.id_ "smooth" ! A.x2 "0" ! A.y2 "100%" $ do+        S.stop ! A.offset "0" ! A.stopColor "#bbb" ! A.stopOpacity ".1"+        S.stop ! A.offset "1" ! A.stopOpacity ".1"++    S.mask ! A.id_ "round" $+        S.rect ! A.width (toValue svgWidth) ! A.height "20" ! A.rx "3" ! A.fill "#fff"++    S.g ! A.mask "url(#round)" $ do+        S.rect ! A.width (toValue widthLeft) ! A.height "20" ! A.fill (toValue colorA)+        S.rect ! A.x (toValue widthLeft) ! A.width (toValue widthRight) ! A.height "20" ! A.fill (toValue colorB)+        S.rect ! A.width (toValue svgWidth) ! A.height "20" ! A.fill "url(#smooth)"++    S.g ! A.fill "#fff" ! A.textAnchor "middle" ! A.fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! A.fontSize "11" $ do+        S.text_ (S.text textLeft)  ! A.x (float $ fromIntegral widthLeft / 2 + 1) ! A.y "15" ! A.fill "#010101" ! A.fillOpacity ".3"+        S.text_ (S.text textLeft)  ! A.x (float $ fromIntegral widthLeft / 2 + 1) ! A.y "14"+        S.text_ (S.text textRight) ! A.x (float $ fromIntegral widthLeft + fromIntegral widthRight / 2 - 1) ! A.y "15" ! A.fill "#010101" ! A.fillOpacity ".3"+        S.text_ (S.text textRight) ! A.x (float $ fromIntegral widthLeft + fromIntegral widthRight / 2 - 1) ! A.y "14"+        +  where+    svgWidth = widthLeft + widthRight+    float :: Double -> AttributeValue+    float = toValue

+ src/Graphics/Badge/Barrier/Style/FlatSquare.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Graphics.Badge.Barrier.Style.FlatSquare+    ( FlatSquare(..)+    , flatSquare+    ) where++import Graphics.Badge.Barrier.Internal+import Graphics.Badge.Barrier.Color++import Text.Blaze.Svg11(Svg, AttributeValue, toValue, (!))+import qualified Text.Blaze.Svg11 as S+import qualified Text.Blaze.Svg11.Attributes as A++data FlatSquare = FlatSquare+    { leftColor  :: Color+    , rightColor :: Color+    }++instance Badge FlatSquare where+    badge FlatSquare{..} = flatSquare' leftColor rightColor++instance HasLeftColor FlatSquare where+    left f (FlatSquare l r) = fmap (\l' -> FlatSquare l' r) (f l)++instance HasRightColor FlatSquare where+    right f (FlatSquare l r) = fmap (\r' -> FlatSquare l r') (f r)++flatSquare :: FlatSquare+flatSquare = FlatSquare gray brightgreen++flatSquare' :: Color -> Color -> BadgeConfig -> Svg+flatSquare' (Color colorA) (Color colorB) BadgeConfig{..} = S.docTypeSvg ! A.width (toValue svgWidth) ! A.height "20" $ do+    S.g ! A.shapeRendering "crispEdges" $ do+        S.rect ! A.width (toValue widthLeft) ! A.height "20" ! A.fill (toValue colorA)+        S.rect ! A.x (toValue widthLeft) ! A.width (toValue widthRight) ! A.height "20" ! A.fill (toValue colorB)++    S.g ! A.fill "#fff" ! A.textAnchor "middle" ! A.fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! A.fontSize "11" $ do+        S.text_ (S.text textLeft)  ! A.x (float $ fromIntegral widthLeft / 2 + 1) ! A.y "14"+        S.text_ (S.text textRight) ! A.x (float $ fromIntegral widthLeft + fromIntegral widthRight / 2 - 1) ! A.y "14"+        +  where+    svgWidth = widthLeft + widthRight+    float :: Double -> AttributeValue+    float = toValue

+ src/Graphics/Badge/Barrier/Style/Plastic.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Graphics.Badge.Barrier.Style.Plastic+    ( Plastic(..)+    , plastic+    ) where++import Graphics.Badge.Barrier.Internal+import Graphics.Badge.Barrier.Color++import Text.Blaze.Svg11(Svg, AttributeValue, toValue, (!))+import qualified Text.Blaze.Svg11 as S+import qualified Text.Blaze.Svg11.Attributes as A++data Plastic = Plastic+    { leftColor  :: Color+    , rightColor :: Color+    }++instance Badge Plastic where+    badge Plastic{..} = plastic' leftColor rightColor++instance HasLeftColor Plastic where+    left f (Plastic l r) = fmap (\l' -> Plastic l' r) (f l)++instance HasRightColor Plastic where+    right f (Plastic l r) = fmap (\r' -> Plastic l r') (f r)++plastic :: Plastic+plastic = Plastic gray brightgreen++plastic' :: Color -> Color -> BadgeConfig -> Svg+plastic' (Color colorA) (Color colorB) BadgeConfig{..} = S.docTypeSvg ! A.width (toValue svgWidth) ! A.height "18" $ do+    S.lineargradient ! A.id_ "smooth" ! A.x2 "0" ! A.y2 "100%" $ do+        S.stop ! A.offset "0"   ! A.stopColor "#fff" ! A.stopOpacity ".7"+        S.stop ! A.offset "0.1" ! A.stopColor "#aaa" ! A.stopOpacity ".1"+        S.stop ! A.offset "0.9" ! A.stopColor "#000" ! A.stopOpacity ".3"+        S.stop ! A.offset "1"   ! A.stopColor "#000" ! A.stopOpacity ".5"++    S.mask ! A.id_ "round" $+        S.rect ! A.width (toValue svgWidth) ! A.height "18" ! A.rx "4" ! A.fill "#fff"++    S.g ! A.mask "url(#round)" $ do+        S.rect ! A.width (toValue widthLeft) ! A.height "18" ! A.fill (toValue colorA)+        S.rect ! A.x (toValue widthLeft) ! A.width (toValue widthRight) ! A.height "18" ! A.fill (toValue colorB)+        S.rect ! A.width (toValue svgWidth) ! A.height "18" ! A.fill "url(#smooth)"++    S.g ! A.fill "#fff" ! A.textAnchor "middle" ! A.fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! A.fontSize "11" $ do+        S.text_ (S.text textLeft)  ! A.x (float $ fromIntegral widthLeft / 2 + 1) ! A.y "14" ! A.fill "#010101" ! A.fillOpacity ".3"+        S.text_ (S.text textLeft)  ! A.x (float $ fromIntegral widthLeft / 2 + 1) ! A.y "13"+        S.text_ (S.text textRight) ! A.x (float $ fromIntegral widthLeft + fromIntegral widthRight / 2 - 1) ! A.y "14" ! A.fill "#010101" ! A.fillOpacity ".3"+        S.text_ (S.text textRight) ! A.x (float $ fromIntegral widthLeft + fromIntegral widthRight / 2 - 1) ! A.y "13"+        +  where+    svgWidth = widthLeft + widthRight+    float :: Double -> AttributeValue+    float = toValue

+ tests/data/flat/1.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="91" height="20"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#bbb" stop-opacity=".1" /><stop offset="1" stop-opacity=".1" /></linearGradient><mask id="round"><rect width="91" height="20" rx="3" fill="#fff" /></mask><g mask="url(#round)"><rect width="37" height="20" fill="#555" /><rect x="37" width="54" height="20" fill="#4c1" /><rect width="91" height="20" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="15" fill="#010101" fill-opacity=".3">build</text><text x="19.5" y="14">build</text><text x="63.0" y="15" fill="#010101" fill-opacity=".3">success</text><text x="63.0" y="14">success</text></g></svg>

+ tests/data/flat/2.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="81" height="20"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#bbb" stop-opacity=".1" /><stop offset="1" stop-opacity=".1" /></linearGradient><mask id="round"><rect width="81" height="20" rx="3" fill="#fff" /></mask><g mask="url(#round)"><rect width="37" height="20" fill="#555" /><rect x="37" width="44" height="20" fill="#e05d44" /><rect width="81" height="20" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="15" fill="#010101" fill-opacity=".3">build</text><text x="19.5" y="14">build</text><text x="58.0" y="15" fill="#010101" fill-opacity=".3">failing</text><text x="58.0" y="14">failing</text></g></svg>

+ tests/data/flat/3.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="62" height="20"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#bbb" stop-opacity=".1" /><stop offset="1" stop-opacity=".1" /></linearGradient><mask id="round"><rect width="62" height="20" rx="3" fill="#fff" /></mask><g mask="url(#round)"><rect width="31" height="20" fill="#97CA00" /><rect x="31" width="31" height="20" fill="#4c1" /><rect width="62" height="20" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="16.5" y="15" fill="#010101" fill-opacity=".3">leaf</text><text x="16.5" y="14">leaf</text><text x="45.5" y="15" fill="#010101" fill-opacity=".3">leaf</text><text x="45.5" y="14">leaf</text></g></svg>

+ tests/data/flat/4.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="596" height="20"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#bbb" stop-opacity=".1" /><stop offset="1" stop-opacity=".1" /></linearGradient><mask id="round"><rect width="596" height="20" rx="3" fill="#fff" /></mask><g mask="url(#round)"><rect width="298" height="20" fill="#555" /><rect x="298" width="298" height="20" fill="#4c1" /><rect width="596" height="20" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="150.0" y="15" fill="#010101" fill-opacity=".3">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="150.0" y="14">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="446.0" y="15" fill="#010101" fill-opacity=".3">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="446.0" y="14">longlonglonglonglonglonglonglonglonglonglonglong</text></g></svg>

+ tests/data/flatSquare/1.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="91" height="20"><g shape-rendering="crispEdges"><rect width="37" height="20" fill="#555" /><rect x="37" width="54" height="20" fill="#4c1" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="14">build</text><text x="63.0" y="14">success</text></g></svg>

+ tests/data/flatSquare/2.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="81" height="20"><g shape-rendering="crispEdges"><rect width="37" height="20" fill="#555" /><rect x="37" width="44" height="20" fill="#e05d44" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="14">build</text><text x="58.0" y="14">failing</text></g></svg>

+ tests/data/flatSquare/3.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="62" height="20"><g shape-rendering="crispEdges"><rect width="31" height="20" fill="#97CA00" /><rect x="31" width="31" height="20" fill="#4c1" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="16.5" y="14">leaf</text><text x="45.5" y="14">leaf</text></g></svg>

+ tests/data/flatSquare/4.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="596" height="20"><g shape-rendering="crispEdges"><rect width="298" height="20" fill="#555" /><rect x="298" width="298" height="20" fill="#4c1" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="150.0" y="14">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="446.0" y="14">longlonglonglonglonglonglonglonglonglonglonglong</text></g></svg>

+ tests/data/plastic/1.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="91" height="18"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#fff" stop-opacity=".7" /><stop offset="0.1" stop-color="#aaa" stop-opacity=".1" /><stop offset="0.9" stop-color="#000" stop-opacity=".3" /><stop offset="1" stop-color="#000" stop-opacity=".5" /></linearGradient><mask id="round"><rect width="91" height="18" rx="4" fill="#fff" /></mask><g mask="url(#round)"><rect width="37" height="18" fill="#555" /><rect x="37" width="54" height="18" fill="#4c1" /><rect width="91" height="18" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="14" fill="#010101" fill-opacity=".3">build</text><text x="19.5" y="13">build</text><text x="63.0" y="14" fill="#010101" fill-opacity=".3">success</text><text x="63.0" y="13">success</text></g></svg>

+ tests/data/plastic/2.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="81" height="18"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#fff" stop-opacity=".7" /><stop offset="0.1" stop-color="#aaa" stop-opacity=".1" /><stop offset="0.9" stop-color="#000" stop-opacity=".3" /><stop offset="1" stop-color="#000" stop-opacity=".5" /></linearGradient><mask id="round"><rect width="81" height="18" rx="4" fill="#fff" /></mask><g mask="url(#round)"><rect width="37" height="18" fill="#555" /><rect x="37" width="44" height="18" fill="#e05d44" /><rect width="81" height="18" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="19.5" y="14" fill="#010101" fill-opacity=".3">build</text><text x="19.5" y="13">build</text><text x="58.0" y="14" fill="#010101" fill-opacity=".3">failing</text><text x="58.0" y="13">failing</text></g></svg>

+ tests/data/plastic/3.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="62" height="18"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#fff" stop-opacity=".7" /><stop offset="0.1" stop-color="#aaa" stop-opacity=".1" /><stop offset="0.9" stop-color="#000" stop-opacity=".3" /><stop offset="1" stop-color="#000" stop-opacity=".5" /></linearGradient><mask id="round"><rect width="62" height="18" rx="4" fill="#fff" /></mask><g mask="url(#round)"><rect width="31" height="18" fill="#97CA00" /><rect x="31" width="31" height="18" fill="#4c1" /><rect width="62" height="18" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="16.5" y="14" fill="#010101" fill-opacity=".3">leaf</text><text x="16.5" y="13">leaf</text><text x="45.5" y="14" fill="#010101" fill-opacity=".3">leaf</text><text x="45.5" y="13">leaf</text></g></svg>

+ tests/data/plastic/4.svg view

@@ -0,0 +1,4 @@+<?xml version="1.0" encoding="UTF-8"?>+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN"+    "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">+<svg xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" width="596" height="18"><linearGradient id="smooth" x2="0" y2="100%"><stop offset="0" stop-color="#fff" stop-opacity=".7" /><stop offset="0.1" stop-color="#aaa" stop-opacity=".1" /><stop offset="0.9" stop-color="#000" stop-opacity=".3" /><stop offset="1" stop-color="#000" stop-opacity=".5" /></linearGradient><mask id="round"><rect width="596" height="18" rx="4" fill="#fff" /></mask><g mask="url(#round)"><rect width="298" height="18" fill="#555" /><rect x="298" width="298" height="18" fill="#4c1" /><rect width="596" height="18" fill="url(#smooth)" /></g><g fill="#fff" text-anchor="middle" font-family="DejaVu Sans,Verdana,Geneva,sans-serif" font-size="11"><text x="150.0" y="14" fill="#010101" fill-opacity=".3">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="150.0" y="13">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="446.0" y="14" fill="#010101" fill-opacity=".3">longlonglonglonglonglonglonglonglonglonglonglong</text><text x="446.0" y="13">longlonglonglonglonglonglonglonglonglonglonglong</text></g></svg>

+ tests/tasty.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+import Lens.Family+import Graphics.Badge.Barrier++import Test.Tasty+import Test.Tasty.Golden++main :: IO ()+main = defaultMain $ testGroup ""+    [ testGroup "flat"+        [ goldenVsString "1" "tests/data/flat/1.svg" . return $ renderBadge flat "build" "success"+        , goldenVsString "2" "tests/data/flat/2.svg" . return $ renderBadge (flat & right .~ red) "build" "failing"+        , goldenVsString "3" "tests/data/flat/3.svg" . return $ renderBadge (flat & left .~ green) "leaf" "leaf"+        , goldenVsString "4" "tests/data/flat/4.svg" . return $ renderBadge flat "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"+        ]+    , testGroup "flatSquare"+        [ goldenVsString "1" "tests/data/flatSquare/1.svg" . return $ renderBadge flatSquare "build" "success"+        , goldenVsString "2" "tests/data/flatSquare/2.svg" . return $ renderBadge (flatSquare & right .~ red) "build" "failing"+        , goldenVsString "3" "tests/data/flatSquare/3.svg" . return $ renderBadge (flatSquare & left .~ green) "leaf" "leaf"+        , goldenVsString "4" "tests/data/flatSquare/4.svg" . return $ renderBadge flatSquare "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"+        ]+    , testGroup "plastic"+        [ goldenVsString "1" "tests/data/plastic/1.svg" . return $ renderBadge plastic "build" "success"+        , goldenVsString "2" "tests/data/plastic/2.svg" . return $ renderBadge (plastic & right .~ red) "build" "failing"+        , goldenVsString "3" "tests/data/plastic/3.svg" . return $ renderBadge (plastic & left .~ green) "leaf" "leaf"+        , goldenVsString "4" "tests/data/plastic/4.svg" . return $ renderBadge plastic "longlonglonglonglonglonglonglonglonglonglonglong" "longlonglonglonglonglonglonglonglonglonglonglong"+        ]+    ]