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
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 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?
I am new to Haskell, so maybe I am missing some fundamental concepts here (or maybe failed to find the appropriate extension). I was wondering if there was a way to optimize or further abstract the following scenario. This code seems very redundant.
Let's say I have the following data classes:
data Person = Person
{ personName :: !String
, personAge :: !Int
} deriving Show
data Dog = Dog
{ dogName :: !String
, dogAge :: !Int
} deriving Show
Let's say I have a service and I'm only concerned with outputing records as strings. In reality, the strings will probably be JSON and the records fetched from the DB, but let's take a simpler case. I basically need a URL token to fetch an appropriate object (say, the string "dog" will get me a Dog, or even just the Haskell "show" string, without expressly declaring it as (value)::Dog).
I have attempted to implement this in several ways...the only thing that seems to work is the following:
data Creature = DogC Dog
| PersonC Person
deriving Show
fromString :: String -> Maybe Creature
fromString "dog" = Just $ DogC $ Dog "muffin" 8
fromString "person" = Just $ PersonC $ Person "John" 22
fromString _ = Nothing
main :: IO ()
main = do
putStrLn $ show $ fromString "dog"
I'm not entirely fond of the new type, nor the list of fromString declarations. And to benefit from the original data declarations, I would probably need to write a similarly tedious expression (eg, "fromCreature") to revert Creature back into my original types. This information might change, so I would probably need TH for a few of the declarations...
Is there a way around some of this? I fiddled with GADTs and classes, but both seemed to be dependent on type- rather than value- based polymorphism (A string identifier tends to cause issues with ambiguous instances). It would be nice to map the constructor to a string (Say, with Data.Map), but constructors often have different kinds.
Update
So, I went with an approach that isn't exactly relevant to the question I had asked, but it may be useful to someone. I did want to maintain some record types, but most didn't add much value and were getting in my way. The steps I had followed went something like:
Use a different/lower-level DB driver, that returns workable types (eg, [ColumnDef] and [[SQLValue]] instead of tuples and records...).
Create ToJSON instances for SQLValue -- most of the types were covered, except a few ByteString types, and I had to handle the conversion of SQLNull to Null. To maintain compatibility with some record types, my default handler looked like: toJSON = genericToJSON defaultOptions { sumEncoding = UnTaggedValue} The untagged value should allow one to read the JSON into defined data types (eg, Dog / Person ) if desired....
Given that column name is accessible from ColumnDef, I wrote an expression that zips [ColumnDef] and [SqlValue] to a list of Aeson-compatible key-value pairs, eg: toJsPairs :: [ColumnDef] -> [SqlValue] -> [(Text,Value)]
Then, I wrote an expression to fetch the JSON from a table name, which more or less serves as my "universal dispatcher." It references a list of authorized tables, so it's less crazy than it might sound.
The code looked a bit like this (using mysql-haskell).
{-# LANGUAGE OverloadedStrings #-}
import qualified Control.Applicative as App
import Database.MySQL.Base
import qualified System.IO.Streams as Streams
import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.Types
import Data.Text.Encoding
import Data.String (fromString)
import Data.ByteString.Internal
import qualified Data.ByteString.Lazy.Internal as BLI
import Data.HashMap.Strict (fromList)
appConnectInfo = defaultConnectInfo {
ciUser = "some_user"
, ciPassword = "some_password"
, ciDatabase = "some_db"
}
instance FromJSON ByteString where
parseJSON (String s) = pure $ encodeUtf8 s
parseJSON _ = App.empty
instance ToJSON ByteString where
toJSON = String . decodeUtf8
instance ToJSON MySQLValue where
toJSON (MySQLNull) = Null
toJSON x = genericToJSON defaultOptions
{ sumEncoding = UntaggedValue } x
-- This expression should fail on dimensional mismatch.
-- It's stupidly lenient, but really dimensional mismatch should
-- never occur...
toJsPairs :: [ColumnDef] -> [MySQLValue] -> [(Text,Value)]
toJsPairs [] _ = []
toJsPairs _ [] = []
toJsPairs (x:xs) (y:ys) = (txt x, toJSON y):toJsPairs xs ys
where
-- Implement any modifications to the key names here
txt = decodeUtf8.columnName
listRecords :: String -> IO BLI.ByteString
listRecords tbl = do
conn <- connect appConnectInfo
-- This is clearly an injection vulnerability.
-- Implemented, however, the values for 'tbl' are intensely
-- vetted. This is just an example.
(defs, is) <- query_ conn $ fromString ( "SELECT * FROM `" ++ tbl ++ "` LIMIT 100")
rcrds <- Streams.toList is
return $ encodePretty $ map (jsnobj defs) rcrds
where
jsnobj :: [ColumnDef] -> [MySQLValue] -> Value
jsnobj defs x = Object $ fromList $ toJsPairs defs x
If what you want to consume at the end is json value - it might make sense to
represent result as json value using aeson library:
{-# LANGUAGE DeriveGeneric #-}
import Data.Aeson
import GHC.Generics
data Dog = Dog Int String deriving (Show, Generic)
data Cat = Cat Int String deriving (Show, Generic)
-- here I'm using instance derived with generics, but you can write one by
-- hands
instance ToJSON Dog
instance ToJSON Cat
-- actions to get stuff from db
getDog :: Monad m => Int -> m Dog
getDog i = return (Dog i (show i))
getCat :: Monad m => Int -> m Cat
getCat i = return (Cat i (show i))
-- dispatcher - picks which action to use
getAnimal :: Monad m => String -> Int -> m (Maybe Value)
getAnimal "dog" i = Just . toJSON <$> getDog i
getAnimal "cat" i = Just . toJSON <$> getCat i
getAnimal _ _ = return Nothing
main :: IO ()
main = do
getAnimal "dog" 2 >>= print
getAnimal "cat" 3 >>= print
getAnimal "chupakabra" 12 >>= print
High energy magic version
class Monad m => MonadAnimal m where
-- basically you want something that fetches extra argumets from HTTP or
-- whatevere, perform DB query and so on.
class Animal a where
animalName :: Proxy a -> String
animalGetter :: MonadAnimal m => m a
locateAnimals :: MonadAnimal m => Q [(String, m Value)]
locateAnimals -- implement using TH (reify function is your friend). It should look for
-- all the animal instances in scope and make a list from them with serialized
-- fetcher.
-- with that in place dispatcher should be easy to implement
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
In GenericPretty, there is an Out class with a default implementation by using GHC.Generic magic.
As you can see that I defined Person data type, and if I want to implement Out class I have to write 3 times manually since Person used Address and Names data types which should be also the instances of Out class.
I want to generate the instance declaration automatically with Template Haskell. The procedure seems simple.
1, Generate instance A for Person and seek the types which are used to define Person.
2, If the type used to define Person is not an instance A, generate it recursively.
However, gen function will not work. The code generation will not stop, I am not sure why. it could be the problem with mapM if you comment it out, the last line in gen will work.
{-# LANGUAGE CPP, TemplateHaskell,StandaloneDeriving, DeriveGeneric, DeriveDataTypeable #-}
module DerivingTopDown where
import Language.Haskell.TH
import GHC.Generics
import Data.Data
import Data.Proxy
import Control.Monad
import Text.PrettyPrint.GenericPretty
import Data.List
import Debug.Trace
import Control.Monad.State
import Control.Monad.Trans
data Person = Person Names Address
| Student Names Address
deriving (Show, Generic, Eq, Ord , Data,Typeable)
data Names = Names String
deriving (Show, Generic, Eq, Ord, Data, Typeable)
data Address = Address String
deriving (Show, Generic, Eq, Ord, Typeable, Data)
{-
data T a b = C1 a | C2 b
instance (Out a , Out b) => Out (T a b)
([],[NormalC Main.Person [(NotStrict,ConT Main.Names),(NotStrict,ConT Main.Address)],
NormalC Main.Student [(NotStrict,ConT Main.Names),(NotStrict,ConT Main.Address)]])
-}
-- instance Out Address
-- instance Out Names
-- instance Out Person
--- class name -> type name, use a stateT to store a dictionary
gen :: Name -> Name -> StateT [Name] Q [Dec]
gen cla typ = do
(tys, cons) <- lift (getTyVarCons typ)
let typeNames = map tvbName tys
let instanceType = foldl' appT (conT typ) $ map varT typeNames
let context = applyContext cla typeNames
let decltyps = (conT cla `appT` instanceType)
isIns <- lift (typ `isInstanceOf` cla)
table <- get
if isIns || elem typ table -- if it is already the instnace or we have generated it return []
then return []
else do
dec <- lift $ fmap (:[]) $ instanceD context decltyps []
modify (typ:) -- add the generated type to dictionary
let names = concatMap getSubType cons
xs <- mapM (\n -> gen cla n) names
return $ concat xs ++ dec
--return dec -- works fine if do not generate recursively by using mapM
f = (fmap fst ((runStateT $ gen ''Out ''Person) []))
getSubType :: Con -> [Name]
getSubType (NormalC n sts) = map type1 (map snd sts)
type1 :: Type -> Name
type1 (ConT n) = n
tvbName :: TyVarBndr -> Name
tvbName (PlainTV name ) = name
tvbName (KindedTV name _) = name
applyContext :: Name -> [Name] -> Q [Pred]
applyContext con typeNames = return (map apply typeNames)
where apply t = ClassP con [VarT t]
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf ty inst = do
t1 <- conT (ty)
isInstance inst [t1]
getTyVarCons :: Name -> Q ([TyVarBndr], [Con])
getTyVarCons name = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD _ _ tvbs cons _ -> return (tvbs,cons)
NewtypeD _ _ tvbs con _ -> return (tvbs,[con])
-- pp = $(stringE . show =<< getCons ''Person)
pp1 name = stringE.show =<< name
isi name = do
t1 <- [t| $name |]
isInstance ''Out [t1]
You have some incomplete function definitions (e.g. type1, tvbName, getTyVarCons) and I am running into that.
I inserted a trace statement in DerivingTopDown.hs at the entry to gen:
import Debug.Trace
...
gen cla typ = trace ("=== typ: " ++ show typ) $ do
...
and then loaded this file into ghci:
{-# LANGUAGE TemplateHaskell #-}
import DerivingTopDown
f
and got the following output:
=== typ: DerivingTopDown.Person
=== typ: DerivingTopDown.Names
=== typ: GHC.Base.String
th.hs:1:1:
Exception when trying to run compile-time code:
DerivingTopDown.hs:(80,17)-(82,68): Non-exhaustive patterns in case
Code: f
Failed, modules loaded: DerivingTopDown.
So it recursed down to GHC.Base.String and then failed in getTyVarCons because the dec for this type is:
dec = TySynD GHC.Base.String [] (AppT ListT (ConT GHC.Types.Char))
which isn't handled by the inner case statement in getTyVarCons.