{-# LANGUAGE CPP             #-}
{-# LANGUAGE TemplateHaskell #-}
module Bio.Chain.Alignment.Scoring.TH where

import Data.Char                 (toLower, toUpper)
import Language.Haskell.TH
import Language.Haskell.TH.Quote

import Bio.Chain.Alignment.Scoring.Loader

type Substitution a = a -> a -> Int

matrix :: QuasiQuoter
matrix :: QuasiQuoter
matrix = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quotePat :: String -> Q Pat
quotePat = String -> Q Pat
forall a. HasCallStack => a
undefined
                     , quoteType :: String -> Q Type
quoteType = String -> Q Type
forall a. HasCallStack => a
undefined
                     , quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
forall a. HasCallStack => a
undefined
                     , quoteDec :: String -> Q [Dec]
quoteDec = String -> Q [Dec]
matrixDec
                     }


matrixDec :: String -> Q [Dec]
matrixDec :: String -> Q [Dec]
matrixDec String
s = do let slines :: [String]
slines = String -> [String]
lines String
s
                 let txt :: String
txt = ([String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
tail) [String]
slines
                 let name :: String
name = [String] -> String
forall a. [a] -> a
head [String]
slines
                 (Name
typeName, Dec
dataDecl) <- String -> Q (Name, Dec)
typeDec String
name
                 (Name
funcName, [Dec]
funDecls) <- String -> String -> Q (Name, [Dec])
functionDec String
name String
txt
                 Dec
smDecl <- Name -> Name -> Q Dec
instDec Name
typeName Name
funcName
                 [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ Dec
dataDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: Dec
smDecl Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
: [Dec]
funDecls

instDec :: Name -> Name -> Q Dec
instDec :: Name -> Name -> Q Dec
instDec Name
typeN Name
funN = Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ [Dec] -> Dec
decl [Dec
body]
  where decl :: [Dec] -> Dec
decl = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] (Type -> Type -> Type
AppT (Name -> Type
ConT ''ScoringMatrix) (Name -> Type
ConT Name
typeN))
        body :: Dec
body = Name -> [Clause] -> Dec
FunD 'scoring [[Pat] -> Body -> [Dec] -> Clause
Clause [Pat
WildP] (Exp -> Body
NormalB (Name -> Exp
VarE Name
funN)) []]

typeDec :: String -> Q (Name, Dec)
typeDec :: String -> Q (Name, Dec)
typeDec String
name = do Name
typeN <- String -> Q Name
newName String
name
                  let dataN :: Name
dataN = String -> Name
mkName (Name -> String
nameBase Name
typeN)
#if !MIN_VERSION_template_haskell(2,12,0)
                  let dervs = [ConT ''Show, ConT ''Eq]
#else
                  let dervs :: [DerivClause]
dervs = [Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Type
ConT ''Show, Name -> Type
ConT ''Eq]]
#endif
                  (Name, Dec) -> Q (Name, Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
typeN, Cxt
-> Name
-> [TyVarBndr]
-> Maybe Type
-> [Con]
-> [DerivClause]
-> Dec
DataD [] Name
typeN [] Maybe Type
forall a. Maybe a
Nothing [Name -> [BangType] -> Con
NormalC Name
dataN []] [DerivClause]
dervs)

functionDec :: String -> String -> Q (Name, [Dec])
functionDec :: String -> String -> Q (Name, [Dec])
functionDec String
name String
txt = do let subM :: [((Char, Char), Int)]
subM = String -> [((Char, Char), Int)]
loadMatrix String
txt
                          Name
funName <- String -> Q Name
newName (Char -> Char
toLower (Char -> Char) -> String -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
name)
                          let funSign :: Dec
funSign = Name -> Type -> Dec
SigD Name
funName (Type -> Type -> Type
AppT (Name -> Type
ConT ''Substitution) (Name -> Type
ConT ''Char))
                          let clauses :: [Clause]
clauses = (((Char, Char), Int) -> [Clause])
-> [((Char, Char), Int)] -> [Clause]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char, Char), Int) -> [Clause]
mkClause [((Char, Char), Int)]
subM
                          let funDecl :: Dec
funDecl = Name -> [Clause] -> Dec
FunD Name
funName [Clause]
clauses
                          (Name, [Dec]) -> Q (Name, [Dec])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
funName, [Dec
funSign, Dec
funDecl])

mkClause :: ((Char, Char), Int) -> [Clause]
mkClause :: ((Char, Char), Int) -> [Clause]
mkClause ((Char
c, Char
d), Int
i) = ([Pat] -> Clause) -> [[Pat]] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Pat]
pair -> [Pat] -> Body -> [Dec] -> Clause
Clause [Pat]
pair (Exp -> Body
NormalB (Int -> Exp
litI Int
i)) []) [[Pat]]
casePairs
  where 
    litC :: Char -> Pat
litC = Lit -> Pat
LitP (Lit -> Pat) -> (Char -> Lit) -> Char -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Lit
CharL
    litI :: Int -> Exp
litI = Lit -> Exp
LitE (Lit -> Exp) -> (Int -> Lit) -> Int -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Lit
IntegerL (Integer -> Lit) -> (Int -> Integer) -> Int -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

    casingFunctions :: [Char -> Pat]
    casingFunctions :: [Char -> Pat]
casingFunctions = [Char -> Pat
litC (Char -> Pat) -> (Char -> Char) -> Char -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toUpper, Char -> Pat
litC (Char -> Pat) -> (Char -> Char) -> Char -> Pat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
toLower]

    casePairs :: [[Pat]]
    casePairs :: [[Pat]]
casePairs = [ [Char -> Pat
f Char
c, Char -> Pat
g Char
d] | Char -> Pat
f <- [Char -> Pat]
casingFunctions, Char -> Pat
g <- [Char -> Pat]
casingFunctions ]