Template Haskore

{-# LANGUAGE TemplateHaskell #-}
module Morpho where

import Data.Char
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad
import qualified Data.Map as M

decapitalize [] = []
decapitalize (x:xs) = (toLower x):xs

capitalize [] = []
capitalize (x:xs) = (toUpper x):xs

type GCat = (String, [String])

toDerive = [''Eq, ''Ord, ''Show, ''Read]

makeCategories :: [GCat] -> [Dec]
makeCategories categories =
    [DataD [] (mkName name) [] (undefValue:[NormalC (mkName value) [] | value <- values]) toDerive
        | (name, values) <- categories,
        let undefValue = NormalC (mkName $ "Undef" ++ name) []]

makeStruct :: Name -> [Name] -> Dec
makeStruct name categories = DataD [] name [] [makeCon categories] []
    where makeCon = RecC name . map
              (\fname -> (mkName (decapitalize $ show fname), NotStrict, ConT fname))

showField :: Exp -> Exp -> Q Exp
showField fname empty = [|\struct -> let value = $(return fname) struct in if value == $(return empty) then "" else show value|]

genPE :: Int -> Q ([Pat], [Exp])
genPE n = do
    ids <- replicateM n (newName "x")
    return (map VarP ids, map VarE ids)

showClause :: Name -> [String] -> Q Clause
showClause sname categories = do
    (pats, vars) <- genPE (length categories)
    -- Рекурсивно строим выражение (" "++show x1++...++"") из списка переменных [x1, ...]
    let varsWithUndef = zip vars (map (\c -> ConE . mkName $ ("Undef" ++ c)) categories)
    let f []       = [| "" |]
        f ((v, undef):[]) = [|(if $(return v) == $(return undef) then "" else (show $(return v)))|]
        f ((v, undef):vars) = [|(if $(return v) == $(return undef) then "" else (show $(return v)) ++ " ") ++ $(f vars)|]
    -- Собираем один клоз функции
    body <- f varsWithUndef
    return $ Clause [ConP sname pats]       -- (A x1 x2)
           (NormalB body) []  -- "A"++" "++show x1++" "++show x2

deriveShow :: Name -> [String] -> Q [Dec]
deriveShow sname categories = do
    showbody <- showClause sname categories
    return [InstanceD [] (AppT (ConT ''Show) (ConT sname)) [FunD 'show [showbody]]]

makeEmptyStruct name fields =
    foldl (\exp field -> AppE exp (ConE . mkName . ("Undef" ++) . show $ field)) (ConE name) fields

concatExps :: [Q Exp] -> Q Exp
concatExps [] = [|[]|]
concatExps (x:xs) = [|$x ++ $(concatExps xs)|]

makeSetter :: Name -> Name -> String -> Exp
makeSetter var field value = TupE [LitE (StringL value), LamE ([VarP var]) (RecUpdE (VarE var) [(field, ConE (mkName value))])]

makeLoaders :: [GCat] -> Q Exp
makeLoaders categories = do
    var <- newName "gv"
    return (ListE $ concat [[makeSetter var field value | value <- values] | (name, values) <- categories, let field = mkName (decapitalize name)])

defGrammarValue :: String -> [GCat] -> Q [Dec]
defGrammarValue structName fields = do
    let categories = makeCategories fields
    let catNames = map (\(DataD _ fname _ _ _) -> fname) categories
    let sname = mkName structName
    let struct = makeStruct sname catNames
    let emptyGV = FunD (mkName "emptyGV") [Clause [] (NormalB $ makeEmptyStruct sname catNames) []]
    shower <- deriveShow sname (fst . unzip $ fields)
    loader <- [d|gvLoader = M.fromList $ $(makeLoaders fields)|]
    return $ categories ++ [struct, emptyGV] ++ shower ++ loader