ehs (empty) → 0.1.0.0

raw patch · 5 files changed

+170/−0 lines, 5 filesdep +basedep +dlistdep +haskell-src-metasetup-changed

Dependencies added: base, dlist, haskell-src-meta, parsec, template-haskell

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• ehs.cabal +27/−0
• src/Ehs.hs +5/−0
• src/Ehs/Internal.hs +116/−0

@@ -0,0 +1,20 @@+Copyright (c) 2014 Yu Fukuzawa++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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,27 @@+name:                ehs+version:             0.1.0.0+synopsis:            embedded Haskell by using quasiquotes.+description:         embedded Haskell by using quasiquotes.+license:             MIT+license-file:        LICENSE+author:              Yu Fukuzawa+maintainer:          Yu Fukuzawa <minpou.primer@gmail.com>+homepage:            http://github.com/minpou/ehs/+bug-reports:         http://github.com/minpou/ehs/+copyright:           Copyright (C) 2014, Yu Fukuzawa +category:            Language+stability:           experimental+build-type:          Simple+cabal-version:       >=1.10++library+  ghc-options:         -O2+  exposed-modules:     Ehs+  other-modules:       Ehs.Internal+  build-depends:       base >= 4.6 && < 5+                     , parsec >= 3+                     , haskell-src-meta < 1.0+                     , template-haskell >= 2.5+                     , dlist+  hs-source-dirs:      src+  default-language:    Haskell2010

@@ -0,0 +1,5 @@+module Ehs (+  ehs+, Embeddable(..)+) where+import Ehs.Internal

@@ -0,0 +1,116 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE UndecidableInstances #-}+module Ehs.Internal where+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.Meta+import Control.Applicative ((<$>),(<$))+import Control.Arrow((***))+import Control.Monad+import Text.Parsec.String+import Text.Parsec.Prim+import Text.Parsec.Char+import Text.Parsec.Combinator+import qualified Data.DList as D++ehs :: QuasiQuoter+ehs = QuasiQuoter+  { quoteExp = \str -> case parse parseEhs "ehs" str of+      Right result -> buildExp result +      Left  err    -> fail $ "parse error: " ++ show err+  , quotePat  = undefined+  , quoteType = undefined+  , quoteDec  = \str -> case parse parseEhs "ehs" str of+      Right result -> buildMain result +      Left  err    -> fail $ "parse error: " ++ show err+  }++buildExp :: [Ehs] -> ExpQ+buildExp es = do+  (vars, stmts) <- (D.toList *** D.toList) <$> foldM buildStmt (D.empty, D.empty) es+  let lastReturn = [noBindS (appE (varE 'return) (appE (varE 'concat) (listE vars)))]+  doE $ stmts ++ lastReturn+  where+    buildStmt (vars, stmts) e = case e of +      Plain s -> strBind [| embed s |]+      Embed exp -> strBind [| embed $(return exp) |]+      Bind pat exp -> do+        stmt <- bindS (return pat) (return exp)+        return (vars, D.snoc stmts (return stmt))+      where+        strBind expq = do+          name <- newName "tmp"+          stmt <- bindS (varP name) expq+          return (D.snoc vars (varE name), D.snoc stmts (return stmt))+  +buildMain :: [Ehs] -> Q [Dec]+buildMain es = do+  main' <- funD (mkName "main") [clause [] doBody []]+  return [main']+  where+    doBody = normalB $ doE $ map buildStmt es+    buildStmt (Plain s)   = noBindS [| putStr s |]+    buildStmt (Embed exp) = noBindS [| embed $(return exp) >>= putStr |]+    buildStmt (Bind pat exp) = bindS (return pat) (return exp)++class Embeddable a where+  embed :: a -> IO String++instance Embeddable String where+  embed = return++instance Show a => Embeddable a where+  embed = return . show++instance Embeddable (IO String) where+  embed = id++instance Show a => Embeddable (IO a) where+  embed = liftM show++data Ehs = +    Plain String  -- foo+  | Embed Exp     -- <%= foo %>+  | Bind  Pat Exp -- <%  foo <- bar %>+  deriving (Show,Eq)++parseEhs :: Parser [Ehs]+parseEhs = (++ [Plain ""]) <$> many (parseEmbed <|> parseBind <|> parsePlain)++parseEmbed :: Parser Ehs+parseEmbed = do+  try $ string "<%="+  e <- manyTill anyChar $ try (string "%>")+  exp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%= %>: " ++ err+  return $ Embed exp++parseBind :: Parser Ehs+parseBind = do+  string "<%"+  p <- manyTill anyChar $ try (string "<-")+  e <- manyTill anyChar $ try (string "%>")+  pat <- case parsePat p of+    Right pat -> return pat+    Left  err -> fail $ "<%= %>: " ++ err+  exp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%= %>: " ++ err+  optional newline+  return $ Bind pat exp++parsePlain :: Parser Ehs+parsePlain = liftM Plain $ many1Till anyChar $ lookAhead $ void (string "<%") <|> eof++many1Till :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]+many1Till p end = scan+  where+    scan = do+      x <- p+      xs <- ([] <$ end) <|> scan+      return $ x : xs