Syntax.hs

-- | Css2.1 syntax
--
-- haskell translation of css 2.1 grammar. 
--
-- See <http://www.w3.org/TR/CSS2/grammar.html> and <http://www.w3.org/TR/CSS2/syndata.html>
module Language.Css.Syntax (
        -- * Stylesheet
        StyleSheet(..), StyleBody(..),

        -- * AtRule
        AtCharSet(..), 
        AtImport(..), ImportHead(..),
        AtMedia(..), 
        AtPage(..), PseudoPage,
        AtFontFace(..),
        
        -- * RuleSet
        RuleSet(..), Decl(..), Prop, Prio(..), Expr(..),
        
        -- * Selectors
        Sel(..), SimpleSel(..), SubSel(..),
        Element, Attr(..), Class, Id, AttrIdent, AttrVal, PseudoVal(..),

        -- * Values
        Value(..), 
       
        -- * Primitives
        Ident(..), Func(..), 
                
        Deg(..), 
        Rad(..),
        Grad(..),
        Color(..),
        Hz(..),
        KHz(..),
        Em(..),
        Ex(..),
        Px(..),
        In(..),
        Cm(..),
        Mm(..),
        Pc(..),
        Pt(..),
        Percentage(..),
        Ms(..),
        S(..),
        Uri(..)

    ) where


import Text.PrettyPrint

data Ident = Ident String
                  deriving (Eq)

--------------------------------------------------------
-- Stylesheet

data StyleSheet = StyleSheet (Maybe AtCharSet) [AtImport] [StyleBody]
                  deriving (Eq)

data StyleBody = SRuleSet    RuleSet 
               | SAtMedia    AtMedia 
               | SAtPage     AtPage
               | SAtFontFace AtFontFace
                  deriving (Eq)

---------------------------------------------------------
-- AtRules

-- | \@charset
data AtCharSet = AtCharSet String
                  deriving (Eq)

-- | \@import
data AtImport = AtImport ImportHead [Ident]
                  deriving (Eq)

data ImportHead = IStr String | IUri Uri
                  deriving (Eq)

-- | \@media
data AtMedia = AtMedia [Ident] [RuleSet]
                  deriving (Eq)

-- | \@page
data AtPage = AtPage (Maybe Ident) (Maybe PseudoPage) [Decl]
                  deriving (Eq)

type PseudoPage = Ident

-- | \@font-face
data AtFontFace = AtFontFace [Decl]
                  deriving (Eq)

---------------------------------------------------------
-- Rules

data RuleSet = RuleSet [Sel] [Decl]
                  deriving (Eq)

-- | Declaration
data Decl = Decl (Maybe Prio) Prop Expr
                  deriving (Eq)
-- | Property
type Prop = Ident

-- | sets @!important@ declaration
data Prio = Important
    deriving (Eq)

---------------------------------------------------------
-- Selectors

-- | Selector
data Sel = SSel SimpleSel    -- ^ single selector	 
	 | DescendSel Sel Sel    -- ^ ' '
	 | ChildSel   Sel Sel    -- ^ \'>\'
	 | AdjSel     Sel Sel    -- ^ \'+\'
                  deriving (Eq)

-- | Simple selector
data SimpleSel = UnivSel [SubSel]           -- ^ Universal selector
    	       | TypeSel Element [SubSel]   -- ^ Type selector
                  deriving (Eq)


data SubSel = AttrSel Attr        -- ^ attribute selector
	    | ClassSel Class          -- ^ \'.\'
	    | IdSel Id                -- ^ \'#\'
	    | PseudoSel PseudoVal     -- ^ pseudo classes/elements
                  deriving (Eq)

-- | attribute selector
data Attr = Attr AttrIdent                
          | AttrIs AttrIdent AttrVal      -- ^ \'=\'
          | AttrIncl AttrIdent AttrVal    -- ^ \'~=\'
          | AttrBegins AttrIdent AttrVal  -- ^ \'|=\'
                  deriving (Eq)

type Element = String
type Class = String
type Id = String
	
type AttrIdent = String
type AttrVal = String

data PseudoVal = PIdent Ident
               | PFunc Func
                  deriving (Eq)

-------------------------------------------------------------------
-- Values

data Expr = EVal Value            -- ^ single value
          | SlashSep Expr Expr    -- ^ slash separated expressions
          | CommaSep Expr Expr    -- ^ comma separated expressions
          | SpaceSep Expr Expr    -- ^ space separated expressions
                  deriving (Eq)

data Value = VDeg Deg | 
             VRad Rad | 
             VGrad Grad | 
             VColor Color | 
             VHz Hz | 
             VKHz KHz | 
             VFunc Func | 
             VIdent Ident | 
             VInt Int | 
             VEm Em | 
             VEx Ex | 
             VPx Px | 
             VIn In | 
             VCm Cm | 
             VMm Mm | 
             VPc Pc | 
             VPt Pt | 
             VDouble Double | 
             VPercentage Percentage | 
             VString String | 
             VMs Ms | 
             VS S | 
             VUri Uri
        deriving (Eq)

data Func = Func Ident Expr
                  deriving (Eq)

-- | \<angle\>
data Deg = Deg Double
        deriving (Eq)

-- | \<angle\>
data Rad = Rad Double
        deriving (Eq)

-- | \<angle\>
data Grad = Grad Double
        deriving (Eq)

-- | \<color\>
data Color = Cword String | 
             Crgb Int Int Int
        deriving (Eq)

-- | \<frequency\>
data Hz = Hz Double
        deriving (Eq)

-- | \<frequency\>
data KHz = KHz Double
        deriving (Eq)

-- | \<length\>
data Em = Em Double
        deriving (Eq)

-- | \<length\>
data Ex = Ex Double
        deriving (Eq)

-- | \<length\>
data Px = Px Int
        deriving (Eq)

-- | \<length\>
data In = In Double
        deriving (Eq)

-- | \<length\>
data Cm = Cm Double
        deriving (Eq)

-- | \<length\>
data Mm = Mm Double
        deriving (Eq)

-- | \<length\>
data Pc = Pc Double
        deriving (Eq)

-- | \<length\>
data Pt = Pt Int
        deriving (Eq)

-- | \<percentage\>
data Percentage = Percentage Double
        deriving (Eq)

-- | \<time\>
data Ms = Ms Double
        deriving (Eq)

-- | \<time\>
data S = S Double
        deriving (Eq)

-- | \<uri\>
data Uri = Uri String
        deriving (Eq)

-------------------------------------------------
-- Show instances

ppMaybe :: Show a => Maybe a -> Doc
ppMaybe = maybe empty (text . show)

punctuateShows :: Show a => Doc -> [a] -> Doc
punctuateShows sep = hcat . punctuate sep . map (text . show)

vsep = vcat . punctuate (text "\n")

-- StyleSheet

instance Show StyleSheet where
    show (StyleSheet ch imp body) = show $ 
               ppMaybe ch 
            $$ (vsep $ map (text . show) imp)
            $$ (vsep $ map (text . show) body)

instance Show StyleBody where
    show x = case x of
                SRuleSet    x -> show x
                SAtMedia    x -> show x
                SAtPage     x -> show x
                SAtFontFace x -> show x
  
-- AtRules

-- @charset
instance Show AtCharSet where
    show (AtCharSet str) = "@charset " ++ str ++ " ;"

-- @import
instance Show AtImport where
    show (AtImport head ms) =
        show $ text "@import" <+> (text $ show head) <+>
        punctuateShows comma ms <+> semi

instance Show ImportHead where
    show x = case x of
                IStr x -> x
                IUri x -> show x
-- @page
instance Show AtPage where
    show (AtPage id pp ds) = show $ text "@page" 
        <+> ppMaybe id <+> ppMaybe pp 
        <+> (braces $ punctuateShows semi ds)


-- @media
instance Show AtMedia where
    show (AtMedia ms rs) = show $ text "@media" 
        <+> punctuateShows comma ms
        <+> punctuateShows comma rs
        

-- @font-face
instance Show AtFontFace where
    show (AtFontFace ds) = show $ text "@font-face" 
        <+> (braces $ punctuateShows semi ds)

-- RuleSets

instance Show RuleSet where
	show (RuleSet sels decls) = show $ (vcat $ punctuate comma $ map (text . show) sels)
                <+> lbrace  
                $$ (nest 4 $ vcat $ punctuate semi $ map (text . show)decls) 
                <+> rbrace

-- Declarations

instance Show Decl where
	show (Decl prio p v) = 
            case prio of
                Just x  -> decl ++ " " ++ show x
                Nothing -> decl        
            where decl = show p ++ " : " ++ show v

instance Show Prio where
    show = const "!important"

-- Selectors

instance Show Sel where
	show x = case x of
		    SSel x -> show x
		    DescendSel x xs -> show x ++ "   " ++ show xs
		    ChildSel   x xs -> show x ++ " > " ++ show xs
		    AdjSel     x xs -> show x ++ " + " ++ show xs

instance Show SimpleSel where
	show x = case x of 
		     UnivSel    xs -> "*" ++ showSubs xs
		     TypeSel el xs -> el  ++ showSubs xs

showSubs :: [SubSel] -> String
showSubs = show . hcat . map (text . show)


instance Show PseudoVal where
    show x = case x of 
                PIdent a -> show a
                PFunc  a -> show a

instance Show SubSel where
	show x = case x of
		    AttrSel a         -> show $ brackets $ text $ show a
		    ClassSel v        -> "." ++ v
		    IdSel v           -> "#" ++ v
		    PseudoSel v       -> ":" ++ show v

instance Show Attr where
    show x = case x of
		    Attr a         -> show $ text a
		    AttrIs a v     -> show $ text a <> equals <> (doubleQuotes $ text v)
		    AttrIncl a v   -> show $ text a <> text "~=" <> (doubleQuotes $ text v)
		    AttrBegins a v -> show $ text a <> text "|=" <> (doubleQuotes $ text v)
	


-- Values

instance Show Expr where
    show x = case x of
                EVal x -> show x
                SlashSep x e -> show x ++ " / " ++ show e
                CommaSep x e -> show x ++ " , " ++ show e
                SpaceSep x e -> show x ++ "   " ++ show e

instance Show Func where
    show (Func name arg) = show $ text (show name) <+> parens (text $ show arg)


instance Show Ident where
	show (Ident a) = a

-- Measure Units


-- Value

instance Show Value where
    show x = case x of
        VDeg a -> show a
        VRad a -> show a
        VGrad a -> show a
        VColor a -> show a
        VHz a -> show a
        VKHz a -> show a
        VFunc a -> show a
        VIdent a -> show a
        VInt a -> show a
        VEm a -> show a
        VEx a -> show a
        VPx a -> show a
        VIn a -> show a
        VCm a -> show a
        VMm a -> show a
        VPc a -> show a
        VPt a -> show a
        VDouble a -> show a
        VPercentage a -> show a
        VString a -> show a
        VMs a -> show a
        VS a -> show a
        VUri a -> show a

-- Value elems

instance Show Deg where
    show (Deg x) = show x ++ "deg"

instance Show Rad where
    show (Rad x) = show x ++ "rad"

instance Show Grad where
    show (Grad x) = show x ++ "grad"

instance Show Color where
    show x = case x of { Cword a -> a ; 
        Crgb r g b -> show $ (text "rgb" <> ) $ parens $ hsep $ punctuate comma $ map (text. show) [r, g, b]}

instance Show Hz where
    show (Hz x) = show x ++ "Hz"

instance Show KHz where
    show (KHz x) = show x ++ "kHz"

instance Show Em where
    show (Em x) = show x ++ "em"

instance Show Ex where
    show (Ex x) = show x ++ "ex"

instance Show Px where
    show (Px x) = show x ++ "px"

instance Show In where
    show (In x) = show x ++ "in"

instance Show Cm where
    show (Cm x) = show x ++ "cm"

instance Show Mm where
    show (Mm x) = show x ++ "mm"

instance Show Pc where
    show (Pc x) = show x ++ "pc"

instance Show Pt where
    show (Pt x) = show x ++ "pt"

instance Show Percentage where
    show (Percentage x) = show x ++ "%"

instance Show Ms where
    show (Ms x) = show x ++ "ms"

instance Show S where
    show (S x) = show x ++ "s"

instance Show Uri where
    show (Uri x) = "url(" ++ show x ++ ")"