Skip to content

Instantly share code, notes, and snippets.

@avh4
Last active October 23, 2019 19:43
Show Gist options
  • Save avh4/8ae2f51d6a8ec9f6844715ddd42e219a to your computer and use it in GitHub Desktop.
Save avh4/8ae2f51d6a8ec9f6844715ddd42e219a to your computer and use it in GitHub Desktop.
Haskell AST types
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment