ehs 0.1.0.1 → 0.7.0

raw patch · 5 files changed

+411/−137 lines, 5 filesdep +bytestringdep +ehsdep +textdep −dlistdep ~haskell-src-metadep ~parsecdep ~template-haskellnew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, ehs, text, time, transformers

Dependencies removed: dlist

Dependency ranges changed: haskell-src-meta, parsec, template-haskell

API changes (from Hackage documentation)

Files

• ehs.cabal +47/−16
• example/Main.hs +18/−0
• src/Ehs.hs +153/−5
• src/Ehs/Internal.hs +0/−116
• src/Ehs/Parser.hs +193/−0

@@ -1,30 +1,61 @@ name:                ehs-version:             0.1.0.1-synopsis:            embedded Haskell by using quasiquotes.-description:         embedded Haskell by using quasiquotes.+version:             0.7.0+synopsis:            Embedded haskell template using quasiquotes.+description:         Embedded haskell template 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+copyright:           Copyright (C) 2014-2015, Yu Fukuzawa+category:            Language, Text, Template stability:           experimental build-type:          Simple cabal-version:       >=1.10-Source-Repository head-  type: git-  location: http://github.com/minpou/ehs.git  library-  ghc-options:         -O2+  ghc-options:         -O2 -Wall   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+  other-modules:       Ehs.Parser+  default-extensions:  DeriveFunctor+                     , FlexibleInstances+                     , LambdaCase+                     , NoMonomorphismRestriction+                     , OverlappingInstances+                     , OverloadedStrings+                     , QuasiQuotes+                     , TemplateHaskell+                     , TypeSynonymInstances+                     , UndecidableInstances+  build-depends:       base >=4.6 && <5+                     , bytestring -any+                     , haskell-src-meta >=0.6.0.7 && <0.7+                     , parsec >=3.1.2 && <3.2+                     , template-haskell -any+                     , text >=0.11.2.3 && <1.3+                     , transformers >= 0.4.2.0   hs-source-dirs:      src   default-language:    Haskell2010++flag example+  description: Build a small example.+  default: False++executable             example+  ghc-options:         -O2+  main-is:             Main.hs+  default-extensions:  NoMonomorphismRestriction+                     , OverloadedStrings+                     , QuasiQuotes+                     , TemplateHaskell+  build-depends:       base+                     , bytestring -any+                     , ehs -any+                     , text+                     , time -any+  hs-source-dirs:      example+  default-language:    Haskell2010+  if flag(example)+    buildable:         True+  else+    buildable:         False

@@ -0,0 +1,18 @@+import Ehs+import Control.Monad+import Data.Time++[ehs|<% time <- getCurrentTime %>+The time is now <%= time %>+<% for x <- [1..15] %>+  <% if x `mod` 15 == 0 %>+Fizzbuzz+  <%| x `mod` 3 == 0 %>+Fizz+  <%| x `mod` 5 == 0 %>+Buzz+  <%| otherwise %>+<%= x :: Int %>+  <% end %>+<% end %>+|]

@@ -1,5 +1,153 @@-module Ehs (-  ehs-, Embeddable(..)-) where-import Ehs.Internal+-----------------------------------------------------------+-- |+-- Module      : Ehs+-- Copyright   : (C) 2014-2015, Yu Fukuzawa+-- License     : MIT+-- Maintainer  : minpou.primer@email.com+-- Stability   : experimental+-- Portability : portable+--+-- See also <http://github.com/minpou/ehs/blob/master/README.md>+-----------------------------------------------------------++module Ehs(ehs, pehs, Embeddable(..), EmbeddableIO) where+import Control.Applicative (Applicative(..))+import Control.Monad hiding (forM, forM_)+import Control.Monad.IO.Class(liftIO)+import Control.Monad.Trans.Writer.Strict+import Data.Foldable(forM_)+import Data.Monoid+import Ehs.Parser+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Text.Parsec(parse)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL++newtype Mon m a = Mon { getMon :: m a }++instance (Monoid w, Monad m) => Monoid (Mon m w) where+  mempty = Mon $ return mempty+  {-# INLINE mempty #-}+  mappend (Mon f) (Mon g) = Mon $ liftM2 mappend f g+  {-# INLINE mappend #-}++ehs :: QuasiQuoter+ehs = QuasiQuoter+  { quoteExp = \str -> case parse parseEhses "ehs" str of+      Right result -> buildExp result+      Left  err    -> fail $ "parse error: " ++ show err+  , quotePat  = undefined+  , quoteType = undefined+  , quoteDec  = \str -> case parse parseEhses "ehs" str of+      Right result -> buildMain result+      Left  err    -> fail $ "parse error: " ++ show err+  }++buildExp :: [Ehs String] -> ExpQ+buildExp es = [| execWriterT $(buildDo es) >>= getMon |]++buildDo :: [Ehs String] -> ExpQ+buildDo es = doE $ map buildDoStmt $ es ++ [Plain ""]++buildDoStmt :: Ehs String -> StmtQ+buildDoStmt (Plain s) = noBindS [| tell (Mon (return s :: IO String)) |]+buildDoStmt (Embed exp) = noBindS [| tell (Mon (embedIO $(return exp))) |]+buildDoStmt (Bind pat exp) = bindS (return pat) [| liftIO $(return exp) |]+buildDoStmt (Let decs) = letS $ map return decs+buildDoStmt (For pat exp es) = noBindS [| forM_ $(return exp) $ \($(return pat)) -> $(buildDo es) |]+buildDoStmt (If clauses) = do+  elseClause <- do+    t <- [| otherwise |]+    return (t, [Plain ""])+  noBindS $ multiIfE $ flip map (clauses ++ [elseClause]) $ \(exp, es) -> do+    innerIf <- buildDo es+    cond <- normalG $ return exp+    return (cond, innerIf)+buildDoStmt _ = error "Illegal Term."++buildMain :: [Ehs String] -> Q [Dec]+buildMain es = do+  main' <- funD (mkName "main") [clause [] doBody []]+  return [main']+  where+    doBody = normalB $ doE $ [noBindS [| $(buildExp es) >>= putStr |]]++{- pure version -}++pehs :: QuasiQuoter+pehs = QuasiQuoter+  { quoteExp = \str -> case parse parseEhses "pehs" str of+      Right result -> buildExpPure result+      Left  err    -> fail $ "parse error: " ++ show err+  , quotePat  = undefined+  , quoteType = undefined+  , quoteDec  = undefined+  }++newtype Id a = Id { runId :: a }+  deriving (Functor)++instance Applicative Id where+  pure = Id+  Id f <*> Id x = Id (f x)++instance Monad Id where+  return = Id+  {-# INLINE return #-}+  Id x >>= f = f x+  {-# INLINE (>>=) #-}++buildExpPure :: [Ehs String] -> ExpQ+buildExpPure es = [| runId (execWriterT $(buildDoPure es) >>= getMon) |]++buildDoPure :: [Ehs String] -> ExpQ+buildDoPure es = doE $ map buildDoStmtPure $ es ++ [Plain ""]++buildDoStmtPure :: Ehs String -> StmtQ+buildDoStmtPure (Plain s) = noBindS [| tell (Mon (Id s :: Id String)) |]+buildDoStmtPure (Embed exp) = noBindS [| tell (Mon (Id (embed $(return exp)))) |]+buildDoStmtPure (Bind pat exp) = bindS (return pat) [| Id $(return exp) |]+buildDoStmtPure (Let decs) = letS $ map return decs+buildDoStmtPure (For pat exp es) = noBindS [| forM_ $(return exp) $ \($(return pat)) -> $(buildDoPure es) |]+buildDoStmtPure (If clauses) = do+  elseClause <- do+    t <- [| otherwise |]+    return (t, [Plain ""])+  noBindS $ multiIfE $ flip map (clauses ++ [elseClause]) $ \(exp, es) -> do+    innerIf <- buildDoPure es+    cond <- normalG $ return exp+    return (cond, innerIf)+buildDoStmtPure _ = error "Illegal Term."++class Embeddable a where+  embed :: a -> String++instance Embeddable String where+  embed = id++instance Embeddable BS.ByteString where+  embed = embed . BS.unpack++instance Embeddable BL.ByteString where+  embed = embed . BL.unpack++instance Embeddable TS.Text where+  embed = embed . TS.unpack++instance Embeddable TL.Text where+  embed = embed . TL.unpack++instance Show a => Embeddable a where+  embed = show++class EmbeddableIO a where+  embedIO :: a -> IO String++instance Embeddable a => EmbeddableIO a where+  embedIO = return . embed++instance Embeddable a => EmbeddableIO (IO a) where+  embedIO = (>>=embedIO)

@@ -1,116 +0,0 @@-{-# 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-  try $ 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 (try (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

@@ -0,0 +1,193 @@+module Ehs.Parser+( Ehs(Plain, Embed, Bind, Let, For, If)+, parseEhses+) where+import Control.Applicative   ((<$), (<$>), (<*))+import Control.Monad+import Data.Char             (isSpace)+import Data.Maybe            (isNothing)+import Data.List             (find)+import GHC.Exts+import Language.Haskell.Meta+import Language.Haskell.TH+import Text.Parsec+import Text.Parsec.String    (Parser)++data Ehs s+  = Plain s+  | Embed Exp+  | Bind Pat Exp+  | Let [Dec]+  | For Pat Exp [Ehs s]+  | If [(Exp, [Ehs s])]+  | Zip (Ehs s, Ehs s, Ehs s)+  deriving (Eq, Show, Functor)++isStmt :: Ehs s -> Bool+isStmt (Plain _) = False+isStmt (Embed _) = False+isStmt _         = True++-- isStmt nopStmt = True+nopStmt :: Ehs s+nopStmt = Let []++-- isStmt nop = False+nop :: IsString s => Ehs s+nop = Plain ""++removeNops :: (Eq s, IsString s) => [Ehs s] -> [Ehs s]+removeNops = nestedFilter (\x -> nop /= x && nopStmt /= x)++nestedMap :: (Ehs a -> Ehs b) -> [Ehs a] -> [Ehs b]+nestedMap f = map go+  where+    go (For pat exp es) = For pat exp $ map go es+    go (If clauses) = If [(exp, map go es) | (exp, es) <- clauses]+    go x = f x++nestedFilter :: (Ehs a -> Bool) -> [Ehs a] -> [Ehs a]+nestedFilter p = go+  where+    go (For pat exp es:xs) = For pat exp (go es) : go xs+    go (If clauses:xs) = If [(exp, go es) | (exp, es) <- clauses] : go xs+    go (x:xs) = if p x then x : go xs else go xs+    go [] = []++parseEhses :: IsString s => Parser [Ehs s]+parseEhses = map (fmap fromString) . removeNops . nestedMap trim . rove . (nop :) <$> many parseEhs <* eof+  where+    trim :: Ehs String -> Ehs String+    trim (Zip (x, p@(Plain _), y))+      | isStmt x && isStmt y = fmap (lchomp . trimAfterLastEOL) p+      | isStmt x = fmap lchomp p+      | isStmt y = fmap trimAfterLastEOL p+    trim (Zip (_, x, _)) = head $ nestedMap trim [x]+    trim x = x+    rove :: [Ehs String] -> [Ehs String]+    rove = \case+      (x:y:z:r) -> Zip (x, deep y, z) : rove (y : z : r)+      [x,y] -> [Zip (x, deep y, nop)]+      [x] -> [Zip (nop, deep x, nop)]+      [] -> [Zip (nop, nop, nop)]+      where+        deep (For pat exp es) = For pat exp $ rove $ nopStmt : es ++ [nopStmt]+        deep (If clauses) = If [(exp, rove $ nopStmt : es ++ [nopStmt]) | (exp, es) <- clauses]+        deep x = x+    lchomp ('\r':'\n': r) = r+    lchomp ('\n': r) = r+    lchomp xs = xs+    trimAfterLastEOL s = reverse rfront ++ reverse (if isNothing (find (=='\n') rrear) then rrear else dropWhile (/='\n') rrear)+      where+        (rrear , rfront) = span isSpace (reverse s)++parseEhs :: Parser (Ehs String)+parseEhs+    = parsePlain+  <|> parseEmbed+  <|> parseFor+  <|> try parseBind+  <|> try parseLet+  <|> parseIf+  <?> "parse error"++parsePlain :: Parser (Ehs String)+parsePlain = do+  plain <- manyTill ("<%" <$ try (string "<%%") <|> (:[]) <$> anyChar)+    $ lookAhead (try tagHead <|> eof)+  guard (not (null plain))+  return $ Plain $ concat plain+  where+    tagHead = string "<%" >> notFollowedBy (char '%')++parseEmbed :: Parser (Ehs String)+parseEmbed = do+  try $ string "<%="+  e <- innerText $ string "%>"+  exp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%= %>: " ++ err+  return $ Embed exp++parseBind :: Parser (Ehs String)+parseBind = do+  string "<%"+  p <- innerText $ string "<-"+  e <- innerText $ 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+  return $ Bind pat exp++parseLet :: Parser (Ehs String)+parseLet = do+  try $ do+    string "<%"+    skipMany space+    string "let"+    skipMany1 space+  ds <- innerText $ string "%>"+  decs <- case parseDecs ds of+    Right decs -> return decs+    Left  err -> fail $ "<%let %>: " ++ err+  return $ Let decs++parseIf :: Parser (Ehs String)+parseIf = do+  try $ do+    string "<%"+    skipMany space+    string "if"+    skipMany1 space+  e <- innerText $ string "%>"+  thenExp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%if %>: " ++ err+  thenStmts <- many parseEhs+  clauses <- manyTill parseElsif (try endTag)+  return $ If $ (thenExp, thenStmts) : clauses++parseElsif :: Parser (Exp, [Ehs String])+parseElsif = do+  try $ string "<%|"+  e <- innerText $ string "%>"+  exp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%| %>: " ++ err+  stmts <- many parseEhs+  return (exp, stmts)++parseFor :: Parser (Ehs String)+parseFor = do+  try $ do+    string "<%"+    skipMany space+    string "for"+    skipMany1 space+  p <- innerText $ string "<-"+  e <- innerText $ string "%>"+  pat <- case parsePat p of+    Right pat -> return pat+    Left  err -> fail $ "<%for %>: " ++ err+  exp <- case parseExp e of+    Right exp -> return exp+    Left  err -> fail $ "<%for %>: " ++ err+  stmts <- manyTill parseEhs (try endTag)+  return $ For pat exp stmts++innerText :: Parser a -> Parser String+innerText = followedBy ("%>" <$ try (string "%%>") <|> (:[]) <$> anyChar)+  where+    followedBy p e = concat <$> manyTill p (try e)++endTag :: Parser ()+endTag = do+  string "<%"+  skipMany space+  string "end"+  skipMany space+  string "%>"+  return ()