Haskell AST types

main.hs

{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.Functor.Identity (Identity(..))

data Never = Never Never


class Go f where
  map3 ::
    (ns1 -> ns2)
    -> (t1 -> t2)
    -> (e1 -> e2)
    -> f ns1 t1 e1
    -> f ns2 t2 e2

class Go' fix where
  type Seed fix t e :: *

  map2 ::
    (Functor ann1) =>
    (ns1 -> ns2)
    -> (forall x. ann1 x -> ann2 x)
    -> fix ns1 ann1
    -> fix ns2 ann2
  cata ::
    (Functor annf) =>
    (annf (Typ ns t e) -> t)
    -> (annf (Expression ns t e) -> e)
    -> fix ns annf
    -> Seed fix t e
  ana ::
    (Functor annf) =>
    (t -> annf (Typ ns t e))
    -> (e -> annf (Expression ns t e))
    -> Seed fix t e
    -> fix ns annf


data Expression ns typ expr
  = Typed expr typ
  | Add expr expr
  | Literal Int
  deriving (Show)
instance Go Expression where
  map3 fns ft fe e =
    case e of
      Typed e' t' -> Typed (fe e') (ft t')
      Add e1 e2 -> Add (fe e1) (fe e2)
      Literal l -> Literal l

data Typ ns typ expr
  = Name ns String
  | Function typ [typ]
  deriving (Show)
--role Typ relational relational relational phantom
instance Go Typ where
  map3 fns ft fe t =
    case t of
      Name ns n -> Name (fns ns) n
      Function first rest -> Function (ft first) (fmap ft rest)


newtype FixAST t ns annf =
  FixAST { unFixAST :: annf (t ns (FixAST Typ ns annf) (FixAST Expression ns annf)) }
deriving instance (Show (annf (t ns (FixAST Typ ns annf) (FixAST Expression ns annf)))) => Show (FixAST t ns annf)

instance Go' (FixAST Typ) where
  type Seed (FixAST Typ) t e = t
  map2 fns fann =
    FixAST . fann . fmap (map3 fns (map2 fns fann) undefined) . unFixAST
  cata ft fe =
    ft . fmap (map3 id (cata ft fe) undefined) . unFixAST
  ana ft fe =
    FixAST . fmap (map3 id (ana ft fe) undefined) . ft

instance Go' (FixAST Expression) where
  type Seed (FixAST Expression) t e = e
  map2 fns fann =
    FixAST . fann . fmap (map3 fns (map2 fns fann) (map2 fns fann)) . unFixAST
  cata ft fe =
    fe . fmap (map3 id (cata ft fe) (cata ft fe)) . unFixAST
  ana ft fe =
    FixAST . fmap (map3 id (ana ft fe) (ana ft fe)) . fe


x :: FixAST Expression String Identity
x =
  FixAST $ Identity $ Typed
    (FixAST $ Identity $ Add
      (FixAST $ Identity $ Literal 1)
      (FixAST $ Identity $ Literal 2)
    )
    (FixAST $ Identity $ Name "Basic" "Int")

y :: FixAST Expression String ((,) String)
y =
  map2 id ((,) "" . runIdentity) x

numberLevels :: (forall x. ann x -> x) -> FixAST Expression ns ann -> FixAST Expression ns ((,) Int)
numberLevels extract e =
  ana ft fe (0, e)
  where
    ft (i, t) =
      let i' = i+1
      in
      (,) i $
      case extract $ unFixAST t of
        Name ns n -> Name ns n
        Function first rest -> Function (i', first) (fmap ((,) i') rest)
    fe (i, e) =
      let i' = i+1
      in
      (,) i $
      case extract $ unFixAST e of
        Typed e' t' -> Typed (i', e') (i', t')
        Add e1 e2 -> Add (i', e1) (i', e2)
        Literal l -> Literal l

z :: FixAST Expression Mod ((,) Int)
z = map2 toMod id $ numberLevels runIdentity x

main = putStrLn (show z)

data Mod = Basic | Unknown deriving (Show)
toMod "Basic" = Basic