Rodhos Soft

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

htmlを吐き出す4

何か形になってきた気が。とりあえず根本的にタグを定義してみた。
しかしdivとかを手で入れるようになってしまい面倒さは変わらないような気も。

import Data.List

main = print (display html)

type ClassName = String
-- data DIV a = DIV ClassName a deriving Show
-- data P a = P ClassName a deriving Show
--
-- display:: DIV a -> String
-- display (DIV name x) = name



type TagName = String
tag::TagName -> String -> String
tag name txt = "<"++name++">" ++ txt ++ "</"++name++">"

type AttributeName = String
type AttributeString = String
attr::AttributeName -> String -> AttributeString
attr name txt = name ++ "=" ++ txt


tagatt::TagName -> [AttributeString] -> String -> String
tagatt name att txt = "<" ++ name ++ " " ++ attstr ++ ">" ++ txt ++ "</"++name++">" where
  attstr = intercalate "" att

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

data TAG = TAG TagName ClassName [ATTRIBUTE] [TAG] |Text String deriving Show
data ATTRIBUTE = Attribute AttributeName String deriving Show

class DISPLAY a where
  display:: a -> String

instance DISPLAY TAG where
  display (TAG tagName className attributes tags) = tagatt tagName (map display ([Attribute "class" (qua className)]++attributes)) (intercalate "" (map display tags))
  display (Text txt) = txt


instance DISPLAY ATTRIBUTE where
  display (Attribute name txt) = attr name txt


-----

html = TAG "html" "" [] htmlall

htmlall = [header, body]

header = TAG "header" "" [] []
body = TAG "body" "" [] [Text "hello"]


Styleタグを付けてみた。

import Data.List

main = putStr (display html)

type ClassName = String



type TagName = String
tag::TagName -> String -> String
tag name txt = "\n<"++name++">\n" ++ txt ++ "</"++name++">\n"

type AttributeName = String
type AttributeString = String
attr::AttributeName -> String -> AttributeString
attr name txt = name ++ "=" ++ txt


tagatt::TagName -> [AttributeString] -> String -> String
tagatt name att txt = "\n<" ++ name ++ " " ++ attstr ++ ">\n" ++ txt ++ "</"++name++">\n" where
  attstr = intercalate "" att

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

data TAG = TAG TagName ClassName [ATTRIBUTE] [TAG] |Text String deriving Show
data ATTRIBUTE = Attribute AttributeName String deriving Show

type PropertyName = String
data STYLE = STYLECLASS [ClassName] [PROPERTY] | STYLETAG TagName [PROPERTY]
data PROPERTY = Property PropertyName String deriving Show

class DISPLAY a where
  display:: a -> String

instance DISPLAY TAG where
  display (TAG tagName className attributes tags) = tagatt tagName (map display ([Attribute "class" (qua className)]++attributes)) (intercalate "" (map display tags))
  display (Text txt) = txt

instance DISPLAY ATTRIBUTE where
  display (Attribute name txt) = attr name txt

instance DISPLAY PROPERTY where
  display (Property name txt) = "\t" ++ name ++ ":" ++ txt ++ ";\n"

instance DISPLAY STYLE where
  display (STYLECLASS classnames props) = intercalate "" (map (" ."++) classnames) ++ "{\n" ++ (intercalate "" (map display props))  ++ "\n}\n"
  display (STYLETAG tagname props) = tagname ++ "{\n" ++ (intercalate "" (map display props))  ++ "\n}\n"


-----

html = TAG "html" "" [] htmlall

htmlall = [header, body]

header = TAG "header" "" [] [style]
style = TAG "style" "" [] [Text (display css)]
body = TAG "body" "hoge" [] [Text "hello"]

css = STYLECLASS ["hoge"] [Property "background-color" "green"]


タグを幾つか定義してみた。これで大体がつくれるかもしれない。

import Data.List

main = putStr (display html)

type ClassName = String



type TagName = String
tag::TagName -> String -> String
tag name txt = "\n<"++name++">\n" ++ txt ++ "</"++name++">\n"

type AttributeName = String
type AttributeString = String
attr::AttributeName -> String -> AttributeString
attr name txt = name ++ "=" ++ txt


tagatt::TagName -> [AttributeString] -> String -> String
tagatt name att txt = "\n<" ++ name ++ " " ++ attstr ++ ">\n" ++ txt ++ "</"++name++">\n" where
  attstr = intercalate "" att

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

data TAG = TAG TagName ClassName [ATTRIBUTE] [TAG] |Text String deriving Show
data ATTRIBUTE = Attribute AttributeName String deriving Show

type PropertyName = String
data STYLE = STYLECLASS [ClassName] [PROPERTY] | STYLETAG TagName [PROPERTY] | STYLEEMPTY
data PROPERTY = Property PropertyName String deriving Show

class DISPLAY a where
  display:: a -> String

instance DISPLAY TAG where
  display (TAG tagName className attributes tags) = tagatt tagName (map display ([Attribute "class" (qua className)]++attributes)) (intercalate "" (map display tags))
  display (Text txt) = txt

instance DISPLAY ATTRIBUTE where
  display (Attribute name txt) = attr name txt

instance DISPLAY PROPERTY where
  display (Property name txt) = "\t" ++ name ++ ":" ++ txt ++ ";\n"

instance DISPLAY STYLE where
  display (STYLECLASS classnames props) = intercalate "" (map (" ."++) classnames) ++ "{\n" ++ (intercalate "" (map display props))  ++ "\n}\n"
  display (STYLETAG tagname props) = tagname ++ "{\n" ++ (intercalate "" (map display props))  ++ "\n}\n"
  display (STYLEEMPTY) = ""


-----

html = htmlcommon htmlall

htmlcommon = _html "" [Attribute "lang" (qua "ja")]
metacommon = _meta "" [Attribute "charset" (qua "UTF-8")] []
htmlall = [headtag "title" (style css) , body]

_meta = TAG "meta"
_html = TAG "html"
_head = TAG "head"
_body = TAG "body"
_div = TAG "div"
_p = TAG "p"
_a href= \className -> TAG "a" className  [Attribute "href" (qua href)]
_title = TAG "title"

style css = TAG "style" "" [] [Text (display css)]

-- head
headtag title style = _head "" [] [metacommon,style, (_title "" [] [Text title])]

-- body
body = _body "hoge" [] [_div "box" [] [Text "Hello", _a "https://yahoo.co.jp" "" [Text "link"]]]

-- css
css = STYLECLASS ["hoge"] [Property "background-color" "green"]

-- template
templatehtml title css bodytag = htmlcommon [headtag title (style css), bodytag]

-- emptyhtml
emptyhtml = templatehtml "title" STYLEEMPTY (_body "" [] [])


gistにのっけた。
html haskell · GitHub