[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