language-lua-qq (empty) → 0.1.0.0
raw patch · 6 files changed
+277/−0 lines, 6 filesdep +basedep +haskell-src-metadep +language-luasetup-changed
Dependencies added: base, haskell-src-meta, language-lua, language-lua-qq, mtl, syb, template-haskell, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- language-lua-qq.cabal +40/−0
- src/Language/Lua/Lift.hs +105/−0
- src/Language/Lua/QQ.hs +98/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Hiromi ISHII (c) 2015++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Hiromi ISHII nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ language-lua-qq.cabal view
@@ -0,0 +1,40 @@+name: language-lua-qq+version: 0.1.0.0+synopsis: Initial project template from stack+description: Please see README.md+homepage: http://github.com/konn/language-lua-qq#readme+license: BSD3+license-file: LICENSE+author: Hiromi ISHII+maintainer: konn.jinro _at_ gmail.com+copyright: 2015 (c) Hiromi ISHII+category: Language+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Language.Lua.QQ+ Language.Lua.Lift+ build-depends: base >= 4.7 && < 5+ , haskell-src-meta+ , language-lua+ , mtl+ , syb >= 0.5.1+ , template-haskell+ , text+ default-language: Haskell2010++test-suite language-lua-qq-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , language-lua-qq+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/konn/language-lua-qq
+ src/Language/Lua/Lift.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DefaultSignatures, DeriveGeneric, FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances, TypeOperators, TypeSynonymInstances #-}+module Language.Lua.Lift (LiftExp(..)) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import GHC.Generics+import Language.Lua++class LiftExp a where+ liftExp :: a -> Exp++ default liftExp :: (GLiftExp (Rep a), Generic a) => a -> Exp+ liftExp a = gLiftExp (from a)++instance LiftExp Exp where+ liftExp = id++instance LiftExp Bool where+ liftExp = Bool++instance LiftExp Int where+ liftExp = Number . show++instance LiftExp Double where+ liftExp = Number . show++instance LiftExp Integer where+ liftExp = Number . show++instance {-# OVERLAPPING #-} LiftExp [Char] where+ liftExp = String++instance {-# OVERLAPPABLE #-} LiftExp a => LiftExp [a] where+ liftExp = TableConst . map (Field . liftExp)++instance LiftExp PrefixExp where+ liftExp = PrefixExp++instance LiftExp LT.Text where+ liftExp = String . LT.unpack++instance LiftExp T.Text where+ liftExp = String . T.unpack++instance (LiftExp a, LiftExp b) => LiftExp (a, b) where+ liftExp (a, b) = TableConst $ map Field [liftExp a, liftExp b]++instance (LiftExp a, LiftExp b, LiftExp c) => LiftExp (a, b, c) where+ liftExp (a, b, c) = TableConst $ map Field [liftExp a, liftExp b, liftExp c]++instance (LiftExp a, LiftExp b, LiftExp c, LiftExp d)+ => LiftExp (a, b, c, d) where+ liftExp (a, b, c, d) =+ TableConst $ map Field [liftExp a, liftExp b, liftExp c, liftExp d]++instance (LiftExp a, LiftExp b, LiftExp c, LiftExp d, LiftExp e)+ => LiftExp (a, b, c, d, e) where+ liftExp (a, b, c, d, e) =+ TableConst $ map Field [liftExp a, liftExp b, liftExp c, liftExp d, liftExp e]++class GLiftExp a where+ gLiftExp :: a x -> Exp++instance LiftExp a => GLiftExp (K1 r a) where+ gLiftExp (K1 a) = liftExp a++instance (GLiftExp l, GLiftExp r) => GLiftExp (l :+: r) where+ gLiftExp (L1 l) = gLiftExp l+ gLiftExp (R1 r) = gLiftExp r++instance (Selector s, GLiftExp l) => GDecodeProduct (M1 S s l) where+ gDecodeProduct s@(M1 l) =+ case selName s of+ "" -> [Field $ gLiftExp l]+ sn -> [NamedField sn $ gLiftExp l]++instance (Constructor c, GDecodeProduct f) => GLiftExp (M1 C c f) where+ gLiftExp m@(M1 f) =+ let xs = gDecodeProduct f+ cn = conName m+ in if null xs+ then TableConst [ NamedField "con" (String cn)]+ else TableConst [ NamedField "con" (String cn)+ , NamedField "args" $ TableConst xs]+class GDecodeProduct k where+ gDecodeProduct :: k x -> [TableField]++instance (Datatype c, GLiftExp f) => GLiftExp (M1 D c f) where+ gLiftExp m@(M1 a) =+ case gLiftExp a of+ TableConst xs ->+ TableConst $ NamedField "typ" (String $ datatypeName m) : xs+ _ -> error "GLiftExp cannoooot!!!"++instance LiftExp c => GDecodeProduct (K1 i c) where+ gDecodeProduct (K1 a) = [Field $ liftExp a]++instance GDecodeProduct U1 where+ gDecodeProduct U1 = []++instance (GDecodeProduct a, GDecodeProduct b) => GDecodeProduct (a :*: b) where+ gDecodeProduct (a :*: b) = gDecodeProduct a ++ gDecodeProduct b++instance LiftExp a => LiftExp (Maybe a)
+ src/Language/Lua/QQ.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ExplicitNamespaces, OverloadedStrings, PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wall #-}+module Language.Lua.QQ (mkExpQQ, lua, mkStatQQ, lstat, mkBlockQQ, lblk) where+import Language.Lua.Lift++import Data.Data (Data)+import Data.Generics (mkQ)+import Data.List (intercalate)+import Language.Haskell.Meta (parseExp)+import Language.Haskell.Meta (parsePat)+import Language.Haskell.TH (ExpQ)+import Language.Haskell.TH (PatQ)+import Language.Haskell.TH (location)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Quote (dataToExpQ)+import Language.Haskell.TH.Quote (dataToPatQ)+import Language.Haskell.TH.Syntax (Loc (..))+import Language.Lua+import qualified Language.Lua as L+import qualified Text.Parsec.LTok as L++mkExpQQ :: String -> QuasiQuoter+mkExpQQ hs = QuasiQuoter { quoteExp = qExp hs L.exp+ , quotePat = qPat hs L.exp+ , quoteType = error "No type quote for lua!"+ , quoteDec = error "No dec quote for lua!"+ }++lua :: QuasiQuoter+lua = mkExpQQ "hs"++mkStatQQ :: String -> QuasiQuoter+mkStatQQ hs = QuasiQuoter { quoteExp = qExp hs L.stat+ , quotePat = qPat hs L.stat+ , quoteType = error "No type quote for lua!"+ , quoteDec = error "No dec quote for lua!"+ }++lstat :: QuasiQuoter+lstat = mkStatQQ "hs"++mkBlockQQ :: String -> QuasiQuoter+mkBlockQQ hs = QuasiQuoter { quoteExp = qExp hs L.chunk+ , quotePat = qPat hs L.chunk+ , quoteType = error "No type quote for lua!"+ , quoteDec = error "No dec quote for lua!"+ }++lblk :: QuasiQuoter+lblk = mkBlockQQ "hs"++qExp :: Data a => String -> L.Parser a -> String -> ExpQ+qExp hs p src = do+ Loc f _ _ (l,c) _ <- location+ case parseNamedText p (intercalate ":" [f, show l, show c]) src of+ Right x -> antiExp hs x+ Left er -> fail $ show er++antiExp :: Data a => String -> a -> ExpQ+antiExp hs = dataToExpQ (mkQ Nothing trans)+ where+ trans (PrefixExp (PEFunCall (NormalFunCall (PEVar (VarName n)) (Args [String src0]))))+ | n == hs =+ let src = show $ L.pprint src0+ in case parseExp src of+ Left err -> Just $ fail err+ Right e -> Just $ return e+ trans (PrefixExp (PEFunCall (MethodCall (PEVar (VarName n)) typ (Args [String src0]))))+ | n == hs =+ let src = show $ L.pprint src0+ in case parseExp src of+ Left err -> Just $ fail err+ Right e ->+ case typ of+ "raw" -> Just $ return e+ "lift" -> Just $ [| liftExp $(return e) |]+ "enum" -> Just $ [| liftExp (fromEnum $(return e)) |]+ _ -> Just $ fail $ "Antiquoter not supported in expression context: " ++ typ+ trans _ = Nothing++qPat :: Data a => String -> L.Parser a -> String -> PatQ+qPat hs p src = case parseText p src of+ Right x -> antiPat hs x+ Left er -> fail $ show er++antiPat :: Data a => String -> a -> PatQ+antiPat hs = dataToPatQ (mkQ Nothing trans)+ where+ trans (PEFunCall (MethodCall (PEVar (VarName n)) typ (Args [String src])))+ | n == hs =+ case parsePat src of+ Left err -> Just $ fail err+ Right e ->+ case typ of+ "p" -> Just $ return e+ _ -> Just $ fail $ "Antiquoter not supported in pattern context: " ++ typ+ trans _ = Nothing
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"