Skip to content

Instantly share code, notes, and snippets.

@Icelandjack

Icelandjack/Deriving.hs

Last active July 2, 2017 13:42
Show Gist options
  • Save Icelandjack/1f578e7103ff327cbcfb3426c005e26c to your computer and use it in GitHub Desktop.
Save Icelandjack/1f578e7103ff327cbcfb3426c005e26c to your computer and use it in GitHub Desktop.
Download ZIP
Template Haskell deriving, first implementation
Raw
Deriving.hs
{-# Language InstanceSigs, ViewPatterns, TupleSections, GeneralizedNewtypeDeriving, TemplateHaskell, LambdaCase #-}
module D where
import Language.Haskell.TH
import Data.Coerce
deriveVia :: Name -> Name -> Name -> Q [Dec]
deriveVia className ty viaNewTy = do
a <- reify className
let
instanceHead, coerceType :: Type
instanceHead = ConT className `AppT` ConT ty
coerceType = ConT viaNewTy `AppT` ConT ty
methods :: [Dec]
methods = concatMap (g coerceType ty) (f a)
return [InstanceD [] instanceHead methods]
f :: Info -> [(Name, Name, Dec)]
f (ClassI (ClassD _ semigroup [getName -> m] [] methods) _) =
map (semigroup, m,) methods
f (ClassI d _) = error (show d)
removeForall = \case
ForallT _ _ ty -> removeForall ty
AppT f x -> removeForall f `AppT` removeForall x
SigT f x -> removeForall f `SigT` removeForall x
x -> x
g :: Type -> Name -> (Name, Name, Dec) -> [Dec]
g m_all underlying (semigroup, m, SigD methodName methodTy)
= [signature, definition]
where
signature :: Dec
signature = SigD methodName (removeWith (ConT underlying) ty) where
ForallT _ _ ty = methodTy
definition :: Dec
definition =
ValD (VarP methodName)
(NormalB body)
[]
body :: Exp
body =
VarE 'coerce
`AppE`
SigE (VarE methodName)
(removeForall (removeWith m_all methodTy))
removeWith constructor = \case
AppT f x ->
AppT (removeWith constructor f) (removeWith constructor x)
ForallT tyVars ctxs ty
| let vars = [ var | var <- tyVars, getName var /= m ]
-> if null vars
then removeWith constructor ty
else ForallT
vars
[ ctx | ctx <- ctxs, ctx /= ClassP semigroup [VarT m] ]
(removeWith constructor ty)
ArrowT ->
ArrowT
VarT var
| var == m
-> constructor
| otherwise
-> VarT var
a -> a
getName :: TyVarBndr -> Name
getName = \case
PlainTV name -> name
KindedTV name _ -> name
@Icelandjack
Copy link
Author

Icelandjack commented May 30, 2017 •
edited
Loading

Use

import D

data Opt a = None | Some a
deriveVia ''Functor     ''Opt ''WrappedMonad
deriveVia ''Applicative ''Opt ''WrappedMonad

instance Monad Opt where
  return = Some

  None   >>= _ = None
  Some a >>= k = k a

data U = U

instance Mon U where
  mempty = U
  mappend U U = U
deriveVia ''Semigroup ''U ''WrappedMonoid

@mrkgnao
Copy link

mrkgnao commented Jun 3, 2017 •
edited
Loading

@Icelandjack this is somewhat vaguely related to something I'm doing in my noether repo:

https://github.com/mrkgnao/noether/blob/master/library/Noether/Algebra/Multiple/Strategies.hs

@Icelandjack
Copy link
Author

I will have to dig into that, thanks for bringing it to my attention @mrkgnao

@Icelandjack
Copy link
Author

Icelandjack commented Jun 26, 2017 •
edited
Loading

Using th-desugar

module TH where

import Language.Haskell.TH
import Language.Haskell.TH.Desugar
import Data.Coerce
import Control.Applicative
import Control.Monad
import Debug.Trace

pattern Dbg :: a
pattern Dbg <- ((\_ -> trace "DEBUG" False) -> True)

pattern DbgShow :: Show a => a
pattern DbgShow <- ((\a -> trace ("DEBUG: " ++ show a) False) -> True)

pattern YesDbgShow :: Show a => a -> a
pattern YesDbgShow a <- ((\a -> trace ("DEBUG: " ++ show a) a) -> a)
  where YesDbgShow (!a) = trace ("DEBUG 2: " ++ show a) a `seq` a

deriveVia :: Name -> Name -> Name -> Q [Dec]
deriveVia semi instanceType via_newtype = do
  DTyConI decs _ <- (reify >=> dsInfo) semi

  let 
    instanceHead :: DType
    instanceHead = DConT semi `DAppT` DConT instanceType    

    coerceType :: DType
    coerceType = DConT via_newtype `DAppT` DConT instanceType

    semi    :: Name
    name    :: Name
    methods :: [DDec]
    (semi, name, methods) = classAndMethods decs

    methods' :: [DDec]
    methods' = methods >>= coerceMethod coerceType instanceType

  pure $ sweeten [DInstanceD Nothing [] instanceHead methods']

classAndMethods :: DDec -> (Name, Name, [DDec])
classAndMethods (DClassD _ctx semi [getName -> name] [] methods) = (semi, name, methods)
classAndMethods _                                                = error "TODO: error"

removeForall :: DType -> DType
removeForall = \case
  DForallT _ _ ty -> removeForall ty
  DAppT f x       -> removeForall f `DAppT` removeForall x
  DSigT f x       -> removeForall f `DSigT` removeForall x
  x               -> x

coerceMethod :: DType -> Name -> DDec -> [DDec]
coerceMethod wrapped_app_ty instanceType (DLetDec (DSigD methodName methodTy)) = [signature, definition]

  where
  signature :: DDec
  signature = DLetDec $ DSigD methodName (removeWith f ty) where
    ty :: DType
    DForallT [DKindedTV f _] _ ty = methodTy

  definition :: DDec
  definition = DLetDec $ DValD (DVarPa methodName) body

  body :: DExp
  body = 
    DVarE 'coerce
    `DAppE`
    method' (DVarE methodName `DAppTypeE` wrapped_app_ty) (map getName vars) where 
      vars = case methodTy of
        DForallT _ _ (DForallT vars _ _) -> vars
        _ -> []

  method' :: DExp -> [Name] -> DExp
  method' = foldl (\acc x -> acc `DAppTypeE` DVarT x)

  removeWith :: Name -> DType -> DType
  removeWith f_name = \case
    DAppT f x ->
      DAppT (removeWith f_name f) (removeWith f_name x)

    DForallT tyVars ctxs ty
      | let vars = [ var | var <- tyVars, getName var /= instanceType ]
     -> if null vars
        then removeWith f_name ty
        else DForallT
          vars
          [ ctx | ctx <- ctxs ]
          (removeWith f_name ty)

    DArrowT ->
      DArrowT

    DVarT var
      | var == f_name
     -> DConT instanceType
      | otherwise
     -> DVarT var

    a -> a

getName :: DTyVarBndr -> Name
getName = \case
  DPlainTV  name   -> name
  DKindedTV name _ -> name

@Icelandjack
Copy link
Author

Icelandjack commented Jun 27, 2017 •
edited
Loading

Works for most

module TH where

import Control.DeepSeq
import Control.Monad.IO.Class
import Language.Haskell.TH
import Language.Haskell.TH.Desugar
import Data.Coerce
import Data.Foldable (find, toList)
import Control.Applicative
import Control.Monad
import Debug.Trace
import Control.Exception

pattern Y :: Show a => a -> a
pattern Y a <- ((\a -> trace ("DEBUG: " ++ show a) a) -> a)
  where Y (!a) = trace ("DEBUG 2: " ++ show a) a `seq` a

data Variables = Var { typeArgs :: [Name], wrappedArgs :: [Name] }
  deriving Show

deriveVia :: Name -> Name -> Name -> Q [Dec]
deriveVia semi instanceType via_newtype = do
  DTyConI decs _ <- (dsInfo <=< reify) semi

  Just (DTyConI info1 insts1) <- dsReify semi
  Just (DTyConI info2 insts2) <- dsReify instanceType
  Just (DTyConI info3 insts3) <- dsReify via_newtype

  Y vars <- case (getKind info1, getKind info2, getKind info3) of
    (STAR, STAR:>CONSTRAINT, _) -> 
      pure Var { typeArgs = [], wrappedArgs = [] }

    (STAR:>CONSTRAINT, STAR, STAR:>STAR) -> 
      pure Var { typeArgs = [], wrappedArgs = [] }

    ((STAR:>STAR):>CONSTRAINT, STAR:>STAR, (STAR:>STAR):>(STAR:>STAR)) -> 
      pure Var { typeArgs = [], wrappedArgs = [] }

    -- deriveVia ''Functor ''PAIR ''WrappedBifunctor
    --
    -- instance Functor (PAIR z) where
    --   fmap :: forall a b. (a -> b) -> PAIR z a -> PAIR z b
    --   fmap = coerce (fmap @(WrappedBifunctor PAIR z) @a @b)
    (   (STAR:>STAR):>CONSTRAINT
      , ((STAR:>STAR):>STAR)
      , (STAR:>(STAR:>STAR)) :> (STAR:>(STAR:>STAR))) -> do
      zzz <- newName "zzz"
      pure Var { typeArgs = [], wrappedArgs = [zzz] }

    -- (STAR:>CONSTRAINT, STAR, STAR:>STAR) -> 
    --   undefined
    -- deriveVia ''Num ''Sorted ''WrappedApplicative
    -- instance Num a => Num (Sorted a) where
     --   (+) :: Sorted a -> Sorted a -> Sorted a
     --   (+) = coerce ((+) @(WrappedApplicative Sorted a))

    (STAR:>CONSTRAINT, STAR:>STAR, (STAR:>STAR):>(STAR:>STAR)) -> do
      xxx <- newName "xxx"
      pure Var { typeArgs = [], wrappedArgs = [xxx] }

    -- deriveVia ''IsZero ''Sorted ''WrappedNumEq
    -- 
    -- instance (Num a, Eq a) => IsZero (Sorted a) where
    --   isZero :: Sorted a -> Bool
    --   isZero = coerce (isZero @(WrappedNumEq (Sorted a)))
    (STAR:>CONSTRAINT, STAR:>STAR, STAR:>STAR) -> do
      yyy <- newName "yyy"
      pure Var { typeArgs = [yyy], wrappedArgs = [] }

    ( (STAR :> (STAR :> STAR)) :> CONSTRAINT
      , STAR :> (STAR :> STAR) 
      , (STAR :> (STAR :> STAR)) :> (STAR :> (STAR :> STAR))) -> do
        yyy <- newName "yyy"
        pure Var { typeArgs = [], wrappedArgs = [] }

    (   (STAR:>STAR):>CONSTRAINT 
      , STAR:>(STAR:>STAR)
      , (STAR:>(STAR:>STAR)) :> (STAR:>(STAR:>STAR))) -> do
        yyy <- newName "yyy"
        pure Var { typeArgs = [], wrappedArgs = [yyy] }

  let 
    missingContext :: DCxt
    missingContext = 
      case (info1, insts1, info3) of
        (DDataD _ _ ze_num _ _ _, Just instances, DDataD _ _ ze_wrapAp _ _ _) -> 
          makeContext (whichVarsToLookOutFor ze_num ze_wrapAp instances)

        (DClassD _ ze_num _ _ _, Just instances, DDataD _ _ ze_wrapAp _ _ _) -> 
          makeContext (whichVarsToLookOutFor ze_num ze_wrapAp instances)

        (_, Nothing, _) -> []
        (DClassD {}, _, _) -> []

    whichVarsToLookOutFor :: Name -> Name -> [DDec] -> [(Name, Name)]
    whichVarsToLookOutFor ze_num ze_wrapAp = foldMap $ \case
      DInstanceD _ _ctx ty _decs -> 
        case ty of
          (DConT num `DAppT` (DConT wrappedApplicative `DAppT` DVarT f `DAppT` DVarT a))
            | ze_num    == num
            , ze_wrapAp == wrappedApplicative 
            , Var { typeArgs = [], wrappedArgs = [new] } <- vars
           -> [(a, new)]

          DConT isZero `DAppT` (DConT wrappedShow `DAppT` DVarT a) 
            | ze_num    == isZero
            , ze_wrapAp == wrappedShow 
            , Var { typeArgs = [new], wrappedArgs = [] } <- vars
           -> [(a, new)]

          DConT num `DAppT` DConT ordc -> []

          DConT num `DAppT ` ((DConT op `DAppT` DVarT a) `DAppT` DVarT b) -> []

          DAppT (DConT num) (DAppT (DConT small) (DVarT a)) -> []

          DAppT (DConT semigroup) (DAppT (DAppT DArrowT (DVarT a)) (DVarT b)) -> []

          DAppT (DConT semigroup) (DAppT (DAppT (DAppT (DConT pair) (DVarT a)) (DVarT b)) (DVarT c)) -> []

          DAppT (DConT semigroup) (DAppT (DAppT (DAppT (DAppT (DConT tuple) (DVarT a)) (DVarT b)) (DVarT c)) (DVarT d)) -> []
  
          DAppT (DConT semigroup) (DAppT (DAppT (DAppT (DAppT (DAppT (DConT tuple) (DVarT a)) (DVarT b)) (DVarT c)) (DVarT d)) (DVarT e)) -> []


          DAppT (DConT functor) (DSigT (DAppT (DConT wrappedapplicative) (DVarT f)) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DAppT (DAppT (DConT readert) (DVarT r)) (DVarT m)) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DConT proxy) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DAppT (DAppT (DAppT (DConT tannen) (DVarT f)) (DVarT p)) (DVarT a)) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DAppT (DAppT (DAppT (DAppT (DConT biff) (DVarT p)) (DVarT f)) (DVarT g)) (DVarT a)) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DAppT (DConT urec) (DAppT (DConT ptr) (DConT unit))) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT functor) (DSigT (DAppT (DConT urec) (DConT char)) (DAppT (DAppT DArrowT DStarT) DStarT)) -> []

          DAppT (DConT bifoldable) (DSigT (DAppT (DConT wrappedbif) (DVarT f)) (DAppT (DAppT DArrowT DStarT) (DAppT (DAppT DArrowT DStarT) DStarT))) -> []

          DAppT (DConT bifoldable) (DSigT (DConT const) (DAppT (DAppT DArrowT DStarT) (DAppT (DAppT DArrowT DStarT) DStarT))) -> []

          DAppT (DConT bifoldable) (DSigT (DAppT (DAppT (DConT tannen) (DVarT f)) (DVarT p)) (DAppT (DAppT DArrowT DStarT) (DAppT (DAppT DArrowT DStarT) DStarT))) -> []

          DAppT (DConT bifoldable) (DSigT (DAppT (DAppT (DAppT (DConT biff) (DVarT p)) (DVarT f)) (DVarT g)) (DAppT (DAppT DArrowT DStarT) (DAppT (DAppT DArrowT DStarT) DStarT))) -> []
  
          a -> error ("ERROR WITH whichVarsToLookOutFor: " ++ show a)
          
          -- _ -> []
 
    makeContext :: [(Name, Name)] -> [DPred]
    makeContext vars = do
      let has :: DPred -> Maybe DPred
          has = \case
             DAppPr f (DVarT a) -> do
               a' <- lookup a vars
               f' <- has f
               pure (DAppPr f' (DVarT a'))

             DConPr name -> 
               case lookup name vars of
                  Just a ->  pure $ DConPr a
                  Nothing -> pure $ DConPr name

             _ -> Nothing

      case insts1 of
        Just instances -> 
          flip foldMap instances $ \case 
              DInstanceD _ ctx _ _ -> foldMap (toList . has)  ctx

      --  TODO order of typeArgs / wrappedArgs
    saturatedInstanceType :: DType    
    saturatedInstanceType = foldl (\acc x -> acc `DAppT` DVarT x) (DConT instanceType) (typeArgs vars ++ wrappedArgs vars)

    instanceHead :: DType
    instanceHead = DConT semi `DAppT` saturatedInstanceType

    coerceType :: DType
    coerceType 
      | Var { wrappedArgs = [], typeArgs = [] } <- vars
      = DConT via_newtype `DAppT` DConT instanceType

      | Var { typeArgs = [], wrappedArgs = [xxx] } <- vars
      = (DConT via_newtype `DAppT` DConT instanceType) `DAppT` DVarT xxx

      | Var { typeArgs = [xxx], wrappedArgs = [] } <- vars
      = DConT via_newtype `DAppT` (DConT instanceType `DAppT` DVarT xxx)

      | Var { typeArgs = [xxx], wrappedArgs = [yyy] } <- vars
      = (DConT via_newtype `DAppT` DConT instanceType) `DAppT` DVarT xxx

    semi    :: Name
    name    :: Name
    methods :: [DDec]
    (semi, name, methods) = classAndMethods decs

    methods' :: [DDec]
    methods' = methods >>= coerceMethod coerceType instanceType saturatedInstanceType

  pure $ case vars of
    Var { typeArgs = [], wrappedArgs = [] } -> 
      sweeten [DInstanceD Nothing [] instanceHead methods']

    Var { typeArgs = [x], wrappedArgs = [] } -> 
      sweeten [DInstanceD Nothing missingContext instanceHead methods']

    Var { typeArgs = [], wrappedArgs = [x] } -> 
      sweeten [DInstanceD Nothing missingContext instanceHead methods']

    Var { typeArgs = [y], wrappedArgs = [x] } -> 
      sweeten [DInstanceD Nothing missingContext instanceHead methods']

classAndMethods :: DDec -> (Name, Name, [DDec])
classAndMethods (DClassD _ctx semi [getName -> name] [] methods) = (semi, name, methods)
classAndMethods _                                                = error "ERROR WITH classAndMethods"

removeForall :: DType -> DType
removeForall = \case
  DForallT _ _ ty -> removeForall ty
  DAppT f x       -> removeForall f `DAppT` removeForall x
  DSigT f x       -> removeForall f `DSigT` removeForall x
  x               -> x

coerceMethod :: DType -> Name -> DType -> DDec -> [DDec]
coerceMethod wrapped_app_ty instanceType saturatedInstanceType (DDefaultSigD{}) = [] 
coerceMethod wrapped_app_ty instanceType saturatedInstanceType (DLetDec (DSigD methodName methodTy)) = [signature, definition]

  where
  signature :: DDec
  signature = DLetDec $ DSigD methodName (removeWith f ty) where
    ty :: DType
    DForallT [DKindedTV f _] _ ty = methodTy

  definition :: DDec
  definition = DLetDec $ DValD (DVarPa methodName) body

  body :: DExp
  body = 
    DVarE 'coerce
    `DAppE`
    method' (DVarE methodName `DAppTypeE` wrapped_app_ty) (map getName vars) where 
      vars = case methodTy of
        DForallT _ _ (DForallT vars _ _) -> vars
        _ -> []

  method' :: DExp -> [Name] -> DExp
  method' = foldl (\acc x -> acc `DAppTypeE` DVarT x)

  removeWith :: Name -> DType -> DType
  removeWith f_name = \case
    DAppT f x ->
      DAppT (removeWith f_name f) (removeWith f_name x)

    DForallT tyVars ctxs ty
      | let vars = [ var | var <- tyVars, getName var /= instanceType ]
     -> if null vars
        then removeWith f_name ty
        else DForallT
          vars
          [ ctx | ctx <- ctxs ]
          (removeWith f_name ty)

    DArrowT ->
      DArrowT

    DVarT var
      | var == f_name
     -> saturatedInstanceType

      | otherwise
     -> DVarT var

    a -> a

getName :: DTyVarBndr -> Name
getName = \case
  DPlainTV  name   -> name
  DKindedTV name _ -> name

infixr :>
data KIND = STAR | KIND :> KIND | CONSTRAINT
  deriving Show

getKind :: DDec -> KIND
getKind (DDataD _ _ _ [] _ _) =
  STAR

getKind (DDataD _ _ _ [DKindedTV a kind] _ _) = 
  case kind of
    DStarT -> 
      STAR :> STAR

getKind (DDataD _ _ _ [DKindedTV _ kind, DKindedTV _ kind'] _ _) = 
  case (kind, kind') of
    (DStarT, DStarT) -> 
      STAR :> (STAR :> STAR)

    ((DArrowT `DAppT` DStarT) `DAppT` DStarT, DStarT) -> 
      (STAR :> STAR) :> (STAR :> STAR)

    ((DArrowT `DAppT` DVarT k) `DAppT` DStarT, DVarT k') | k == k' -> 
      (STAR :> STAR) :> (STAR :> STAR)

getKind (DDataD _ _ _ [DKindedTV _ kind, DKindedTV _ kind', DKindedTV _ kind''] _ _) = 
  case (kind, kind', kind'') of
    ( ((DArrowT `DAppT` DVarT k) `DAppT` ((DArrowT `DAppT` DVarT k1) `DAppT` DStarT))
      , DVarT k'
      , DVarT k1' ) | (k, k1) == (k', k1') -> (STAR:>(STAR:>STAR)) :> (STAR:>(STAR:>STAR))

  -- [DKindedTV p ((DArrowT `DAppT` DVarT k) `DAppT` ((DArrowT `DAppT` DVarT k1) `DAppT` DStarT))
  -- ,DKindedTV a (DVarT k),DKindedTV b (DVarT k1)] 

getKind (DClassD _ _  [DKindedTV _ kind] _ _) = 
  case kind of
    DStarT ->
      STAR :> CONSTRAINT
    (DArrowT `DAppT` DStarT) `DAppT` DStarT -> 
      (STAR :> STAR) :> CONSTRAINT

    (DArrowT `DAppT` DStarT) `DAppT` ((DArrowT `DAppT` DStarT) `DAppT` DStarT) -> 
      (STAR :> (STAR :> STAR)) :> CONSTRAINT

    a -> error ("ERROR WITH getKind DClassD --> " ++ show a)

getKind a = error ("ERROR WITH getKind --> " ++ show a)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment