TH fun

gistfile1.hs

-- I have datatype (Maybe c, ls::[Double]) and want to produce next template haskell code:

ks <- forM [1..lenA] (\_ -> newName "k")
f (t+c*h) (y + d * zipWith ks ls)  -- where ls 

Template.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
module Template
    where

import Data.Maybe


--import Language.Haskell.TH.Syntax
--import Language.Haskell.TH.Quote
import Language.Haskell.TH.Quote
import Language.Haskell.TH


import Text.Parsec
import qualified Text.Parsec.Token as P
import Text.Parsec.Language (haskellDef) 
import Text.Parsec.Expr
import Text.Parsec.String
import qualified GHC.Num

import Control.Monad

import Debug.Trace

lexer       = P.makeTokenParser haskellDef { P.reservedOpNames = ["*","/","+","-","sqrt","sin","cos"] }

whiteSpace= P.whiteSpace lexer
lexeme    = P.lexeme lexer
symbol    = P.symbol lexer
float     = P.float lexer
parens    = P.parens lexer
semi      = P.semi lexer
natural   = P.natural lexer
identifier= P.identifier lexer
reserved  = P.reserved lexer
reservedOp= P.reservedOp lexer

expr    :: Parser Double
expr    = buildExpressionParser table factor
        <?> "expression"
factor  =   parens expr
        <|> try float
        <|> fmap realToFrac natural
        <?> "simple expression"
table   = [ [prefix "-" negate]
          , [prefix "sqrt" sqrt,prefix "sin" sin,prefix "cos" cos]
          , [op "*" (*) AssocLeft, op "/" (/) AssocLeft]
          , [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
          ]          
          where
             op s f assoc = Infix (do{ reservedOp s; return f} <?> "operator") assoc
             prefix s f   = Prefix (do { reservedOp s; return f} <?> "prefix")

run :: Show a => Parser a -> String -> IO ()
run p input = case (parse p "" input) of
                Left err -> do{ putStr "parse error at "
                              ; print err
                              }
                Right x  -> print x


runLex :: Show a => Parser a -> String -> IO ()
runLex p input
        = run (do{ whiteSpace
                 ; x <- p
                 ; eof
                 ; return x
                 }) input

erun :: Parser Double -> String -> Double
erun p input = erun' (do { whiteSpace ; x <- p ; eof; return x})
    where
        erun' p' = case (parse p' "" input) of
                    Left err -> error $ "Parse error at "++(show err)
                    Right x  -> x

data MExp = Delimeter | Row (Maybe Double,[Double]) deriving (Show,Eq)

rowRhs (Row (_,ls)) = ls
rowRhs _ = error "no a row"

fromRow (Row t) = t
fromRow _       = error "not a row"

test = 
    let vs = valuesFromString $ unlines 
                [
                 "1.2 |  "
                ,"1 | 2*(sin 3)/(sqrt 5)   "
                ,"3 | 4                 & 5"
                ,"- + -"
                ,"  | 1"
                ]
    in vs
    where 
        isImplicit vs = 
            let vs' = takeWhile (/=Delimeter) vs
            in  case () of
                    _ | trace (show vs') False -> undefined
                    _ | trace (show $ zip [0..] (map (length . rowRhs) vs')) False -> undefined
                    _ -> any (\(i,v) -> i>=(length v)) $ zip[0..] (map rowRhs vs')

valuesFromString :: String -> [MExp]
valuesFromString = 
    mapMaybe go . lines
    where
        go ('-':s) = Just Delimeter
        go ('#':s) = Nothing
        go (ls) | null.filter (==' ')$ ls = Nothing
                | otherwise = 
            let (lhs,_:rhs) = span (/='|') ls
                l = case filter (/= ' ') lhs of
                        "" -> Nothing
                        ls -> Just $! erun expr ls
            in Just $ Row (l, map (erun expr) $! grp '&' rhs)



grp c s = case dropWhile (==c) s of
    "" -> []
    s' -> if any (/=' ') w then w : grp c c'' else grp c c''
          where (w,c'') = break (==c) s'

-- data MExp = Delimeter | Row (Maybe Double,[Double]) deriving (Show,Eq)

qrk  :: QuasiQuoter
qrk  =  QuasiQuoter {quoteExp = x}
    where
        x s = case () of
                _ | trace (show $ valuesFromString s) False -> undefined
                _ -> rk $ valuesFromString s


jv = Just . VarE
jld = Just . LitE. DoublePrimL . toRational
plus = VarE $! mkName "+"
mult = VarE $! mkName "*"




rk :: [MExp] -> Q Exp
rk mExp = do
    let (ab,_:c:[]) = break (==Delimeter) mExp
        lenA     = length ab
    let f = mkName "f"
        h = mkName "h"
        t = mkName "t"
        y = mkName "y"
    kn <- forM [1..lenA] (\_ -> newName "k")
    let kvv = zip kn ab
    ks' <- forM kvv $ \(k,r) -> do
            t <- rkt1 r kn
            return $ ValD (VarP k) (NormalB t) []
    y' <- rkt2 c kn
    return $ LamE [VarP f, VarP h, TupP [VarP t,VarP y]] $ LetE ks' y'
    where 
        rkt1 (Row (Just c,ls)) ks = do
            let f = mkName "f"
                h = mkName "h"
                t = mkName "t"
                y = mkName "y"
            let ft = InfixE (Just (VarE t)) (VarE (mkName "+")) (Just $ InfixE (Just (LitE $ DoublePrimL $ toRational c)) (VarE (mkName "*")) (Just (VarE h)))
                st = if null ls 
                        then (VarE y)
                        else
                            InfixE (jv y) plus
                                (Just $ InfixE (jv h) (mult)
                                    (Just $ foldl1 (\x y -> InfixE (Just x) plus (Just y)) $
                                                zipWith (\k l -> InfixE (jv k) mult (jld l)) ks ls
                                    )
                                )
            return $ AppE ( AppE (VarE f) ft) st
        rkt2 (Row (_,ls)) ks = do
            let f = mkName "f"
                y = mkName "y"
                h = mkName "h"
            return $ InfixE (jv y) plus
                        (Just $ InfixE (jv h) mult
                            (Just $ foldl1 (\x y -> InfixE (Just x) plus (Just y)) $
                                        zipWith (\k l -> InfixE (jv k) mult (jld l)) ks ls
                            )
                        )

Test.hs

{-# LANGUAGE QuasiQuotes #-}
module Test
    where

import Template

test1 = [qrk|
1 | 1
- + --
  | 1
|]