{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
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)
ordinizeFromDict ::
String ->
[(String, String)] ->
Name ->
[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)