From b8daf07f28d76feec7a0000e1d5c19f6c587f46a Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Mon, 9 Sep 2019 21:56:20 +1200
Subject: [PATCH] Implement @import & @media

Dependency injection required for an HTTP client library.
---
 src/Data/CSS/Preprocessor/Conditions.hs      | 62 ++++++++++++++-
 src/Data/CSS/Preprocessor/Conditions/Expr.hs | 82 ++++++++++++++++++++
 stylist.cabal                                |  3 +-
 3 files changed, 143 insertions(+), 4 deletions(-)
 create mode 100644 src/Data/CSS/Preprocessor/Conditions/Expr.hs

diff --git a/src/Data/CSS/Preprocessor/Conditions.hs b/src/Data/CSS/Preprocessor/Conditions.hs
index 8c9fd2b..b323972 100644
--- a/src/Data/CSS/Preprocessor/Conditions.hs
+++ b/src/Data/CSS/Preprocessor/Conditions.hs
@@ -1,22 +1,28 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Data.CSS.Preprocessor.Conditions(
-        ConditionalStyles(..)
+        ConditionalStyles(..), loadImports, expandForMedia
     ) where
 
+import qualified Data.CSS.Preprocessor.Conditions.Expr as Query
+
 import Data.CSS.Syntax.StyleSheet
 import Data.CSS.Syntax.Tokens(Token(..))
 
+import Data.Text.Internal (Text(..))
 import Data.Text (unpack)
-import Network.URI (URI(..), URIAuth(..))
+import Network.URI (URI(..), URIAuth(..), parseURI)
 
 import Data.List
 
 data ConditionalStyles s = ConditionalStyles {
     hostURL :: URI,
     mediaDocument :: String,
-    inner :: s
+    inner :: s,
+    conditions :: [(Query.Expr, StyleRef)]
 }
 
+data StyleRef = External URI | Internal [Token] deriving Eq
+
 hostUrlS :: ConditionalStyles s -> String
 hostUrlS = show . hostURL
 
@@ -30,6 +36,7 @@ instance StyleSheet s => StyleSheet (ConditionalStyles s) where
     setPriority x self = self {inner = setPriority x $ inner self}
     addRule self rule = self {inner = addRule (inner self) rule}
 
+    addAtRule self "document" (Whitespace:toks) = addAtRule self "document" toks
     addAtRule self "document" (Comma:toks) = addAtRule self "document" toks
     addAtRule self "document" (Url match:toks)
         | unpack match == hostUrlS self = parseAtBlock self toks
@@ -50,5 +57,54 @@ instance StyleSheet s => StyleSheet (ConditionalStyles s) where
     -- TODO Support regexp() conditions, requires new dependency
     addAtRule self "document" tokens = (self, skipAtRule tokens)
 
+    addAtRule self "media" toks
+        | (cond, LeftCurlyBracket:block) <- Query.parse LeftCurlyBracket toks =
+            let (block', toks') = scanBlock block in (self {
+                conditions = (cond, Internal block') : conditions self
+            }, toks')
+    addAtRule self "media" tokens = (self, skipAtRule tokens)
+
+    addAtRule self "import" (Whitespace:toks) = addAtRule self "import" toks
+    addAtRule self "import" (Url src:toks) = parseAtImport self src toks
+    addAtRule self "import" (String src:toks) = parseAtImport self src toks
+    addAtRule self "import" tokens = (self, skipAtRule tokens)
+
     addAtRule self rule tokens =
         let (self', tokens') = addAtRule (inner self) rule tokens in (self {inner = self'}, tokens')
+
+--------
+---- @import/@media
+--------
+parseAtImport :: StyleSheet s => ConditionalStyles s -> Text -> [Token] -> (ConditionalStyles s, [Token])
+parseAtImport self src toks
+    | (cond, Semicolon:toks') <- Query.parse Semicolon toks, Just uri <- parseURI $ unpack src =
+        (self { conditions = (cond, External uri) : conditions self }, toks')
+parseAtImport self _ toks = (self, skipAtRule toks)
+
+loadImports :: StyleSheet s => (URI -> IO Text) ->
+        (Text -> Query.Datum) -> (Token -> Query.Datum) ->
+        ConditionalStyles s -> IO s
+loadImports = loadImports' [] []
+loadImports' :: StyleSheet s => [URI] -> [(Query.Expr, StyleRef)] -> (URI -> IO Text) ->
+        (Text -> Query.Datum) -> (Token -> Query.Datum) ->
+        ConditionalStyles s -> IO s
+loadImports' blocklist ((cond, src):conds) loader vars evalToken self
+    | Query.eval vars evalToken cond, Internal tokens <- src =
+        loadImports' blocklist conds loader vars evalToken (parse' self tokens)
+    | Query.eval vars evalToken cond, External uri <- src, uri `notElem` blocklist = do
+        response <- loader uri
+        loadImports' (uri:blocklist) conds loader vars evalToken (parse self response)
+    | otherwise = loadImports' blocklist conds loader vars evalToken self
+loadImports' blocklist [] loader v t self
+    | conds == [] = return $ inner self
+    | otherwise = loadImports' blocklist conds loader v t self {conditions = []}
+    where conds = conditions self
+
+expandForMedia :: StyleSheet s => (Text -> Query.Datum) -> (Token -> Query.Datum) ->
+        ConditionalStyles s -> s
+expandForMedia vars evalToken self | conds == [] = inner self
+    | otherwise = expandForMedia vars evalToken $
+        foldl parse' self {conditions = []} [
+            src | (cond, Internal src) <- conds, Query.eval vars evalToken cond
+        ]
+    where conds = conditions self
diff --git a/src/Data/CSS/Preprocessor/Conditions/Expr.hs b/src/Data/CSS/Preprocessor/Conditions/Expr.hs
new file mode 100644
index 0000000..8e691f6
--- /dev/null
+++ b/src/Data/CSS/Preprocessor/Conditions/Expr.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Data.CSS.Preprocessor.Conditions.Expr(
+        Expr, Op(..), parse, eval, Datum(..)
+    ) where
+
+import Data.CSS.Syntax.Tokens(Token(..))
+import Data.Text.Internal (Text(..))
+import Data.Text (stripPrefix)
+
+type Expr = [Op]
+data Op = And | Or | Not | Var Text | Tok Token | MkRatio | Func Text [Token]
+    | Less | LessEq | Equal | Greater | GreaterEq deriving Eq
+
+parse :: Token -> [Token] -> (Expr, [Token])
+parse end toks = let (toks', rest) = break (== end) toks in (parse' toks' [], rest)
+
+--------
+---- Shunting Yard parser
+--------
+parse' :: [Token] -> [(Op, Int)] -> Expr
+parse' (Whitespace:toks) ops = parse' toks ops
+
+parse' (Comma:toks) ops = pushOp toks Or 10 ops
+parse' (Ident "not":toks) ops = pushOp toks Not 20 ops
+parse' (Function "not":toks) ops = pushOp toks Not 0 ops
+parse' (Ident "only":toks) ops = parse' toks ops
+parse' (Ident "and":toks) ops = pushOp toks And 30 ops
+parse' (Ident "or":toks) ops = pushOp toks Or 30 ops
+parse' (Delim '<':Delim '=':toks) ops = pushOp toks LessEq 40 ops
+parse' (Delim '<':toks) ops = pushOp toks LessEq 40 ops
+parse' (Delim '>':Delim '=':toks) ops = pushOp toks GreaterEq 40 ops
+parse' (Delim '>':toks) ops = pushOp toks Greater 40 ops
+parse' (Colon:tok:toks) ops = Tok tok : pushOp toks Equal 40 ops
+parse' (Delim '/':toks) ops = pushOp toks MkRatio 50 ops
+
+parse' (LeftParen:toks) ops = pushOp toks (Var ")") 0 ops
+parse' (RightParen:toks) ((Var ")", 0):ops) = parse' toks ops
+parse' (RightParen:toks) ((Not, 0):ops) = Not : parse' toks ops -- Functional not syntax
+parse' toks@(RightParen:_) ((op, _):ops) = op : parse' toks ops
+parse' (RightParen:_) [] = [] -- Invalid!
+parse' (Function name:toks) ops
+    | (args, RightParen:toks') <- break (== RightParen) toks = Func name args : parse' toks' ops
+    | otherwise = [op | (op, _) <- ops] -- Invalid!
+parse' (Ident var:toks) ops@((peek, _):ops')
+    -- First, fix up various range syntaxes.
+    | peek `elem` [Less, LessEq, Greater, GreaterEq] = -- Chained conditions
+        Var var : peek : Var var : parse' toks ops'
+    | Just var' <- stripPrefix "max-" var = Var var' : pushOp toks LessEq 1000 ops
+    | Just var' <- stripPrefix "min-" var = Var var' : pushOp toks GreaterEq 1000 ops
+    | otherwise = Var var : parse' toks ops
+parse' (tok:toks) ops = Tok tok : parse' toks ops
+parse' [] ops = [op | (op, _) <- ops]
+
+pushOp :: [Token] -> Op -> Int -> [(Op, Int)] -> Expr
+pushOp toks op b ((peek, b'):ops') | b' >= b = peek : pushOp toks op b ops'
+pushOp toks op b ops = parse' toks ((op, b):ops)
+
+--------
+---- Shunting Yard Evaluator
+--------
+data Datum = B Bool | N Float | Ratio Float Float deriving Eq
+
+eval :: (Text -> Datum) -> (Token -> Datum) -> Expr -> Bool
+eval = eval' []
+
+eval' :: [Datum] -> (Text -> Datum) -> (Token -> Datum) -> Expr -> Bool
+eval' (B x:B y:stack) v t (And:ops) = eval' (B (x && y):stack) v t ops
+eval' (B x:B y:stack) v t (Or:ops) = eval' (B (x || y):stack) v t ops
+eval' (B x:stack) v t (Not:ops) = eval' (B (not x):stack) v t ops
+eval' stack v t (Var name:ops) = eval' (v name:stack) v t ops
+eval' stack v t (Tok tok:ops) = eval' (t tok:stack) v t ops
+-- TODO: How should I handle ratios?
+eval' (N x:N y:stack) v t (MkRatio:ops) = eval' (Ratio x y:stack) v t ops
+eval' _ _ _ (Func _ _:_) = False -- Unsupported here, parser used elsewhere
+eval' (N x:N y:stack) v t (Less:ops) = eval' (B (x < y):stack) v t ops
+eval' (N x:N y:stack) v t (LessEq:ops) = eval' (B (x <= y):stack) v t ops
+eval' (x:y:stack) v t (Equal:ops) = eval' (B (x == y):stack) v t ops
+eval' (N x:N y:stack) v t (Greater:ops) = eval' (B (x > y):stack) v t ops
+eval' (N x:N y:stack) v t (GreaterEq:ops) = eval' (B (x >= y):stack) v t ops
+eval' (B ret:_) _ _ [] = ret
+eval' [] _ _ [] = True -- Special case
+eval' _ _ _ _ = False -- Error handling fallback.
diff --git a/stylist.cabal b/stylist.cabal
index 4d0089e..3021845 100644
--- a/stylist.cabal
+++ b/stylist.cabal
@@ -58,7 +58,8 @@ library
   -- Modules included in this library but not exported.
   other-modules:       Data.CSS.Syntax.StylishUtil,
                        Data.CSS.Style.Importance, Data.CSS.Style.Common, Data.CSS.Style.Cascade,
-                       Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret, Data.CSS.Style.Selector.Specificity
+                       Data.CSS.Style.Selector.Index, Data.CSS.Style.Selector.Interpret, Data.CSS.Style.Selector.Specificity,
+                       Data.CSS.Preprocessor.Conditions.Expr
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
-- 
2.30.2