{-# LANGUAGE TemplateHaskellQuotes #-}
module Text.Numerals.Algorithm.Template (
ordinizeFromDict
) where
import Data.Map.Strict(Map, elems, fromListWith)
import Data.Text(Text, isSuffixOf, pack, snoc)
import Text.Numerals.Internal(_replaceSuffix)
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(ConT, AppT, ArrowT), mkName)
_getPrefix :: [Char] -> [Char] -> (Int, [Char])
_getPrefix :: [Char] -> [Char] -> (Int, [Char])
_getPrefix [] [Char]
bs = (Int
0, [Char]
bs)
_getPrefix [Char]
as [] = ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
as, [])
_getPrefix aa :: [Char]
aa@(Char
a:[Char]
as) ba :: [Char]
ba@(Char
b:[Char]
bs)
| Char
a Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
b = [Char] -> [Char] -> (Int, [Char])
_getPrefix [Char]
as [Char]
bs
| Bool
otherwise = ([Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
aa, [Char]
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 (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 :: [Char] -> Exp
_packText = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pack) (Exp -> Exp) -> ([Char] -> Exp) -> [Char] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lit -> Exp
LitE (Lit -> Exp) -> ([Char] -> Lit) -> [Char] -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit
StringL
_packExp :: Int -> String -> Exp -> Exp
_packExp :: Int -> [Char] -> 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 [Char]
sc Exp
nm = Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE '(<>)) Exp
nm) ([Char] -> Exp
_packText [Char]
sc)
_packExp Int
l [Char]
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)))) ([Char] -> Exp
_packText [Char]
sc)) Exp
nm
_ordinizeSingle :: Exp -> String -> String -> ((Int, String), ([Exp], Exp))
_ordinizeSingle :: Exp -> [Char] -> [Char] -> ((Int, [Char]), ([Exp], Exp))
_ordinizeSingle Exp
nm [Char]
sa [Char]
sb = ((Int, [Char])
p, ([Exp -> Exp -> Exp
AppE (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'isSuffixOf) ([Char] -> Exp
_packText [Char]
sa)) Exp
nm], Int -> [Char] -> Exp -> Exp
_packExp Int
l [Char]
sc Exp
nm))
where p :: (Int, [Char])
p@(Int
l, [Char]
sc) = [Char] -> [Char] -> (Int, [Char])
_getPrefix [Char]
sa [Char]
sb
_ordinizeMap :: Exp -> [(String, String)] -> Map (Int, String) ([Exp], Exp)
_ordinizeMap :: Exp -> [([Char], [Char])] -> Map (Int, [Char]) ([Exp], Exp)
_ordinizeMap Exp
n = (([Exp], Exp) -> ([Exp], Exp) -> ([Exp], Exp))
-> [((Int, [Char]), ([Exp], Exp))]
-> Map (Int, [Char]) ([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, [Char]), ([Exp], Exp))] -> Map (Int, [Char]) ([Exp], Exp))
-> ([([Char], [Char])] -> [((Int, [Char]), ([Exp], Exp))])
-> [([Char], [Char])]
-> Map (Int, [Char]) ([Exp], Exp)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> ((Int, [Char]), ([Exp], Exp)))
-> [([Char], [Char])] -> [((Int, [Char]), ([Exp], Exp))]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> [Char] -> ((Int, [Char]), ([Exp], Exp)))
-> ([Char], [Char]) -> ((Int, [Char]), ([Exp], Exp))
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Exp -> [Char] -> [Char] -> ((Int, [Char]), ([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 :: [Char] -> [([Char], [Char])] -> Name -> [Dec]
ordinizeFromDict [Char]
nm [([Char], [Char])]
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, [Char]) ([Exp], Exp) -> [([Exp], Exp)]
forall k a. Map k a -> [a]
elems (Exp -> [([Char], [Char])] -> Map (Int, [Char]) ([Exp], Exp)
_ordinizeMap Exp
t' [([Char], [Char])]
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 = [Char] -> Name
mkName [Char]
"t"
t' :: Exp
t' = Name -> Exp
VarE Name
t
nnm :: Name
nnm = [Char] -> Name
mkName [Char]
nm
tText :: Type -> Type
tText = (Type -> Type -> Type
`AppT` Name -> Type
ConT ''Text)