Re: [Haskell-cafe] Need help to get started with GHC.Generics

15 Sep 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 mailto:haskell-cafe@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 mailto:lysxia@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 mailto:lysxia@gmail.com mailto:lysxia@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:par... https://hackage.haskell.org/package/aeson-1.5.4.0/docs/Data-Aeson.html#v:par...>|.
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.

Re: [Haskell-cafe] Need help to get started with GHC.Generics

Compl Yue