diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014 matt + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# Mi - Support Library for Multiple Instance + +## Quick Start + +see examples diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mi.cabal b/mi.cabal new file mode 100644 --- /dev/null +++ b/mi.cabal @@ -0,0 +1,21 @@ +name: mi +version: 0.0.1 +synopsis: Multiple Instance for Haskell +description: Library for Multiple Instance +license: MIT +license-file: LICENSE +author: matt, ejima +maintainer: matt76k@gmail.com +homepage: https://github.com/matt76k/mi +copyright: Copyright (c) 2014 matt +category: Language +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + exposed-modules: Language.MI.TH + hs-Source-Dirs: src + other-extensions: TemplateHaskell, QuasiQuotes + build-depends: base >=4.6 && <4.7, template-haskell >=2.8 && <2.9, parsec >=3.1 && <3.2, haskell-src-meta >=0.6 && <0.7, split >=0.2 && <0.3 + default-language: Haskell2010 diff --git a/src/Language/MI/TH.hs b/src/Language/MI/TH.hs new file mode 100644 --- /dev/null +++ b/src/Language/MI/TH.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +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 + --runIO $ print fn + changed <- return $ trans funcdef (fn:funcs) + --runIO $ print changed + funcds <- return $ tof $ toFuncD changed + --runIO $ print funcds + t <- return $ mkExplicitFunc (namechange (mkName fn) funcds) funcs + --runIO $ print t + imp <- return $ toFuncD $ mkimpfunc fn dic funcds + --runIO $ print imp + 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)