{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

-- |
-- Module      : Text.Numerals.Algorithm.Template
-- Description : A module that constructs template Haskell to make defining an ordinize function more convenient.
-- Maintainer  : hapytexeu+gh@gmail.com
-- Stability   : experimental
-- Portability : POSIX
--
-- The module is designed to construct an 'Exp' based on the mapping data provided. It will check if the text object
-- ends with the given suffix, and replace the suffix with another suffix. It aims to compile this into an efficient function.
module Text.Numerals.Algorithm.Template
  ( ordinizeFromDict,
  )
where

import Data.Map.Strict (Map, elems, fromListWith)
#if __GLASGOW_HASKELL__ < 803
import Data.Semigroup((<>))
#endif
import Data.Text (Text, isSuffixOf, pack, snoc)
import Language.Haskell.TH (Body (GuardedB), Clause (Clause), Dec (FunD, SigD), Exp (AppE, ConE, LitE, VarE), Guard (NormalG), Lit (CharL, IntegerL, StringL), Name, Pat (VarP), Type (AppT, ArrowT, ConT), mkName)
import Text.Numerals.Internal (_replaceSuffix)

_getPrefix :: [Char] -> [Char] -> (Int, [Char])
_getPrefix :: String -> String -> (Int, String)
_getPrefix [] String
bs = (Int
0, String
bs)
_getPrefix String
as [] = (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
as, [])
_getPrefix aa :: String
aa@(Char
a : String
as) ba :: String
ba@(Char
b : String
bs)
  | Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b = String -> String -> (Int, String)
_getPrefix String
as String
bs
  | Bool
otherwise = (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
aa, String
ba)

_orCondition :: [Exp] -> Guard
_orCondition :: [Exp] -> Guard
_orCondition [] = Exp -> Guard
NormalG (Name -> Exp
ConE 'False)
_orCondition [Exp]
xs = Exp -> Guard
NormalG ((Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(||))) [Exp]
xs)

_packText :: String -> Exp
_packText :: String -> Exp
_packText = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Exp -> Exp) -> (String -> Exp) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> (String -> Lit) -> String -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Lit
StringL

_packExp :: Int -> String -> Exp -> Exp
_packExp :: Int -> String -> Exp -> Exp
_packExp Int
0 [] Exp
nm = Exp
nm
_packExp Int
0 [Char
s] Exp
nm = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'snoc) Exp
nm) (Lit -> Exp
LitE (Char -> Lit
CharL Char
s))
_packExp Int
0 String
sc Exp
nm = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<>)) Exp
nm) (String -> Exp
_packText String
sc)
_packExp Int
l String
sc Exp
nm = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '_replaceSuffix) (Lit -> Exp
LitE (Integer -> Lit
IntegerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l)))) (String -> Exp
_packText String
sc)) Exp
nm

_ordinizeSingle :: Exp -> String -> String -> ((Int, String), ([Exp], Exp))
_ordinizeSingle :: Exp -> String -> String -> ((Int, String), ([Exp], Exp))
_ordinizeSingle Exp
nm String
sa String
sb = ((Int, String)
p, ([Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'isSuffixOf) (String -> Exp
_packText String
sa)) Exp
nm], Int -> String -> Exp -> Exp
_packExp Int
l String
sc Exp
nm))
  where
    p :: (Int, String)
p@(Int
l, String
sc) = String -> String -> (Int, String)
_getPrefix String
sa String
sb

_ordinizeMap :: Exp -> [(String, String)] -> Map (Int, String) ([Exp], Exp)
_ordinizeMap :: Exp -> [(String, String)] -> Map (Int, String) ([Exp], Exp)
_ordinizeMap Exp
n = (([Exp], Exp) -> ([Exp], Exp) -> ([Exp], Exp))
-> [((Int, String), ([Exp], Exp))]
-> Map (Int, String) ([Exp], Exp)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
fromListWith ([Exp], Exp) -> ([Exp], Exp) -> ([Exp], Exp)
forall {a} {b} {b}. ([a], b) -> ([a], b) -> ([a], b)
f ([((Int, String), ([Exp], Exp))] -> Map (Int, String) ([Exp], Exp))
-> ([(String, String)] -> [((Int, String), ([Exp], Exp))])
-> [(String, String)]
-> Map (Int, String) ([Exp], Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String) -> ((Int, String), ([Exp], Exp)))
-> [(String, String)] -> [((Int, String), ([Exp], Exp))]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> ((Int, String), ([Exp], Exp)))
-> (String, String) -> ((Int, String), ([Exp], Exp))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Exp -> String -> String -> ((Int, String), ([Exp], Exp))
_ordinizeSingle Exp
n))
  where
    f :: ([a], b) -> ([a], b) -> ([a], b)
f ([a]
as, b
a) ([a]
bs, b
_) = ([a]
bs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
as, b
a)

_toGuard :: ([Exp], Exp) -> (Guard, Exp)
_toGuard :: ([Exp], Exp) -> (Guard, Exp)
_toGuard ([Exp]
gs, Exp
es) = ([Exp] -> Guard
_orCondition [Exp]
gs, Exp
es)

-- | Construct a function with the given name that maps suffixes in the first
-- item of the 2-tuples to the second item of the 2-tuples. It turns this into a
-- declaration.
ordinizeFromDict ::
  -- | The name of the function, often this is just @ordinize'@
  String ->
  -- | The list of suffixes and their corresponding mapping, the suffixes should be non-overlapping.
  [(String, String)] ->
  -- | The name of the post-processing function in case there was no match, one can for example use 'id'.
  Name ->
  -- | The corresponding declaration.
  [Dec]
ordinizeFromDict :: String -> [(String, String)] -> Name -> [Dec]
ordinizeFromDict String
nm [(String, String)]
ts Name
pp = [Name -> Type -> Dec
SigD Name
nnm (Type -> Type
tText (Type -> Type
tText Type
ArrowT)), Name -> [Clause] -> Dec
FunD Name
nnm [[Pat] -> Body -> [Dec] -> Clause
Clause [Name -> Pat
VarP Name
t] ([(Guard, Exp)] -> Body
GuardedB ((([Exp], Exp) -> (Guard, Exp)) -> [([Exp], Exp)] -> [(Guard, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map ([Exp], Exp) -> (Guard, Exp)
_toGuard (Map (Int, String) ([Exp], Exp) -> [([Exp], Exp)]
forall k a. Map k a -> [a]
elems (Exp -> [(String, String)] -> Map (Int, String) ([Exp], Exp)
_ordinizeMap Exp
t' [(String, String)]
ts)) [(Guard, Exp)] -> [(Guard, Exp)] -> [(Guard, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Exp -> Guard
NormalG (Name -> Exp
ConE 'True), Exp -> Exp -> Exp
AppE (Name -> Exp
VarE Name
pp) Exp
t')])) []]]
  where
    t :: Name
t = String -> Name
mkName String
"t"
    t' :: Exp
t' = Name -> Exp
VarE Name
t
    nnm :: Name
nnm = String -> Name
mkName String
nm
    tText :: Type -> Type
tText = (Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text)