diff --git a/src/HTML.agda b/src/HTML.agda index c4d894e..441c09f 100644 --- a/src/HTML.agda +++ b/src/HTML.agda @@ -1,16 +1,70 @@ open import Agda.Primitive renaming (Set to Type) -open import Relation.Binary.PropositionalEquality -open import Data.List hiding (head; span) -open import Data.Nat using (ℕ; _<ᵇ_) -open import Data.String hiding (_==_; show; head) renaming (_++_ to _++ˢ_; concat to concatˢ) -open import Data.Char hiding (_==_; show) +open import Data.Nat open import Data.Bool +import Data.String as S +import Data.Char as C +import Data.List as L +open S using (String) +open C using (Char) +open L using (List) + open import Base module HTML where +private + _≤ᶜ_ : Char → Char → Bool + c₀ ≤ᶜ c₁ = C.toℕ c₀ ≤ᵇ C.toℕ c₁ + + + +valid-attribute-name : String → Bool +valid-attribute-name x = L.all valid-attribute-char (S.toList x) + where + valid-attribute-char : Char → Bool + valid-attribute-char c = + ('a' ≤ᶜ c) ∧ (c ≤ᶜ 'z') ∨ + ('A' ≤ᶜ c) ∧ (c ≤ᶜ 'Z') + +valid-tag-name : String → Bool +valid-tag-name x = L.all valid-tag-char (S.toList x) + where + valid-tag-char : Char → Bool + valid-tag-char c = + ('a' ≤ᶜ c) ∧ (c ≤ᶜ 'z') ∨ + ('A' ≤ᶜ c) ∧ (c ≤ᶜ 'Z') ∨ + ('0' ≤ᶜ c) ∧ (c ≤ᶜ '9') + +record Attribute : Type where + field + name : String + value : String + {name-is-valid}: T (valid-attribute-name name) + +instance + open Attribute + EqAttribute : Eq Attribute + EqAttribute ._==_ x y = x .name == y .name ∧ x .value == y .value + +record HTMLTag : Type where + field + name : String + attributes : List Attribute + {name-is-valid}: T (valid-tag-name name) + +instance + open HTMLTag + + EqTag : Eq HTMLTag + EqTag ._==_ x y = x .name == y .name ∧ x .attributes == y .attributes + +data Element : Type where + textnode : String → Element + node : HTMLTag → List Element → Element + +{- data HTMLTag : Type where html head meta title body : HTMLTag div p a span : HTMLTag @@ -42,29 +96,24 @@ instance ShowHTMLTag .show span = "span" ShowHTMLTag .show (h n) = "h" ++ˢ show n -data AttributeName : Type where - lang src name content href style : AttributeName +data Attr : Type where + lang= src= name= content= href= style= : String → Attr -instance - ShowAttributeName : Show AttributeName - ShowAttributeName .show lang = "lang" - ShowAttributeName .show src = "src" - ShowAttributeName .show name = "name" - ShowAttributeName .show content = "content" - ShowAttributeName .show href = "href" - ShowAttributeName .show style = "style" +attr-name : Attr → String +attr-name (lang= _) = "lang" +attr-name (src= _) = "src" +attr-name (name= _) = "name" +attr-name (content= _) = "content" +attr-name (href= _) = "href" +attr-name (style= _) = "style" -record Attribute : Type where - field - attrname : AttributeName - value : String -- maybe string ? how to handle syntax? -open Attribute - -AttrList : Type -AttrList = List Attribute - -_=_ : AttributeName → String → AttrList -attrname = value = record { attrname = attrname ; value = value } ∷ [] +attr-value : Attr → String +attr-value (lang= x) = x +attr-value (src= x) = x +attr-value (name= x) = x +attr-value (content= x) = x +attr-value (href= x) = x +attr-value (style= x) = x mutual DOM : Type @@ -72,7 +121,7 @@ mutual data Element : Type where textnode : String → Element - element : HTMLTag → AttrList → DOM → Element + element : HTMLTag → List Attr → DOM → Element record Listable (T L : Type) : Type where field @@ -80,30 +129,29 @@ record Listable (T L : Type) : Type where open Listable ⦃...⦄ instance - ListListable : {T : Type} → Listable (List T) T - ListListable .enlist l = l - StringDOMAble : Listable String Element StringDOMAble .enlist x = textnode x ∷ [] -_,_ : {D₁ D₂ L : Type} → ⦃ Listable D₁ L ⦄ → ⦃ Listable D₂ L ⦄ → D₁ → D₂ → List L -x , y = (enlist x) Data.List.++ (enlist y) + ListListable : {T : Type} → Listable (List T) T + ListListable .enlist x = x -infixr 10 _,_ + IdListable : {T : Type} → Listable T T + IdListable .enlist x = x ∷ [] -<_&_>_ : {D : Type} → ⦃ Listable D Element ⦄ → (x : HTMLTag) → AttrList → D → (y : HTMLTag) → {T (x == y)} → DOM -< tag & attrs > inner = element tag attrs (enlist inner) ∷ [] + PairListable : {T L : Type} → ⦃ Listable T L ⦄ → Listable (L × T) L + PairListable .enlist (x , y) = x ∷ enlist y -<_>_ : {D : Type} → ⦃ Listable D Element ⦄ → (x : HTMLTag) → D → (y : HTMLTag) → {T (x == y)} → DOM -< tag > inner = element tag [] (enlist inner) ∷ [] +<_&_>_ : {Es As : Type} → ⦃ Listable Es Element ⦄ → ⦃ Listable As Attr ⦄ → (x : HTMLTag) → As → Es → (y : HTMLTag) → {T (x == y)} → Element +< tag & attrs > inner = element tag (enlist attrs) (enlist inner) -<_&_/> : (x : HTMLTag) → AttrList → DOM -< tag & attrs /> = element tag attrs [] ∷ [] - -<_/> : (x : HTMLTag) → DOM -< tag /> = element tag [] [] ∷ [] +<_>_ : {Es : Type} → ⦃ Listable Es Element ⦄ → (x : HTMLTag) → Es → (y : HTMLTag) → {T (x == y)} → Element +< tag > inner = element tag [] (enlist inner) +<_&_/> : {As : Type} → ⦃ Listable As Attr ⦄ → (x : HTMLTag) → As → Element +< tag & attrs /> = element tag (enlist attrs) [] +<_/> : (x : HTMLTag) → Element +< tag /> = element tag [] [] encode : List Char → String → String encode escapes text = fromList (concatMap (λ x → toList (escape-char x)) (toList text)) @@ -119,8 +167,8 @@ private ≡ "hi <3 </p>" encode-test = refl -render-attr : Attribute → String -render-attr x = show (x .attrname) ++ˢ "=" ++ˢ encode (toList "\t\n\r \"'=<>`") (x .value) +render-attr : Attr → String +render-attr x = show (attr-name x) ++ˢ "=" ++ˢ encode (toList "\t\n\r \"'=<>`") (attr-value x) {-# TERMINATING #-} -- TODO: we should eliminate the tree as a traversable instead of doing it like this render-element : Element → String @@ -130,16 +178,13 @@ render-element (element tag attrlist inner) = ++ˢ concatˢ (map render-element inner) ++ˢ "" -render-dom : DOM → String -render-dom x = concatˢ (map render-element x) - -sample-dom : DOM +sample-dom : Element sample-dom = - < html & lang = "en" > + < html & lang= "en" > < head > < title > "Test page in Agda" , - < meta & name = "description" , content = "Simple webpage rendered in Agda DSL" /> , - < meta & name = "author" , content = "xenia" /> + < meta & name= "description" , content= "Simple webpage rendered in Agda DSL" /> , + < meta & name= "author" , content= "xenia" /> , < body > < p > "hello" , @@ -149,3 +194,5 @@ sample-dom = + +-} diff --git a/src/HTML/Render.agda b/src/HTML/Render.agda new file mode 100644 index 0000000..3bd219b --- /dev/null +++ b/src/HTML/Render.agda @@ -0,0 +1,42 @@ +open import Agda.Primitive renaming (Set to Type) + +open import Data.Bool + +import Data.String as S +import Data.List as L +import Data.Char as C +open S using (String) +open L using (List) +open C using (Char) + +open import HTML +open import Base + +module HTML.Render where + +private + -- encodes using HTML decimal escapes (ɭ) + encode : List Char → String → String + encode escapes text = S.fromList (L.concatMap (λ x → S.toList (escape-char x)) (S.toList text)) + where + escape-char : Char → String + escape-char ch = + if L.any (_== ch) escapes + then "&#" S.++ show (C.toℕ ch) S.++ ";" + else S.fromChar ch + +render-attr : Attribute → String +render-attr x = x .name S.++ "=" S.++ encode (S.toList "\t\n\r \"'=<>`") (x .value) + where + open Attribute + +{-# TERMINATING #-} -- TODO: we should eliminate the tree as a traversable instead of doing it like this +render-element : Element → String +render-element (textnode x) = encode (S.toList "") x -- we don't technically need to escape all these characters, but it's easier to do this +render-element (node tag inner) = + "<" S.++ tag .name S.++ S.concat (L.map (λ attr → " " S.++ render-attr attr) (tag .attributes)) S.++ ">" + S.++ S.concat (L.map render-element inner) + S.++ "" + where + open HTMLTag + diff --git a/src/HTML/Syntax.agda b/src/HTML/Syntax.agda new file mode 100644 index 0000000..84a9f5b --- /dev/null +++ b/src/HTML/Syntax.agda @@ -0,0 +1,103 @@ +open import Agda.Primitive renaming (Set to Type) + +open import Data.Product +open import Data.Bool hiding (_<_) + +import Data.String as S +import Data.List as L +open S using (String) +open L using (List) + +open import Base + +open import HTML + +module HTML.Syntax where + +module Attributes where + open HTMLTag + mkAttr : (name : String) → {T (valid-attribute-name name)} → HTMLTag → String → HTMLTag + mkAttr attr-name {attr-name-is-valid} tag value = + record tag + { attributes = record + { name = attr-name + ; value = value + ; name-is-valid = attr-name-is-valid + } + L.∷ tag .attributes + ; name = tag .name + ; name-is-valid = tag .name-is-valid + } + + _id=_ = mkAttr "id" + infixl 20 _id=_ + _class=_ = mkAttr "class" + infixl 20 _class=_ + _style=_ = mkAttr "style" + infixl 20 _style=_ + _lang=_ = mkAttr "lang" + infixl 20 _lang=_ + _src=_ = mkAttr "src" + infixl 20 _src=_ + _href=_ = mkAttr "href" + infixl 20 _href=_ + _name=_ = mkAttr "name" + infixl 20 _name=_ + _content=_ = mkAttr "content" + infixl 20 _content=_ + +open Attributes hiding (mkAttr) public + +module Tags where + mkTag : (name : String) → {T (valid-tag-name name)} → HTMLTag + mkTag name {name-is-valid} = record { name = name ; attributes = L.[]; name-is-valid = name-is-valid } + + html = mkTag "html" + body = mkTag "body" + head = mkTag "head" + meta = mkTag "meta" + title = mkTag "title" + img = mkTag "img" + p = mkTag "p" + span = mkTag "span" + footer = mkTag "footer" + + open import Data.Nat + open import Relation.Binary.PropositionalEquality + postulate + h-is-valid : (x : ℕ) → T (valid-tag-name ("h" S.++ show x)) -- :3 + h : ℕ → HTMLTag + h x = record + { name = "h" S.++ show x + ; attributes = L.[] + ; name-is-valid = h-is-valid x + } + +open Tags hiding (mkTag) public + +record DOMAble (T : Type) : Type where + field + endom : T → List Element +open DOMAble ⦃...⦄ + +instance + TextnodeDOMAble : DOMAble String + TextnodeDOMAble .endom x = textnode x L.∷ L.[] + + ElementDOMAble : DOMAble Element + ElementDOMAble .endom e = e L.∷ L.[] + + ListDOMAble : {T : Type} → ⦃ DOMAble T ⦄ → DOMAble (List T) + ListDOMAble .endom x = L.concatMap endom x + + PairDOMAble : {T₀ T₁ : Type} → ⦃ DOMAble T₀ ⦄ → ⦃ DOMAble T₁ ⦄ → DOMAble (T₀ × T₁) + PairDOMAble .endom (x , y) = endom x L.++ endom y + +module Syntax where + open HTMLTag + <_>_ : {D : Type} → ⦃ DOMAble D ⦄ → (t₀ : HTMLTag) → D → (t₁ : HTMLTag) → {T (t₀ .name == t₁ .name)} → Element + < t₀ > sub = node t₀ (endom sub) + + <_/> : HTMLTag → Element + <_/> t = node t L.[] +open Syntax public diff --git a/src/Main.agda b/src/Main.agda index 8e41683..95608bb 100644 --- a/src/Main.agda +++ b/src/Main.agda @@ -8,7 +8,7 @@ import Data.Vec as V import Data.List as L open S using (String) open L using (List) -open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to _,,,_) +open import Data.Product using (_×_; proj₁; proj₂; _,_) open import Data.Nat hiding (_<_; _>_) open import Data.Unit using (⊤; tt) open import Data.Bool @@ -23,7 +23,9 @@ open import NonEmpty open import Parse-HTTP open import Parse-HTTP.URL hiding (_/_) open import Parse-HTTP.Methods -import HTML +open import HTML +import HTML.Syntax +import HTML.Render import UTF-8 response-with-content : ℕ → S.String → String → List Byte → List Byte @@ -60,23 +62,29 @@ response-without-content status-code status = module Pages where open HTML - render-index : Maybe S.String → HTML.DOM + render-index : Maybe S.String → HTML.Element render-index query = - < html & lang = "en" , style = "color: yellow; background: black; padding: 1em;" > + < html lang= "en" style= "color: white; background: black; padding: 1em;" > < head > - < title > "Test page in Agda" , - < meta & name = "description" , content = "Simple webpage rendered in Agda DSL" /> , - < meta & name = "author" , content = "xenia" /> + < title > "henttp index" , + < meta name= "description" content= "Simple webpage rendered in Agda DSL" /> , + < meta name= "author" content= "xenia" /> , < body > - < h 1 > "hi" , + < h 1 > + < span style= "color: yellow;" > "hen" , + < span style= "color: purple;" > "ttp" + , < p > - "welcome to the " , - < span & style = "color: white;" > "index" , - (((λ q → < span & style = "color: fuchsia;" > " (query = " , q , ")" ) <$> query) or-else L.[]) - - + "what is this?" + + , + < footer > + "meow" + + where + open HTML.Syntax handle-request : Request → IO (List Byte) handle-request req = @@ -85,7 +93,7 @@ handle-request req = 200-ok "text/html" (UTF-8.encode-string (S.toList ( - HTML.render-dom (Pages.render-index (req .target .query)) + HTML.Render.render-element (Pages.render-index (req .target .query)) ))) ) else pure 404-not-found