Splice generator for your record types.

Text.Templating.Heist.Generic.Core.hs

{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE MultiParamTypeClasses  #-}

{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE EmptyDataDecls         #-}

module Text.Templating.Heist.Generic.Core
( ToSplice(..)
, Generic

, genericToSplice
) where

import           GHC.Generics

import           Control.Monad

import qualified Data.Text as T (pack)
import           Data.Text (Text)

import qualified Text.Templating.Heist as H (textSplice, runChildrenWith)
import           Text.Templating.Heist (Splice)

data Options = Options { renamer :: (String -> Maybe String) }

class ToSplice a where
    toSplice :: (Monad m) => a -> Splice m

    default toSplice :: (Monad m, Generic a, GIsRecord (Rep a) True, GToSpliceTree (Rep a)) => a -> Splice m
    toSplice val = genericToSplice val

------------------------------------------------------------------------------

genericToSplice :: (Monad m, Generic a, GIsRecord (Rep a) True, GToSpliceTree (Rep a))
              => a
              -> Splice m
genericToSplice val = spliceTreeToSplice $ gtoSpliceTree (Options Just) (from val)

------------------------------------------------------------------------------

data SpliceTree m = Leaf (Splice m) | Branch [(Text, SpliceTree m)]

joinSpliceTrees :: SpliceTree m -> SpliceTree m -> SpliceTree m
joinSpliceTrees (Branch xs) (Branch ys) = Branch (xs ++ ys)
joinSpliceTrees _ _= error "Could not join splice trees" -- It will never come to this.
-- joinSpliceTrees is called from (a :*: b) instance that calls the selector instance which returns Branch.
-- Still, it would be nice to have it verified by the type system somehow.

spliceTreeToSplice :: (Monad m) => SpliceTree m -> Splice m
spliceTreeToSplice (Leaf s) = s
spliceTreeToSplice (Branch xs) = H.runChildrenWith $ map (\(l, stree) -> (l, spliceTreeToSplice stree)) xs

class GToSpliceTree f where
    gtoSpliceTree :: (Monad m) => Options -> f a -> SpliceTree m

-- | Product of types
instance (GToSpliceTree a, GToSpliceTree b) => GToSpliceTree (a :*: b) where
    gtoSpliceTree o (x :*: y) = joinSpliceTrees (gtoSpliceTree o x) (gtoSpliceTree o y)

-- | Sum of types
instance (GToSpliceTree a, GToSpliceTree b) => GToSpliceTree (a :+: b) where
    gtoSpliceTree o (L1 x) = gtoSpliceTree o x
    gtoSpliceTree o (R1 x) = gtoSpliceTree o x

-- | Datatype information tag
instance (GToSpliceTree a) => GToSpliceTree (M1 D c a) where
    gtoSpliceTree o (M1 x) = gtoSpliceTree o x

-- | Constructor tag
instance (GToSpliceTree a, Constructor c) => GToSpliceTree (M1 C c a) where
    gtoSpliceTree o (M1 x) = gtoSpliceTree o x

-- | Selector tag
instance (GToSpliceTree a, Selector s) => GToSpliceTree (M1 S s a) where
    gtoSpliceTree o s@(M1 x) = maybe (Branch []) (\name -> Branch [(name, gtoSpliceTree o x)]) sname
        where sname = maybe Nothing (Just . T.pack) $ (renamer o) $ selName s

-- | K1s
instance (ToSplice a) => GToSpliceTree (K1 i a) where
    gtoSpliceTree _ (K1 x) = Leaf $ toSplice x

------------------------------------------------------------------------------

data True
data False

class GIsRecord (f :: * -> *) b | f -> b
instance (GIsRecord f b) => GIsRecord (M1 D c f) b
instance (GIsRecord f b) => GIsRecord (M1 C c f) b
instance (GIsRecord f b) => GIsRecord (f :*: g) b
instance GIsRecord (M1 S NoSelector f) False
instance (GIsRecord f b) => GIsRecord (M1 S c f) b
instance GIsRecord (K1 i c) True

Text.Templating.Heist.Generic.Instances.hs

{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE OverlappingInstances   #-}

module Text.Templating.Heist.Generic.Instances
(
) where

import qualified Data.Text as T (pack)
import           Data.Text (Text)

import qualified Text.Templating.Heist as H (textSplice, runChildrenWith, mapSplices)

import           Text.Templating.Heist.Generic.Core (ToSplice(..))
import           Text.Templating.Heist (Splice)

import           Data.Word (Word, Word8, Word16, Word32, Word64)
import           Data.Int (Int, Int8, Int16, Int32, Int64)

------------------------------------------------------------------------------

------------------------------------------------------------------------------

showableToSplice :: (Monad m, Show a) => a -> Splice m
showableToSplice = H.textSplice . T.pack . show
{-# INLINE showableToSplice #-}


instance ToSplice Char where
    toSplice = H.textSplice . T.pack . (\x -> [x])

instance ToSplice Double where
    toSplice = showableToSplice

instance ToSplice Float where
    toSplice = showableToSplice

instance ToSplice Integer where
    toSplice = showableToSplice

instance ToSplice Int where
    toSplice = showableToSplice

instance ToSplice Int8 where
    toSplice = showableToSplice

instance ToSplice Int16 where
    toSplice = showableToSplice

instance ToSplice Int32 where
    toSplice = showableToSplice

instance ToSplice Int64 where
    toSplice = showableToSplice

instance ToSplice Word where
    toSplice = showableToSplice

instance ToSplice Word8 where
    toSplice = showableToSplice

instance ToSplice Word16 where
    toSplice = showableToSplice

instance ToSplice Word32 where
    toSplice = showableToSplice

instance ToSplice Word64 where
    toSplice = showableToSplice

------------------------------------------------------------------------------

listToSplice :: (Monad m, ToSplice a) => [a] -> Splice m
listToSplice = H.mapSplices (\x -> H.runChildrenWith [(T.pack "value", toSplice x)])
{-# INLINE listToSplice #-}

instance ToSplice [Double] where
    toSplice = listToSplice

instance ToSplice [Float] where
    toSplice = listToSplice

instance ToSplice [Int] where
    toSplice = listToSplice

instance ToSplice [Int8] where
    toSplice = listToSplice

instance ToSplice [Int16] where
    toSplice = listToSplice

instance ToSplice [Int32] where
    toSplice = listToSplice

instance ToSplice [Int64] where
    toSplice = listToSplice

instance ToSplice [Word] where
    toSplice = listToSplice

instance ToSplice [Word8] where
    toSplice = listToSplice

instance ToSplice [Word16] where
    toSplice = listToSplice

instance ToSplice [Word32] where
    toSplice = listToSplice

instance ToSplice [Word64] where
    toSplice = listToSplice

------------------------------------------------------------------------------

instance ToSplice [Char] where
    toSplice = H.textSplice . T.pack

instance ToSplice Text where
    toSplice = H.textSplice

------------------------------------------------------------------------------

instance (ToSplice a) => ToSplice [a] where
    toSplice =  H.mapSplices toSplice