diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + 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/blaze-shields.cabal b/blaze-shields.cabal new file mode 100644 --- /dev/null +++ b/blaze-shields.cabal @@ -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 diff --git a/lib/Text/Blaze/Svg/Shields.hs b/lib/Text/Blaze/Svg/Shields.hs new file mode 100644 --- /dev/null +++ b/lib/Text/Blaze/Svg/Shields.hs @@ -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 + "" + 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