Bye.hs

{-# LANGUAGE TemplateHaskell #-}

module Bye where

import Hi

data Hi =
  Hi1 Int
  | Hi2 String
  | Hi3 [Int] Int
  | Hi4
  deriving (Eq, Show)

mkClassInstance ''Hi

{-

  mkClassInstance ''Hi
======>
  class AsHi a_aczZ where
    _Hi :: a_aczZ -> Hi
    _Hi1 :: a_aczZ -> Maybe Int
    _Hi2 :: a_aczZ -> Maybe String
    _Hi3 :: a_aczZ -> Maybe ((,) [Int] Int)
    _Hi4 :: a_aczZ -> Maybe ()
    _Hi1 = ((.) _Hi1) _Hi
    _Hi2 = ((.) _Hi2) _Hi
    _Hi3 = ((.) _Hi3) _Hi
    _Hi4 = ((.) _Hi4) _Hi
  instance AsHi Hi where
    _Hi = id
    _Hi1
      = \ a_acA0
          -> case a_acA0 of
               Hi1 x_acA1 -> Just x_acA1
               _ -> Nothing
    _Hi2
      = \ a_acA2
          -> case a_acA2 of
               Hi2 x_acA3 -> Just x_acA3
               _ -> Nothing
    _Hi3
      = \ a_acA4
          -> case a_acA4 of
               Hi3 x_acA5 x_acA6 -> Just (((,) x_acA5) x_acA6)
               _ -> Nothing
    _Hi4
      = \ a_acA7
          -> case a_acA7 of
               Hi4 -> Just ()
               _ -> Nothing


-}

Hi.hs

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE TemplateHaskell #-}

module Hi(mkClassInstance)    where

import Control.Lens(Lens', Iso', Traversal', view, preview, _5, iso, toListOf)
import Control.Monad(join)
import Data.Foldable(toList)
import Data.List.NonEmpty(NonEmpty((:|)))
import Data.Semigroup((<>))
import Language.Haskell.TH(DecsQ, Dec(FunD, SigD, InstanceD, ClassD), TyVarBndr(PlainTV), Clause(Clause), Body(NormalB), Exp(VarE, AppE, ConE, LamE, CaseE), Match(Match), Type(AppT, ConT, ArrowT, VarT), Con(NormalC, RecC, InfixC), Pat(VarP, ConP, WildP), reify, mkName, newName)
import Language.Haskell.TH.Lens
import Language.Haskell.TH.Syntax(OccName(OccName), Name(Name))

nameIdFunction ::
  Name
  -> Name
nameIdFunction =
  mkNameFrom ("_" <>)

nameConstructorFunction ::
  HasConstructor a =>
  a
  -> Name
nameConstructorFunction c =
  mkNameFrom ("_" <>) (view constructorName c)

mkClassInstance ::
  Name
  -> DecsQ
mkClassInstance n =
  let classname =
        mkNameFrom ("As" <>) n
  in  do  r <- reify n
          case preview (_TyConI . _DataD . _5) r of
            Just x ->
              let t = x >>= toList . getCon
              in  do  c <- mkClass n t classname
                      i <- mkInstance n t classname
                      pure (c ++ i)            
            Nothing ->
              fail "not a data type"

mkInstance ::
  Name -- data type name
  -> [Constructor] -- constructors
  -> Name -- class name
  -> DecsQ
mkInstance n x classname =
  let idy ::
        Dec
      idy =
        FunD
          (nameIdFunction n)
          [
            Clause [] (NormalB (VarE (mkName "id"))) []
          ]
      perConstructor ::
        Constructor
        -> DecsQ
      perConstructor c =
        do  a <- newName "a"
            -- g :: [Name]
            g <- traverse (const (newName "x")) (getConstructorArgumentTypes c)
            pure
              [
                FunD (nameConstructorFunction c)
                  [
                    Clause
                      []
                      -- \a ->
                      (NormalB (LamE [VarP a]
                        -- case a of
                        (CaseE (VarE a) 
                          [
                            Match (ConP (view constructorName c) (VarP <$> g)) (NormalB (AppE (ConE (mkName ("Just"))) (pairExps (VarE <$> g)))) []
                          , Match WildP (NormalB (ConE (mkName ("Nothing")))) []
                          ]
                        )
                      ))
                      []
                  ]
              ]
  in  do  r <- join <$> traverse perConstructor x
          pure
            [
              InstanceD Nothing [] (AppT (ConT classname) (ConT n)) (idy:r)
            ]

mkClass ::
  Name -- data type name
  -> [Constructor] -- constructors
  -> Name -- class name
  -> DecsQ
mkClass n x classname =
  let perConstructor ::
        Name -- type variable name
        -> Constructor
        -> [Dec]
      perConstructor tv c =
        let n' =
              nameConstructorFunction c
        in [
              SigD n' (AppT (AppT ArrowT (VarT tv)) (AppT (ConT (mkName "Maybe")) (pairTypes (getConstructorArgumentTypes c))))
            , FunD
                n'
                [
                  let body =
                        NormalB
                          (AppE (AppE (VarE (mkName ".")) (VarE n')) (VarE (nameIdFunction n)))
                  in  Clause
                        []
                        body
                        []
                ]
            ]
  in  do  tv <- newName "a"
          pure
            [
              ClassD
              []
              classname
              [PlainTV tv]
              []
              (
                SigD (nameIdFunction n) (AppT (AppT ArrowT (VarT tv)) (ConT n)) :
                (x >>= perConstructor tv)
              )
            ]

----

occName ::
  HasName a =>
  Lens' a OccName
occName =
  name . (\k (Name o x) -> fmap (\o' -> Name o' x) (k o))

occNameWrapped ::
  Iso'
    OccName
    String
occNameWrapped =
  iso
    (\(OccName s) -> s)
    OccName

mkNameFrom ::
  (String -> String)
  -> Name
  -> Name
mkNameFrom k =
  mkName . k . view (occName . occNameWrapped)

pairTypes ::
  [Type]
  -> Type
pairTypes =
  pair AppT (ConT (mkName "(,)")) (ConT (mkName "()"))

pairExps ::
  [Exp]
  -> Exp
pairExps =
  pair AppE (ConE (mkName "(,)")) (ConE (mkName "()"))


pair ::
  (a -> a -> a)
  -> a
  -> a
  -> [a]
  -> a
pair _ _ z [] =
  z
pair k w _ (h:t) =
  let pair' (q :| []) =
        q
      pair' (q :| (i:j)) =
        k (k w q) (pair' (i :| j))
  in  pair' (h :| t)

{-
normalRecInfixName ::
  Traversal' Con Name
normalRecInfixName f (NormalC n x) =
  fmap (\n' -> NormalC n' x) (f n)
normalRecInfixName f (RecC n x) =
  fmap (\n' -> RecC n' x) (f n)
normalRecInfixName f (InfixC x n y) =
  fmap (\n' -> InfixC x n' y) (f n)
normalRecInfixName _ r@(ForallC _ _ _) =
  pure r
normalRecInfixName _ r@(GadtC _ _ _) =
  pure r
normalRecInfixName _ r@(RecGadtC _ _ _) =
  pure r
-}

data ConstructorArgument =
  ConstructorArgument
    (Maybe Name)
    Type
  deriving (Eq, Ord, Show)

class HasConstructorArgument a where
  constructorArgument ::
    Lens' a ConstructorArgument
  constructorArgumentName ::
    Lens' a (Maybe Name)
  constructorArgumentName =
    constructorArgument . constructorArgumentName
  constructorArgumentType ::
    Lens' a Type
  constructorArgumentType =
    constructorArgument . constructorArgumentType
  
instance HasConstructorArgument ConstructorArgument where
  constructorArgument =
    id
  constructorArgumentName f (ConstructorArgument n t) =
    fmap (\n' -> ConstructorArgument n' t) (f n)
  constructorArgumentType f (ConstructorArgument n t) =
    fmap (\t' -> ConstructorArgument n t') (f t)

data Constructor =
  Constructor
    Name
    [ConstructorArgument]
  deriving (Eq, Ord, Show)

class HasConstructor a where
  constructor ::
    Lens' a Constructor
  constructorName ::
    Lens' a Name
  constructorName =
    constructor . constructorName
  constructorArgumentList ::
    Lens' a [ConstructorArgument]
  constructorArgumentList =
    constructor . constructorArgumentList
  constructorArguments ::
    Traversal' a ConstructorArgument
  constructorArguments =
    constructorArgumentList . traverse

instance HasConstructor Constructor where
  constructor =
    id
  constructorName f (Constructor n a) =
    fmap (\n' -> Constructor n' a) (f n)
  constructorArgumentList f (Constructor n a) =
    fmap (\a' -> Constructor n a') (f a)

getCon ::
  Con
  -> Maybe Constructor
getCon (NormalC n ts) =
  Just (Constructor n ((\(_, t) -> ConstructorArgument Nothing t) <$> ts))
getCon (RecC n x) =
  Just (Constructor n ((\(vn, _, t) -> ConstructorArgument (Just vn) t) <$> x))
getCon (InfixC x n y) =
  Just (Constructor n ((\(_, t) -> ConstructorArgument Nothing t) <$> [x, y]))
getCon _ =
  Nothing

getConstructorArgumentTypes ::
  HasConstructor a =>
  a
  -> [Type]
getConstructorArgumentTypes =
  toListOf (constructorArguments . constructorArgumentType)