Concatenative.hs 9.09 KB
Newer Older
1
2
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase, DeriveGeneric #-}
module Algebra.Monad.Concatenative(StackBuiltin(..),StackVal(..),t'StackDict,StackState,defaultState,StackSymbol(..),AtomClass(..),ConcatT,concatT,MonadStack(..),Opaque(..)) where
3
4

import Definitive
5
import Language.Parser
6
import GHC.Generics
7
8

newtype Opaque a = Opaque a
9
                 deriving (Generic)
10
11
instance Show (Opaque a) where show _ = "#<opaque>"
data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
12
                    | Builtin_Clear | Builtin_Stack
13
14
15
16
17
18
                    | Builtin_Pick 
                    | Builtin_Pop  | Builtin_PopN
                    | Builtin_Dup  | Builtin_DupN
                    | Builtin_Swap | Builtin_SwapN
                    | Builtin_Range | Builtin_Each
                    | Builtin_Add | Builtin_Sub | Builtin_Mul | Builtin_Div | Builtin_Mod | Builtin_Sign
19
20
                    | Builtin_DeRef | Builtin_Def
                    | Builtin_Exec
21
                    | Builtin_CurrentDict | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
22
                    | Builtin_Quote
23
                    | Builtin_Extra b
24
                    deriving (Show,Generic)
25
26
27
28
data StackVal s b a = StackBuiltin (StackBuiltin b)
                    | StackInt Int
                    | StackSymbol s
                    | StackList [StackVal s b a]
29
                    | StackDict (Map s (StackVal s b a))
30
31
                    | StackProg [s]
                    | StackExtra (Opaque a)
32
                    deriving (Show,Generic)
33

34
35
36
37
t'StackDict :: Traversal' (StackVal s b a) (Map s (StackVal s b a))
t'StackDict k (StackDict d) = StackDict <$> k d
t'StackDict _ x = return x

38
39
40
41
42
43
44
data StackState st s b a = StackState {
  _stack :: [StackVal s b a],
  _progStack :: [s],
  _depth :: Int,
  _dict :: Map s (StackVal s b a),
  _extraState :: st
  }
45
  deriving Generic
46
47
48
49
50
51
52
53
54
55
56
57

stack :: Lens' (StackState st s b a) [StackVal s b a]
stack = lens _stack (\x y -> x { _stack = y })
progStack :: Lens' (StackState st s b a) [s]
progStack = lens _progStack (\x y -> x { _progStack = y })
depth :: Lens' (StackState st s b a) Int
depth = lens _depth (\x y -> x { _depth = y })
dict :: Lens' (StackState st s b a) (Map s (StackVal s b a))
dict = lens _dict (\x y -> x { _dict = y })
extraState :: Lens st st' (StackState st s b a) (StackState st' s b a)
extraState = lens _extraState (\x y -> x { _extraState = y })

58
data AtomClass s = OpenBrace | CloseBrace | Number Int | Quoted s | Comment s | Other s
59
60
61
62
63
class Ord s => StackSymbol s where atomClass :: s -> AtomClass s
instance StackSymbol String where
  atomClass "{" = OpenBrace
  atomClass "}" = CloseBrace
  atomClass ('\'':t) = Quoted t
64
  atomClass ('"':t) = Quoted (init t)
65
66
  atomClass (':':t) = Comment t
  atomClass x = maybe (Other x) Number (matches Just readable x)
67

68
69
execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (s -> m ()) -> s -> m ()
execSymbolImpl execBuiltin' onComment atom = do
70
71
72
73
74
75
76
77
78
79
  st <- get
  case atomClass atom of
    OpenBrace -> do depth =~ (+1) ; when (st^.depth > 0) (progStack =~ (atom:))
    CloseBrace -> do
      depth =~ subtract 1
      if st^.depth == 1 then do
        stack =~ (StackProg (reverse $ st^.progStack):)
        progStack =- []
        else progStack =~ (atom:)
    Quoted a | st^.depth==0 -> stack =~ (StackSymbol a:)
80
81
    Comment a -> onComment a
    Number n | st^.depth==0 -> stack =~ (StackInt n:)
82
83
84
85
86
87
    _ -> case st^.depth of
           0 -> case st^.dict.at atom of
             Just v -> exec v
             Nothing -> stack =~ (StackSymbol atom:)
           _ -> progStack =~ (atom:)
  where exec (StackBuiltin b) = execBuiltin' b
88
        exec (StackProg p) = traverse_ (execSymbolImpl execBuiltin' onComment) p
89
90
        exec x = stack =~ (x:)

91
92
execBuiltin :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
execBuiltin runExtra onComment = go
93
94
95
96
97
98
99
100
101
  where 
    go Builtin_Def = get >>= \st -> case st^.stack of
      (val:StackSymbol var:tl) -> do dict =~ insert var val ; stack =- tl
      _ -> return ()
    go Builtin_ListBegin = stack =~ (StackBuiltin Builtin_ListBegin:)
    go Builtin_ListEnd = stack =~ \st -> let (h,_:t) = break (\x -> case x of
                                                                               StackBuiltin Builtin_ListBegin -> True
                                                                               _ -> False) st
                                                  in StackList (reverse h):t
102
    go Builtin_Stack = stack =~ \x -> StackList x:x
103
    go Builtin_Clear = stack =- []
104
105
    go Builtin_Pick = stack =~ \st -> case st of StackInt i:StackInt n:t | i<n, x:t' <- drop i t -> x:drop (n-i-1) t'
                                                 _ -> st
106
    go Builtin_Pop = stack =~ drop 1
107
    go Builtin_PopN = stack =~ \st -> case st of StackInt n:t | (h,_:t') <- splitAt n t -> h+t' ; _ -> st
108
109
110
111
112
113
114
115
    go Builtin_Swap = stack =~ \st -> case st of x:y:t -> y:x:t ; _ -> st
    go Builtin_SwapN = stack =~ \st -> case st of
      StackInt n:st' ->
        case splitAt (n+1) st' of
          (x:tx,y:ty) -> y:tx+(x:ty)
          _ -> st
      _ -> st
    go Builtin_Dup = stack =~ \st -> case st of x:t -> x:x:t ; _ -> st
116
    go Builtin_DupN = stack =~ \st -> case st of StackInt n:t | x:_ <- drop n t -> x:t ; _ -> st
117
    go Builtin_Range = stack =~ \st -> case st of StackInt n:t -> StackList [StackInt i | i <- [0..n-1]]:t ; _ -> st
118
119
120
121
122
    go Builtin_Each = do
      st <- get
      case st^.stack of
        e:StackList l:t -> do
          stack =- t
123
          for_ l $ \x -> do stack =~ (x:) ; execVal e
124
        _ -> return ()
125
126
127
128
129
130
131
132
133

    go Builtin_CurrentDict = getl dict >>= \d -> stack =~ (StackDict d:)
    go Builtin_Empty = stack =~ (StackDict zero:)
    go Builtin_Insert = stack =~ \case
      x:StackSymbol s:StackDict d:t -> StackDict (insert s x d):t
      st -> st
    go Builtin_Delete = stack =~ \case
      StackSymbol s:StackDict d:t -> StackDict (delete s d):t
      st -> st
134
135
136
137
138
139
    go Builtin_Lookup = join $ do
      stack <~ \case
        el:th:StackSymbol s:StackDict d:t -> case lookup s d of
          Just x -> (x:t,execVal th)
          Nothing -> (t,execVal el)
        st -> (st,return ())
140
141
142
143
144
145
146
147
148
149
150
151
152
153
    go Builtin_Keys = stack =~ \case
      StackDict d:t -> StackList (map StackSymbol (keys d)):t
      st -> st
    
    go Builtin_Add = stack =~ \st -> case st of StackInt m:StackInt n:t -> StackInt (n+m):t; _ -> st
    go Builtin_Sub = stack =~ \st -> case st of StackInt m:StackInt n:t -> StackInt (n-m):t; _ -> st
    go Builtin_Mul = stack =~ \st -> case st of StackInt m:StackInt n:t -> StackInt (n*m):t; _ -> st
    go Builtin_Div = stack =~ \st -> case st of StackInt m:StackInt n:t -> StackInt (n`div`m):t; _ -> st
    go Builtin_Mod = stack =~ \st -> case st of StackInt m:StackInt n:t -> StackInt (n`mod`m):t; _ -> st
    go Builtin_Sign = stack =~ \st -> case st of StackInt n:t -> StackInt (case compare n 0 of
                                                                              LT -> -1
                                                                              GT -> 1
                                                                              EQ -> 0):t; _ -> st

154
155
156
157
158
159
160
161
    go Builtin_DeRef = do
      st <- get
      stack =~ \x -> case x of
                       StackSymbol v:t -> maybe (StackSymbol v) id (st^.dict.at v):t
                       _ -> x
    go Builtin_Exec = do
      st <- get
      case st^.stack of
162
163
        StackProg p:t -> do stack =- t ; execVal (StackProg p)
        StackBuiltin p:t -> do stack =- t ; execVal (StackBuiltin p)
164
        _ -> return ()
165
166
167
168
    go Builtin_Quote = stack =~ \case
      StackList l:t -> StackProg [s | StackSymbol s <- l]:t
      st -> st
      
169
170
    go (Builtin_Extra x) = runExtra x

171
172
173
    execVal (StackProg p) = traverse_ (execSymbolImpl go onComment) p
    execVal (StackBuiltin b) = go b
    execVal _ = return ()
174
175

class (StackSymbol s,Monad m) => MonadStack st s b a m | m -> st s b a where
176
  execSymbol :: (b -> m ()) -> (s -> m ()) -> s -> m ()
177
178
  runStackState :: State [StackVal s b a] x -> m x
  runExtraState :: State st x -> m x
179
  runDictState :: State (Map s (StackVal s b a)) x -> m x
180
181

newtype ConcatT st b o s m a = ConcatT { _concatT :: StateT (StackState st s b o) m a }
182
                          deriving (Functor,SemiApplicative,Unit,Applicative,MonadTrans)
183
184
instance Monad m => Monad (ConcatT st b o s m) where join = coerceJoin ConcatT
instance (StackSymbol s,Monad m) => MonadStack st s b a (ConcatT st b a s m) where
185
  execSymbol x y z = ConcatT $ execSymbolImpl (execBuiltin (map _concatT x) (map _concatT y)) (map _concatT y) z
186
187
  runStackState st = ConcatT $ (\x -> return (swap $ stack (map swap (st^..state)) x))^.stateT
  runExtraState st = ConcatT $ (\x -> return (swap $ extraState (map swap (st^..state)) x))^.stateT
188
  runDictState st = ConcatT $ (\x -> return (swap $ dict (map swap (st^..state)) x))^.stateT
189
190
191
192
193

defaultState = StackState [] [] 0

concatT :: Iso (ConcatT st b o s m a) (ConcatT st' b' o' s' m' a') (StateT (StackState st s b o) m a) (StateT (StackState st' s' b' o') m' a')
concatT = iso ConcatT (\(ConcatT x) -> x)