Suppose I have an arbitrary module
module Foo where
foo :: Moo -> Goo
bar :: Car -> Far
baz :: Can -> Haz
where foo, bar, and baz are correctly implemented, etc.
I'd like to reify this module into an automatically-generated data type and corresponding object:
import Foo (Moo, Goo, Car, Far, Can, Haz)
import qualified Foo
data FooModule = Foo
{ foo :: Moo -> Goo
, bar :: Car -> Far
, baz :: Can -> Haz
}
_Foo_ = Foo
{ foo = Foo.foo
, bar = Foo.bar
, baz = Foo.baz
}
Names must be precisely the same as the original module.
I could do this by hand, but that is very tedious, so I'd like to write some code to perform this task for me.
I'm not really sure how to approach such a task. Does Template Haskell provide a way to inspect modules? Should I hook into some GHC api? Or am I just as well off with a more ad-hoc approach such as scraping haddock pages?
(This is for GHC-7.4.2; it probably won't compile with HEAD or 7.6 because of some changes in Outputable). I didn't find anything to inspect modules in TH.
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS -Wall #-}
import GHC
import GHC.Paths -- ghc-paths package
import Outputable
import GhcMonad
main :: IO ()
main = runGhc (Just libdir) $ goModule "Data.Map"
goModule :: GhcMonad m => String -> m ()
goModule modStr = do
df <- getSessionDynFlags
_ <- setSessionDynFlags df
-- ^ Don't know if this is the correct way, but it works for this purpose
setContext [IIDecl (simpleImportDecl (mkModuleName modStr))]
infos <- mapM getInfo =<< getNamesInScope
let ids = onlyIDs infos
liftIO . putStrLn . showSDoc . render $ ids
onlyIDs :: [Maybe (TyThing, Fixity, [Instance])] -> [Id]
onlyIDs infos = [ i | Just (AnId i, _, _) <- infos ]
render :: [Id] -> SDoc
render ids = mkFields ids $$ text "------------" $$ mkInits ids
mkFields :: [Id] -> SDoc
mkFields = vcat . map (\i ->
text "," <+> pprUnqual i <+> text "::" <+> ppr (idType i))
mkInits :: [Id] -> SDoc
mkInits = vcat . map (\i ->
text "," <+> pprUnqual i <+> text "=" <+> ppr i)
-- * Helpers
withUnqual :: SDoc -> SDoc
withUnqual = withPprStyle (mkUserStyle neverQualify AllTheWay)
pprUnqual :: Outputable a => a -> SDoc
pprUnqual = withUnqual . ppr
Related
Suppose I want to implement FromJSON for a data type. Below are the complete source code:
{-# LANGUAGE
NamedFieldPuns
, OverloadedStrings
, TupleSections
, ViewPatterns
#-}
module Main
( main
) where
import Data.Aeson
import Control.Monad
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as M
import qualified Data.Text as T
data Foo
= Foo
{ aaa :: Int
, bbb :: T.Text
, ccc :: Maybe (Int, Int)
, extra :: M.Map T.Text T.Text
}
instance FromJSON Foo where
parseJSON = withObject "Foo" $ \obj -> do
aaa <- obj .: "aaa"
bbb <- obj .: "bbb"
ccc <- obj .:? "ccc"
let existingFields = T.words "aaa bbb ccc"
obj' =
-- for sake of simplicity, I'm not using the most efficient approach.
filter ((`notElem` existingFields) . fst)
. HM.toList
$ obj
(M.fromList -> extra) <- forM obj' $ \(k,v) ->
withText "ExtraText" (pure . (k,)) v
pure Foo {aaa,bbb,ccc,extra}
main :: IO ()
main = pure ()
This data type Foo has a bunch of fields of potentially different types and in the end there is extra to collect all remaining fields.
Obviously no one would enjoy updating existingFields every time some fields get add/remove/update-ed, any recommended approach on collecting unused fields?
An alternative that I can think of is to stack a StateT on top with obj (converted to Map) as the initial state, and use something like Data.Map.splitLookup to "discharge" used fields. But I'm reluctant to do so as it will involve some lifting around monad stacks and it doesn't sound very good performance-wise removing elements one at a time from Map in comparison to filtering through HashMap in one pass in the end.
no one would enjoy updating existingFields every time some fields get
add/remove/update-ed
Consider this function
import Data.Aeson.Types (Parser)
import Data.Text (Text)
import Control.Monad.Trans.Writer
import Data.Functor.Compose
keepName :: (Object -> Text -> Parser x)
-> Object -> Text -> Compose (Writer [Text]) Parser x
keepName f obj fieldName = Compose $ do
tell [fieldName]
pure (f obj fieldName)
It takes as input an operator like .: or .:? and "enriches" its result value so that, instead of returning a Parser, it returns a Parser nested inside a Writer that serves to accumulate the supplied field names. The composition is wrapped in the Compose newtype, which automatically gives us an Applicative instance because, as mentioned in the docs:
(Applicative f, Applicative g) => Applicative (Compose f g)
(The composition is not a Monad though. Also take note that we are using Writer and not WriterT. We are nesting Applicatives, not applying monad transformers).
The rest of the code doesn't change that much:
{-# LANGUAGE ApplicativeDo #-}
instance FromJSON Foo where
parseJSON = withObject "Foo" $ \obj -> do
let Compose (runWriter -> (parser,existingFields)) =
do aaa <- keepName (.:) obj "aaa"
bbb <- keepName (.:) obj "bbb"
ccc <- keepName (.:?) obj "ccc"
pure Foo {aaa,bbb,ccc,extra = mempty}
obj' =
filter ((`notElem` existingFields) . fst)
. HM.toList
$ obj
(M.fromList -> extra) <- forM obj' $ \(k,v) ->
withText "ExtraText" (pure . (k,)) v
r <- parser
pure $ r { extra }
In our haskell code base, business logic is interlaved with tracing and logging code. This can obscure the business logic and make it harder to understand and debug. I am looking for ideas how to reduce the code footprint of logging and tracing to make the business logic stick out more.
Our code currently mostly looks roughly like this:
someFunction a b cs =
withTaggedSpan tracer "TRACE_someFunction" [("arg_b", show b)] $ do
logDebug logger $ "someFunction start: " <> show (trimDownC <$> cs)
result <- do ... some business logic ...
if isError result then
logError logger $ "someFunction error: " <> show result
else
logDebug logger $ "someFunction success: " <> show (trimDownResult result)
One observation is that whe mostly trace the entire function body and log at beginning and end. This should allow combining tracing and logging into single helper and automatically extract function name and names of captured values via meta programming. I have used AST transforming compile time macros and runtime introspection in other languges before but not Haskell.
What are good ways to do this using Template Haskell, HasCallStack or other options?
(Cross posted at https://www.reddit.com/r/haskell/comments/gdfu52/extracting_context_for_tracinglogging_via_haskell/)
Let's assume for simplicity that the functions in your business logic are of the form:
_foo :: Int -> String -> ReaderT env IO ()
_bar :: Int -> ExceptT String (ReaderT env IO) Int
That is, they return values in a ReaderT transformer over IO, or perhaps also throw errors using ExceptT. (Actually that ReaderT transformer isn't required right now, but it'll come in handy later).
We could define a traced function like this:
{-# LANGUAGE FlexibleInstances #-}
import Data.Void (absurd)
import Control.Monad.IO.Class
import Control.Monad.Reader -- from "mtl"
import Control.Monad.Trans -- from "transformers"
import Control.Monad.Trans.Except
traced :: Traceable t => Name -> t -> t
traced name = _traced name []
type Name = String
type Arg = String
class Traceable t where
_traced :: Name -> [Arg] -> t -> t
instance Show r => Traceable (ReaderT env IO r) where
_traced msg args t = either absurd id <$> runExceptT (_traced msg args (lift t))
instance (Show e, Show r) => Traceable (ExceptT e (ReaderT env IO) r) where
_traced msg args t =
do
liftIO $ putStrLn $ msg ++ " invoked with args " ++ show args
let mapExits m = do
e <- m
case e of
Left err -> do
liftIO $ putStrLn $ msg ++ " failed with error " ++ show err
return $ Left err
Right r -> do
liftIO $ putStrLn $ msg ++ " exited with value " ++ show r
return $ Right r
mapExceptT (mapReaderT mapExits) t
instance (Show arg, Traceable t) => Traceable (arg -> t) where
_traced msg args f = \arg -> _traced msg (args ++ [show arg]) (f arg)
This solution is still a bit unsatisfactory because, for functions that call other functions, we must decide at the outset if we want the traced version of the called functions or not.
One thing we could try—although more invasive to the code—is to put our functions in a record, and make the environment of the ReaderT equal to that same record. Something like this:
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
import GHC.Generics
-- from "red-black-record"
import Data.RBR (FromRecord (..), IsRecordType, ToRecord (..))
data MyAPI = MyAPI
{ foo :: Int -> String -> ReaderT MyAPI IO (),
bar :: Int -> ExceptT String (ReaderT MyAPI IO) Int,
baz :: Bool -> ExceptT String (ReaderT MyAPI IO) ()
}
deriving (Generic, FromRecord, ToRecord)
An then use some generics utility library (here red-black-record) to write a function that says: "if every function in your record is Traceable, I will give you another record where all the functions are traced":
import Data.Kind
import Data.Proxy
import Data.Monoid (Endo(..))
import GHC.TypeLits
import Data.RBR
( I (..),
KeyValueConstraints,
KeysValuesAll,
Maplike,
cpure'_Record,
liftA2_Record,
)
traceAPI ::
( IsRecordType r t,
Maplike t,
KeysValuesAll (KeyValueConstraints KnownSymbol Traceable) t
) =>
r ->
r
traceAPI =
let transforms =
cpure'_Record (Proxy #Traceable) $
\fieldName -> Endo (traced fieldName)
applyTraced (Endo endo) (I v) = I (endo v)
in fromRecord . liftA2_Record applyTraced transforms . toRecord
-- small helper function to help invoke the functions in the record
call :: MonadReader env m => (env -> f) -> (f -> m r) -> m r
call getter execute = do
f <- asks getter
execute f
Alternatively, in order to avoid magic, such function could we written by hand for each particular API record.
Putting it to work:
main :: IO ()
main = do
let api =
traceAPI $
MyAPI
{ foo = \_ _ ->
do liftIO $ putStrLn "this is foo",
bar = \_ ->
do
liftIO $ putStrLn "this is bar"
return 5,
baz = \_ ->
do
call foo $ \f -> lift $ f 0 "fooarg"
call bar $ \f -> f 23
throwE "oops"
}
flip runReaderT api $ runExceptT $ baz api False
pure ()
-- baz invoked with args ["False"]
-- foo invoked with args ["0","\"fooarg\""]
-- this is foo
-- foo exited with value ()
-- bar invoked with args ["23"]
-- this is bar
-- bar exited with value 5
-- baz failed with error "oops"
Pure functions are deterministic. If you know what went into them, you can always reproduce the result. Thus, you shouldn't need a lot of logging inside the main parts of a functional code base.
Log the impure actions only, and architect your code into a pure core with a small imperative shell. Log only the impure actions that take place in the shell. I've described the technique in a blog post here.
I'd like to replace this boilerplate with code generation:
import qualified Y15.D01
import qualified Y15.D02
import qualified Y15.D03
import qualified Y15.D04
import qualified Y15.D05
import qualified Y15.D06HM
import qualified Y15.D06IO
import qualified Y15.D06ST
import qualified Y15.D07
import qualified Y15.D08
import qualified Y15.D09
import qualified Y15.D10
import qualified Y15.D11
import qualified Y15.D12
import qualified Y15.D13
...
days :: [(String, [String -> IO String])]
days =
[ ("Y15.D01", i2ios [Y15.D01.solve1, Y15.D01.solve2])
, ("Y15.D02", i2ios [Y15.D02.solve1, Y15.D02.solve2])
, ("Y15.D03", i2ios [Y15.D03.solve1, Y15.D03.solve2])
, ("Y15.D04", i2ios [Y15.D04.solve1, Y15.D04.solve2])
, ("Y15.D05", i2ios [Y15.D05.solve1, Y15.D05.solve2])
, ("Y15.D06HM",i2ios [Y15.D06HM.solve1, Y15.D06HM.solve2]) -- Data.Map.Strict
, ("Y15.D06IO",ioi2ios [Y15.D06IO.solve1, Y15.D06IO.solve2]) -- Data.Array.IO
, ("Y15.D06ST",i2ios [Y15.D06ST.solve1, Y15.D06ST.solve2]) -- Data.Array.ST
, ("Y15.D07", i2ios [Y15.D07.solve1, Y15.D07.solve2])
, ("Y15.D08", i2ios [Y15.D08.solve1, Y15.D08.solve2])
, ("Y15.D09", i2ios [Y15.D09.solve1, Y15.D09.solve2])
, ("Y15.D10", i2ios [Y15.D10.solve1, Y15.D10.solve2])
, ("Y15.D11", s2ios [Y15.D11.solve1, Y15.D11.solve2])
, ("Y15.D12", i2ios [Y15.D12.solve1, Y15.D12.solve2])
, ("Y15.D13", i2ios [Y15.D13.solve1, Y15.D13.solve2])
]
where s2ios :: [a -> b] -> [a -> IO b]
s2ios = fmap (return .)
i2ios :: [a -> Int] -> [a -> IO String]
i2ios = fmap ((return . show) .)
ioi2ios :: [a -> IO Int] -> [a -> IO String]
ioi2ios = fmap (fmap show .)
https://github.com/oshyshko/adventofcode/blob/master/src/Main.hs
I am new to Template Haskell and I would appreciate any help/suggestions on where to start with these questions:
How to list modules in a project that match /Y\d\d.D\d\d.*/ pattern?
How to generate imports for p.1?
How to retrieve types of solve1 and solve2 fns from a given module?
How to generate days list?
With respect to question (2), Template Haskell cannot generate import statements. You can see a very old feature request for it in the bug tracker on GitLab but no one's been sufficiently inspired to implement it.
With respect to question (3), if modules have been imported and their names are available as strings, you can use TH to retrieve the type of a binding in each module like so. Given:
-- M001.hs
module M001 where
solve1 :: Int
solve1 = 10
-- M002.hs
module M002 where
solve1 :: IO Int
solve1 = return 20
-- THTest1.hs
{-# LANGUAGE TemplateHaskell #-}
module THTest1 where
import M001
import M002
import Language.Haskell.TH
let
modules = ["M001", "M002"]
showType :: String -> Q ()
showType nm = do
Just n <- lookupValueName nm
VarI _ typ _ <- reify n
reportWarning $ show nm ++ " has type " ++ show typ
return ()
in do mapM_ showType (map (++ ".solve1") modules)
return []
Then compiling THTest.hs will generate two warnings:
warning: "M001.solve1" has type ConT GHC.Types.Int
warning: "M002.solve1" has type AppT (ConT GHC.Types.IO)
(ConT GHC.Types.Int)
For question (4), here's a simplified example using modules M001 and M002 as defined above. Compile this program with ghc -ddump-splices to see the definition generated for days:
-- THTest2.hs
{-# LANGUAGE TemplateHaskell #-}
import M001
import M002
import Control.Monad
import GHC.Types
import Language.Haskell.TH
let
-- list of modules to search
modules = ["M001", "M002"]
-- assoc list of adapter function by argument type
funcs = [(ConT ''Int, 'return), (AppT (ConT ''IO) (ConT ''Int), 'id)]
getDay :: String -> Q Exp
getDay modname = do
-- look up name (e.g., M001.solve1)
Just n <- lookupValueName (modname ++ ".solve1")
-- get type of binding
VarI _ typ _ <- reify n
-- look up appropriate adapter function
let Just f = lookup typ funcs
-- ("M001", adapter_f M001.solve1)
[|($(pure $ LitE (StringL modname)),
$(pure $ AppE (VarE f) (VarE n)))|]
makeDays :: Q [Dec]
makeDays = do
[d| days :: [(String, IO Int)]
days = $(ListE <$> mapM getDay modules)
|]
in makeDays
main = do
forM days $ \(modname, action) -> do
putStr modname
putStr ": "
print =<< action
Then running it will output:
M001: 10
M002: 20
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.
1) I need to pass a field constructor parameter to a function. I made some tests but i was unable to do so. Is it possible? Otherwise, is it possible with lens package?
2) Is it possible in a MonadState to modify a field using modify? (I made a few attempts, but without success. For example: modify (second = "x") does not work.
import Control.Monad.State
data Test = Test {first :: Int, second :: String} deriving Show
dataTest = Test {first = 1, second = ""}
test1 = runStateT modif1 dataTest -- OK
test2 = runStateT (modif2 "!") dataTest -- OK
test3 = runStateT (modif3 second) dataTest -- WRONG
-- modif1 :: StateT Test IO ()
modif1 = do
st <- get
r <- lift getLine
put $ st {second = "x" ++ r}
-- modif2 :: String -> StateT Test IO ()
modif2 s = do
stat <- get
r <- lift getLine
put $ stat {second = "x" ++ r ++ s}
-- modif3 :: ???? -> StateT Test IO ()
modif3 fc = do
stat <- get
r <- lift getLine
put $ stat {fc = "x" ++ r}
-- When i try to load the module, this is the result:
-- ghc > Failed:
-- ProvaRecord.hs:33:16:`fc' is not a (visible) constructor field name
As you said, you're probably looking for lenses. A lens is a value that allows to read, set or modify a given field. Usually with Control.Lens, you define fields with underscores and you use makeLenses to create full-featured lenses.
There are many combinators that allow lenses to be used together within MonadState. In your case we can use %=, which in this case would be specialized to type
(MonadState s m) => Lens' s b -> (b -> b) -> m ()
which modifies a state value using a given lens and a function that operates on the inside value.
Your example could be rewritten using lenses as follows:
{-# LANGUAGE TemplateHaskell, RankNTypes #-}
import Control.Lens
import Control.Monad.State
data Test = Test { _first :: Int
, _second :: String
}
deriving Show
-- Generate `first` and `second` lenses.
$(makeLenses ''Test)
-- | An example of a universal function that modifies any lens.
-- It reads a string and appends it to the existing value.
modif :: Lens' a String -> StateT a IO ()
modif l = do
r <- lift getLine
l %= (++ r)
dataTest :: Test
dataTest = Test { _first = 1, _second = "" }
test :: IO Test
test = execStateT (modif second) dataTest