mi (empty) → 0.0.1

raw patch · 5 files changed

+194/−0 lines, 5 filesdep +basedep +haskell-src-metadep +parsecsetup-changed

Dependencies added: base, haskell-src-meta, parsec, split, template-haskell

Files

LICENSE +21/−0
README.md +5/−0
Setup.hs +2/−0
mi.cabal +21/−0
src/Language/MI/TH.hs +145/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,5 @@+# Mi - Support Library for Multiple Instance++## Quick Start++see examples

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ mi.cabal view

@@ -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

+ src/Language/MI/TH.hs view

@@ -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)