{-# 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 { quotePat :: String -> Q Pat quotePat = forall a. HasCallStack => a undefined , quoteType :: String -> Q Type quoteType = forall a. HasCallStack => a undefined , quoteExp :: String -> Q Exp quoteExp = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> [a] tail) [String] slines let name :: String name = 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 forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ Dec dataDecl forall a. a -> [a] -> [a] : Dec smDecl forall a. a -> [a] -> [a] : [Dec] funDecls instDec :: Name -> Name -> Q Dec instDec :: Name -> Name -> Q Dec instDec Name typeN Name funN = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ [Dec] -> Dec decl [Dec body] where decl :: [Dec] -> Dec decl = Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec InstanceD 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 <- forall (m :: * -> *). Quote m => String -> m 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 forall a. Maybe a Nothing [Name -> Type ConT ''Show, Name -> Type ConT ''Eq]] #endif forall (m :: * -> *) a. Monad m => a -> m a return (Name typeN, Cxt -> Name -> [TyVarBndr ()] -> Maybe Type -> [Con] -> [DerivClause] -> Dec DataD [] Name typeN [] 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 <- forall (m :: * -> *). Quote m => String -> m Name newName (Char -> Char toLower 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 = 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 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) = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Lit CharL litI :: Int -> Exp litI = Lit -> Exp LitE forall b c a. (b -> c) -> (a -> b) -> a -> c . Integer -> Lit IntegerL forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (Integral a, Num b) => a -> b fromIntegral casingFunctions :: [Char -> Pat] casingFunctions :: [Char -> Pat] casingFunctions = [Char -> Pat litC forall b c a. (b -> c) -> (a -> b) -> a -> c . Char -> Char toUpper, Char -> Pat litC 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 ]