formatf.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Kind
import Data.Proxy
import GHC.TypeLits

data FormatItem = FInt | FString | FChar Char

type Format = [FormatItem]

type ParseFormat :: Symbol -> Format
type ParseFormat s = ParseHole (UnconsSymbol s)

type ParseHole :: Maybe (Char, Symbol) -> Format
type family ParseHole ms where
  ParseHole Nothing = '[]
  ParseHole (Just '( '%', s)) = ParseHoleType (UnconsSymbol s)
  ParseHole (Just '( c, s)) = FChar c : ParseFormat s

type ParseHoleType :: Maybe (Char, Symbol) -> Format
type family ParseHoleType ms where
  ParseHoleType Nothing = '[FChar '%']
  ParseHoleType (Just '( 's', s)) = FString : ParseFormat s
  ParseHoleType (Just '( 'd', s)) = FInt : ParseFormat s
  ParseHoleType (Just '(c, s)) = FChar '%' : FChar c : ParseFormat s

class FormatF (f :: Format) where
  type FormatToType f
  toFunction :: String -> FormatToType f

instance FormatF f => FormatF (FInt : f) where
  type FormatToType (FInt : f) = Int -> FormatToType f
  toFunction str = \i -> toFunction @f (str ++ show i)

instance FormatF f => FormatF (FString : f) where
  type FormatToType (FString : f) = String -> FormatToType f
  toFunction str = \s -> toFunction @f (str ++ s)

instance (KnownChar c, FormatF f) => FormatF (FChar c : f) where
  type FormatToType (FChar c : f) = FormatToType f
  toFunction str = toFunction @f (str ++ [charVal (Proxy @c)])

instance FormatF '[] where
  type FormatToType '[] = String
  toFunction str = str

formatf :: forall s f. f ~ ParseFormat s => FormatF f => FormatToType f
formatf = toFunction @f ""

main = do
  putStrLn (formatf @"hello %s with id=%d" "kana" 10)