diff --git a/Language/Egison/Quote.hs b/Language/Egison/Quote.hs --- a/Language/Egison/Quote.hs +++ b/Language/Egison/Quote.hs @@ -15,7 +15,6 @@ {-# Language TemplateHaskell, QuasiQuotes, TypeSynonymInstances, FlexibleInstances, UndecidableInstances, ViewPatterns, OverlappingInstances, IncoherentInstances #-} module Language.Egison.Quote(egison, - TypeSignature, parseType, pickupAntiquote, parseAntiquote, @@ -36,11 +35,9 @@ import Language.Egison.Parser import Language.Egison.Variables -import Data.Either -import Data.Ratio -import Data.Maybe -import Data.List - +import Data.Either (either) +import Data.Ratio (numerator, denominator, (%)) +import Data.IORef (newIORef) import Control.Monad.Error hiding (lift) import Control.Monad.Trans hiding (lift) import Control.Arrow @@ -95,7 +92,7 @@ quoteExp = \input -> let (antiquotes, input') = pickupAntiquote input (expr, typ) = extractValue . readQuote $ input' - in + in do toHaskellExp expr antiquotes typ, quotePat = error "Not implemented pat-quote.", quoteType = error "Not implemented type-quote.", @@ -104,61 +101,79 @@ -- * 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) +matchAppType :: Type -> Maybe ([Type], Type) +matchAppType t@(AppT (AppT ArrowT _) _) = Just . matchAppType' $ t + where + matchAppType' (AppT (AppT ArrowT arg) rest) = first (++[arg]) $ matchAppType' rest + matchAppType' ret = ([], ret) +matchAppType _ = Nothing +matchTupleType :: Type -> Maybe [Type] +matchTupleType (AppT (TupleT _) ret) = return [ret] +matchTupleType (AppT rest element) = (++[element]) <$> matchTupleType rest +matchTupleType _ = Nothing + +matchListType :: Type -> Maybe Type +matchListType t = case t of {AppT ListT typ -> return typ; _ -> Nothing} + +matchConstType :: Type -> Maybe String +matchConstType t= case t of {ConT t -> Just . nameBase $ t; _ -> Nothing} + -- 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 +converter :: Type -> ExpQ +converter (matchConstType -> Just "Char") = [| \(Char x) -> x |] +converter (matchConstType -> Just "String") = [| \(String x) -> x |] +converter (matchConstType -> Just "Bool") = [| \(Bool x) -> x |] +converter (matchConstType -> Just "Int") = [| \(Number x) -> (fromIntegral x) :: Int |] +converter (matchConstType -> Just "Integer") = [| \(Number x) -> x |] +converter (matchConstType -> Just "Double") = [| \(Float x) -> x |] +converter (matchConstType -> Just "Float") = [| \(Float x) -> (realToFrac x) :: Float |] +converter (matchTupleType -> Just 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) +converter (matchListType -> Just t) = [| \(Collection vs) -> map $(converter t) vs |] +converter (matchAppType -> Just (args, ret)) = [| \func@(Func _ _ env) -> $(wrap 'func 'env) |] + where + wrap (varE -> funcVal) (varE -> env) = do + (funcName, (func, funcP)) <- (show &&& varE &&& varP) <$> newName "func" + argsName <- mapM newName $ map (("x"++) . show) [1..length args] + let (args, argsP) = (map varE &&& map varP) argsName + (lamE argsP + (appE (converter ret) + (appE (varE 'unsafePerformIO) + (doE $ + bindS funcP (appE (varE 'newIORef) (appE (conE 'Value) funcVal)) : + noBindS [| runIOThrowsError $ defineVar $(env) (funcName, []) $(func) |] : + makeBinding (map show argsName) args env ++ + [noBindS [| runIOThrowsError (eval $(env) (ApplyExpr (VarExpr funcName []) (TupleExpr (map toEgisonExpr $(listE args))))) |]])))) +converter t = error $ "Invarid type: " ++ show t -- * Parser -- | Parser for TypeSignature -parseType :: Parser TypeSignature +parseType :: Parser Type parseType = do t1_ <- many (try $ lexeme parseType' <* lexeme (string "->")) t2 <- lexeme parseType' case t1_ of [] -> return t2 - t1 -> return (ArrowTS t1 t2) + t1 -> return $ foldr AppT t2 (map (AppT ArrowT) t1) -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') +parseType' :: Parser Type +parseType' = (string "Char" >> return (ConT ''Char)) + <|> (string "String" >> return (ConT ''String)) + <|> (string "Bool" >> return (ConT ''Bool)) + <|> (string "Int" >> return (ConT ''Int)) + <|> (string "Integer" >> return (ConT ''Integer)) + <|> (string "Float" >> return (ConT ''Float)) + <|> (string "Double" >> return (ConT ''Double)) + <|> (try $ parens $ do thd <- lexeme parseType' + ttl <- many (lexeme (char ',') >> lexeme parseType') + return $ if null ttl + then thd + else foldl AppT (TupleT (length $ thd:ttl)) (thd:ttl)) + <|> brackets (AppT ListT <$> lexeme parseType') + <|> parens parseType -- | Pick up antiquoted variables and delete notation @#{~}@ -- @@ -180,7 +195,7 @@ <|> (eof >> return ([], "")) -- | Parser for egison-quote -parseQuote :: Parser (EgisonExpr, TypeSignature) +parseQuote :: Parser (EgisonExpr, Type) parseQuote = do spaces expr <- lexeme parseExpr @@ -189,7 +204,7 @@ return (expr, typ) -- | Read function for egison-quote -readQuote :: String -> ThrowsError (EgisonExpr, TypeSignature) +readQuote :: String -> ThrowsError (EgisonExpr, Type) readQuote = readOrThrow parseQuote instance Lift InnerExpr where @@ -215,9 +230,9 @@ (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 (MacroVarExpr x) = appsE [conE 'MacroVarExpr, lift x] + lift (PatVarOmitExpr x l) = appsE [conE 'PatVarOmitExpr, lift x, lift l] + lift (VarOmitExpr x l) = appsE [conE 'VarOmitExpr, lift x, lift l] lift (PatVarExpr x l) = appsE [conE 'PatVarExpr, lift x, lift l] lift WildCardExpr = conE 'WildCardExpr lift (ValuePatExpr x) = appE (conE 'ValuePatExpr) (lift x) @@ -249,15 +264,26 @@ -- * Construction Exp +-- | make do-binding +makeBinding :: [String] -- ^ variable names + -> [ExpQ] -- ^ binding expressions + -> ExpQ -- ^ environmental name + -> [StmtQ] +makeBinding names exprs env = zipWith (\name expr -> noBindS [|runIOThrowsError $ defineVar $(env) (name, []) =<< (liftIO $ makeClosure $(env) (toEgisonExpr $(expr)))|]) names exprs + +nameExprWithType :: String -> TypeQ -> ExpQ +nameExprWithType name typ = sigE (varE (mkName name)) typ + -- | construct Exp from Egison-expression and type signature -toHaskellExp :: EgisonExpr -> [String] -> TypeSignature -> ExpQ -toHaskellExp (FuncExpr (TupleExpr args) expr) antiquotes (ArrowTS t1 t2) | length args == length t1 = do +toHaskellExp :: EgisonExpr -> [String] -> Type -> ExpQ +toHaskellExp (FuncExpr (TupleExpr args) expr) antiquotes (nArgsApp (length args) -> (t1, t2)) = do let (argsName, argsType) = unzip . concat $ zipWith argsExpand args t1 - argsExpr = zipWith (\aname atype -> sigE (varE (mkName aname)) atype) argsName argsType - bindExprs envName = zipWith (\aname aexpr -> noBindS [|runIOThrowsError $ defineVar $(varE envName) (aname, []) =<< (liftIO $ makeClosure $(varE envName) (toEgisonExpr $(aexpr)))|]) argsName argsExpr + argsExpr = zipWith nameExprWithType argsName argsType + bindnames = antiquotes ++ argsName + bindexprs = map (varE . mkName) antiquotes ++ argsExpr (lamE (map toHaskellArgsPat args) - (appE (converter t2) (evalEgisonTopLevel expr antiquotes bindExprs))) -toHaskellExp expr antiquotes typ = appE (converter typ) (evalEgisonTopLevel expr antiquotes (const [])) + (appE (converter t2) (evalEgisonTopLevel expr bindnames bindexprs))) +toHaskellExp expr antiquotes typ = appE (converter typ) (evalEgisonTopLevel expr antiquotes (map (varE . mkName) antiquotes)) childExpr :: EgisonExpr -> [EgisonExpr] childExpr (CharExpr _) = [] @@ -266,9 +292,9 @@ childExpr (NumberExpr _) = [] childExpr (FloatExpr _) = [] childExpr (VarExpr _ cs) = cs -childExpr (MacroVarExpr _ cs) = cs -childExpr (PatVarOmitExpr c) = [c] -childExpr (VarOmitExpr c) = [c] +childExpr (MacroVarExpr _) = [] +childExpr (PatVarOmitExpr _ cs) = cs +childExpr (VarOmitExpr _ cs) = cs childExpr (PatVarExpr _ cs) = cs childExpr WildCardExpr = [] childExpr (ValuePatExpr c) = [c] @@ -304,27 +330,36 @@ 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 -argsExpand _ _ = error "Invarid type." +nArgsApp :: Int -> Type -> ([Type], Type) +nArgsApp 0 ret = ([], ret) +nArgsApp n (AppT (AppT ArrowT arg) rest) = first (arg:) $ nArgsApp (n-1) rest +nArgsApp _ _ = error "Invarid Args." +-- | Expand binding +-- +-- > [a1 [a2 a3]] :: (Int, (Char, Char)) --> [(a1, Int), (a2, Char), (a3, Char)] +argsExpand :: EgisonExpr -> Type -> [(String, TypeQ)] +argsExpand (PatVarExpr a _) t = [(a, return t)] +argsExpand (TupleExpr as) (matchTupleType -> Just ts) | length as == length ts = concat $ zipWith argsExpand as ts + | otherwise = error "Wrong number of args." +argsExpand e t = error $ "Invarid argument: \n" ++ show e ++ "\n" ++ show t + +-- | Egison binding to Haskell binding +-- +-- > [a1 [a2 a3]] --> (a1, (a2, a3)) toHaskellArgsPat :: EgisonExpr -> PatQ toHaskellArgsPat (PatVarExpr a _) = varP (mkName a) toHaskellArgsPat (TupleExpr as) = tupP $ map toHaskellArgsPat as -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 +evalEgisonTopLevel :: EgisonExpr -- ^ evaluated expression + -> [String] -- ^ variable names + -> [ExpQ] -- ^ binding expressions + -> ExpQ +evalEgisonTopLevel expr bindvars bindexprs = do + (env, envP) <- (varE &&& varP) <$> newName "env" (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|]]))] - ))) + envP `bindS` (varE 'primitiveBindings) : + noBindS (appE (varE 'loadLibraries) env) : + makeBinding bindvars bindexprs env ++ + [noBindS [| runIOThrowsError $ eval $(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.1 +Version: 0.2 -- A short (one-line) description of the package. Synopsis: A quasi quotes for using Egison expression in Haskell code @@ -53,7 +53,7 @@ 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 + Build-depends: base < 5, mtl >= 2.0, egison >= 2.4.3, parsec, template-haskell -- Modules not exported by this package. -- Other-modules: