egison-quote (empty) → 0.1.0
raw patch · 4 files changed
+319/−0 lines, 4 filesdep +basedep +egisondep +mtlsetup-changed
Dependencies added: base, egison, mtl, parsec, template-haskell
Files
- LICENSE +7/−0
- Language/Egison/Quote.hs +244/−0
- Setup.hs +2/−0
- egison-quote.cabal +66/−0
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2012, Takuya Kuwahara++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.
+ Language/Egison/Quote.hs view
@@ -0,0 +1,244 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.Egison.Quote+-- Copyright : (c) Takuya Kuwahara 2012+-- License : MIT+-- +-- Maintainer : kuwahara111011@gmail.com+-- Stability : unstable+-- Portability : non-portable (GHC-7.4.0 for GHC's extensions)+-- +-- The quasi quotes for egison expression+-- +----------------------------------------------------------------------------- ++{-# Language TemplateHaskell, QuasiQuotes, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, OverlappingInstances, IncoherentInstances #-}++module Language.Egison.Quote(egison,+ TypeSignature,+ parseQuote,+ parseType,+ readQuote,+ toHaskellExp) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote++import Text.Parsec+import Text.Parsec.String (Parser)++import Language.Egison.Core+import Language.Egison.Types hiding (Type, Parser)+import Language.Egison.Parser+import Language.Egison.Variables++import Data.Either+import Data.Ratio+import Control.Monad.Error hiding (lift)+import Control.Monad.Trans hiding (lift)+import Control.Arrow+import Control.Applicative hiding ((<|>), many)++import System.IO.Unsafe (unsafePerformIO)++class IsEgisonExpr a where+ toEgisonExpr :: a -> EgisonExpr++instance Integral i => IsEgisonExpr i where toEgisonExpr = NumberExpr . fromIntegral+instance IsEgisonExpr Char where toEgisonExpr = CharExpr+instance IsEgisonExpr String where toEgisonExpr = StringExpr+instance IsEgisonExpr Bool where toEgisonExpr = BoolExpr+instance IsEgisonExpr Float where toEgisonExpr = FloatExpr . realToFrac+instance IsEgisonExpr Double where toEgisonExpr = FloatExpr+instance IsEgisonExpr a => IsEgisonExpr [a] where toEgisonExpr = CollectionExpr . map (ElementExpr . toEgisonExpr)+instance (IsEgisonExpr a, IsEgisonExpr b) => IsEgisonExpr (a, b) where+ toEgisonExpr (x, y) = TupleExpr $ [toEgisonExpr $ x, toEgisonExpr $ y]+instance (IsEgisonExpr a, IsEgisonExpr b, IsEgisonExpr c) => IsEgisonExpr (a, b, c) where+ toEgisonExpr (x, y, z) = TupleExpr $ [toEgisonExpr $ x, toEgisonExpr $ y, toEgisonExpr $ z]+instance (IsEgisonExpr a, IsEgisonExpr b, IsEgisonExpr c, IsEgisonExpr d) => IsEgisonExpr (a, b, c, d) where+ toEgisonExpr (w, x, y, z) = TupleExpr $ [toEgisonExpr $ w, toEgisonExpr $ x, toEgisonExpr $ y, toEgisonExpr $ z]++runIOThrowsError :: IOThrowsError a -> IO a+runIOThrowsError = fmap ignore . runErrorT+ where ignore = either (error . show) id++-- * QuasiQuoter++-- | +-- QuasiQuoter for egison expression+-- The format is:+--+-- > expr := [egison | <egison-expression> :: <type-signature> |]+--+-- Type signature is defined as follows+--+-- > <Typ> = Bool | Int | Double | Float | Char | String | [<Typ>] | (<Typ>, <Typ>, ..., <Typ>) | <Typ> -> <Typ> -> ... <Typ>+--+-- Embedded Egison expression is run-time evaluated by using 'Language.Egison.Core.eval' and 'System.Unsafe.unsafePerformIO'.+-- For more detailed usage, please refer to <https://github.com/xenophobia/Egison-Quote>. +egison :: QuasiQuoter+egison = QuasiQuoter {+ quoteExp = uncurry toHaskellExp . extractValue . readQuote,+ quotePat = error "Not implemented pat-quote.",+ quoteType = error "Not implemented type-quote.",+ quoteDec = error "Not implemented dec-quote."+ }++-- * Type++-- | The type of type signature of egison expression+data TypeSignature = CharTS | StringTS | BoolTS | IntTS | IntegerTS | FloatTS | DoubleTS+ | TupleTS [TypeSignature] | ListTS TypeSignature + | ArrowTS [TypeSignature] TypeSignature deriving (Show)++-- Generate [ EgisonVal -> (corresponding Haskell Value) ] function from TypeSignature+converter :: TypeSignature -> ExpQ+converter CharTS = [| \(Char x) -> x |]+converter StringTS = [| \(String x) -> x |]+converter BoolTS = [| \(Bool x) -> x |]+converter IntTS = [| \(Number x) -> (fromIntegral x) :: Int |]+converter IntegerTS = [| \(Number x) -> x |]+converter DoubleTS = [| \(Float x) -> x |]+converter FloatTS = [| \(Float x) -> (realToFrac x) :: Float |]+converter (TupleTS ts) = do+ patvars <- replicateM (length ts) $ newName "x"+ lamE [conP 'Tuple [listP $ map varP patvars]] (foldl (\acc (x, t) -> appE acc (appE (converter t) (varE x))) (conE $ tupleDataName (length ts)) (zip patvars ts))+converter (ListTS t) = [| \(Collection vs) -> map $(converter t) vs |]+converter (ArrowTS _ _) = error "Invarid return type: t1 -> t2."++-- TypeSignature -> (corresponding Haskell Type)+tsToType :: TypeSignature -> TypeQ+tsToType CharTS = [t| Char |]+tsToType StringTS = [t| String |]+tsToType BoolTS = [t| Bool |]+tsToType IntTS = [t| Int |]+tsToType IntegerTS = [t| Integer |]+tsToType DoubleTS = [t| Double |]+tsToType FloatTS = [t| Float |]+tsToType (TupleTS ts) = foldl appT (tupleT (length ts)) (map tsToType ts)+tsToType (ListTS t) = appT listT (tsToType t)+tsToType (ArrowTS t1 t2) = appT (foldl appT arrowT (map tsToType t1)) (tsToType t2)++-- * Parser++-- | Parser for TypeSignature+parseType :: Parser TypeSignature+parseType = do+ t1_ <- many (try $ lexeme parseType' <* lexeme (string "->"))+ t2 <- lexeme parseType'+ case t1_ of+ [] -> return t2+ t1 -> return (ArrowTS t1 t2)++parseType' = (string "Char" >> return CharTS)+ <|> (string "String" >> return StringTS)+ <|> (string "Bool" >> return BoolTS)+ <|> (string "Int" >> return IntTS)+ <|> (string "Integer" >> return IntegerTS)+ <|> (string "Float" >> return FloatTS)+ <|> (string "Double" >> return DoubleTS)+ <|> parens (do thd <- lexeme parseType'+ ttl <- many (lexeme (char ',') >> lexeme parseType')+ return $ if null ttl then thd else TupleTS (thd:ttl))+ <|> brackets (ListTS <$> lexeme parseType')++-- | Parser for egison-quote+parseQuote :: Parser (EgisonExpr, TypeSignature)+parseQuote = do+ spaces+ expr <- lexeme parseExpr+ lexeme (string "::")+ typ <- lexeme parseType+ return (expr, typ)++-- | Read function for egison-quote+readQuote :: String -> ThrowsError (EgisonExpr, TypeSignature)+readQuote = readOrThrow parseQuote++instance Lift InnerExpr where+ lift (ElementExpr x) = appE (conE 'ElementExpr) (lift x)+ lift (SubCollectionExpr x) = appE (conE 'SubCollectionExpr) (lift x)++instance Lift ArrayElementExpr where+ lift (AElementExpr x) = appE (conE 'AElementExpr) (lift x)+ lift (AInnerArrayExpr l) = appE (conE 'AInnerArrayExpr) (lift l)++instance Lift Args where+ lift (AVar x) = appE (conE 'AVar) (lift x)+ lift (ATuple l) = appE (conE 'ATuple) (lift l)++instance Lift EgisonExpr where+ lift (CharExpr x) = appE (conE 'CharExpr) (lift x)+ lift (BoolExpr x) = appE (conE 'BoolExpr) (lift x)+ lift (NumberExpr x) = appE (conE 'NumberExpr) (lift x)+ lift (FloatExpr x) = let (n, d) = (numerator &&& denominator) (realToFrac x) in+ (appE (conE 'FloatExpr)+ (appE (varE 'fromRational)+ (appsE [(varE '(%)),+ (litE (integerL n)),+ (litE (integerL d))])))+ lift (VarExpr x l) = appsE [conE 'VarExpr, lift x, lift l]+ lift (MacroVarExpr x l) = appsE [conE 'MacroVarExpr, lift x, lift l]+ lift (PatVarOmitExpr x) = appE (conE 'PatVarOmitExpr) (lift x)+ lift (VarOmitExpr x) = appE (conE 'VarOmitExpr) (lift x)+ lift (PatVarExpr x l) = appsE [conE 'PatVarExpr, lift x, lift l]+ lift WildCardExpr = conE 'WildCardExpr+ lift (ValuePatExpr x) = appE (conE 'ValuePatExpr) (lift x)+ lift (CutPatExpr x) = appE (conE 'CutPatExpr) (lift x)+ lift (NotPatExpr x) = appE (conE 'NotPatExpr) (lift x)+ lift (AndPatExpr l) = appE (conE 'AndPatExpr) (lift l)+ lift (OrPatExpr l) = appE (conE 'OrPatExpr) (lift l)+ lift (PredPatExpr x l) = appsE [conE 'PredPatExpr, lift x, lift l]+ lift (InductiveDataExpr x y) = appsE [conE 'InductiveDataExpr, lift x, lift y]+ lift (TupleExpr l) = appsE [conE 'TupleExpr, lift l]+ lift (CollectionExpr l) = appsE [conE 'CollectionExpr, lift l]+ lift (ArrayExpr l) = appsE [conE 'ArrayExpr, lift l]+ lift (FuncExpr l x) = appsE [conE 'FuncExpr, lift l, lift x]+ lift (MacroExpr l x) = appsE [conE 'MacroExpr, lift l, lift x]+ lift (LoopExpr v w x y z) = appsE [conE 'LoopExpr, lift v, lift w, lift x, lift y, lift z]+ lift (ParamsExpr x y z) = appsE [conE 'ParamsExpr, lift x, lift y, lift z]+ lift (IfExpr x y z) = appsE [conE 'IfExpr, lift x, lift y, lift z]+ lift (LetExpr l x) = appsE [conE 'LetExpr, lift l, lift x]+ lift (LetRecExpr l x) = appsE [conE 'LetRecExpr, lift l, lift x]+ lift (DoExpr l x) = appsE [conE 'DoExpr, lift l, lift x]+ -- lift (TypeExpr x) = (appE (conE 'TypeExpr) (lift x))+ lift (MatchExpr x y z) = appsE [conE 'MatchExpr, lift x, lift y, lift z]+ lift (MatchAllExpr x y l) = appsE [conE 'MatchAllExpr, lift x, lift y, lift l]+ lift (GenerateArrayExpr x y) = appsE [conE 'GenerateArrayExpr, lift x, lift y]+ lift (ApplyExpr x l) = appsE [conE 'ApplyExpr, lift x, lift l]+ lift SomethingExpr = conE 'SomethingExpr+ lift UndefinedExpr = conE 'UndefinedExpr+ lift x = error "Not implemented lift"++-- * Construction Exp++-- | construct Exp from Egison-expression and type signature+toHaskellExp :: EgisonExpr -> TypeSignature -> ExpQ+toHaskellExp (FuncExpr (TupleExpr args) expr) (ArrowTS t1 t2) | length args == length t1 = do+ env <- newName "env"+ let (argsName, argsType) = unzip . concat $ zipWith argsExpand args t1+ argsExpr = zipWith (\aname atype -> sigE (varE (mkName aname)) atype) argsName argsType+ bindEnv = bindS (varP env) [|liftIO primitiveBindings|]+ loadEnv = noBindS [|liftIO (loadLibraries $(varE env))|]+ bindExprs = zipWith (\aname aexpr -> noBindS [|defineVar $(varE env) (aname, []) =<< (liftIO $ makeClosure $(varE env) (toEgisonExpr $(aexpr)))|]) argsName argsExpr+ (lamE (map toHaskellArgsPat args)+ (appE (varE 'unsafePerformIO) + (appE (varE 'runIOThrowsError)+ (doE $ bindEnv : loadEnv : (bindExprs ++ [noBindS (appE (appE (varE 'fmap) (converter t2)) [|eval $(varE env) expr|])])))))+toHaskellExp expr typ = appE (converter typ) (appE (varE 'evalEgison) (lift expr))++argsExpand :: EgisonExpr -> TypeSignature -> [(String, TypeQ)]+argsExpand (PatVarExpr a _) t = [(a, tsToType t)]+argsExpand (TupleExpr as) (TupleTS ts) = concat $ zipWith argsExpand as ts+argsExpand _ _ = error "Invarid type."++toHaskellArgsPat :: EgisonExpr -> PatQ+toHaskellArgsPat (PatVarExpr a _) = varP (mkName a)+toHaskellArgsPat (TupleExpr as) = tupP $ map toHaskellArgsPat as++evalEgison :: EgisonExpr -> EgisonVal+evalEgison expr = unsafePerformIO $ do+ env <- primitiveBindings+ loadLibraries env+ runIOThrowsError $ eval env expr
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ egison-quote.cabal view
@@ -0,0 +1,66 @@+-- egison-quote.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: egison-quote++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1.0++-- A short (one-line) description of the package.+Synopsis: A quasi quotes for using Egison expression in Haskell code++-- A longer description of the package.+Description: A quasi quotes for using Egison expression in Haskell code.+ Egison is a purely functional language featured strong pattern matching faculty.+ This package enable us to use (restricted) Egison expression in Haskell source code.++-- URL for the project homepage or repository.+Homepage: https://github.com/xenophobia/Egison-Quote++-- The license under which the package is released.+License: MIT++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Takuya Kuwahara++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: kuwahara111011@gmail.com++-- A copyright notice.+-- Copyright: ++Category: Language++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.8+++Library+ -- Modules exported by the library.+ Exposed-modules: Language.Egison.Quote+ + -- Packages needed in order to build this package.+ Build-depends: base < 5, mtl >= 2.0, egison >= 2.4.0, parsec, template-haskell+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: + +Source-Repository head+ type: git+ location: https://github.com/xenophobia/Egison-Quote