diff --git a/Language/Egison/Quote.hs b/Language/Egison/Quote.hs --- a/Language/Egison/Quote.hs +++ b/Language/Egison/Quote.hs @@ -12,14 +12,17 @@ -- ----------------------------------------------------------------------------- -{-# Language TemplateHaskell, QuasiQuotes, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, OverlappingInstances, IncoherentInstances #-} +{-# Language TemplateHaskell, QuasiQuotes, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, ViewPatterns, OverlappingInstances, IncoherentInstances #-} module Language.Egison.Quote(egison, TypeSignature, - parseQuote, parseType, + pickupAntiquote, + parseAntiquote, + parseQuote, readQuote, - toHaskellExp) where + toHaskellExp, + evalEgisonTopLevel) where import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -35,6 +38,9 @@ import Data.Either import Data.Ratio +import Data.Maybe +import Data.List + import Control.Monad.Error hiding (lift) import Control.Monad.Trans hiding (lift) import Control.Arrow @@ -45,12 +51,13 @@ class IsEgisonExpr a where toEgisonExpr :: a -> EgisonExpr -instance Integral i => IsEgisonExpr i where toEgisonExpr = NumberExpr . fromIntegral +instance IsEgisonExpr Int where toEgisonExpr = NumberExpr . fromIntegral +instance IsEgisonExpr Integer 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 String where toEgisonExpr = StringExpr 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] @@ -67,19 +74,29 @@ -- | -- QuasiQuoter for egison expression +-- -- The format is: -- -- > expr := [egison | :: |] -- +-- For example, with Egison pattern matching, /powerset function/ can be expressed easily as follows. +-- +-- >>> [egison|(lambda [$l] (match-all l (Multiset Integer) [ l])) :: [Int] -> [[Int]]|] [1..3] +-- [[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]] +-- -- Type signature is defined as follows -- -- > = Bool | Int | Double | Float | Char | String | [] | (, , ..., ) | -> -> ... -- -- Embedded Egison expression is run-time evaluated by using 'Language.Egison.Core.eval' and 'System.Unsafe.unsafePerformIO'. --- For more detailed usage, please refer to . +-- For more detailed usage, please refer to . egison :: QuasiQuoter egison = QuasiQuoter { - quoteExp = uncurry toHaskellExp . extractValue . readQuote, + quoteExp = \input -> + let (antiquotes, input') = pickupAntiquote input + (expr, typ) = extractValue . readQuote $ input' + in + toHaskellExp expr antiquotes typ, quotePat = error "Not implemented pat-quote.", quoteType = error "Not implemented type-quote.", quoteDec = error "Not implemented dec-quote." @@ -143,6 +160,25 @@ return $ if null ttl then thd else TupleTS (thd:ttl)) <|> brackets (ListTS <$> lexeme parseType') +-- | Pick up antiquoted variables and delete notation @#{~}@ +-- +-- > "(+ #{x} y)" ---> ([x], "(+ x y)") +pickupAntiquote :: String -> ([String], String) +pickupAntiquote input = either (error.show) id $ parse parseAntiquote "Antiquote" input + +-- | Parser for 'pickupAntiquote' +parseAntiquote :: Parser ([String], String) +parseAntiquote = (try $ do lexeme (char '#') + lexeme (char '{') + antiquote <- identifier + lexeme (char '}') + (antiquotes, rest) <- parseAntiquote + return $ (antiquote:antiquotes, ' ':antiquote++" "++rest)) + <|> (try $ do c <- anyChar + (antiquotes, rest) <- parseAntiquote + return $ (antiquotes, c:rest)) + <|> (eof >> return ([], "")) + -- | Parser for egison-quote parseQuote :: Parser (EgisonExpr, TypeSignature) parseQuote = do @@ -214,20 +250,60 @@ -- * 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" +toHaskellExp :: EgisonExpr -> [String] -> TypeSignature -> ExpQ +toHaskellExp (FuncExpr (TupleExpr args) expr) antiquotes (ArrowTS t1 t2) | length args == length t1 = do 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 + bindExprs envName = zipWith (\aname aexpr -> noBindS [|runIOThrowsError $ defineVar $(varE envName) (aname, []) =<< (liftIO $ makeClosure $(varE envName) (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)) + (appE (converter t2) (evalEgisonTopLevel expr antiquotes bindExprs))) +toHaskellExp expr antiquotes typ = appE (converter typ) (evalEgisonTopLevel expr antiquotes (const [])) +childExpr :: EgisonExpr -> [EgisonExpr] +childExpr (CharExpr _) = [] +childExpr (StringExpr _) = [] +childExpr (BoolExpr _) = [] +childExpr (NumberExpr _) = [] +childExpr (FloatExpr _) = [] +childExpr (VarExpr _ cs) = cs +childExpr (MacroVarExpr _ cs) = cs +childExpr (PatVarOmitExpr c) = [c] +childExpr (VarOmitExpr c) = [c] +childExpr (PatVarExpr _ cs) = cs +childExpr WildCardExpr = [] +childExpr (ValuePatExpr c) = [c] +childExpr (CutPatExpr c) = [c] +childExpr (NotPatExpr c) = [c] +childExpr (AndPatExpr cs) = cs +childExpr (OrPatExpr cs) = cs +childExpr (PredPatExpr c cs) = c:cs +childExpr (InductiveDataExpr _ cs) = cs +childExpr (TupleExpr cs) = cs +childExpr (CollectionExpr cs) = map go cs + where go (ElementExpr x) = x + go (SubCollectionExpr x) = x +childExpr (ArrayExpr cs) = concatMap go cs + where go (AElementExpr x) = [x] + go (AInnerArrayExpr xs) = concatMap go xs +childExpr (FuncExpr c1 c2) = [c1, c2] +childExpr (MacroExpr _ c) = [c] +childExpr (LoopExpr _ _ c1 c2 c3) = [c1, c2, c3] +childExpr (ParamsExpr _ c1 c2) = [c1, c2] +childExpr (IfExpr c1 c2 c3) = [c1, c2, c3] +childExpr (LetExpr bs c) = c:concatMap go bs + where go (x, y) = [x, y] +childExpr (LetRecExpr bs c) = c:map snd bs +childExpr (DoExpr bs c) = c:concatMap go bs + where go (x, y) = [x, y] +-- childExpr (TypeExpr DestructInfoExpr) +childExpr (MatchExpr c1 c2 ms) = c1:c2:concatMap go ms + where go (x, y) = [x, y] +childExpr (MatchAllExpr c1 c2 (c3, c4)) = [c1, c2, c3, c4] +childExpr (GenerateArrayExpr c1 c2) = [c1, c2] +childExpr (ApplyExpr c1 c2) = [c1, c2] +childExpr SomethingExpr = [] +childExpr UndefinedExpr = [] + argsExpand :: EgisonExpr -> TypeSignature -> [(String, TypeQ)] argsExpand (PatVarExpr a _) t = [(a, tsToType t)] argsExpand (TupleExpr as) (TupleTS ts) = concat $ zipWith argsExpand as ts @@ -237,8 +313,18 @@ 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 +evalEgison :: EgisonExpr -> Env -> EgisonVal +evalEgison expr env = unsafePerformIO $ runIOThrowsError $ eval env expr + +evalEgisonTopLevel :: EgisonExpr -> [String] -> (Name -> [StmtQ]) -> ExpQ +evalEgisonTopLevel expr vars binds = do + env <- newName "env" + let exprs = map (varE . mkName) vars + (appE (varE 'unsafePerformIO) + (doE ( + [(varP env) `bindS` (varE 'primitiveBindings), + noBindS (appE (varE 'loadLibraries) (varE env))] ++ + zipWith (\vname vexpr -> noBindS [|runIOThrowsError $ defineVar $(varE env) (vname, []) =<< (liftIO $ makeClosure $(varE env) (toEgisonExpr $(vexpr)))|]) vars exprs ++ + binds env ++ + [noBindS (appE (varE 'runIOThrowsError) (appsE [varE 'eval, varE env, [|expr|]]))] + ))) diff --git a/egison-quote.cabal b/egison-quote.cabal --- a/egison-quote.cabal +++ b/egison-quote.cabal @@ -7,7 +7,7 @@ -- 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 +Version: 0.1.1 -- A short (one-line) description of the package. Synopsis: A quasi quotes for using Egison expression in Haskell code