Rodhos Soft

備忘録を兼ねた技術的なメモです。Rofhos SoftではiOSアプリ開発を中心としてAndroid, Webサービス等の開発を承っております。まずはご相談下さい。

htmlを吐き出してみる。

haskell

データ型と型クラスを使って少しまとめてみた。
同じようなコードを書かなくてはいけなくて面倒に感じる。
良い方法はないのだろうか。

import Data.List
main = print (tag_doctype ++ html)

tag_doctype = "<!DOCTYPE html>"

html = string (HTML [header,body])
header = HeadTag (HEAD "OK!")
body = BodyTag (BODY (htmlbody ++ scriptpart))

htmlbody = foldr (++) "" [tag_p "hello", tag_div (tag_canvas ""), string (A "https://www.yahoo.co.jp/" "Link") ]
scriptpart = tag_script scriptlist


class TransString a where
  string::a -> String
  stringjoin::[a] -> String
  stringjoin list = intercalate "" (map string list)



data Anchor = A { aURL::String, aLabel::String}
instance TransString Anchor where
  string (A { aURL=u, aLabel=l}) = (tagatt "a" (attr "href" (qua u)) l)

-- 色々なタグをタグでまとめた。
data TAG = HeadTag HEADERTAG
          |BodyTag BODYTAG
          |TitleTag TITLETAG

instance TransString TAG where
  string (HeadTag tag) = string tag
  string (BodyTag tag) = string tag
  string (HeadTag tag) = string tag

data HTMLTAG = HTML { htmlText::[TAG]}
instance TransString HTMLTAG where
  string (HTML { htmlText=tags}) =  tag "html" (stringjoin tags)

data HEADERTAG = HEAD { headText::String}
instance TransString HEADERTAG where
  string (HEAD { headText=txt}) = tag "head" txt

data BODYTAG = BODY { bodyText::String}
instance TransString BODYTAG where
  string (BODY { bodyText=txt}) = tag "body" txt

data TITLETAG = TITLE { titleText::String}
instance TransString TITLETAG where
  string (TITLE { titleText=txt}) = tag "title" txt

tag name txt = "<"++name++">" ++ txt ++ "</"++name++">"

attr::String -> String -> String
attr name txt = name ++ "=" ++ txt
tagatt::String -> String -> String->String
tagatt name att txt = "<" ++ name ++ " " ++ att ++ ">" ++ txt ++ "</"++name++">"

qua::String->String
qua txt = "'" ++ txt ++ "'"

trycode::(TransString a) => a -> String
trycode x = string x

tag_div txt = "<div>" ++ txt ++ "</div>"
tag_canvas txt = "<canvas id='canvas' width='200' height='200'>" ++ txt ++ "</canvas>"
tag_p txt = "<p>" ++ txt ++ "</p>"
tag_script txt = "<script>" ++ txt ++ "</script>"

assign v e = v ++ " = " ++ e
variable v = "var " ++ v
action target message = " " ++ target ++ "." ++ message
func name v = name ++ "(" ++ v ++")"
quo el = "'" ++ el ++  "'"
getElement el= action "document" (func "getElementById" (quo el))
jsfunc funcname input block = "function " ++ funcname ++ "(" ++ input  ++ ")" ++ block

canvas = "canvas"
context = "context"
sc1 = assign (variable canvas) (getElement canvas)
sc2 = assign (variable context)  (action canvas (func "getContext" (quo "2d")))
sc3 = assign (variable "cx") "100"
sc4 = assign (variable "cy") "100"

sc5 = action context (func "beginPath" "")
sc6 = assign "context.strokeStyle" "'#ff0000'"
sc7 = action context (func "arc" "120, 80, 70, 0, Math.PI*2, false")
sc8 = action context (func "stroke" "")

--jsfunc "drawFillRect" "cx,cy,w,h" (action context (func "fillRect" "cx-w/2, cy-h/2, w, h"))

-- sc9 = "drawFillRect(10,10,40,40)"

scriptlist = intercalate ";" [sc1,sc2,sc3,sc4,sc5,sc6,sc7,sc8]