module Language.MI.TH where
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Language.Haskell.Meta.Parse (parseDecs)
import Data.List.Split hiding (oneOf)
import Data.List
import Data.IORef
import System.IO.Unsafe
dicTable = unsafePerformIO (newIORef [("dicName", ["FuncName"])])
mi = QuasiQuoter
{ quoteExp = undefined
, quotePat = undefined
, quoteType = undefined
, quoteDec = multipleInstance
}
pMultipleInstance :: Parser (String, String, String)
pMultipleInstance = do
spaces >> string "instance"
dic <- (many1 space *> pDicName)
spaces >> string "::"
typeclass <- (spaces *> pTypeClassName)
datatype <- (many1 space *> pDataTypeName)
(many1 space) >> string "where"
funcdef <- (many1 space *> pFuncDef)
return $ (,,) dic typeclass funcdef
pDicName = (:) <$> lower <*> many1 alphaNum
pTypeClassName = (:) <$> upper <*> many1 alphaNum
pDataTypeName = (:) <$> upper <*> many1 alphaNum
pFuncDef = many1 anyToken
pFunc :: Parser String
pFunc = do
spaces >> string "mi" >> spaces >> string "=" >> spaces
dic <- ((:) <$> lower <*> many alphaNum)
funcdef <- many anyToken
return dic
appendUnderbar :: String -> String
appendUnderbar x = x ++ "_"
sub :: String -> Parser String
sub x = do
s <- oneOf ">(,|-` ="
string x
t <- oneOf "),|` "
return $ s : (appendUnderbar(x) ++ [t])
replaceMatchAll s line =
case parse replaceAllParser "" line of
Left _ -> line
Right x -> x
where
replace1Parser =
do
n <- manyTill anyChar (lookAhead $ try s)
m <- s
return (n ++ m)
replaceAllParser =
do
n <- replace1Parser
m <- try replaceAllParser <|> many anyChar
return (n ++ m)
multipleInstance input = do
case parse pFunc "Func Parser" input of
(Right dic) -> miFunc dic input
(Left _) -> case parseDecs input of
(Right x) -> case x of
((ClassD cxt' name tv _ funcSig):rest) -> miClass cxt' name tv funcSig
_ -> error "unexpected"
(Left _) -> case parse pMultipleInstance "Instance Parser" input of
(Right (dic, typeclass, funcdef)) -> miInstance dic typeclass funcdef
(Left _) -> error "unexpected"
miClass c name tv funcSig = do
return $ [DataD c
(mkName $ nameBase $ name)
tv
[RecC (mkName $ nameBase $ name) (funcDefSig funcSig)]
[]]
where
funcDefSig = foldr (\(SigD n t) a -> (n, NotStrict, t) : a) []
miInstance dic typeclass funcdef = do
runIO $ do table <- readIORef dicTable
writeIORef dicTable (table ++ [(dic, getFuncName $ toFuncD input)])
return $ [ValD (VarP $ mkName dic)
(NormalB (RecConE (mkName typeclass) (body src)))
(subfunc src)
]
where
input = splitOn "\n" funcdef
src = mkNewFunc $ toFuncD input
toFuncD = concat . foldr (\str a -> case parseDecs str of
(Left err) -> error err
(Right x) -> x : a) []
mkNewFunc = foldr (\(FunD name def) a -> ((mkName $ nameBase name), def, (mkName $ (nameBase name) ++ "'")) : a) []
getFuncName = foldr (\(FunD name def) a -> (nameBase name): a) []
body = foldr (\(name, def, name') a -> (name, VarE name') : a) []
subfunc = foldr (\(name, def, name') a -> (FunD name' def) : a) []
miFunc dic funcdef = do
funcs <- runIO $ do table <- readIORef dicTable
case lookup dic table of
Nothing -> return []
Just v -> return v
fn <- return $ nameBase $ funcname $ tof $ toFuncD funcdef
changed <- return $ trans funcdef (fn:funcs)
funcds <- return $ tof $ toFuncD changed
t <- return $ mkExplicitFunc (namechange (mkName fn) funcds) funcs
imp <- return $ toFuncD $ mkimpfunc fn dic funcds
return $ (mkExplicitFunc (namechange (mkName fn) funcds) funcs) ++ imp
where
flapflap = (InfixE (Just (VarE 'flip)) (VarE $ mkName ".") (Just (InfixE (Just (VarE 'flip)) (VarE $ mkName ".") Nothing)))
valFunc dic ((FunD name _):fs) = ValD (VarP $ mkName $ nameBase name) (NormalB (AppE (AppE flapflap (VarE $ mkName $ (nameBase name) ++ "'")) (VarE $ mkName dic))) []
mkExplicitFunc ((FunD name c):fs) dic = (FunD (mkName $ (nameBase name) ++ "'") (clausepat dic (nameBase name) c)):fs
toFuncD s = case parseDecs s of
Left err -> error err
Right x -> x
trans = foldr (\d a -> replaceMatchAll (sub d) a)
tof ((ValD p b d):xs) = d
funcname ((FunD name c):xs) = name
clausepat dic fn = foldr (\(Clause p b d) a -> (Clause ([VarP $ mkName "dic"]++p) b (d++(dicapp dic)++(recursivefunc fn))) : a) []
dicapp [] = []
dicapp (x:xs) = (ValD (VarP $ mkName $ x++"_") (NormalB (AppE (VarE $ mkName x) (VarE $ mkName "dic"))) []) : (dicapp xs)
recursivefunc fn = [(ValD (VarP $ mkName $ fn++"_") (NormalB (AppE (VarE $ mkName $ fn++"'") (VarE $ mkName "dic"))) [])]
namechange fn = foldr (\(FunD name c) a -> (FunD fn c) : a) []
ttt ((FunD name ((Clause p b d):cs)):fs) = foldr (\x y -> (x++" ")++y) [] (take (length p) $ splitOn "," $ intersperse ',' ['a'..'z'])
mkimpfunc fn d a = fn++" "++(ttt a)++" = "++fn++"'"++" "++d++" "++(ttt a)