repl.it
@anonymous/

RundownTroubledPackage

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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}

data Never = Never Never

class Go f where
  map4 ::
    (ns1 -> ns2)
    -> (ann1 -> ann2)
    -> (t1 -> t2)
    -> (e1 -> e2)
    -> f ns1 ann1 t1 e1
    -> f ns2 ann2 t2 e2

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

  map2 ::
    (ns1 -> ns2)
    -> (ann1 -> ann2)
    -> fix ns1 ann1
    -> fix ns2 ann2
  cata ::
    (ns -> ns')
    -> (ann -> ann')
    -> (Typ ns' ann' t' e' -> t')
    -> (Expression ns' ann' t' e' -> e')
    -> fix ns ann
    -> Pick fix t' e'

  ana ::
    (ns' -> ns)
    -> (ann' -> ann)
    -> (t' -> Typ ns' ann' t' e')
    -> (e' -> Expression ns' ann' t' e')
    -> Pick fix t' e'
    -> fix ns ann


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

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

newtype FTyp ns ann =
  FixT { unFixT :: Typ ns ann (FTyp ns ann) Never }
  deriving (Show)

instance Go' FTyp where
  type Pick FTyp t e = t

  map2 fns fann =
    FixT . map4 fns fann (map2 fns fann) undefined . unFixT
  cata fns fann ft fe (FixT t) =
    ft $
    case t of
      Name ann ns n -> Name (fann ann) (fns ns) n
      Function first rest -> Function (cata fns fann ft fe first) (fmap (cata fns fann ft fe) rest)

  ana fns fann ft fe a =
    FixT $ case ft a of
      Name ann ns n -> Name (fann ann) (fns ns) n
      Function first rest -> Function (ana fns fann ft fe (first)) (fmap (ana fns fann ft fe) rest)

newtype FExpression ns ann =
  FixE { unFixE :: Expression ns ann (FTyp ns ann) (FExpression ns ann) }
  deriving (Show)

instance Go' FExpression where
  type Pick FExpression t e = e

  map2 fns fann =
    FixE . map4 fns fann (map2 fns fann) (map2 fns fann) . unFixE

  cata fns fann ft fe e =
    fe $
    case unFixE e of
      Typed ann e' t' -> Typed (fann ann) (cata fns fann ft fe e') (cata fns fann ft undefined t')
      Add ann e1 e2 -> Add (fann ann) (cata fns fann ft fe e1) (cata fns fann ft fe e2)
      Literal ann l -> Literal (fann ann) l

  ana fns fann ft fe a =
    FixE $ case fe a of
      Typed ann e' t' -> Typed (fann ann) (ana fns fann ft fe e') (ana fns fann ft fe t')
      Add ann e1 e2 -> Add (fann ann) (ana fns fann ft fe e1) (ana fns fann ft fe e2)
      Literal ann l -> Literal (fann ann) l

x :: FExpression String ()
x =
  FixE $ Typed ()
    (FixE $ Add ()
      (FixE $ Literal () 1)
      (FixE $ Literal () 2)
    )
    (FixT $ Name () "Basic" "Int")

y :: FExpression String String
y =
  map2 id (\() -> "") x

numberLevels :: FExpression ns ann -> FExpression ns Int
numberLevels e =
  ana fns fann ft fe ((0, e))
  where
    fns (_, ns) = ns
    fann (i, _) = i
    ft (i, t) =
      let i' = i+1
      in
      case unFixT t of
        Name ann ns n -> Name (i', ann) (i', ns) n
        Function first rest -> Function (i', first) (fmap ((,) i') rest)
    fe (i, e) =
      let i' = i+1
      in
      case unFixE e of
        Typed ann e' t' -> Typed (i', ann) (i', e') (i', t')
        Add ann e1 e2 -> Add (i', ann) (i', e1) (i', e2)
        Literal ann l -> Literal (i', ann) l

z :: FExpression Mod Int
z = map2 toMod id $ numberLevels x

main = putStrLn (show z)

data Mod = Basic | Unknown deriving (Show)
toMod "Basic" = Basic
GHCi, version 8.6.5