erin/DSLUnique.icl

   1 module DSLUnique
   2
   3 import StdEnv
   4 import UniqueState
   5
   6 class list v
   7 where
   8         list :: [Int] -> *v *[Int]
   9         (++.) infixr 5 :: *(v *[Int]) *(v *[Int]) -> *(v *[Int])
  10
  11 class select v
  12 where
  13         (!.) infixl 9 :: *(v *[Int]) *(v Int) -> *(v Int)
  14
  15 class expr v
  16 where
  17         lit :: a -> *(v a) | toStringU a
  18         (+.) infixl 6 :: *(v Int) *(v Int) -> *(v Int)
  19         (-.) infixl 6 :: *(v Int) *(v Int) -> *(v Int)
  20         (*.) infixl 7 :: *(v Int) *(v Int) -> *(v Int)
  21         (/.) infixl 7 :: *(v Int) *(v Int) -> *(v Int)
  22         If :: *(v Bool) *(v a) *(v a) -> *(v a)
  23
  24 class step v
  25 where
  26         (>>*.) infixl 1 :: *(v .t) *[Step *v .t .u] -> *(v .u)
  27
  28 :: *Step v t u
  29         = IfValue ((v t) -> *(v Bool, v t)) ((v t) -> v u)
  30         | Always (v u)
  31
  32 class toStringU a
  33 where
  34         toStringU :: .a -> String
  35
  36 instance toStringU Bool
  37 where
  38         toStringU :: !.Bool -> String
  39         toStringU a
  40                 = code inline {
  41                         .d 0 1 i
  42                                 jsr BtoAC
  43                         .o 1 0
  44                 }
  45 instance toStringU Int
  46 where
  47         toStringU :: !.Int -> String
  48         toStringU a
  49                 = code inline {
  50                         .d 0 1 i
  51                                 jsr ItoAC
  52                         .o 1 0
  53                 }
  54
  55 instance toStringU String
  56 where
  57         toStringU :: !.String -> String
  58         toStringU a
  59                 = code inline {
  60                         no_op
  61                 }
  62
  63 show :: u:a -> *(State String u:b) | toStringU a
  64 show x = State \s -> (undef, s +++ toStringU x)
  65
  66 instance list (State String)
  67 where
  68         list x = show " list " >>| pure undef
  69         (++.) l r = l >>| show " ++ " >>| r >>| pure undef
  70
  71 instance select (State String)
  72 where
  73         // >>| expects both sides to have the same attribute, this is not the case
  74         // here
  75         (!.) a i = a >>| show " ! " >>| i >>| pure undef
  76
  77 instance expr (State String)
  78 where
  79         lit x = show x
  80         (+.) l r = l >>| show " + " >>| r >>| pure undef
  81         (-.) l r = l >>| show " - " >>| r >>| pure undef
  82         (*.) l r = l >>| show " * " >>| r >>| pure undef
  83         (/.) l r = l >>| show " / " >>| r >>| pure undef
  84         If b t e = show "If " >>| b >>| t >>| e >>| pure undef
  85
  86 instance step (State String)
  87 where
  88         (>>*.) l cs = l >>| show " >>*. [" >>|
  89                 printSteps cs
  90         where
  91                 printSteps [] = show "]"
  92                 printSteps [IfValue p c:cs]
  93                         # (pb, pr) = p (show "i")
  94                         = show "IfValue (\\i->(" >>| pb >>| show ", " >>| pr >>| show ")) (\\v->" >>| c (show "v") >>| show ")" >>| commaCont cs
  95                 printSteps [Always c:cs] = show "Always " >>| c >>| commaCont cs
  96
  97                 commaCont [] = printSteps []
  98                 commaCont cs = show ", " >>| printSteps cs
  99
 100 instance list Maybe
 101 where
 102         list x = undef//Just x
 103         (++.) l r = l >>= \l -> r >>= \r -> pure (l ++ r)
 104
 105 instance select Maybe
 106 where
 107         (!.) a i = a >>= \a -> i >>= \i -> pure (a!!i)
 108
 109 instance expr Maybe
 110 where
 111         lit x = pure x
 112         (+.) l r = l >>= \l -> r >>= \r -> pure (l + r)
 113         (-.) l r = l >>= \l -> r >>= \r -> pure (l - r)
 114         (*.) l r = l >>= \l -> r >>= \r -> pure (l * r)
 115         (/.) _ (Just 0) = Nothing
 116         (/.) l r = l >>= \l -> r >>= \r -> pure (l / r)
 117         If b t e = b >>= \b
 118                 | b = t
 119                 | otherwise = e
 120
 121 instance step Maybe
 122 where
 123         (>>*.) _ [] = Nothing
 124         (>>*.) _ [Always c:_] = c
 125         (>>*.) Nothing [_:cs] = Nothing >>*. cs
 126         (>>*.) v=:(Just _) [IfValue p c:cs]
 127                 = case p v of
 128                         (Nothing, v) = Nothing
 129                         (Just b, v) = if b (c v) (v >>*. cs)
 130
 131 Start :: (Maybe Int, String, Maybe Int, String)
 132 Start = (lit 1 +. lit 2, snd (runState (lit 1 +. lit 2) ""), t, snd (runState t ""))
 133
 134 t :: *(v Int) | expr, step v
 135 t = lit 38 /. lit 0 >>*.
 136         [ IfValue (\v->(lit True, v)) (\i->i)
 137         , Always (lit 42)
 138         ]