I am implementing a DSL that is based on using standard haskell functions/combinators to build database queries. From an implementation POV I decided to represent variables in the query like this:
newtype Variable = Var { fromVar :: Text }
this however forces the user to write Var "something" quite often, so I decided to
write a quasiquoter that does this automatically.
here is an example for the DSL:
{-# LANGUAGE OverloadedStrings #-}
maxQuery :: Query MAX
maxQuery = match
( sch `isa` "school"
$ forWhich "ranking" `labelMatches` ran $ε)
`get` [ran]
`max` [ran]
where
[sch,ran] = map Var ["sch","ran"]
what I would like it to be:
maxQuery :: Query MAX
maxQuery = match
( sch `isa` "school"
$ forWhich "ranking" `labelMatches` ran $ε)
`get` [ran]
`max` [ran]
where [defVars| sch ran |]
or something similar to this.
the quasiquoter i wrote is here:
{-# LANGUAGE TemplateHaskell #-}
module TypeDBTH where
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.List.Split
import Data.Text (pack)
mkVars :: [String] -> Dec
mkVars vars = ValD
(ListP (map (VarP . mkName) vars))
(NormalB (ListE (map (\v -> AppE (ConE $ mkName "Var")
$ AppE (VarE $ mkName "pack")
(LitE $ StringL v))
vars)))
[]
defVars :: QuasiQuoter
defVars = QuasiQuoter { quoteDec = quoteVars }
--, quoteExp = expQuoteVars }
quoteVars :: String -> Q [Dec]
quoteVars = return . return . mkVars . filter (/= "") . splitOn " "
expQuoteVars :: String -> Q Exp
expQuoteVars s = return $ LetE [(mkVars . filter (/= "") . splitOn " " $ s)] (LitE $ StringL "x")
originally I only wrote quoteVars. for testing in ghci I added expQuoteVars.
However, removing the latter one now and trying to write
...
where [defVars| sch ran |]
leaves me with two errors:
lib/TypeDBQuery.hs:806:1: error:
parse error (possibly incorrect indentation or mismatched brackets)
because of the where [quasiquoter] with nothing after it
and
lib/TypeDBQuery.hs:807:5: error:
• Exception when trying to run compile-time code:
lib/TypeDBTH.hs:18:11-46: Missing field in record construction quoteExp
Code: Language.Haskell.TH.Quote.quoteExp defVars " sch ran "
• In the quasi-quotation: [defVars| sch ran |]
|
807 | x = [defVars| sch ran |]
| ^^^^^^^^^^^^^^^^^^^^
how can i use the quasiquoter for a quoteDec instead of quoteExp?
is this possible at all?
I would also be open to use it like this if this is easier then:
maxQuery :: Query MAX
maxQuery = let [defVars | sch ran |] in
$ match
( sch `isa` "school"
$ forWhich "ranking" `labelMatches` ran $ε)
`get` [ran]
`max` [ran]
i took a look at the "tutorials" and info sites of wiki.haskell.org and the TH modules but could not figure out how to do this...
https://wiki.haskell.org/Template_Haskell#What_to_do_when_you_can.27t_splice_that_there
https://wiki.haskell.org/Quasiquotation
https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial
You can only use declaration quasi quotes in top-level declarations unfortunately. From the documentation:
A quasiquote may appear in place of
An expression
A pattern
A type
A top-level declaration
Instead of using TH, you could consider using OverloadedStrings:
instance IsString Variable where
fromString str = Var (pack str)
maxQuery :: Query MAX
maxQuery = match
( "sch" `isa` "school"
$ forWhich "ranking" `labelMatches` "ran" $ε)
`get` ["ran"]
`max` ["ran"]
Related
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?
Is it possible to write code in the following spirit:
data EventTable = "table1" | "table2" | "some_other_table"
case eventTable of
"table1" -> -- do something
"table2" -> -- do something else
"some_other_table" -> -- do something else
"unknown_table"-> -- SHOULD NOT COMPILE
I'm trying to work directly with the string literals that a remote API provides, instead of first mapping them to a regular Haskell sum-type/ADT and having to write serialisation and deserialisation functions for it.
Haskell doesn't have anything like TypeScript's string literal types (which are singleton types: TypeScript will only allow you to use a given string if it can tell that you've checked the string does indeed fit the type), and the best way is probably to just hand-roll a regular datatype and a simple smart constructor. But as #chi points out in the comments, if you have a lot of strings to deal with this is probably a job for code generation.
We'll write a Template Haskell helper to turn splices like
stringLitTy "Foo" ["bar", "baz"]
into a data declaration, a smart constructor, and a toString function:
data Foo = Bar | Baz deriving (Eq, Ord, Bounded, Enum, Show, Read)
mkFoo :: String -> Maybe Foo
mkFoo "bar" = Just Bar
mkFoo "baz" = Just Baz
mkFoo _ = Nothing
fooToString :: Foo -> String
fooToString Bar = "bar"
fooToString Baz = "baz"
The code to do this is simple enough, so if you're not familiar with TH this'll be a good crash course.
First let's create some names for the type and the functions, and a mapping from the string literals to some constructor names.
{-# LANGUAGE TemplateHaskell #-}
module StringLit where
import Data.Char
import Language.Haskell.TH
legaliseCon :: String -> String
legaliseCon (x:xs) = toUpper x : map (\c -> if not (isAlphaNum c) then '_' else c) xs
legaliseFun :: String -> String
legaliseFun (x:xs) = toLower x : map (\c -> if not (isAlphaNum c) then '_' else c) xs
stringLitTy :: String -> [String] -> Q [Dec]
stringLitTy typeName strs =
let tyName = mkName $ legaliseCon typeName
constrName = mkName $ legaliseFun ("mk" ++ typeName)
toStringName = mkName $ legaliseFun (typeName ++ "ToString")
conNames = [(n, mkName $ legaliseCon n) | n <- strs]
in sequenceA [
mkDataDecl tyName (map snd conNames),
mkConstrDecl constrName conNames,
mkToStringDecl toStringName conNames
]
legaliseCon and legaliseFun are blunt instruments to get a string into a form which is valid for a constructor or a function. (There's definitely room for improvement there!) stringLitTy calls mkDataDecl, mkConstrDecl and mkToStringDecl, below, to generate the top-level declarations. They're all pretty simple: mkDataDecl calls dataD to construct the datatype declaration with an appropriate deriving clause.
enumClasses = sequenceA [
[t| Eq |],
[t| Ord |],
[t| Bounded |],
[t| Enum |],
[t| Show |],
[t| Read |]
]
mkDataDecl :: Name -> [Name] -> Q Dec
mkDataDecl tyName conNames =
dataD
(return []) -- datatype context
tyName -- name
[] -- type parameters
Nothing -- kind annotation
[normalC n [] | n <- conNames] -- constructors, none of which have any parameters
enumClasses -- "deriving" classes
mkConstrDecl uses funD to generate the code for the smart constructor (mkFoo), based on the mapping from strings to the generated constructors' names.
mkConstrDecl :: Name -> [(String, Name)] -> Q Dec
mkConstrDecl name map = funD name $ [
clause
[litP $ stringL str] -- the string literal pattern on the LHS
(normalB $ appE [| Just |] (conE con)) -- Just Con on the RHS
[] -- where clauses
| (str, con) <- map]
++ [clause [wildP] (normalB $ [| Nothing |]) []] -- mkFoo _ = Nothing
And mkToStringDecl does much the same, except the constructors are on the left hand side and the string literals are on the right. And there's need for a wildcard clause or the Maybe.
mkToStringDecl :: Name -> [(String, Name)] -> Q Dec
mkToStringDecl name map = funD name [
clause
[conP con []]
(normalB $ litE $ stringL str)
[]
| (str, con) <- map]
So, if I import StringLit in another module and write a splice,
{-# LANGUAGE TemplateHaskell #-}
module Test where
import StringLitTy
stringLitTy "EventTable" ["table1", "table2", "some_other_table"]
I can perform case analysis on the constructors of the generated EventTable type. It's not exactly what you asked for in the question, but I think it gets you 90% of the way there.
tableNumber Table1 = Just 1
tableNumber Table2 = Just 2
tableNumber Some_other_table = Nothing
-- for good measure:
ghci> :l Test
[1 of 2] Compiling StringLitTy ( StringLitTy.hs, interpreted )
[2 of 2] Compiling Test ( Test.hs, interpreted )
Ok, modules loaded: Test, StringLitTy.
ghci> :bro
data EventTable = Table1 | Table2 | Some_other_table
mkEventTable :: [Char] -> Maybe EventTable
eventTableToString :: EventTable -> [Char]
ghci> tableNumber Table1
Just 1
Oh, one more thing: since the Q monad allows you to run IO actions in your splices, you can (say) query the database to get your table names. Template Haskell programming is "just programming", so you can do all the usual Monad stuff with Q (like traverse):
getTablesFromDb :: IO [(String, [String])]
getTablesFromDb = {- ... -}
mkTables :: Q [Dec]
mkTables = do
tables <- runIO getTablesFromDb
concat <$> traverse (uncurry stringLitTy) tables
I know there is a Paginator package for Yesod but I prefer a simpler UI so I was creating a simple pagination logic for my app. However, I couldn't figure out a way to convert the parameter value to Integer.
import Data.Text (unpack, singleton)
import Data.Maybe
one = singleton '1' -- convert char to Text, required by fromMaybe
getTestPanelR :: Handler Html
getTestPanelR = do
ptext <- lookupGetParam "p" -- guessing returns Maybe Text
p <- fromMaybe one ptext -- ??? does not work
-- pn <- ??? Once p is extracted successfully, how to convert to an integer?
s <- runDB $ selectList [] [Asc PersonName, LimitTo 10 , OffsetBy $ (pn - 1) * 10]
(widget, enctype) <- generateFormPost $ entryForm Nothing
defaultLayout $ do
$(widgetFile "person")
When I run the above Code I get the following error message:
No instance for (MonadHandler Maybe)
arising from a use of `lookupGetParam'
Possible fix: add an instance declaration for (MonadHandler Maybe)
In the second argument of `($)', namely `lookupGetParam "p"'
In a stmt of a 'do' block:
p <- fromMaybe one $ lookupGetParam "p"
In the expression:
...
When I write out 'ptext' using #{show ptext} it shows Just "1". Having gotten the GET parameter, how do I convert it to an integer so I can do pagination? (need to add 1 for 'next' and subtract 1 for 'prev')
FWIW, when I try this using GHCi, it works fine:
Prelude Data.Maybe Data.Text> let one = singleton '1'
Prelude Data.Maybe Data.Text> let x = Just $ singleton '5'
Prelude Data.Maybe Data.Text> let y = fromMaybe one x
Prelude Data.Maybe Data.Text> y
"5"
Prelude Data.Maybe Data.Text> read $ Data.Text.unpack y ::Int -- This is probably unsafe because I cannot trust 'y' in my web app
5
Update:
I tired #Ankur's suggestion pageNumber <- (lookupGetParam "p" >>= return . (read :: String -> Int) . fromMaybe "1") and I get the following error:
Couldn't match expected type `String' with actual type `Text'
Expected type: Maybe Text -> String
Actual type: Maybe Text -> Text
In the return type of a call of `fromMaybe'
In the second argument of `(.)', namely `fromMaybe "1"'
Build failure, pausing...
If change the "1" to one (Data.Text.singleton '1'), I still get the exact same error message.
Thanks!
lookupGetParam returns ParamValue which is type ParamValue = String. So basically it is String rather than Text.
Try this:
pageNumber <- (lookupGetParam "p" >>= return . (read :: String -> Int) . fromMaybe "1")
UPDATE:
Actually the latest version of lookupGetParam is Text based so adding the OverloadedStrings language extension should get the job done:
Put this {-# LANGUAGE OverloadedStrings #-} at the start of the code file and use:
pageNumber <- (lookupGetParam "p" >>= return . (read :: String -> Int) . unpack . fromMaybe "1")
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
I am writing a simple HashString class, which is just a string and its hash:
data HashString = HashString Int -- ^ hash
T.Text -- ^ string!
Now I'm trying to generate these at compile time with something like:
$(hString "hello, world") :: HashString
I want the hash, and the text packing to happen at compile time. How do I do this?
Here's what I've tried so far, but I'm not sure if its right, nor am I sure it does everything at compile time:
hString :: String -> Q Exp
hString s = [| HashString (hash $ T.pack s) (T.pack s) |]
The way you've written your code, no evaluation will happen at compile-time. When you quote a Haskell expression with [| ... |], the quoted code/AST is inserted where you apply it without any evaluation, so writing:
$(hString "hello, world")
is exactly the same as writing:
let s = "hello, world" in HashString (hash $ T.pack s) (T.pack s)
But think about it like this: you use [| ... |] to quote an expression to be inserted later, and you generate code at compile-time with $(...). So, if you include some code $(foo) in a quoted expression bla = [| bar $(foo) |], doing $(bla) will generate the code bar $(foo), which in turn will evaluate foo at compile time. Also, to take a value that you generate at compile time and generate an expression from it, you use the lift function. So, what you want to do is this:
import Data.String (fromString)
import Language.Haskell.TH.Syntax
hString s = [| HashString $(lift . hash . T.pack $ s) (fromString s) |]
This evaluates the hash function at compile time, since the inner splice is resolved after the outer splice was resolved. By the way, using fromString from Data.String is the generic way of constructing some OverloadedString data type from a String.
Also, you should consider making a quasi-quoter for your HashString interface. Using quasi-quoters is more natural than manually calling splice functions (And you've already used them; the nameless [| ... |] quoter quotes Haskell expressions).
You would create a quasiquoter like this:
import Language.Haskell.TH.Quote
hstr =
QuasiQuoter
{ quoteExp = hString -- Convenient: You already have this function
, quotePat = undefined
, quoteType = undefined
, quoteDec = undefined
}
This would let you write HashStrings with this syntax:
{-# LANGUAGE QuasiQuotes #-}
myHashString = [hstr|hello, world|]