make-token.hs

{-# LANGUAGE OverloadedStrings #-}

-- Need to fix "Pattern match(es) are overlapped" by hand

module Main where

import Control.Arrow
import Data.Char
import Data.List

main :: IO ()
main = do
    putStrLn "{-# LANGUAGE OverloadedStrings #-}"
    putStr "\n"
    putStrLn "module Token where"
    putStr "\n"
    putStrLn "import Data.ByteString (ByteString)"
    putStrLn "import qualified Data.ByteString as B"
    putStrLn "import Data.Ix"
    putStr "\n"
    putStrLn "-- $setup"
    putStrLn "-- >>> :set -XOverloadedStrings"
    putStr "\n"
    printTokens tokens
    putStr "\n"
    printDoctests targets
    printToToken targets
  where
    uniqKeys = map head $ group $ map fst staticTableList
    tokens = map mkToken uniqKeys
    targets = zip uniqKeys tokens

mkToken :: String -> String
mkToken key = "T" ++ concatMap capitalize (splitBy isAlphaNum key)

capitalize :: String -> String
capitalize []     = []
capitalize (x:xs) = toUpper x : xs

splitBy :: (Char -> Bool) -> String -> [String]
splitBy _ [] = []
splitBy p xs
    | r == ""   = splitBy p xs''
    | otherwise = r : splitBy p xs''
  where
    (r,xs') = span p xs
    xs'' = dropWhile (not . p) xs'

printDoctests :: [(String,String)] -> IO ()
printDoctests xs = do
    putStrLn "-- |"
    putStrLn "--"
    mapM_ pr xs
    pr ("foo",tokenOther)
  where
    pr (k,t) = do
        putStrLn $ "-- >>> toToken \"" ++ k ++ "\""
        putStrLn $ "-- " ++ t

tokenOther :: String
tokenOther = "TOTHER"

printTokens :: [String] -> IO ()
printTokens []     = return ()
printTokens (t:ts) = do
    putStrLn $ "data Token = " ++ t
    mapM_ pr ts
    putStrLn $ "           | " ++ tokenOther
    putStrLn   "           deriving (Eq,Ord,Show,Enum,Bounded,Ix)"
  where
    pr x = putStrLn $ "           | " ++ x

printToToken :: [(String,String)] -> IO ()
printToToken xs = do
    putStrLn "toToken :: ByteString -> Token"
    putStrLn "toToken bs = case len of"
    mapM_ printCase ys
    putStrLn $ "    _ -> " ++ tokenOther
    putStrLn "  where"
    putStrLn "    len = B.length bs"
    putStrLn "    lst = B.last bs"
  where
    addLen kv@(k,_) = (length k, kv)
    extract zs = (l,kv)
      where
        l = fst $ head zs
        (_,kv) = unzip zs
    ys = map extract $ groupBy (\x y -> fst x == fst y) $ sort $ map addLen xs

printCase :: (Int, [(String,String)]) -> IO ()
printCase (l,xs) = do
    putStrLn $ "    " ++ show l ++ " -> case lst of"
    mapM_ pr xs'
    putStrLn $ "        _   -> " ++ tokenOther
  where
    xs' = map (first reverse) $ sort $ map (first reverse) xs
    pr (k,t) = do
        putStrLn $ "        " ++ show w ++ " -> if bs == \"" ++ k ++ "\" then " ++ t ++ " else " ++ tokenOther
      where
        w = ord $ last k

staticTableList :: [(String, String)]
staticTableList = [
    (":authority", "")
  , (":method", "GET")
  , (":method", "POST")
  , (":path", "/")
  , (":path", "/index.html")
  , (":scheme", "http")
  , (":scheme", "https")
  , (":status", "200")
  , (":status", "204")
  , (":status", "206")
  , (":status", "304")
  , (":status", "400")
  , (":status", "404")
  , (":status", "500")
  , ("accept-charset", "")
  , ("accept-encoding", "gzip, deflate")
  , ("accept-language", "")
  , ("accept-ranges", "")
  , ("accept", "")
  , ("access-control-allow-origin", "")
  , ("age", "")
  , ("allow", "")
  , ("authorization", "")
  , ("cache-control", "")
  , ("content-disposition", "")
  , ("content-encoding", "")
  , ("content-language", "")
  , ("content-length", "")
  , ("content-location", "")
  , ("content-range", "")
  , ("content-type", "")
  , ("cookie", "")
  , ("date", "")
  , ("etag", "")
  , ("expect", "")
  , ("expires", "")
  , ("from", "")
  , ("host", "")
  , ("if-match", "")
  , ("if-modified-since", "")
  , ("if-none-match", "")
  , ("if-range", "")
  , ("if-unmodified-since", "")
  , ("last-modified", "")
  , ("link", "")
  , ("location", "")
  , ("max-forwards", "")
  , ("proxy-authenticate", "")
  , ("proxy-authorization", "")
  , ("range", "")
  , ("referer", "")
  , ("refresh", "")
  , ("retry-after", "")
  , ("server", "")
  , ("set-cookie", "")
  , ("strict-transport-security", "")
  , ("transfer-encoding", "")
  , ("user-agent", "")
  , ("vary", "")
  , ("via", "")
  , ("www-authenticate", "")
  ]