Append.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

{- |
  Type-level list appending and properties
-}
module Append where

import Union
import Control.Arrow

{- |
  Type-level list appending.
-}
type family as ++ bs where
  '[]      ++ bs = bs
  (a : as) ++ bs = a : (as ++ bs)

{- |
  Properties of type-level list appending.
-}
class Append fs where

  {- | Sum of (appending @fs@ and @gs@) can be separated onto either sum of @fs@ or sum of @gs@.
  -}
  split  :: Union (fs ++ gs) a -> Either (Union fs a) (Union gs a)

  {- | Sum of @gs@ can be "left-extended" into a sum of (appending @fs@ and @gs@).
  -}
  extend :: Union        gs  a -> Union (fs ++ gs) a

instance Append '[] where
  split = Right
  extend = id

instance Append fs => Append (f : fs) where
  split = elim
    (Left . Here)
    (left   There . split @fs)

  extend = There . extend @fs

Cofree.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
  Annotated fixpoint (tree) for a functor.
-}
module Cofree where

import Data.Foldable
import Control.Monad
import Text.PrettyPrint.HughesPJClass

{- |
  Turn functor @f@ into a tree with @a@ as annotation at each node.
-}
data Cofree f a = a :> f (Cofree f a)
  deriving (Functor, Foldable, Traversable)

instance Show (f (Cofree f a)) => Show (Cofree f a) where
  showsPrec i (_ :> f) = showsPrec i f

instance Pretty (f (Cofree f a)) => Pretty (Cofree f a) where
  pPrintPrec l i (_ :> f) = pPrintPrec l i f

Example.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}

module Example where

import Control.Monad.Identity
import Data.String
import Text.PrettyPrint.HughesPJClass

import Tree
import Union
import Cofree
import Features

{- | Feature lists for two languages.
-}
type Uncurried = [UncurriedExponent, LetFun, Let, Var]
type Curried   = [         Exponent,         Let, Var]

{- | Transformation between two languages.
-}
curryExponent :: Tree Uncurried a -> Identity (Tree Curried a)
curryExponent =                                         -- v-- annotation
  replace @'[UncurriedExponent, LetFun] @'[Exponent] @'[Let, Var] \a
    -- uncurried exponent elimination
    -> elim @UncurriedExponent do
      \case
        Call_ f xs   -> pure (foldl (Apply a) f xs)
        Fun_  args b -> pure (foldr (Lam   a) b args)

    -- let-with-args feature elimination
    $  elim @LetFun do
      \case
        LetFun_ name args body k -> pure (Let a name (foldr (Lam a) body args) k)

    $  absurd

source :: Tree Uncurried ()
source = call_ "map"
  [ fun_ ["i", "x"] $ call_ "lookup" ["x", "assoc"]
  , "xs"
  ]

dest :: Tree Curried ()
dest = runIdentity (curryExponent source)

Features.hs

{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BlockArguments #-}

module Features where

import Prelude hiding ((<>))
import Data.String
import Text.PrettyPrint.HughesPJClass

import Union
import Tree
import Cofree

---- Features -----------------------------------------------------------------

{- | Variable.
-}
newtype Var a
  = Var_ String
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

{- | Variable as AST.
-}
pattern Var :: Var `In` fs => a -> String -> Tree fs a
pattern Var a name = a :> Case (Var_ name)

{- | Variable as AST w/o annotation.
-}
var_ :: Var `In` fs => String -> Tree fs ()
var_ = Var ()

{- | Short-hand syntax for variables.
-}
instance (a ~ (), Var `In` fs) => IsString (Tree fs a) where
  fromString = var_

instance Pretty (Var a) where
  pPrint (Var_ n) = text n

{- | Curried functions and their invocations.
-}
data Exponent a
  = Apply_ a a
  | Lam_ String a
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

pattern Apply :: Exponent `In` fs => a -> Tree fs a -> Tree fs a -> Tree fs a
pattern Lam   :: Exponent `In` fs => a -> String    -> Tree fs a -> Tree fs a

pattern Apply a f x      = a :> Case (Apply_ f x)
pattern Lam   a arg body = a :> Case (Lam_   arg body)

apply_ :: Exponent `In` fs => Tree fs () -> Tree fs () -> Tree fs ()
lam_   :: Exponent `In` fs => String     -> Tree fs () -> Tree fs ()

apply_ = Apply ()
lam_   = Lam ()

instance Pretty a => Pretty (Exponent a) where
  pPrintPrec l p (Apply_ f x) =
    maybeParens (p > 8) do
      pPrintPrec l p f <+> pPrintPrec l 9 x

  pPrintPrec l p (Lam_ f x) =
    maybeParens (p > 8) do
      hang ("\\" <> pPrintPrec l p f <+> "->") 2 do
        pPrint x

{- | Curried functions and their invocations.
-}
data UncurriedExponent a
  = Call_ a [a]
  | Fun_ [String] a
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

pattern Call :: UncurriedExponent `In` fs => a -> Tree fs a -> [Tree fs a] -> Tree fs a
pattern Fun  :: UncurriedExponent `In` fs => a -> [String]   -> Tree fs a  -> Tree fs a

pattern Call a f xs      = a :> Case (Call_ f xs)
pattern Fun  a args body = a :> Case (Fun_  args body)

call_ :: UncurriedExponent `In` fs => Tree fs () -> [Tree fs ()] -> Tree fs ()
fun_  :: UncurriedExponent `In` fs => [String]   ->  Tree fs ()  -> Tree fs ()

call_ = Call ()
fun_  = Fun  ()

instance Pretty a => Pretty (UncurriedExponent a) where
  pPrintPrec l p (Call_ f xs) =
    pPrintPrec l p f <> parens (fsep $ punctuate comma $ map pPrint xs)

  pPrintPrec l p (Fun_ args x) =
    maybeParens (p > 9) do
      hang ("fun" <+> parens (fsep $ punctuate comma $ map text args) <+> "->") 2 do
        pPrintPrec l 9 x

{- | Value declarations.
-}
data Let a = Let_ String a a
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

pattern Let :: Let `In` fs => a -> String -> Tree fs a -> Tree fs a -> Tree fs a
pattern Let a name x k = a :> Case (Let_ name x k)

let_ :: Let `In` fs => String -> Tree fs () -> Tree fs () -> Tree fs ()
let_ = Let ()

instance Pretty a => Pretty (Let a) where
  pPrintPrec l p (Let_ n x k) =
    vcat
      [ hang ("let" <+> text n <+> "=") 2 (pPrint x)
      , pPrint k
      ]

{- | Value declarations.
-}
data LetFun a = LetFun_ String [String] a a
  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)

pattern LetFun :: LetFun `In` fs => a -> String -> [String] -> Tree fs a -> Tree fs a -> Tree fs a
pattern LetFun a name args x k = a :> Case (LetFun_ name args x k)

letFun_ :: Let `In` fs => String -> Tree fs () -> Tree fs () -> Tree fs ()
letFun_ = Let ()

instance Pretty a => Pretty (LetFun a) where
  pPrintPrec l p (LetFun_ n xs x k) =
    vcat
      [ hang ("let" <+> text n <+> parens (fsep $ punctuate comma $ map text xs) <+> "=") 2 (pPrint x)
      , pPrint k
      ]

Tree.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

{- |
  Abstract Syntax Tree as a sum of its features with annotations.
-}
module Tree where

import Control.Arrow
import Data.Function (fix)
import Data.Traversable

import Union
import Cofree
import Append

{- |
  AST.
-}
type Tree fs info = Cofree (Union fs) info

transform ::
     ( Monad m
     , Traversable (Union fs)
     )
  => (a -> Union fs (Tree gs b) -> m (Tree gs b))  -- ^ handler
  ->       Tree  fs          a                     -- ^ source
  ->     m (Tree gs          b)
{- |
  Cata-like folding of tree while changing both ALL features and annotation.
  Handler receives a tree with all subtrees already converted in bottom-up manner.
-}
transform f = fix \go (a :> fa) -> traverse go fa >>= f a

hide ::
     ( Monad m
     , Traversable f
     , Traversable (Union fs)
     )
  => (a -> f (Tree      fs  a) -> m (Tree fs a))
  ->          Tree (f : fs) a
  ->       m (Tree      fs  a)
{- |
  Rewrite one feature from a language into existing features.
  Handler receives a tree with all subtrees already converted in bottom-up manner.
-}
hide f = transform \a -> elim (f a) (pure . (a :>))

replace ::
     forall fs hs gs m a
  .  ( Append fs
     , Append hs
     , Monad m
     , Traversable (Union (fs ++ gs))
     )
  => (a -> Union fs (Tree (hs ++ gs) a) -> m (Tree (hs ++ gs) a))
  ->                 Tree (fs ++ gs) a
  ->              m (Tree (hs ++ gs) a)
{- |
  Rewrite some features from a language into existing and new features.
  Handler receives a tree with all subtrees already converted in bottom-up manner.
-}
replace f = transform \a fs -> do
  case split @fs @gs fs of
    Left  fs -> f a fs
    Right gs -> pure (a :> extend @hs gs)

Union.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}

{- |
  Open sum for functors.
-}
module Union where

import Text.PrettyPrint.HughesPJClass

{- |
  Sum of @fs@.
-}
data Union fs a where
  Here  ::       f  a -> Union (f : fs) a
  There :: Union fs a -> Union (f : fs) a

{- |
  Membership of functor @f@ inside `Union fs`
-}
class f `In` fs where
  inject  ::       f  a -> Union  fs a   -- ^ inject into sum
  project :: Union fs a -> Maybe (f  a)  -- ^ extract from sum

infix 1 `In`

instance {-# OVERLAPS #-} f `In` f : fs where
  inject  = Here
  project = elim Just (const Nothing)

instance f `In` fs => f `In` g : fs where
  inject  = There . inject
  project = elim (const Nothing) project

{- |
  Universal match for sum parts.
-}
pattern Case :: f `In` fs => f a -> Union fs a
pattern Case fa <- (project -> Just fa)
  where Case fa =   inject fa

{- |
  General eliminator for unempty sums.
-}
elim :: forall f fs a c. (f a -> c) -> (Union fs a -> c) -> Union (f : fs) a -> c
elim here there = \case
  Here  fa -> here  fa
  There u  -> there u

{- |
  General eliminator for empty sums.
-}
absurd :: Union '[] a -> c
absurd = \case

-- Various instances

instance Functor     (Union '[]) where fmap     f = \case
instance Foldable    (Union '[]) where foldMap  f = \case
instance Traversable (Union '[]) where traverse f = \case

instance (Functor f, Functor (Union fs)) => Functor (Union (f : fs)) where
  fmap f = elim (Here . fmap f) (There . fmap f)

instance (Foldable f, Foldable (Union fs)) => Foldable (Union (f : fs)) where
  foldMap = liftA2 elim foldMap foldMap

instance (Traversable f, Traversable (Union fs)) => Traversable (Union (f : fs)) where
  traverse f = elim (fmap Here . traverse f) (fmap There . traverse f)

instance Eq  (Union '[] a) where _  ==       _ = True
instance Ord (Union '[] a) where _ `compare` _ = EQ

instance (Eq (f a), Eq (Union fs a)) => Eq (Union (f : fs) a) where
  Here  fa == Here  ga = fa == ga
  There ua == There va = ua == va
  _        == _        = False

instance (Ord (f a), Ord (Union fs a)) => Ord (Union (f : fs) a) where
  Here  fa `compare` Here  ga = fa `compare` ga
  There ua `compare` There va = ua `compare` va
  Here  _  `compare` There _  = LT
  _        `compare` _        = GT

instance Show (Union '[] a) where
  show = absurd

instance (Show (f a), Show (Union fs a)) => Show (Union (f : fs) a) where
  showsPrec i = elim (showsPrec i) (showsPrec i)

instance Pretty (Union '[] a) where
  pPrint = absurd

instance (Pretty (f a), Pretty (Union fs a)) => Pretty (Union (f : fs) a) where
  pPrintPrec i r = elim (pPrintPrec i r) (pPrintPrec i r)