Suppose you're writing some Template Haskell code that transforms record declarations. The first transformation you would want to write is the identity one, right? So let's go over the fields and not change them:
module TH where
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
foo :: DecsQ -> DecsQ
foo = fmap $ map $ \d -> case d of
DataD _ dataName tvbs Nothing [con#(RecC conName fields)] [] ->
DataD [] dataName
tvbs
Nothing
[RecC conName $ map transformField fields]
[]
_ -> d
-- TODO: Write my awesome transformation here
transformField :: VarBangType -> VarBangType
transformField (v, b, t) = (v, b, t)
You try it out in a module with a record type:
{-# LANGUAGE TemplateHaskell #-}
import TH
foo [d| data R = MkR{ x :: Int } |]
So far so good. However, things break if we turn on DuplicateRecordFields in our program, even though we haven't written transformField yet (i.e. it is still the identity function):
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}
import TH
foo [d| data R = MkR{ x :: Int } |]
This program now fails to compile, with the following message:
Use.hs:5:1: error:
Illegal variable name: $sel:x:MkR
When splicing a TH declaration:
data R_0 = MkR_1 {$sel:x:MkR_2 :: GHC.Types.Int}
Even this super-minimal program fails with a similar error:
{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-}
$([d| data R = MkR{ x :: Int } |])
There's not much mystery why this happens: as the DuplicateRecordFields documentation explains, field selectors are mangled to be unique accross all record types, and TH gets these mangled field names.
But how to solve this is not explained on that same page. For now, I am using the following function to unmangle a mangled field name into something that roundtrips accross data declaration splices:
import Data.List.Split
unmangle :: Name -> Name
unmangle (Name occ flavour) = Name occ' flavour
where
occ' = case wordsBy (== ':') (occString occ) of
["$sel", fd, _qual] -> mkOccName fd
_ -> occ
transformField :: VarBangType -> VarBangType
transformField (v, b, t) = (unmangle v, b, t)
This works, but doesn't feel like the right solution, and probably won't survive changes to GHC-internal details of name mangling. Is there a better way to do this?
Related
I have recently started playing around with liquid haskell, and from all of the tutorials I could find, I could not find any examples like the following.
data MaybePerson = MaybePerson {
name' :: Maybe String,
age' :: Maybe Int
}
data Person = Person {
name :: String,
age :: Int
}
{-# measure p :: MaybePerson -> Bool #-}
p (MaybePerson (Just _) (Just _)) = True
p _ = False
{-# type JustPerson = {x:MaybePerson | p x} #-}
-- Attempts to instantiate a maybe person into a concrete Person
{-# getPerson :: JustPerson -> Person #-}
getPerson (MaybePerson (Just name) (Just age)) = Person name age
getPerson _ = undefined
If I try the following, my module does not type-check, as expected:
test = getPerson (MaybePerson Nothing Nothing)
However, for some reason, the following still does not type check:
test2 = getPerson (MaybePerson (Just "bob") (Just 25))
and I get the error
Error: Liquid Type Mismatch
36 | test2 = getPerson (MaybePerson (Just "bob") (Just 25))
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Inferred type
VV : {v : MaybePerson | v == ?a}
not a subtype of Required type
VV : {VV : MaybePerson | Blank.p VV}
In Context
?a : MaybePerson
Moreover, if I leave out the getPerson _ = undefined line, I get
Your function is not total: not all patterns are defined.
Even though clearly this function is total because of the precondition specified with liquidhaskell.
What am I doing wrong here? I essentially just want to be able to reason with subtypes of a Maybe a type which are coming from the Just constructor, but I couldn't find any examples anywhere of where to do this properly.
sorry for the late reply! I should find some way to get notified about questions. Ok, there are two things going on, both of which we should fix!
First, there is something glitchy happening with
{-# measure p :: MaybePerson -> Bool #-}
The right syntax is just
{-# measure p #-}
p :: MaybePerson -> Bool
But there was no error message, so there's no way for you to know!
Second, when I change the above I still get some strange error about
GHC.Maybe -- I can't recall the exact issue right now, will fix
on my laptop, but for illustration, I tweaked your code to:
{-# LIQUID "--exact-data-cons" #-}
import Prelude hiding (Maybe (..))
data Maybe a = Just a | Nothing
To redefine Maybe. This should not be needed will figure out a fix ASAP
With this, your code works as is, e.g. see here
http://goto.ucsd.edu/liquid/index.html#?demo=permalink%2F1573693313_399.hs
So you can now define
{-# getPerson :: JustPerson -> Person #-}
getPerson (MaybePerson (Just name) (Just age)) = Person name age
and just remove the equation for the other cases. Further,
test1 = getPerson (MaybePerson Nothing Nothing) -- error
yields a type error, but the below is safe
test2 = getPerson (MaybePerson (Just "bob") (Just 25)) -- ok
Thanks for pointing this out, will fix!
I was looking at the penultimate example in this blog post (also here), and after verifying it ran, it seemed to confirm that lens can generate Has typeclasses, which I take was the implication from the author of the blog. However, I miss where this is described, either in the lens contents or the lens tutorial. Any explanations external to official docs for how this is done would also be welcome. But it seems like this may just be standard when using the most basic feature (makeLenses, or in this case, makeLensesWith).
Here is the reproduced code:
#!/usr/bin/env stack
-- stack --resolver lts-8.12 script
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
import Control.Concurrent.Async.Lifted.Safe
import Control.Monad.Reader
import Control.Concurrent.STM
import Say
import Control.Lens
import Prelude hiding (log)
data Env = Env
{ envLog :: !(String -> IO ())
, envBalance :: !(TVar Int)
}
makeLensesWith camelCaseFields ''Env
modify :: (MonadReader env m, HasBalance env (TVar Int), MonadIO m)
=> (Int -> Int)
-> m ()
modify f = do
env <- ask
liftIO $ atomically $ modifyTVar' (env^.balance) f
logSomething :: (MonadReader env m, HasLog env (String -> IO ()), MonadIO m)
=> String
-> m ()
logSomething msg = do
env <- ask
liftIO $ (env^.log) msg
main :: IO ()
main = do
ref <- newTVarIO 4
let env = Env
{ envLog = sayString
, envBalance = ref
}
runReaderT
(concurrently
(modify (+ 1))
(logSomething "Increasing account balance"))
env
balance <- readTVarIO ref
sayString $ "Final balance: " ++ show balance
Field is the word lens uses to describe the pattern of one class per named field, allowing multiple records with the same field name but (optionally) different types. So camelCaseFields, makeFieldOptics, defaultFieldRules all say in their name that they will generate these HasFoo classes, in the usual terse style of lens.
makeClassy also generates classes named Has*, but named after the data type, not the record field, and not following a different pattern.
Your code above generates the following code (shown with -ddump-splices):
makeLensesWith camelCaseFields ''Env
======>
class HasBalance s a | s -> a where
balance :: Lens' s a
instance HasBalance Env (TVar Int) where
{-# INLINE balance #-}
balance f_a4eTr (Env x1_a4eTs x2_a4eTt)
= (fmap (\ y1_a4eTu -> (Env x1_a4eTs) y1_a4eTu)) (f_a4eTr x2_a4eTt)
class HasLog s a | s -> a where
log :: Lens' s a
instance HasLog Env (String -> IO ()) where
{-# INLINE log #-}
log f_a4eTx (Env x1_a4eTy x2_a4eTz)
= (fmap (\ y1_a4eTA -> (Env y1_a4eTA) x2_a4eTz)) (f_a4eTx x1_a4eTy)
Using yesod and persistent, I made what I think is a handy type to handle Markdown data:
{-# LANGUAGE OverloadedStrings #-}
module Utils.MarkdownText where
import Prelude
import Data.Text.Lazy
import Data.Text as T
import Database.Persist
import Database.Persist.Sql
import Text.Blaze
import Text.Markdown
newtype MarkdownText = MarkdownText { rawMarkdown :: T.Text }
instance PersistField MarkdownText where
toPersistValue = PersistText . rawMarkdown
fromPersistValue (PersistText val) = Right $ MarkdownText { rawMarkdown = val }
fromPersistValue _ = Left "invalid type"
instance PersistFieldSql MarkdownText where
sqlType _ = SqlString
instance ToMarkup MarkdownText where
toMarkup = (markdown def) . fromStrict . rawMarkdown
preEscapedToMarkup = toMarkup . rawMarkdown
You may notice in the ToMarkup instance I use def to get markdown parameters. If I would like to change these settings, and not have it hardcoded in this module, what are my options?
I have considered the option of making MarkdownText take the settings information as a parameter, but what other options are there (if any)?
I'm going to simplify the problem so that we only need core libraries. We want to change how we Show a MarkdownText based on some ExampleSettings that contain a prefix and a suffix.
{-# LANGUAGE OverloadedStrings #-}
import Data.Text as T
import Data.Monoid
import Data.String
newtype MarkdownText = MarkdownText { rawMarkdown :: T.Text}
instance IsString MarkdownText where
fromString = MarkdownText . fromString
data ExampleSettings = ExampleSettings { prefix :: T.Text, suffix :: T.Text }
def = ExampleSettings "" ""
emphasise = def { prefix = "*", suffix = "*" }
showWithSettings :: ExampleSettings -> T.Text -> String
showWithSettings set = show . (\x -> prefix set <> x <> suffix set)
instance Show MarkdownText where
show = showWithSettings def . rawMarkdown
main = print $ MarkdownText "Hello World"
There are a number of options for how to solve this problem, first at the value level, then at the type level, and finally globally at the type level.
Add a field
We have a few options for how we can proceed. The simplest option is to add the setting at the value level. We'll wrap up the settings with the MarkdownText.
data ConfiguredMarkdownText = ConfiguredMarkdownText {
markdownText :: MarkdownText,
settings :: ExampleSettings }
instance Show ConfiguredMarkdownText where
show t = showWithSettings (settings t) (rawMarkdown . markdownText $ t)
main = print $ ConfiguredMarkdownText "Hello World" emphasise
For convenience, we added an IsString instance for MarkdownText in the first section.
Add a type parameter
We could carry the extra data we need around at the type level instead of at the value level. We add a type parameter to MarkdownText to indicate which settings to use.
newtype MarkdownText s = MarkdownText { rawMarkdown :: T.Text}
We make types to represent the possible settings
data Def = Def
data Emphasise = Emphasise
We can add a type class for types that determine settings, and instances for the possible settings.
{-# LANGUAGE FunctionalDependencies #-}
class Setting v k | k -> v where
setting :: proxy k -> v
instance Setting ExampleSettings Def where
setting _ = def
instance Setting ExampleSettings Emphasise where
setting _ = emphasise
We can Show any MarkdownText s as long as s provides the Setting.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
instance (Setting ExampleSettings s) => Show (MarkdownText s) where
show t = showWithSettings (setting t) (rawMarkdown t)
main = print ("Hello World" :: MarkdownText Emphasise)
MarkdownText :: * -> * requires a slightly different IsString instance.
instance IsString (MarkdownText s) where
fromString = MarkdownText . fromString
Reflect the value from a type parameter
The reflection package provides a way to temporarily associate a value with a type. This lets us do the same thing as in the previous example, but without needing to make types of our own to represent the settings.
import Data.Reflection
We start by adding an extra type parameter to MarkdownText, the same as in the previous section.
newtype MarkdownText s = MarkdownText { rawMarkdown :: T.Text}
The reflection package defines a class, Reifies, that is almost identical to the Setting class we made for the previous section. This lets us jump straight to defining the Show instance.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
instance (Reifies s ExampleSettings) => Show (MarkdownText s) where
show t = showWithSettings (reflect t) (rawMarkdown t)
We'll define a little convenience function to tag the type parameter of MarkdownTexts
markdownText :: proxy s -> T.Text -> MarkdownText s
markdownText _ = MarkdownText
and complete the example of setting the ExampleSettings to be used when showing a MarkdownText. We provide the reified value with reify :: a -> (forall s. Reifies s a => Proxy s -> r) -> r, which passes back a proxy for the type the value has been reified to.
main = reify emphasise (\p -> print (markdownText p "Hello World"))
This has an advantage over the simpler version from the next section; multiple settings can be used for MarkdownTexts with different type parameters.
main = reify emphasise $ \p1 ->
reify def $ \p2 ->
do
print (markdownText p1 "Hello World")
print (markdownText p2 "Goodbye")
Reflect a global configuration
The reflection package also defines a simpler class, Given. It's defined as class Given a where given :: a. It represents values that can be determined from the type of the value itself. This allows us to provide a single global configuration value for a specific type, like ExampleSettings. We can jump straight to writing the show instance for MarkdownText.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
instance (Given ExampleSettings) => Show (MarkdownText) where
show = showWithSettings given . rawMarkdown
We provide the given ExampleSettings with give :: a -> (Given a => r) -> r.
main = give emphasise $ print (MarkdownText "Hello World")
I've got a situation where I need to compile some Haskell code on different machines.
At least one of these machines has a rather old version of Control.Concurrent.STM, that doesn't know modifyTVar. My current workaround is to copy the code for modifyTVar from a newer version of the package. This got me wondering, if it would be possible to use template Haskell to check if a function is already defined and only define it, if it's missing. I'm aware that the proper solution would probably be to get more recent packages, but the situation got me curious.
It seems to be possible as follows. First a helper module:
{-# LANGUAGE TemplateHaskell #-}
module AddFn where
import Language.Haskell.TH
-- | Add a function if it doesn't exist.
addFn :: String -> Q [Dec] -> Q [Dec]
addFn name decl = do
r <- lookupValueName name
case r of
Just l -> return []
Nothing -> report False ("adding missing " ++ name) >> decl
and use it as in
{-# LANGUAGE TemplateHaskell #-}
module Main where
import AddFn
import qualified Data.Traversable as T
$(addFn "mapM"
[d| mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
mapM = T.mapM
|])
$(addFn "mapM1"
[d| mapM1 :: (Monad m) => (a -> m b) -> [a] -> m [b]
mapM1 = T.mapM
|])
The drawback is that it's using lookupValueName, which is only in the recent versions of TH, so when dealing with old installations, this probably won't help. Perhaps a possible solution would be to instead call reify on a given name, and use recover to handle the case when the name is missing.
Update: The version using reify instead of lookupValueName works:
-- | Add a function if it doesn't exist.
addFn :: String -> Q [Dec] -> Q [Dec]
addFn name decl = recover decl (reify (mkName name) >> return [])
Template Haskell is somewhat overkill for this - you can use CPP instead, using the MIN_VERSION macros that Cabal will define:
{-# LANGUAGE CPP #-}
#if MIN_VERSION_stm(2, 3, 0)
-- nothing
#else
modifyTVar = ...
#endif
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).