coco-0.0.0.0: Coco/TH.hs

module Coco.TH where
import qualified Language.Haskell.TH as TH
import Data.Void (Void, absurd)
import Control.Applicative (empty)
import Control.Monad (join)
import Data.Foldable1 (Foldable1, foldl1')
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import qualified Data.Text.Lazy as T
import qualified Data.Text as TS
import Data.UUID (UUID)

instanceD :: (Functor t, Foldable1 t) => [TH.Dec] -> t TH.Name -> TH.Dec
instanceD = flip
	$ TH.InstanceD empty empty
	. foldl1' TH.AppT
	. fmap TH.ConT

funD :: TH.Name -> TH.Exp -> [TH.Dec]
funD name
	= pure
	. TH.FunD name
	. pure
	. flip (TH.Clause empty) empty
	. TH.NormalB

instance2 :: Applicative q => TH.Name -> TH.Name -> [TH.Name] -> q [TH.Dec]
instance2 a b
	= pure
	. fmap (instanceD empty)
	. (fmap (:|) [a, b] <*>)
	. fmap (join (<>) . pure)

instanceMaybeToVoid :: Applicative q => TH.Name -> TH.Name -> [TH.Name] -> q [TH.Dec]
instanceMaybeToVoid cls fn = pure . fmap
	( instanceD
		( funD fn
		$ TH.AppE (TH.VarE 'pure)
		$ TH.VarE 'empty
		)
	. (cls :|)
	. (''Void :)
	. pure
	)

instanceFromVoid :: Applicative q => TH.Name -> TH.Name -> TH.Name -> [TH.Name] -> q [TH.Dec]
instanceFromVoid clsMaybeTo clsTo fnTo
	= pure
	. (<*>)
		[ instanceD
			( funD fnTo
			$ TH.VarE 'absurd
			)
		. (clsTo :|)
		, instanceD empty
		. (clsMaybeTo :|)
		]
	. fmap (: [''Void])

nonVoid :: [TH.Name]
nonVoid = [''B.ByteString, ''BS.ByteString, ''T.Text, ''TS.Text, ''String, ''UUID]