[Haskell-cafe] Need help to get started with GHC.Generics
Compl Yue
compl.yue at gmail.com
Tue Sep 15 11:55:09 UTC 2020
I end up with a working poc, yes, without generics involved, like this:
```
{-# LANGUAGE
ViewPatterns,
KindSignatures,
TypeOperators,
DataKinds,
FlexibleInstances,
FlexibleContexts,
PatternSynonyms,
ConstraintKinds,
ScopedTypeVariables,
BangPatterns
#-}
module Main where
import Prelude
import GHC.TypeLits ( Symbol
, KnownSymbol
, symbolVal
)
import Data.Kind ( Type )
import Data.Maybe
import Data.Proxy
import Data.Dynamic
-- artifacts for named arguments
newtype NamedArg (t :: Type) (name :: Symbol) = NamedArg t
type name !: t = NamedArg t name
type name ?: t = NamedArg (Maybe t) name
pattern Arg :: t -> name !: t
pattern Arg t = NamedArg t
{-# COMPLETE Arg #-}
arg :: name !: t -> t
arg (NamedArg a) = a
optionalArg :: name ?: t -> Maybe t
optionalArg (NamedArg !ma) = ma
defaultArg :: t -> name ?: t -> t
defaultArg !a (NamedArg !ma) = fromMaybe a ma
-- * minimum data structures as interface with scripting code
type AttrKey = String
data AttrVal = NilValue
| IntValue !Integer
| StrValue !String
deriving (Eq, Ord, Typeable)
instance Show AttrVal where
show NilValue = "nil"
show (IntValue !x) = show x
show (StrValue !x) = show x
data ArgsPack = ArgsPack {
positional'args :: [AttrVal]
, keyword'args :: [(AttrKey, AttrVal)]
}
instance Semigroup ArgsPack where
(ArgsPack p1 kw1) <> (ArgsPack p2 kw2) = ArgsPack (p1 ++ p2) (kw1 ++ kw2)
instance Monoid ArgsPack where
mempty = ArgsPack [] []
takeKwArg
:: AttrKey -> [(AttrKey, AttrVal)] -> (Maybe AttrVal, [(AttrKey, AttrVal)])
takeKwArg !k !kwargs = go [] kwargs
where
go
:: [(AttrKey, AttrVal)]
-> [(AttrKey, AttrVal)]
-> (Maybe AttrVal, [(AttrKey, AttrVal)])
go _ [] = (Nothing, kwargs)
go others (p@(!key, !val) : kwargs') = if key == k
then (Just val, reverse others ++ kwargs')
else go (p : others) kwargs'
type ContProc = (AttrVal -> IO ()) -> IO ()
-- | Haskell functions callable with an apk
class Callable fn where
call :: fn -> ArgsPack -> ContProc
-- instance for nullary functions, which is the base case
instance Callable ContProc where
call !fn (ArgsPack !args !kwargs) exit =
if null args && null kwargs then fn exit else error "extraneous args"
-- instance for repacking arg receiver
instance Callable fn' => Callable (ArgsPack -> fn') where
call !fn !apk !exit = call (fn apk) (ArgsPack [] []) exit
-- instances for positional arg receivers
instance Callable fn' => Callable (AttrVal -> fn') where
call !fn (ArgsPack (val : args) !kwargs) !exit =
call (fn val) (ArgsPack args kwargs) exit
call _ _ _ = error "missing anonymous arg"
instance Callable fn' => Callable (Maybe AttrVal -> fn') where
call !fn (ArgsPack [] !kwargs) !exit =
call (fn Nothing) (ArgsPack [] kwargs) exit
call !fn (ArgsPack (val : args) !kwargs) !exit =
call (fn (Just val)) (ArgsPack args kwargs) exit
instance Callable fn' => Callable (String -> fn') where
call !fn (ArgsPack (val : args) !kwargs) !exit = case val of
StrValue !val' -> call (fn val') (ArgsPack args kwargs) exit
_ -> error "arg type mismatch"
call _ _ _ = error "missing anonymous arg"
instance Callable fn' => Callable (Maybe String -> fn') where
call !fn (ArgsPack [] !kwargs) !exit =
call (fn Nothing) (ArgsPack [] kwargs) exit
call !fn (ArgsPack (val : args) !kwargs) !exit = case val of
StrValue !val' -> call (fn (Just val')) (ArgsPack args kwargs) exit
_ -> error "arg type mismatch"
-- todo instances for receivers of positional arg of (Maybe) Integer
-- type, and other types covered by AttrVal
-- instances for keyword arg receivers
instance (KnownSymbol name, Callable fn') => Callable (NamedArg AttrVal name -> fn') where
call !fn (ArgsPack !args !kwargs) !exit = case takeKwArg argName kwargs of
(Just !val, kwargs') ->
call (fn (NamedArg val)) (ArgsPack args kwargs') exit
(Nothing, kwargs') -> case args of
[] -> error $ "missing named arg: " <> argName
(val : args') -> call (fn (NamedArg val)) (ArgsPack args' kwargs') exit
where !argName = symbolVal (Proxy :: Proxy name)
instance (KnownSymbol name, Callable fn') => Callable (NamedArg (Maybe AttrVal) name -> fn') where
call !fn (ArgsPack !args !kwargs) !exit = case takeKwArg argName kwargs of
(Nothing, !kwargs') -> case args of
[] -> call (fn (NamedArg Nothing)) (ArgsPack [] kwargs') exit
val : args' ->
call (fn (NamedArg (Just val))) (ArgsPack args' kwargs') exit
(!maybeVal, !kwargs') ->
call (fn (NamedArg maybeVal)) (ArgsPack args kwargs') exit
where !argName = symbolVal (Proxy :: Proxy name)
instance (KnownSymbol name, Callable fn') => Callable (NamedArg String name -> fn') where
call !fn (ArgsPack !args !kwargs) !exit = case takeKwArg argName kwargs of
(Just !val, !kwargs') -> case val of
StrValue !val' -> call (fn (NamedArg val')) (ArgsPack args kwargs') exit
_ -> error "arg type mismatch"
(Nothing, !kwargs') -> case args of
[] -> error $ "missing named arg: " <> argName
val : args' -> case val of
StrValue !val' ->
call (fn (NamedArg val')) (ArgsPack args' kwargs') exit
_ -> error "arg type mismatch"
where !argName = symbolVal (Proxy :: Proxy name)
instance (KnownSymbol name, Callable fn') => Callable (NamedArg (Maybe String) name -> fn') where
call !fn (ArgsPack !args !kwargs) !exit = case takeKwArg argName kwargs of
(Just !val, !kwargs') -> case val of
StrValue !val' ->
call (fn (NamedArg (Just val'))) (ArgsPack args kwargs') exit
_ -> error "arg type mismatch"
(Nothing, !kwargs') -> case args of
[] -> call (fn (NamedArg Nothing)) (ArgsPack [] kwargs') exit
val : args' -> case val of
StrValue !val' ->
call (fn (NamedArg (Just val'))) (ArgsPack args' kwargs') exit
_ -> error "arg type mismatch"
where !argName = symbolVal (Proxy :: Proxy name)
-- todo instances for receivers of keyword arg of (Maybe) Integer
-- type, and other types covered by AttrVal
-- * functions to be callable from scripting code
-- | interfacing Haskell function meant to be easily called by scripting code
assert
:: "expect" !: AttrVal
-> "target" ?: AttrVal
-> "message" ?: String
-> (AttrVal -> IO ())
-> IO ()
assert (Arg !expect) (optionalArg -> !maybeTarget) (defaultArg "sth ought to be" -> !message) !exit
= case maybeTarget of
Nothing -> case expect of
NilValue -> error $ "* assertion failed: " <> message
IntValue 0 -> error $ "* assertion failed: " <> message
StrValue "" -> error $ "* assertion failed: " <> message
_ -> exit $ StrValue $ "* assertion passed: " <> message
Just target -> if expect == target
then exit $ StrValue $ "* assertion passed: " <> message
else error $ "* assertion failed: " <> message
-- mockup & test out
main :: IO ()
main = do
call assert apk1 $ \ !result -> putStrLn $ "Got result1: " <> show result
call assert apk2 $ \ !result -> putStrLn $ "Got result2: " <> show result
call assert apk3 $ \ !result -> putStrLn $ "Got result3: " <> show result
call assert apk4 $ \ !result -> putStrLn $ "Got result4: " <> show result
where
!apk1 = ArgsPack
[]
[ ("message", StrValue "as good will")
, ("target" , IntValue 333)
, ("expect" , IntValue 333)
]
!apk2 = ArgsPack [IntValue 333, IntValue 333, StrValue "as good will"] []
!apk3 = ArgsPack [IntValue 333] [("target", IntValue 333)]
!apk4 = ArgsPack [] [("target", IntValue 333), ("expect", IntValue 555)]
```
> On 2020-09-11, at 00:50, YueCompl via Haskell-Cafe <haskell-cafe at haskell.org <mailto:haskell-cafe at haskell.org>> wrote:
>
> Then any better approach, to auto (or at least semi-auto) adapt an ArgsPack toward applying an arbitrary Haskell function?
>
>> On 2020-09-11, at 00:35, Li-yao Xia <lysxia at gmail.com <mailto:lysxia at gmail.com>> wrote:
>>
>> This doesn't sound like a use case for generics then. Just to spare you the trouble of following a red herring.
>>
>> On 9/10/2020 12:26 PM, YueCompl wrote:
>>> Li-yao, thanks for the pointer. And my case is not really about ADTs, but to introspect the arguments an arbitrary Haskell function takes, including how many and what type each argument is, so as to extract proper values from a given ArgsPack, then call that Haskell function with those values as args it expects.
>>> I'm not sure at a glance, that generics-eot has demonstrated how to obtain argument list with type info for a function, and will look into the details as I can.
>>> Thanks with regards,
>>> Compl
>>>> On 2020-09-10, at 23:08, Li-yao Xia <lysxia at gmail.com <mailto:lysxia at gmail.com> <mailto:lysxia at gmail.com <mailto:lysxia at gmail.com>>> wrote:
>>>>
>>>> Hi Compl,
>>>>
>>>> I couldn't tell what's generic (in the sense of GHC.Generics) about this example. A clearer example would be to give two applications with different algebraic data types, and to show how they consist of the same boilerplate, where the differences are only due to the differing numbers of fields and constructors.
>>>>
>>>> As for tutorials on generics, a good starting point might be generics-eot. Its documentation comes with a series of tutorials:
>>>>
>>>> https://generics-eot.readthedocs.io/en/stable/ <https://generics-eot.readthedocs.io/en/stable/>
>>>>
>>>> Li-yao
>>>>
>>>> On 9/10/2020 9:44 AM, YueCompl via Haskell-Cafe wrote:
>>>>> Dear Cafe,
>>>>> I'm tinkering with the idea for arbitrary Haskell functions to be easily called from scripting code, I see auto derive with GHC.Generics might be the most promising tool, but I'm lost after read https://wiki.haskell.org/GHC.Generics <https://wiki.haskell.org/GHC.Generics> and hackage docs. I have no clue so far with how to start with it.
>>>>> Specifically I want the section highlighted in blue get auto generated, within the following `runghc` ready example:
>>>>> ```
>>>>> {-# LANGUAGEBangPatterns#-}
>>>>> moduleMain where
>>>>> importPrelude
>>>>> importGHC.Generics
>>>>> importData.Dynamic
>>>>> -- * minimum data structures as interface with scripting code
>>>>> typeAttrKey=String
>>>>> dataAttrVal=NilValue
>>>>> |IntValue!Integer
>>>>> |StrValue!String
>>>>> deriving(Eq,Ord,Typeable)
>>>>> instanceShowAttrValwhere
>>>>> show NilValue="nil"
>>>>> show (IntValue!x)=show x
>>>>> show (StrValue!x)=show x
>>>>> dataArgsPack=ArgsPack{
>>>>> positional'args::[AttrVal]
>>>>> ,keyword'args::[(AttrKey,AttrVal)]
>>>>> }
>>>>> instanceSemigroupArgsPackwhere
>>>>> (ArgsPackp1 kw1)<>(ArgsPackp2 kw2)=ArgsPack(p1 ++p2)(kw1 ++kw2)
>>>>> instanceMonoidArgsPackwhere
>>>>> mempty =ArgsPack[][]
>>>>> classCallableawhere
>>>>> call::a->ArgsPack->(AttrVal->IO())->IO()
>>>>> -- * functions to be callable from scripting code
>>>>> newtypeAssert=Assert(
>>>>> Expect->MaybeTarget->Message->IOMessage
>>>>> )
>>>>> typeExpect=AttrVal
>>>>> typeTarget=AttrVal
>>>>> typeMessage=String
>>>>> instanceCallableAssertwhere
>>>>> -- can this get auto-generated ? with https://wiki.haskell.org/GHC.Generics <https://wiki.haskell.org/GHC.Generics>
>>>>> call (Assert!assert)(ArgsPack!args !kwargs)!exit =do
>>>>> (expect,target,message)<-parseApk
>>>>> result <-assert expect target message
>>>>> exit $StrValueresult
>>>>> where
>>>>> parseApk::IO(Expect,MaybeTarget,Message)
>>>>> parseApk =goParse
>>>>> (Left"missing arg: expect",Nothing,Left"missing arg: message")
>>>>> args
>>>>> kwargs
>>>>> goParse (got'expect,got'target,got'message)[][]=casegot'expect of
>>>>> Leftmsg ->error msg
>>>>> Rightexpect ->casegot'message of
>>>>> Leftmsg ->error msg
>>>>> Rightmessage ->return (expect,got'target,message)
>>>>> goParse (got'expect,got'target,got'message)args' ((name,val):kwargs')
>>>>> =casename of
>>>>> "expect"->casegot'expect of
>>>>> Right{}->error "duplicate arg: expect"
>>>>> Left{}->goParse (Rightval,got'target,got'message)args' kwargs'
>>>>> "target"->casegot'target of
>>>>> Just{}->error "duplicate arg: target"
>>>>> Nothing->goParse (got'expect,Justval,got'message)args' kwargs'
>>>>> "message"->casegot'message of
>>>>> Right{}->error "duplicate arg: message"
>>>>> Left{}->caseval of
>>>>> StrValuemessage ->
>>>>> goParse (got'expect,got'target,Rightmessage)args' kwargs'
>>>>> _ ->error "bad arg type for: message"
>>>>> _ ->error "unexpected keyword args"
>>>>> goParse (got'expect,got'target,got'message)(val :args')[]=
>>>>> casegot'expect of
>>>>> Left{}->goParse (Rightval,got'target,got'message)args' []
>>>>> Right{}->casegot'target of
>>>>> Nothing->goParse (got'expect,Justval,got'message)args' []
>>>>> Just{}->casegot'message of
>>>>> Left{}->caseval of
>>>>> StrValuemessage ->
>>>>> goParse (got'expect,got'target,Rightmessage)args' []
>>>>> _ ->error "bad arg type for: message"
>>>>> Right{}->error "extranous positional args"
>>>>> -- mockup & test out
>>>>> main::IO()
>>>>> main =
>>>>> call
>>>>> (Assertassert)
>>>>> (ArgsPack[IntValue333,StrValue"as good will"]
>>>>> [("target",IntValue333)]
>>>>> )
>>>>> $\result ->putStrLn $"Got result: "<>show result
>>>>> -- | plain Haskell function meant to be easily called by scripting code
>>>>> assert::Expect->MaybeTarget->Message->IOMessage
>>>>> assert !expect !maybeTarget !message =casemaybeTarget of
>>>>> Nothing->return $"* assertion not applicable: "<>message
>>>>> Justtarget ->ifexpect ==target
>>>>> thenreturn $"* assertion passed: "<>message
>>>>> elseerror $"* assertion failed: "<>message
>>>>> ```
>>>>> I tried to understand how
>>>>> * The compiler can provide a default generic implementation for
>>>>> |parseJSON
>>>>> <https://hackage.haskell.org/package/aeson-1.5.4.0/docs/Data-Aeson.html#v:parseJSON <https://hackage.haskell.org/package/aeson-1.5.4.0/docs/Data-Aeson.html#v:parseJSON>>|.
>>>>> is implemented in [aeson](https://hackage.haskell.org/package/aeson <https://hackage.haskell.org/package/aeson>) and it is overwhelming to me at the moment ...
>>>>> Is there easier scaffold template for me to start with GHC.Generics? Or there're even better techniques to achieve my final goal?
>>>>> Help please!
>>>>> Best regards,
>>>>> Compl
>>>>> _______________________________________________
>>>>> Haskell-Cafe mailing list
>>>>> To (un)subscribe, modify options or view archives go to:
>>>>> http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe <http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe>
>>>>> Only members subscribed via the mailman list are allowed to post.
>
> _______________________________________________
> Haskell-Cafe mailing list
> To (un)subscribe, modify options or view archives go to:
> http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe <http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe>
> Only members subscribed via the mailman list are allowed to post.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/haskell-cafe/attachments/20200915/c1b5f251/attachment-0001.html>
More information about the Haskell-Cafe
mailing list