egison-quote 0.1.1 → 0.2

raw patch · 2 files changed

+116/−81 lines, 2 filesdep ~egisonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: egison

API changes (from Hackage documentation)

Files

• Language/Egison/Quote.hs +114/−79
• egison-quote.cabal +2/−2

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

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