Skip to content

Instantly share code, notes, and snippets.

@dcastro
Last active January 18, 2021 16:02
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save dcastro/ef6bfef0b72d67f3efe86044bcb23655 to your computer and use it in GitHub Desktop.
Save dcastro/ef6bfef0b72d67f3efe86044bcb23655 to your computer and use it in GitHub Desktop.
TyFam inductive case
import Data.Vinyl (Rec(..))
data Tag = TagInt | TagPair Tag Tag
data Exp (t :: Tag) where
EInt :: Int -> Exp 'TagInt
EPair :: Exp t1 -> Exp t2 -> Exp ('TagPair t1 t2)
type family RightComb (tags :: [Tag]) :: Tag where
RightComb '[ x, y ] = 'TagPair x y
RightComb (x ': xs) = 'TagPair x (RightComb xs)
-- Turns:
-- EInt 1 :& EInt 2 :& EInt 3 :& RNil
-- Into:
-- EPair (EInt 1) (EPair (EInt 2) (EInt 3))
rightComb :: forall (tags :: [Tag]) . Rec Exp tags -> Exp (RightComb tags)
rightComb = \case
a :& b :& RNil -> EPair a b
a :& xs -> EPair a (rightComb xs)
• Could not deduce: RightComb (r : rs) ~ 'TagPair r (RightComb rs)
      from the context: input ~ (r : rs)
        bound by a pattern with constructor:
                   :& :: forall u (a :: u -> *) (r :: u) (rs :: [u]).
                         a r -> Rec a rs -> Rec a (r : rs),
                 in a case alternative
        at src/Michelson/Example.hs:18:3-9
      Expected type: Exp (RightComb input)
        Actual type: Exp ('TagPair r (RightComb rs))
    • In the expression: EPair a (rightComb xs)
      In a case alternative: a :& xs -> EPair a (rightComb xs)
      In the expression:
        \case
          a :& b :& RNil -> EPair a b
          a :& xs -> EPair a (rightComb xs)
    • Relevant bindings include
        xs :: Rec Exp rs (bound at src/Michelson/Example.hs:18:8)
        a :: Exp r (bound at src/Michelson/Example.hs:18:3)
   |
18 |   a :& xs -> EPair a (rightComb xs)
   |              ^^^^^^^^^^^^^^^^^^^^^^

@dcastro
Copy link
Author

dcastro commented Jan 18, 2021

Update: this works:

type family RightComb (tags :: [Tag]) :: Tag where
  RightComb '[ x ] = x
  RightComb (x ': xs) = 'TagPair x (RightComb xs)

rightComb :: forall (tags :: [Tag]) . Rec Exp tags -> Exp (RightComb tags)
rightComb = \case
  a :& RNil -> a
  a :& b :& xs -> EPair a (rightComb (b :& xs))
```

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