blaze-shields (empty) → 0.1.0.0
raw patch · 4 files changed
+211/−0 lines, 4 filesdep +basedep +blaze-htmldep +blaze-markupsetup-changed
Dependencies added: base, blaze-html, blaze-markup, blaze-svg
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- blaze-shields.cabal +24/−0
- lib/Text/Blaze/Svg/Shields.hs +157/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Qinka+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 blaze-shields nor the names of its+ 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 HOLDER 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ blaze-shields.cabal view
@@ -0,0 +1,24 @@+name: blaze-shields+version: 0.1.0.0+synopsis: create svg by Haskell+description: a Haskell version of shields ,which is on github.+homepage: http://githubcom/Qinka/blaze-shields+bug-reports: https://github.com/Qinka/blaze-shields/issues+license: BSD3+license-file: LICENSE+author: Qinka+maintainer: qinka@live.com+category: Web+build-type: Simple+cabal-version: >= 1.12++library+ exposed-modules:+ Text.Blaze.Svg.Shields+ build-depends:+ base >= 4.8 && < 5,+ blaze-markup >= 0.7 && < 1,+ blaze-html >= 0.8 && <1,+ blaze-svg >=0.3 && < 0.6+ default-language: Haskell2010+ hs-source-dirs:lib
+ lib/Text/Blaze/Svg/Shields.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}+++++module Text.Blaze.Svg.Shields+ (+ plasticStyle,+ flatStyle,+ socialStyle,+ flatSquareStyle+ ) where++ import Prelude hiding (id,show)+ import Control.Monad(when)+ import Data.Maybe(fromMaybe)++ import Text.Blaze(ToMarkup,AttributeValue)+ import Text.Blaze.Internal(string,stringValue,attribute,AttributeValue,Attribute)+ import Text.Blaze.Html((!),toHtml)+ import Text.Blaze.Html5(style)+ import Text.Blaze.Html5.Attributes(xmlns,href)+ import Text.Blaze.Svg(Svg)+ import Text.Blaze.Svg11(+ svg,lineargradient,stop,rect,g,path,text_,rect,+ image,a+ )+ import Text.Blaze.Svg11.Attributes(+ width,height,x2,y2,offset,stopColor,stopOpacity,id_,+ rx,fill,d,textAnchor,fontFamily,fontSize,x,y,fillOpacity,+ xlinkHref,shapeRendering,type_,stroke,fontWeight+ )+ import qualified Text.Blaze.Svg11 as S11+ import qualified Text.Blaze.Svg11.Attributes as S11A+ import qualified Text.Blaze.Html5.Attributes as H5A+ import qualified Prelude as P++ show :: Show a => a -> AttributeValue+ show x = stringValue show_+ where+ show_ = P.show x+ xmlnsXlink :: AttributeValue -- ^ Attribute value.+ -> Attribute -- ^ Resulting attribute.+ xmlnsXlink = attribute "xmlns:xlink" " xmlns:xlink=\""++ plasticStyle ::(Show a,ToMarkup a,Show b,Num b,Floating b)=> (a,b) --left+ -> (a,b) --right+ -> Maybe String --colorA+ -> Maybe String --colorB+ -> Svg -- rt+ plasticStyle (l,lp) (r,rp) cA cB = svg ! xmlns "http://www.w3.org/2000/svg" ! width (show $ lp+rp+20) ! height "18" $ do+ lineargradient ! id_ "smooth" ! x2 "0" ! y2 "100%" $ do+ stop ! offset "0" ! stopColor "#fff" ! stopOpacity ".7"+ stop ! offset ".1" ! stopColor "#aaa" ! stopOpacity ".1"+ stop ! offset ".9" ! stopColor "#000" ! stopOpacity ".3"+ stop ! offset "1" ! stopColor "#000" ! stopOpacity ".5"+ S11.mask ! id_ "round" $+ rect ! width (show $ lp+rp+20) ! height "18" ! rx "4" ! fill "#fff"+ g ! S11A.mask "url(#round)" $ do+ rect ! width (show $ lp+10) ! height "18" ! fill colorA+ rect ! x (show $ lp+10) ! width (show $ 10+rp) ! height "18" ! fill colorB+ rect ! width (show $ lp+rp+20) ! height "18" ! fill "url(#smooth)"+ g ! fill "#fff" ! textAnchor "middle" ! fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! fontSize "11" $ do+ text_ ! x (show $ lp/2+7) ! y "14" ! fill "#010101" ! fillOpacity "0.3" $ toHtml l+ text_ ! x (show $ lp/2+7) ! y "13" $ toHtml l+ text_ ! x (show $ lp+rp/2+13) ! y "14" ! fill "#010101" ! fillOpacity "0.3" $ toHtml r+ text_ ! x (show $ lp+rp/2+13) ! y "13" $ toHtml r+ where+ colorA = stringValue $ fromMaybe "#555" cA+ colorB = stringValue $ fromMaybe "#4c1" cB++ flatStyle ::(Show a,ToMarkup a,Show b,Num b,Floating b)=> (a,b) --left+ -> (a,b) --right+ -> Maybe String --colorA+ -> Maybe String --colorB+ -> Svg -- rt+ flatStyle (l,lp) (r,rp) cA cB = svg ! xmlns "http://www.w3.org/2000/svg" ! width (show $ lp+rp+20) ! height "20" $ do+ lineargradient ! id_ "smooth" ! x2 "0" ! y2 "100%" $ do+ stop ! offset "0" ! stopOpacity ".1" ! stopColor "#bbb"+ stop ! offset "1" ! stopOpacity ".1"+ S11.mask ! id_ "round" $+ rect ! width (show $ lp+rp+20) ! height "20" ! rx "3" ! fill "#fff"+ g ! S11A.mask "url(#round)" $ do+ rect ! width (show $lp+10) ! height "20" ! fill colorA+ rect ! width (show $rp+10) ! x (show $lp+10) ! height "20" ! fill colorB+ rect ! width (show $ lp+rp+20) ! height "20" ! fill "url(#smooth)"+ g ! fill "#fff" ! textAnchor "middle" ! fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! fontSize "11" $ do+ text_ ! x (show $ lp/2+6) ! y "15" ! fill "#010101" ! fillOpacity ".3" $ toHtml l+ text_ ! x (show $ lp/2+6) ! y "14" $ toHtml l+ text_ ! x (show $ lp +rp/2+13) ! y "14" ! fill "#010101" ! fillOpacity ".3" $ toHtml r+ text_ ! x (show $ lp +rp/2+13) ! y "14" $ toHtml r+ where+ colorA = stringValue $ fromMaybe "#555" cA+ colorB = stringValue $ fromMaybe "#4c1" cB++++ flatSquareStyle ::(Show a,ToMarkup a,Show b,Num b,Floating b)=> (a,b) --left+ -> (a,b) --right+ -> Maybe String --colorA+ -> Maybe String --colorB+ -> Svg -- rt++ flatSquareStyle (l,lp) (r,rp) cA cB = svg ! xmlns "http://www.w3.org/2000/svg" ! width (show $ lp+rp+20) ! height "20" $ do+ g ! shapeRendering "crispEdges" $ do+ rect ! width (show $ lp+10) ! height "20" ! fill colorA+ rect ! x (show $ lp+10) ! width (show $ rp+10) ! height "20" ! fill colorB+ g ! fill "#fff" ! textAnchor "middle" ! fontFamily "DejaVu Sans,Verdana,Geneva,sans-serif" ! fontSize "11" $ do+ text_ ! x (show $ lp/2+7) !y "14" $ toHtml l+ text_ ! x (show $ lp+rp/2+13) !y "14" $ toHtml r+ where+ colorA = stringValue $ fromMaybe "#555" cA+ colorB = stringValue $ fromMaybe "#4c1" cB+ socialStyle ::(Show a,ToMarkup a,Show b,Num b,Floating b)=> (a,b) --left+ -> (a,b) --right+ -> Maybe String --logo-url+ -> Maybe String --link1+ -> Maybe String --link2+ -> Svg -- rt+ socialStyle (l,lp) (r,rp) logo la lb= svg ! xmlns "http://www.w3.org/2000/svg" ! xmlnsXlink "http://www.w3.org/1999/xlink"! width (show $ lp+ww+pp+rp+21) ! height "20" $ do+ style ! type_ "text/css" $ do+ "<![CDATA[\n"+ " #llink:hover { fill:url(#b); stroke:#ccc; }\n"+ " #rlink:hover { fill:#4183C4; }\n"+ " ]]>"+ lineargradient ! id_ "a" ! x2 "0" ! y2 "100%" $ do+ stop ! offset "0" ! stopColor "#fcfcfc" ! stopOpacity "0"+ stop ! offset "1" ! stopOpacity ".1"+ lineargradient ! id_ "b" ! x2 "0" ! y2 "100%" $ do+ stop ! offset "0" ! stopColor "#ccc" ! stopOpacity ".1"+ stop ! offset "1" ! stopOpacity ".1"+ g ! stroke "#d5d5d5" $ do+ rect ! stroke "none" ! fill "#fcfcfc" ! x "0.5" ! y "0.5" ! width (show $ lp +7) ! height "19" ! rx "2"+ rect ! y "0.5" ! x (show $ lp+ww+pp+13.5) ! width (show $ rp+7) ! height "19" ! rx "2" ! fill "#fafafa"+ rect ! x (show $ lp+ww+pp+13) ! y "7.5" ! width "0.5" ! height "5" ! stroke "#fafafa"+ path ! d (stringValue pd) ! stroke "d5d5d5" ! fill "#fafafa"+ case logo of+ Just u -> image ! x "5" ! y "3" ! width "14" ! height "14" ! xlinkHref (stringValue u)+ Nothing -> return ()+ g ! fill "#333" ! textAnchor "middle" ! fontFamily "Helvetica Neue,Helvetica,Arial,sans-serif" ! fontWeight "700" ! fontSize "11px" $ do+ text_ ! x (show $ (lp+ww)/2+14) ! y "15" ! fill "#fff" $ toHtml l+ text_ ! x (show $ (lp+ww)/2+14) ! y "14" $ toHtml l+ text_ ! x (show $ lp+ww+pp+rp/2+17) ! y "15" ! fill "#fff" $ toHtml r+ case lb of+ Just lb' -> a ! xlinkHref (stringValue lb')+ Nothing -> a+ $ text_ ! id_ "rlink" ! x (show $ lp+ww+pp+rp/2+17) ! y "14" $ toHtml r+ case la of+ Just la' -> a ! xlinkHref (stringValue la')+ Nothing -> a+ $ rect ! id_ "llink" ! stroke "#d5d5d5" ! fill "url(#a)" ! x "0.5" ! y "0.5" ! width (show $ lp+7+ww+pp) ! height "19" ! rx "2"+ where+ pd = "M"++P.show (lp+ww+pp+13)++" 6.5l-3 3v1l3 3"+ ww = case logo of+ Nothing -> 0+ Just _ -> 14+ pp = 4