repl.it
@anonymous/

SmoothLoudAutoexec

Haskell

No description

fork
loading
Files
  • main.hs
main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}

-- Base types

data ExprF var t e
  = Literal Int
  | Binary e var e
  | Typed t e
  deriving (Functor)

mapT :: (a -> b) -> ExprF var a e -> ExprF var b e
mapT f e =
  case e of
    Literal i -> Literal i
    Binary l op r -> Binary l op r
    Typed t e -> Typed (f t) e
  

data TypeF t
  = TypeConstructor String [t]
  | FunctionType t t
  deriving (Functor)

-- AST types

newtype Expr ann var = FixExpr { unFixExpr :: ann (ExprF var (Type ann) (Expr ann var)) }
newtype Type ann = FixType { unFixType :: ann (TypeF (Type ann)) }
newtype Decl ann doc var = Decl (ann (Maybe doc, Maybe (Type ann), Expr ann var))
newtype Module ann = Module [Decl ann String String]

-- Recursion schemes

cataExpr :: Functor ann => (ann (ExprF var (Type ann) a) -> a) -> Expr ann var -> a
cataExpr f = f . fmap (fmap $ cataExpr f) . unFixExpr

cataType :: Functor ann => (ann (TypeF a) -> a) -> Type ann -> a
cataType f = f . fmap (fmap $ cataType f) . unFixType

-- Converting annotations

class Convert t where
  type SetAnn (ann' :: * -> *) t
  type GetAnn t :: * -> *
  convert :: (forall x. (GetAnn t) x -> ann' x) -> t -> SetAnn ann' t

instance Functor ann => Convert (Expr ann var) where
  type SetAnn ann' (Expr ann var) = Expr ann' var
  type GetAnn (Expr ann var) = ann
  convert f = cataExpr (FixExpr . f . fmap (mapT (convert f)))

instance Functor ann => Convert (Type ann) where
  type SetAnn ann' (Type ann) = Type ann'
  type GetAnn (Type ann) = ann
  convert f = cataType (FixType . f)

instance Functor ann => Convert (Decl ann doc var) where
  type SetAnn ann' (Decl ann doc var) = Decl ann' doc var
  type GetAnn (Decl ann doc var) = ann
  convert f (Decl d) =
    Decl (f $ fmap convertD d)
    where
      convertD (doc, t, e) = (doc, fmap (convert f) t, convert f e)

instance Functor ann => Convert (Module ann) where
  type SetAnn ann' (Module ann) = Module ann'
  type GetAnn (Module ann) = ann
  convert f (Module m) = Module $ fmap (convert f) m

--

main = putStrLn "main"
GHCi, version 8.6.5