I use quasi quoters to create my smart-constructed data types at compile time. This looks something like:
import qualified Data.Text as T
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH (Q, Exp, Pat(..), Lit(..))
import Language.Haskell.TH.Syntax (Lift(..))
import qualified Language.Haskell.TH.Syntax as TH
import Instances.TH.Lift () -- th-lift-instances package
newtype NonEmptyText = NonEmptyText Text
textIsWhitespace :: Text -> Bool
textIsWhitespace = T.all (== ' ')
mkNonEmptyText :: Text -> Maybe NonEmptyText
mkNonEmptyText t = if textIsWhitespace t then Nothing else (Just (NonEmptyText t))
compileNonEmptyText :: QuasiQuoter
compileNonEmptyText = QuasiQuoter
{ quoteExp = compileNonEmptyText'
, quotePat = error "NonEmptyText is not supported as a pattern"
, quoteDec = error "NonEmptyText is not supported at top-level"
, quoteType = error "NonEmptyText is not supported as a type"
}
where
compileNonEmptyText' :: String -> Q Exp
compileNonEmptyText' s = case mkNonEmptyText (pack s) of
Nothing -> fail $ "Invalid NonEmptyText: " ++ s
Just txt -> [| txt |]
(I can provide a standalone working example if necessary—I just pulled this example out of a larger codebase)
Essentially, by just deriving Lift for my newtypes, I can place the data type in an expression quasi quoter [| txt |] to implement quoteExp.
But I'm having trouble with quotePat. If I do e.g.:
Just txt -> [p| txt |]
Then I get a warning that the first txt is unused, and the second shadows the first. I'm pretty sure that that pattern is just creating a new name txt rather than splicing in the in-scope txt like the expression quasi quoter did, since when I do:
f :: NonEmptyText -> Bool
f [compileNonEmptyText|test|] = True
f _ = False
everything matches the first statement.
Alright I think I've got it. Starting from the base string s, I can wrap that in StringL and LitP to get a literal string, which because of Text's IsString instance will become a Text. From there I need to apply the NonEmptyText constructor using ConP:
compileNonEmptyTextPattern' :: String -> Q TH.Pat
compileNonEmptyTextPattern' s = case mkNonEmptyText (pack s) of
Nothing -> fail $ "Invalid NonEmptyText: " ++ s
Just (NonEmptyText txt) -> pure $ ConP 'NonEmptyText [(LitP (StringL (T.unpack txt)))]
It's unfortunate that this is so much more verbose than the expression version, though! I wonder if there could be a typeclass for Q Pat like Lift is for Q Exp?
Related
I have a data type like this:
module My.Module
data A = A { aFoo :: Integer } deriving (Generic, Show)
And I have generic option for Aeson
import Data.Char ( toUpper, toLower )
genericOptions :: String -> Options
genericOptions prefix = defaultOptions
{ fieldLabelModifier = dropPrefix $ length prefix
, constructorTagModifier = addPrefix prefix
, omitNothingFields = True
}
where
dropPrefix l s = let remainder = drop l s
in (toLower . head) remainder : tail remainder
addPrefix p s = p ++ toUpper (head s) : tail s
So I can use it like this
instance A.FromJSON A where
parseJSON = A.genericParseJSON $ genericOptions "A"
instance A.ToJSON A where
toJSON = A.genericToJSON $ genericOptions "A"
But I realize I could use some template haskell
import Data.Aeson.TH ( deriveJSON )
import Language.Haskell.TH.Syntax ( Dec, Name, Q )
genericDeriveJSON :: Name -> Q [Dec]
genericDeriveJSON name =
deriveJSON (genericOptions (show name)) name
$(genericDeriveJSON ''A)
It throws an error:
Exception when trying to run
compile-time code:
Prelude.tail: empty list
Code: A.genericDeriveJSON ''A
It seems drop l s on dropPrefix returned an empty string meaning the value of show name is not string "A". Since I don't think I could inspect the value, anybody knows what is the value?
Try to use nameBase instead of show (which is meant for debugging and not core logic).
To see what show is doing you can look at the implementation of show which is defined as showName which is itself defined as showName' Alone, to see roughly that it constructs the fully qualified name of your type.
I currently have a working parser in megaparsec, where I build an AST for my program. I now want to do some weeding operations on my AST, while being able to use the same kind of pretty errors as the parser. While this stage is after parsing, I'm wondering if there are general practices for megaparsec in doing so. Is there a way for me to extract every line and comment (used in the bundle) and add it to each item in my AST? Is there any other way that people tackle this problem?
Apologies in advance if this sounds open ended, but I'm mainly wondering is there are some better ideas than getting the line numbers and creating bundles myself. I'm still new to haskell so I haven't been able to navigate properly through all the source code.
This was answered by the megaparsec developer here.
To summarize, parsers have a getOffset function that returns the current char index. You can use that along with an initial PosState to create an error bundle which you can later pretty print.
I have a sample project within the github thread, and pasted again here:
module TestParser where
import Data.List.NonEmpty as NonEmpty
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import Data.Void
import Parser
import Text.Megaparsec
data Sample
= Test Int
String
| TestBlock [Sample]
| TestBlank
deriving (Show, Eq)
sampleParser :: Parser Sample
sampleParser = do
l <- many testParser
return $ f l
where
f [] = TestBlank
f [s] = s
f p = TestBlock p
testParser :: Parser Sample
testParser = do
offset <- getOffset
test <- symbol "test"
return $ Test offset test
fullTestParser :: Parser Sample
fullTestParser = baseParser testParser
testParse :: String -> Maybe (ParseErrorBundle String Void)
testParse input =
case parse (baseParser sampleParser) "" input of
Left e -> Just e
Right x -> do
(offset, msg) <- testVerify x
let initialState =
PosState
{ pstateInput = input
, pstateOffset = 0
, pstateSourcePos = initialPos ""
, pstateTabWidth = defaultTabWidth
, pstateLinePrefix = ""
}
let errorBundle =
ParseErrorBundle
{ bundleErrors = NonEmpty.fromList [TrivialError offset Nothing Set.empty]
-- ^ A collection of 'ParseError's that is sorted by parse error offsets
, bundlePosState = initialState
-- ^ State that is used for line\/column calculation
}
return errorBundle
-- Sample verify; throw an error on the second test key
testVerify :: Sample -> Maybe (Int, String)
testVerify tree =
case tree of
TestBlock [_, Test a _, _] -> Just (a, "Bad")
_ -> Nothing
testMain :: IO ()
testMain = do
testExample "test test test"
putStrLn "Done"
testExample :: String -> IO ()
testExample input =
case testParse input of
Just error -> putStrLn (errorBundlePretty error)
Nothing -> putStrLn "pass"
Some parts are from other files, but the important parts are in the code.
With Template Haskell I would like to generate records, eg:
data MyRecordA = MyRecordA
{fooA :: String, barA :: Bool}
The uppercase A in MyRecordA, fooA, barA and the type Bool of the second field should be variable and specified by the caller of the TH function.
I tried with several variations of:
{-# LANGUAGE TemplateHaskell #-}
module THRecord where
import Language.Haskell.TH
mkRecord :: Name -> Name -> Q [Dec]
mkRecord name cls = [d|
data $typeName :: $constName
{$fieldFoo, $fieldBar}
|]
where
typeName = conT $ "MyRecord" <> name
constrName = RecC $ "MyRecord" <> name
fieldFoo = sigP name ($clsString)
fieldBar = sigP name cls
clsString = conT "String"
Unfortunately, I get parse errors like
src/THRecord.hs:8:9: error: parse error on input ‘$fieldFoo’
There are several issues here; lets look at them one by one. The splice you have:
[d|
data $typeName :: $constName
{$fieldFoo, $fieldBar}
|]
is simply not valid; you may only splice entire expressions, types, or declarations, and not parts thereof. You also probably meant data $typeName = $constName but of course the same restriction applies to that, so it still won't work.
The definition
fieldFoo = sigP name ($clsString)
doesn't work because you may not have an splice of a local variable without an intervening quote. This is known as the 'stage restriction'.
fieldFoo = sigP name ($clsString)
fieldBar = sigP name cls
sigP is wrong because it constructs a pattern; you don't need to build any patterns (not sure what you meant here).
typeName = conT $ "MyRecord" <> name
constrName = RecC $ "MyRecord" <> name
clsString = conT "String"
All of these are trying to treat a Name as a String. If it isn't clear why that doesn't make sense, perhaps you should familiarize yourself with the basics of Haskell.
Now the solution:
import Data.Monoid
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
defBang = Bang NoSourceUnpackedness NoSourceStrictness
stringType = ConT ''String
mkRecord :: Name -> Name -> Q [Dec]
mkRecord name cls = (pure.pure)$
DataD [] typeName [] Nothing [constr] []
where
typeName = mkName $ "MyRecord" <> nameBase name
constr = RecC typeName [(mkName $ "foo" <> nameBase name, defBang, stringType)
,(mkName $ "bar" <> nameBase name, defBang, ConT cls)]
Note that you don't even make use of the Q monad here; not to generate names, nor to reify info about names. Therefore you can actually write a function Name -> Name -> Dec and then applying pure.pure to the result produces a type which can be spliced.
The above is for GHC 8.0.1; the AST of Template Haskell varies significantly between majour releases so it may not compile exactly as is on other versions.
Then e.g.
$(mkRecord (mkName "XYZ") ''Bool)
$(mkRecord (mkName "A") ''Int)
produces
data MyRecordXYZ = MyRecordXYZ {fooXYZ :: String, barXYZ :: Bool}
data MyRecordA = MyRecordA {fooA :: String, barA :: Int}
Finally, here is a solution which doesn't require TH. The family of types you wish to generate can be represented in a first class way:
import GHC.TypeLits
data MyRecord (nm :: Symbol) t = MyRecord { foo :: String, bar :: t }
type MyRecordA = MyRecord "A" Bool
type MyRecordXYZ = MyRecord "XYZ" Int
I have a parser which parses to an ast which contains Text values. I
am trying to use this parser with quasiquoting, but the implementation
of Data for Text is incomplete. I've attached a smallish test case, when I try to compile Text.hs I get:
Text.hs:17:9:
Exception when trying to run compile-time code:
Data.Text.Text.toConstr
Code: Language.Haskell.TH.Quote.quoteExp expr " test "
Is there a way to get this working?
I read through the discussion here: http://www.haskell.org/pipermail/haskell-cafe/2010-January/072379.html
It seems that no-one has found a proper solution to this issue? Also, I tried the Data instance given there and it didn't work, I have no idea how to fix it (or how to use it since the text package already has a Data instance for Text). I don't really understand a lot of the generics stuff and how it works.
The only solution I have so far is to give up using Text in the ast and go back to using String.
{-# LANGUAGE DeriveDataTypeable #-}
module Syntax where
import Data.Data
import Data.Text
data Expr = Iden Text
| Num Integer
| AntiIden Text
deriving (Eq,Show,Data,Typeable)
---------------------
module Parser where
import Control.Applicative
import Control.Monad.Identity
import qualified Data.Text as T
import Text.Parsec hiding (many, optional, (<|>), string, label)
import Text.Parsec.Language
import qualified Text.Parsec.Token as P
import Text.Parsec.Text ()
import Syntax
parseExpr :: T.Text -> Either ParseError Expr
parseExpr s =
runParser expr () "" s
expr :: ParsecT T.Text () Identity Expr
expr =
whiteSpace >> choice
[do
_ <- char '$'
AntiIden <$> identifier
,Num <$> natural
,Iden <$> identifier
]
identifier :: ParsecT T.Text () Identity T.Text
identifier = T.pack <$> P.identifier lexer
natural :: ParsecT T.Text () Identity Integer
natural = P.natural lexer
lexer :: P.GenTokenParser T.Text () Identity
lexer = P.makeTokenParser langDef
whiteSpace :: ParsecT T.Text () Identity ()
whiteSpace = P.whiteSpace lexer
langDef :: GenLanguageDef T.Text st Identity
langDef = P.LanguageDef
{ P.commentStart = "{-"
, P.commentEnd = "-}"
, P.commentLine = "--"
, P.nestedComments = True
, P.identStart = letter <|> char '_'
, P.identLetter = alphaNum <|> oneOf "_"
, P.opStart = P.opLetter langDef
, P.opLetter = oneOf "+-*/<>="
, P.reservedOpNames= []
, P.reservedNames = []
, P.caseSensitive = False
}
-------------------
module Quasi where
import Language.Haskell.TH.Quote
import Language.Haskell.TH
import Data.Generics
import qualified Data.Text as T
import Syntax
import Parser (parseExpr)
expr :: QuasiQuoter
expr = QuasiQuoter {quoteExp = prs
,quotePat = undefined
,quoteType = undefined
,quoteDec = undefined}
where
prs :: String -> Q Exp
prs s = p s
>>= dataToExpQ (const Nothing
`extQ` antiExpE
)
p s = either (fail . show) return (parseExpr $ T.pack s)
antiExpE :: Expr -> Maybe ExpQ
antiExpE v = fmap varE (antiExp v)
antiExp :: Expr -> Maybe Name
antiExp (AntiIden v) = Just $ mkName $ T.unpack v
antiExp _ = Nothing
----------------------------
-- test.hs:
{-# LANGUAGE QuasiQuotes #-}
import Syntax
import Quasi
test,test1,test2 :: Expr
-- works
test = [expr| 1234 |]
-- works
test1 = let stuff = Num 42
in [expr| $stuff |]
-- doesn't work
test2 = [expr| test |]
main :: IO ()
main = putStrLn $ show test2
Solution: add this function using extQ to the dataToExpQ call:
handleText :: T.Text -> Maybe ExpQ
handleText x =
-- convert the text to a string literal
-- and wrap it with T.pack
Just $ appE (varE 'T.pack) $ litE $ StringL $ T.unpack x
Add an extQ for handleText where handleText explicitly takes Text to an ExpQ, rather than going through generic machinery.
Here's one for Strings, for example, that renders them more efficiently than as explicit cons cells:
handleStr :: String -> Maybe (TH.ExpQ)
handleStr x = Just $ TH.litE $ TH.StringL x
Quasiquotation as described in haskellwiki is shown mostly as useful tool for embedding other languages inside Haskell without messing around with string quotation.
Question is: For Haskell itself, how easy it would be to put existing Haskell code through a quasiquoter for the purpose of just replacing tokens and passing the result over to ghc? Perhaps Template Haskell is key here?
I have looked for code examples and didn't find any. Some EDSLs can benefit from this ability by reducing the size of their combinating operators (e.g. turn 'a .|. b .>>. c' to '[myedsl|a | b >> c]').
You can build quasi-quoters that manipulate Haskell code by, for example, using the haskell-src-meta package. It parses valid Haskell code into an AST, which you can then modify.
In this case, the easiest way to modify the AST is by using Data.Generics to apply a generic transformation to the whole AST that replaces operators with other operators.
We'll begin by building the transformation function for generic Haskell expressions. The data type that represents an expression is Exp in the template-haskell package.
For example, to convert the operator >> to .>>. we'd use a function like
import Language.Haskell.TH (Exp(..), mkName)
replaceOp :: Exp -> Exp
replaceOp (VarE n) | n == mkName ">>" = VarE (mkName ".>>.")
replaceOp e = e
This changes a variable expression (VarE), but cannot do anything to any other kind of expressions.
Now, to walk the whole AST and to replace all occurrences of >> we'll use the functions everywhere and mkT from Data.Generic.
import Data.Generics (everywhere, mkT)
replaceEveryOp :: Exp -> Exp
replaceEveryOp = everywhere (mkT replaceOp)
In order to make several replacements, we can alter the function so that it takes an association list of any operator to replace.
type Replacements = [(String, String)]
replaceOps :: Replacements -> Exp -> Exp
replaceOps reps = everywhere (mkT f) where
f e#(VarE n) = case rep of
Just n' -> VarE (mkName n')
_ -> e
where rep = lookup (show n) reps
f e = e
And by the way, this is a good example of a function that is much nicer to write by using the view patterns language extension.
{-# LANGUAGE ViewPatterns #-}
replaceOps :: Replacements -> Exp -> Exp
replaceOps reps = everywhere (mkT f) where
f (VarE (replace -> Just n')) = VarE (mkName n')
f e = e
replace n = lookup (show n) reps
Now all that's left for us to do is to build the "myedsl" quasi-quoter.
{-# LANGUAGE ViewPatterns #-}
import Data.Generics (everywhere, mkT)
import Language.Haskell.Meta.Parse (parseExp)
import Language.Haskell.TH (Exp(..), mkName, ExpQ)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
type Replacements = [(String, String)]
replacements :: Replacements
replacements =
[ ("||", ".|.")
, (">>", ".>>.")
]
myedls = QuasiQuoter
{ quoteExp = replaceOpsQ
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
replaceOpsQ :: String -> ExpQ
replaceOpsQ s = case parseExp s of
Right e -> return $ replaceOps replacements e
Left err -> fail err
replaceOps :: Replacements -> Exp -> Exp
replaceOps reps = everywhere (mkT f) where
f (VarE (replace -> Just n')) = VarE (mkName n')
f e = e
replace n = lookup (show n) reps
If you save the above to its own module (e.g. MyEDSL.hs), then you can import it and use the quasi-quoter.
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
import MyEDSL
foo = [myedsl| a || b >> c |]
Note that I've used || instead of | because the latter is not a valid operator in Haskell (since it's the syntactic element used for pattern guards).