Merge pull request #279 from mixphix/splice-tyapps

Support for `-XTypeApplications`

ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for shakespeare
 
+### 2.1.1
+
+* Add support for `TypeApplications` inside Shakespeare quasiquotes
+
 ### 2.1.0
 
 * Add `OverloadedRecordDot`-style record access in expressions

Text/Shakespeare/Base.hs

@@ -29,7 +29,7 @@ module Text.Shakespeare.Base
 
 import Language.Haskell.TH.Syntax hiding (makeRelativeToProject)
 import Language.Haskell.TH (appE)
-import Data.Char (isUpper, isSymbol, isPunctuation, isAscii)
+import Data.Char (isUpper, isSymbol, isPunctuation, isAscii, isLower, isNumber)
 import Data.FileEmbed (makeRelativeToProject)
 import Text.ParserCombinators.Parsec
 import Text.Parsec.Prim (Parsec)
@@ -41,6 +41,8 @@ import qualified Data.Text.Lazy as TL
 import qualified System.IO as SIO
 import qualified Data.Text.Lazy.IO as TIO
 import Control.Monad (when)
+import Data.Maybe (mapMaybe)
+import Data.List.NonEmpty (nonEmpty, NonEmpty ((:|)))
 
 newtype Ident = Ident String
  deriving (Show, Eq, Read, Data, Typeable, Ord, Lift)
@@ -55,6 +57,7 @@ data Deref = DerefModulesIdent [String] Ident
  | DerefBranch Deref Deref
  | DerefList [Deref]
  | DerefTuple [Deref]
+ | DerefType String
  | DerefGetField Deref String
  -- ^ Record field access via @OverloadedRecordDot@. 'derefToExp' only supports this
  -- feature on compilers which support @OverloadedRecordDot@.
@@ -93,7 +96,7 @@ parseDeref = do
 
  -- See: http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2
  isOperatorChar c
- | isAscii c = c `elem` "!#$%&*+./<=>?@\\^|-~:"
+ | isAscii c = c `elem` "!#$%&*+./<=>?\\^|-~:"
  | otherwise = isSymbol c || isPunctuation c
 
  derefPrefix x = do
@@ -103,17 +106,29 @@ parseDeref = do
  derefInfix x = try $ do
  _ <- delim
  xs <- many $ try $ derefSingle >>= \x' -> delim >> return x'
- op <- many1 (satisfy isOperatorChar) <?> "operator"
+ op <- (many1 (satisfy isOperatorChar) <* lookAhead (oneOf " \t")) <?> "operator"
  -- special handling for $, which we don't deal with
  when (op == "$") $ fail "don't handle $"
  let op' = DerefIdent $ Ident op
  ys <- many1 $ try $ delim >> derefSingle
  skipMany $ oneOf " \t"
  return $ DerefBranch (DerefBranch op' $ foldl1 DerefBranch $ x : xs) (foldl1 DerefBranch ys)
  derefSingle = do
- x <- derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit <|> ident
+ x <- derefType <|> derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> fmap DerefString strLit <|> ident
  fields <- many recordDot
  pure $ foldl DerefGetField x fields
+ tyNameOrVar = liftA2 (:) (alphaNum <|> char '\'') (many (alphaNum <|> char '_' <|> char '\''))
+ derefType = try $ do
+ _ <- char '@' >> notFollowedBy (oneOf " \t")
+ x <-
+ try tyNameOrVar
+ <|> try (string "()")
+ <|> try strLit
+ <|> between
+ (char '(')
+ (char ')')
+ (unwords <$> many ((try tyNameOrVar <|> try strLitQuoted) <* many (oneOf " \t")))
+ pure $ DerefType x
  recordDot = do
  _ <- char '.'
  x <- lower <|> char '_'
@@ -139,11 +154,8 @@ parseDeref = do
  Nothing -> DerefIntegral $ read' "Integral" $ n ++ x
  Just z -> DerefRational $ toRational
  (read' "Rational" $ n ++ x ++ '.' : z :: Double)
- strLit = do
- _ <- char '"'
- chars <- many quotedChar
- _ <- char '"'
- return $ DerefString chars
+ strLitQuoted = liftA2 (:) (char '"') (many quotedChar) <> fmap pure (char '"')
+ strLit = char '"' *> many quotedChar <* char '"'
  quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""
  escapedChar =
  let cecs = [('n', '\n'), ('r', '\r'), ('b', '\b'), ('t', '\t')
@@ -173,8 +185,31 @@ expType :: Ident -> Name -> Exp
 expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE
 expType (Ident "") = error "Bad Ident"
 
+strType :: String -> Type
+strType t0 = case t0 of
+ "" -> ConT ''()
+ hd : tl
+ | all isNumber t0 -> LitT (NumTyLit (read t0))
+ | isLower hd -> VarT (mkName (hd : tl))
+ | otherwise -> ConT (mkName (hd : tl))
+
+strTypeWords :: String -> Type
+strTypeWords t = case words t of
+ [] -> ConT ''()
+ [ty] -> strType ty
+ ts@(ty : tys)
+ | not (null ty)
+ && head ty == '\"'
+ && not (null (last ts))
+ && last (last ts) == '\"' ->
+ LitT (StrTyLit t)
+ | otherwise -> foldl AppT (strType ty) (map strType tys)
+
 derefToExp :: Scope -> Deref -> Exp
-derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y
+derefToExp s (DerefBranch x y) = case y of
+ DerefBranch (DerefType t) y' -> derefToExp s x `AppTypeE` strTypeWords t `AppE` derefToExp s y'
+ DerefType t -> derefToExp s x `AppTypeE` strTypeWords t
+ _ -> derefToExp s x `AppE` derefToExp s y
 derefToExp _ (DerefModulesIdent mods i@(Ident s)) =
  expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods)
 derefToExp scope (DerefIdent i@(Ident s)) =
@@ -184,6 +219,7 @@ derefToExp scope (DerefIdent i@(Ident s)) =
 derefToExp _ (DerefIntegral i) = LitE $ IntegerL i
 derefToExp _ (DerefRational r) = LitE $ RationalL r
 derefToExp _ (DerefString s) = LitE $ StringL s
+derefToExp _ (DerefType _) = error "exposed type application"
 derefToExp s (DerefList ds) = ListE $ map (derefToExp s) ds
 derefToExp s (DerefTuple ds) = TupE $
 #if MIN_VERSION_template_haskell(2,16,0)

shakespeare.cabal

@@ -1,5 +1,5 @@
 name: shakespeare
-version: 2.1.0
+version: 2.1.1
 license: MIT
 license-file: LICENSE
 author: Michael Snoyman <[email protected]>

test/Text/Shakespeare/BaseSpec.hs

@@ -33,6 +33,31 @@ spec = do
  (DerefBranch (DerefIdent (Ident "+")) (DerefIdent (Ident "a")))
  (DerefIdent (Ident "b"))))
 
+ it "parseDeref parse single type applications" $ do
+ runParser parseDeref () "" "x @y" `shouldBe`
+ Right
+ (DerefBranch
+ (DerefIdent (Ident "x"))
+ (DerefType "y"))
+ it "parseDeref parse unit type applications" $ do
+ runParser parseDeref () "" "x @()" `shouldBe`
+ Right
+ (DerefBranch
+ (DerefIdent (Ident "x"))
+ (DerefType "()"))
+ it "parseDeref parse compound type applications" $ do
+ runParser parseDeref () "" "x @(Maybe String)" `shouldBe`
+ Right
+ (DerefBranch
+ (DerefIdent (Ident "x"))
+ (DerefType "Maybe String"))
+ it "parseDeref parse single @ as operator" $ do
+ runParser parseDeref () "" "x @ y" `shouldBe`
+ Right
+ (DerefBranch
+ (DerefBranch (DerefIdent (Ident "@")) (DerefIdent (Ident "x")))
+ (DerefIdent (Ident "y")))
+
  it "parseDeref parse expressions with record dot" $ do
  runParser parseDeref () "" "x.y" `shouldBe`
  Right (DerefGetField (DerefIdent (Ident "x")) "y")
@@ -106,4 +131,3 @@ spec = do
 
  eShowErrors :: Either ParseError c -> c
  eShowErrors = either (error . show) id
-