From f353fece6960aea7b3ec6a4b635bc8a0699d17f8 Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Tue, 12 Nov 2013 19:39:49 -0800
Subject: [PATCH] subdivide css functions

---
 library/css.rkt            | 165 ++++---------------------------------
 library/css/column.rkt     |  22 +++++
 library/css/core.rkt       |  35 ++++++++
 library/css/font-face.rkt  |  86 +++++++++++++++++++
 library/css/gradient.rkt   |  44 ++++++++++
 library/css/misc.rkt       |  28 +++++++
 library/css/transition.rkt |  16 ++++
 library/css/typography.rkt |  46 +++++++++++
 8 files changed, 292 insertions(+), 150 deletions(-)
 create mode 100644 library/css/column.rkt
 create mode 100644 library/css/core.rkt
 create mode 100644 library/css/font-face.rkt
 create mode 100644 library/css/gradient.rkt
 create mode 100644 library/css/misc.rkt
 create mode 100644 library/css/transition.rkt
 create mode 100644 library/css/typography.rkt

diff --git a/library/css.rkt b/library/css.rkt
index 99d4c1f..92dc75f 100644
--- a/library/css.rkt
+++ b/library/css.rkt
@@ -1,157 +1,22 @@
 #lang racket/base
-(require racket/string racket/list)
-(require (planet mb/pollen/readability))
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;
-; CSS Helper functions.
-; use these either in CSS style block,
-; or inline style.
-;;;;;;;;;;;;;;;;;;;;;;;;;
+; todo: make this hoover up everything in css directory & provide out.
 
-(define css-property-prefixes '("-moz-" "-webkit-" "-o-" "-ms-" ""))
+(require "css/core.rkt" 
+         "css/column.rkt"
+         "css/font-face.rkt"
+         "css/gradient.rkt"
+         "css/misc.rkt"
+         "css/transition.rkt"
+         "css/typography.rkt")
 
-(define (join-css-strings properties)
-  (define line-ending ";\n")
-  (define out-string (string-join properties line-ending))
-  (if (ends-with? out-string line-ending) ; might already have the line ending, so don't duplicate it
-      out-string
-      (string-append out-string line-ending)))
 
-(define (make-css-strings property-prefixes property-suffix values)
-  ; general function for creating groups of css properties
-  ; with browser prefixes and one value
-  (define (map-suffix suffix prefixes)
-    (map (λ(prefix) (string-append prefix suffix)) prefixes))
-  
-  (define (join-css-prop-and-value p v)
-    (string-join (list (->string p) (->string v)) ": "))
-  
-  (define properties (map-suffix property-suffix property-prefixes))
-  
-  ; if single value provided, convert to list of values
-  ; so that it will work with map in the next step
-  (when (not (list? values))
-    (set! values (make-list (len properties) values)))
-  
-  (map join-css-prop-and-value properties values))
+(provide (all-from-out "css/core.rkt" 
+                       "css/column.rkt"
+                       "css/font-face.rkt"
+                       "css/gradient.rkt"
+                       "css/misc.rkt"
+                       "css/transition.rkt"
+                       "css/typography.rkt"))
 
-(define (make-css-columns #:count count #:gap [gap #f])
-  ; shorthand for css column declaration
-  (join-css-strings  (append
-                      (make-css-strings css-property-prefixes "column-count" count)
-                      (if gap
-                          (make-css-strings css-property-prefixes "column-gap" gap)
-                          empty))))
 
-(define (make-css-avoid-column-break-inside)
-  ; this gets applied to list items to keep them from breaking across columns
-  ; however it doesn't work in Firefox due to bug; workaround is stupid
-  (join-css-strings (append
-                     (make-css-strings css-property-prefixes "column-break-inside" "avoid")
-                     (make-css-strings css-property-prefixes "break-inside" "avoid-column"))))
-
-(define (make-css-transition property duration #:timing-function [timing-function #f] #:delay [delay #f])
-  (define transition-prefixes '("-moz-" "-webkit-" ""))
-  (join-css-strings  (append
-                      (make-css-strings transition-prefixes "transition-property" property)
-                      (make-css-strings transition-prefixes "transition-duration" duration)
-                      (if timing-function
-                          (make-css-strings transition-prefixes "transition-timing-function" timing-function)
-                          empty)
-                      (if delay
-                          (make-css-strings transition-prefixes "transition-delay" delay)
-                          empty))))
-
-
-(define (make-css-ot-features feature-tags [feature-values 1])
-  ; if single value provided, upconvert to list
-  (when (not (list? feature-tags))
-    (set! feature-tags (list feature-tags)))
-  
-  ; same here: convert single value into list
-  (when (not (list? feature-values))
-    (let ([single-value feature-values])
-      (set! feature-values (make-list (len feature-tags) single-value))))
-  
-  ; use single quotes in the formatter because css string might be used in an inline tag
-  ; with form style="[string]" so double quotes are irritating
-  (define feature-tag-string (string-join (map (λ(tag value) (format "'~a' ~a" tag value)) feature-tags feature-values) ", "))
-  
-  ; I hate accommodating old browsers but I'll make an exception because OT support is 
-  ; critical to most MB projects
-  ; if this comes before new-style -moz- declaration, it will work for all.
-  (define feature-tag-string-old-firefox (string-join (map (λ(tag value) (format "'~a=~a'" tag value)) feature-tags feature-values) ", "))
-  
-  (define feature-tag-property "font-feature-settings")
-  
-  (join-css-strings (append
-                     (make-css-strings '("-moz-") feature-tag-property feature-tag-string-old-firefox)
-                     (make-css-strings css-property-prefixes feature-tag-property feature-tag-string))))
-
-
-(define (make-css-hyphens [value "auto"])
-  (join-css-strings (make-css-strings css-property-prefixes "hyphens" value)))
-
-(define (make-css-background-gradient colors [stops #f] #:radial [radial #f] #:horizontal [horizontal #f])
-  ; this doesn't handle old-style webkit syntax. todo: add it? I think I don't care
-  
-  ; check inputs for failure
-  (when (or (not (list? colors)) (< (len colors) 2))
-    (error "Not enough colors to make gradient in" colors))
-  (when (and stops (< (len stops) (len colors)))
-    (error "Not enough stops for given number of colors in" stops))
-  
-  (when (not stops) ; distribute colors evenly between 0 and 100
-    ; new-stops is range of steps incremented properly and rounded to int, then append 100 to end
-    (let ([new-stops `(,@(map ->int (range 0 100 (/ 100 (sub1 (len colors))))) 100)])
-      ; convert to list of percentages
-      (set! stops (map (λ(x) (format "~a%" x)) new-stops))))
-  
-  ; color / percentage pairs separated by commas
-  (define color-stop-string (string-join (map (λ(color stop) (format "~a ~a" color stop)) colors stops) ", "))
-  
-  ; set up gradient options
-  (define gradient-type (if radial "radial" "linear"))
-  (define gradient-direction (if horizontal "left" "top"))
-  
-  ; can't use standard make-css-strings in this case because the prefixes appear in the value,
-  ; not in the property (which is always "background")
-  (define gradient-strings (map (λ(prefix) (format "background: ~a~a-gradient(~a, ~a)" prefix gradient-type gradient-direction color-stop-string)) css-property-prefixes))
-  
-  ; just fill with the last color if gradient not available
-  (define fallback-string (format "background: ~a" (last colors)))
-  
-  ; put fallback string at front of list
-  (join-css-strings (cons fallback-string gradient-strings)))
-
-
-(define (make-css-small-caps)
-  (join-css-strings (list "text-transform: lowercase" (make-css-ot-features "c2sc"))))
-
-(define (make-css-caps)
-  (join-css-strings (list "text-transform: uppercase" (make-css-ot-features "case"))))
-
-(define (make-css-kerning)
-  (join-css-strings (list "text-rendering: optimizeLegibility" (make-css-ot-features "kern"))))
-
-
-(define (make-css-ligatures)
-  (join-css-strings (list "text-rendering: optimizeLegibility" (make-css-ot-features "liga"))))
-
-
-
-; editability can't be handled as pure css because firefox requires extra content-editable attribute.
-; does it still? todo: further research, maybe this can be css only.
-(define (editable . stuff)
-  (define editable-string (make-css-editable))
-  `(div ((style ,editable-string)(contenteditable "true")) ,@stuff))
-
-(define (make-css-editable)
-  (join-css-strings (list "user-modify: read-write"
-                          "-moz-user-modify: read-write"
-                          "-webkit-user-modify: read-write-plaintext-only"
-                          "outline-style: none")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(provide (all-defined-out))
\ No newline at end of file
diff --git a/library/css/column.rkt b/library/css/column.rkt
new file mode 100644
index 0000000..edecf2a
--- /dev/null
+++ b/library/css/column.rkt
@@ -0,0 +1,22 @@
+#lang racket/base
+(require "core.rkt")
+
+(provide (all-defined-out))
+
+(define (make-css-columns #:count count #:gap [gap #f])
+  ; shorthand for css column declaration
+  (join-css-strings  (append
+                      (make-css-strings css-property-prefixes "column-count" count)
+                      (if gap
+                          (make-css-strings css-property-prefixes "column-gap" gap)
+                          empty))))
+
+(define (make-css-avoid-column-break-inside)
+  ; this gets applied to list items to keep them from breaking across columns
+  ; however it doesn't work in Firefox due to bug; workaround is stupid
+  (join-css-strings (append
+                     (make-css-strings css-property-prefixes "column-break-inside" "avoid")
+                     (make-css-strings css-property-prefixes "break-inside" "avoid-column"))))
+
+
+
diff --git a/library/css/core.rkt b/library/css/core.rkt
new file mode 100644
index 0000000..dd60d3f
--- /dev/null
+++ b/library/css/core.rkt
@@ -0,0 +1,35 @@
+#lang racket/base
+(require racket/string racket/list racket/contract)
+(require (planet mb/pollen/readability))
+
+(provide (all-defined-out)
+         (all-from-out racket/string racket/list racket/contract (planet mb/pollen/readability)))
+
+(define css-property-prefixes '("-moz-" "-webkit-" "-o-" "-ms-" ""))
+
+(define (join-css-strings properties)
+  (define line-ending ";\n")
+  (define out-string (string-join properties line-ending))
+  (if (ends-with? out-string line-ending) ; might already have the line ending, so don't duplicate it
+      out-string
+      (string-append out-string line-ending)))
+
+(define (make-css-string p v)
+    (string-join (list (->string p) (->string v)) ": "))
+
+(define (make-css-strings property-prefixes property-suffix values)
+  ; general function for creating groups of css properties
+  ; with browser prefixes and one value
+  (define (map-suffix suffix prefixes)
+    (map (λ(prefix) (string-append prefix suffix)) prefixes))
+  
+  
+  (define properties (map-suffix property-suffix property-prefixes))
+  
+  ; if single value provided, convert to list of values
+  ; so that it will work with map in the next step
+  (when (not (list? values))
+    (set! values (make-list (len properties) values)))
+  
+  (map make-css-string properties values))
+
diff --git a/library/css/font-face.rkt b/library/css/font-face.rkt
new file mode 100644
index 0000000..ee63522
--- /dev/null
+++ b/library/css/font-face.rkt
@@ -0,0 +1,86 @@
+#lang racket/base
+(require "core.rkt")
+(require (planet mb/pollen/file-tools))
+(require net/url-structs net/base64 racket/file)
+(provide (all-defined-out))
+
+(module+ test (require rackunit))
+
+
+(define/contract (base64-font-string? x)
+  (any/c . -> . boolean?)
+  ((->string x) . starts-with? . "data:"))
+
+(module+ test
+  (check-true (base64-font-string? "data:foobar"))
+  (check-false (base64-font-string? "foobar")))
+
+
+(define/contract (font-format p)
+  (pathish? . -> . (or/c string? #f))
+  (case (get-ext (->path p))
+    [("eot") "embedded-opentype"]
+    [("woff") "woff"]
+    [("ttf" "otf") "truetype"] ; yep, in this CSS declaration, otf is considered 'truetype'
+    [("svg") "svg"]
+    [else #f]))
+
+(module+ test
+  (check-equal? (font-format "foo.eot") "embedded-opentype")
+  (check-equal? (font-format "foo.woff") "woff")
+  (check-equal? (font-format "foo.ttf") "truetype")
+  (check-equal? (font-format "foo.otf") "truetype")
+  (check-equal? (font-format "foo.svg") "svg")
+  (check-false (font-format "foo")))
+
+
+(define/contract (font-mime-type p)
+  (pathish? . -> . (or/c string? #f))
+  (case (get-ext (->path p))
+    [("eot") "application/vnd.ms-fontobject"]
+    [("woff") "application/font-woff"]
+    [("ttf") "application/x-font-truetype"]
+    [("otf") "application/x-font-opentype"]
+    [("svg") "image/svg+xml"]
+    [else #f]))
+
+(module+ test
+  (check-equal? (font-mime-type "foo.eot") "application/vnd.ms-fontobject")
+  (check-equal? (font-mime-type (->url "foo.woff?bar=ino")) "application/font-woff")
+  (check-equal? (font-mime-type "foo.ttf") "application/x-font-truetype")
+  (check-equal? (font-mime-type "foo.otf") "application/x-font-opentype")
+  (check-equal? (font-mime-type "foo.svg") "image/svg+xml")
+  (check-false (font-mime-type "foo")))
+
+
+(define/contract (path->base64-font-string p)
+  (pathish? . -> . base64-font-string?)
+  (define path (->path p))
+  ;; for CSS, base64 encode needs to be done with no line separator
+  (format "data:~a;charset=utf-8;base64,~a" (font-mime-type p) (base64-encode (file->bytes path) #"")))
+
+
+
+
+(define/contract (font-face-declaration font-family 
+                                        src-url
+                                        #:font-style [font-style "normal"] 
+                                        #:font-weight [font-weight "normal"]
+                                        #:font-stretch [font-stretch "normal"]
+                                        #:base64 [base64? #f])
+  ((string? (or/c urlish? base64-font-string?)) 
+   (#:font-style string?  #:font-weight string? #:font-stretch string? #:base64 boolean?)
+   . ->* . string?)
+  (let* [(url (->url src-url))
+         (url-value (if base64? (path->base64-font-string src-url) (->path url)))
+         (src (format "url('~a') format('~a')" url-value (font-format src-url)))]
+    (string-append "@font-face {\n" 
+                   (join-css-strings (map make-css-string 
+                                          '(font-family font-style font-weight font-stretch src)
+                                          (list font-family font-style font-weight font-stretch src)))
+                   "}")))
+
+(define ffd font-face-declaration)
+
+(module+ main
+(display (ffd "Miso" "charter-regular.woff" #:font-style "italic" #:font-weight "700" #:base64 #t)))
\ No newline at end of file
diff --git a/library/css/gradient.rkt b/library/css/gradient.rkt
new file mode 100644
index 0000000..00e4d89
--- /dev/null
+++ b/library/css/gradient.rkt
@@ -0,0 +1,44 @@
+#lang racket/base
+(require "core.rkt")
+
+(provide (all-defined-out))
+
+(define (make-css-background-gradient colors [stops #f] 
+                                      #:radial [radial #f] 
+                                      #:horizontal [horizontal #f]
+                                      #:direction [direction #f])
+  ; this doesn't handle old-style webkit syntax. todo: add it? I think I don't care
+  
+  ; check inputs for failure
+  (when (or (not (list? colors)) (< (len colors) 2))
+    (error "Not enough colors to make gradient in" colors))
+  (when (and stops (< (len stops) (len colors)))
+    (error "Not enough stops for given number of colors in" stops))
+  
+  (when (not stops) ; distribute colors evenly between 0 and 100
+    ; new-stops is range of steps incremented properly and rounded to int, then append 100 to end
+    (let ([new-stops `(,@(map ->int (range 0 100 (/ 100 (sub1 (len colors))))) 100)])
+      ; convert to list of percentages
+      (set! stops (map (λ(x) (format "~a%" x)) new-stops))))
+  
+  ; color / percentage pairs separated by commas
+  (define color-stop-string (string-join (map (λ(color stop) (format "~a ~a" color stop)) colors stops) ", "))
+  
+  ; set up gradient options
+  (define gradient-type (if radial "radial" "linear"))
+  (define gradient-direction (or direction (if horizontal "left" "top")))
+  
+  ; can't use standard make-css-strings in this case because the prefixes appear in the value,
+  ; not in the property (which is always "background")
+  (define gradient-strings (map (λ(prefix) (format "background: ~a~a-gradient(~a, ~a)" prefix gradient-type gradient-direction color-stop-string)) css-property-prefixes))
+  
+  ; just fill with the last color if gradient not available
+  (define fallback-string (format "background: ~a" (last colors)))
+  
+  ; put fallback string at front of list
+  (join-css-strings (cons fallback-string gradient-strings)))
+
+(module+ main
+  (display (make-css-background-gradient (list "hsl(216, 78%, 95%)" "hsl(0, 0%, 99%)") 
+                                         (list "0%" "100%")
+                                         #:direction "to top right")))
\ No newline at end of file
diff --git a/library/css/misc.rkt b/library/css/misc.rkt
new file mode 100644
index 0000000..a32b3e0
--- /dev/null
+++ b/library/css/misc.rkt
@@ -0,0 +1,28 @@
+#lang racket/base
+(require "core.rkt")
+
+(provide (all-defined-out))
+
+
+; editability can't be handled as pure css because firefox requires extra content-editable attribute.
+; does it still? todo: further research, maybe this can be css only.
+(define (editable . stuff)
+  (define editable-string (make-css-editable))
+  `(div ((style ,editable-string)(contenteditable "true")) ,@stuff))
+
+(define (make-css-editable)
+  (join-css-strings (list "user-modify: read-write"
+                          "-moz-user-modify: read-write"
+                          "-webkit-user-modify: read-write-plaintext-only"
+                          "outline-style: none")))
+
+
+(define (make-media-query starting-size ending-size max-width interval)
+  (string-join (cons (format "@media all {html {font-size: ~apx;}}" starting-size)
+                     (for/list ([size (in-range starting-size (sub1 ending-size) -1)])
+                       (format "@media all and (max-width:~apx){html {font-size: ~apx;}}" 
+                               (- max-width (* interval (- starting-size size))) size))) "\n"))
+
+
+(module+ main
+  (display (make-media-query 15 11 980 60)))
\ No newline at end of file
diff --git a/library/css/transition.rkt b/library/css/transition.rkt
new file mode 100644
index 0000000..fff07c8
--- /dev/null
+++ b/library/css/transition.rkt
@@ -0,0 +1,16 @@
+#lang racket/base
+(require "core.rkt")
+
+(provide (all-defined-out))
+
+(define (make-css-transition property duration #:timing-function [timing-function #f] #:delay [delay #f])
+  (define transition-prefixes '("-moz-" "-webkit-" ""))
+  (join-css-strings  (append
+                      (make-css-strings transition-prefixes "transition-property" property)
+                      (make-css-strings transition-prefixes "transition-duration" duration)
+                      (if timing-function
+                          (make-css-strings transition-prefixes "transition-timing-function" timing-function)
+                          empty)
+                      (if delay
+                          (make-css-strings transition-prefixes "transition-delay" delay)
+                          empty))))
diff --git a/library/css/typography.rkt b/library/css/typography.rkt
new file mode 100644
index 0000000..7235499
--- /dev/null
+++ b/library/css/typography.rkt
@@ -0,0 +1,46 @@
+#lang racket/base
+(require "core.rkt")
+
+(provide (all-defined-out))
+
+(define (make-css-ot-features feature-tags [feature-values 1])
+  ; if single value provided, upconvert to list
+  (when (not (list? feature-tags))
+    (set! feature-tags (list feature-tags)))
+  
+  ; same here: convert single value into list
+  (when (not (list? feature-values))
+    (let ([single-value feature-values])
+      (set! feature-values (make-list (len feature-tags) single-value))))
+  
+  ; use single quotes in the formatter because css string might be used in an inline tag
+  ; with form style="[string]" so double quotes are irritating
+  (define feature-tag-string (string-join (map (λ(tag value) (format "'~a' ~a" tag value)) feature-tags feature-values) ", "))
+  
+  ; I hate accommodating old browsers but I'll make an exception because OT support is 
+  ; critical to most MB projects
+  ; if this comes before new-style -moz- declaration, it will work for all.
+  (define feature-tag-string-old-firefox (string-join (map (λ(tag value) (format "'~a=~a'" tag value)) feature-tags feature-values) ", "))
+  
+  (define feature-tag-property "font-feature-settings")
+  
+  (join-css-strings (append
+                     (make-css-strings '("-moz-") feature-tag-property feature-tag-string-old-firefox)
+                     (make-css-strings css-property-prefixes feature-tag-property feature-tag-string))))
+
+
+(define (make-css-hyphens [value "auto"])
+  (join-css-strings (make-css-strings css-property-prefixes "hyphens" value)))
+
+(define (make-css-small-caps)
+  (join-css-strings (list "text-transform: lowercase" (make-css-ot-features "c2sc"))))
+
+(define (make-css-caps)
+  (join-css-strings (list "text-transform: uppercase" (make-css-ot-features "case"))))
+
+(define (make-css-kerning)
+  (join-css-strings (list "text-rendering: optimizeLegibility" (make-css-ot-features "kern"))))
+
+
+(define (make-css-ligatures)
+  (join-css-strings (list "text-rendering: optimizeLegibility" (make-css-ot-features "liga"))))
\ No newline at end of file