Concatenative.hs 12.4 KB
Newer Older
1
{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies, GeneralizedNewtypeDeriving, LambdaCase, DeriveGeneric #-}
2
3
module Algebra.Monad.Concatenative(
  -- * Extensible stack types
4
  StackBuiltin(..),StackSymbol(..),StackVal(..),StackStep(..),StackClosure(..),execValue,
5
6
7
8
9
10
11
  t'StackDict,
  -- * The MonadStack class
  StackState,defaultState,
  MonadStack(..),
  AtomClass(..),
  -- ** A concrete implementation
  ConcatT,concatT,Opaque(..)) where
12
13

import Definitive
14
import Language.Parser
15
import GHC.Generics (Generic)
16
17

newtype Opaque a = Opaque a
18
                 deriving (Generic)
19
instance Show (Opaque a) where show _ = "#<opaque>"
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
data StackStep s b a = VerbStep s | ConstStep (StackVal s b a) | CommentStep s | ClosureStep Bool (StackClosure s b a)
                     deriving (Show,Generic)
data StackClosure s b a = StackClosure [(StackProgram s b a,StackClosure s b a)] (StackProgram s b a)
                        deriving (Show,Generic)
type StackProgram s b a = [StackStep s b a]

i'StackClosure :: Iso' ([(StackProgram s b a,StackClosure s b a)],StackProgram s b a) (StackClosure s b a)
i'StackClosure = iso (\(cs,c) -> StackClosure cs c) (\(StackClosure cs c) -> (cs,c))

t'ClosureStep :: Traversal' (StackStep s b a) (StackClosure s b a)
t'ClosureStep k (ClosureStep b c) = ClosureStep b<$>k c
t'ClosureStep _ x = pure x

allSteps :: Fold' (StackClosure s b a) (StackStep s b a)
allSteps = from i'StackClosure.(l'1.each.l'1.each .+ l'2.each)
subClosure :: Int -> Fold' (StackClosure s b a) (StackClosure s b a)
subClosure 0 = id
subClosure n = (allSteps.t'ClosureStep.subClosure (n+1))
               .+ (from i'StackClosure.l'1.each.l'2.subClosure (n-1))

closureSplices :: Fold' (StackClosure s b a) (StackClosure s b a)
closureSplices = allSteps.t'ClosureStep.subClosure (1::Int)
               
runClosure execBuiltin' onComment clos = do
  p <- flatten =<< forl closureSplices clos (\c -> StackClosure [] <$> flatten c)
  stack =~ (StackProg p:)
  
  where flatten (StackClosure cs c) = do
          pref <- map fold $ for cs $ \(i,StackClosure _ p) -> (i+) <$> do
            traverse_ (runStep execBuiltin' onComment) p
            stack <~ \(h:t) -> (t,[ConstStep h])
          return (pref + c)
          
runStep execBuiltin' onComment (VerbStep s) = getl (dict.at s) >>= \case
  Just v -> runVal v
  Nothing -> stack =~ (StackSymbol s:)
  where runVal (StackBuiltin b) = execBuiltin' b
        runVal (StackProg p) = traverse_ (runStep execBuiltin' onComment) p
        runVal x = stack =~ (x:)
runStep _ _ (ConstStep v) = stack =~ (v:)
runStep _ onComment (CommentStep c) = onComment c
runStep _ _ (ClosureStep True (StackClosure _ p)) = stack =~ (StackProg p:)
runStep execBuiltin' onComment (ClosureStep _ c) = runClosure execBuiltin' onComment c

64
data StackBuiltin b = Builtin_ListBegin | Builtin_ListEnd
65
                    | Builtin_Clear | Builtin_Stack
66
                    | Builtin_Pick | Builtin_Shift | Builtin_Shaft
67
68
69
70
71
                    | 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
72
73
                    | Builtin_DeRef | Builtin_Def
                    | Builtin_Exec
74
                    | Builtin_CurrentDict | Builtin_Empty | Builtin_Insert | Builtin_Lookup | Builtin_Delete | Builtin_Keys
75
                    | Builtin_Quote
76
                    | Builtin_Extra b
77
                    deriving (Show,Generic)
78
79
80
81
data StackVal s b a = StackBuiltin (StackBuiltin b)
                    | StackInt Int
                    | StackSymbol s
                    | StackList [StackVal s b a]
82
                    | StackDict (Map s (StackVal s b a))
83
                    | StackProg (StackProgram s b a)
84
                    | StackExtra (Opaque a)
85
                    deriving (Show,Generic)
86

87
88
89
90
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

91
92
data StackState st s b a = StackState {
  _stack :: [StackVal s b a],
93
  _progStack :: [StackClosure s b a],
94
95
96
  _dict :: Map s (StackVal s b a),
  _extraState :: st
  }
97
  deriving Generic
98
99
100

stack :: Lens' (StackState st s b a) [StackVal s b a]
stack = lens _stack (\x y -> x { _stack = y })
101
progStack :: Lens' (StackState st s b a) [StackClosure s b a]
102
103
104
105
106
107
progStack = lens _progStack (\x y -> x { _progStack = 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 })

108
data AtomClass s = OpenBrace | CloseBrace | OpenSplice | CloseSplice | Number Int | Quoted s | Comment s | Other s
109
110
111
class Ord s => StackSymbol s where atomClass :: s -> AtomClass s
instance StackSymbol String where
  atomClass "{" = OpenBrace
112
  atomClass "{@" = OpenSplice
113
  atomClass "}" = CloseBrace
114
  atomClass "@}" = CloseSplice
115
  atomClass ('\'':t) = Quoted t
116
  atomClass ('"':t) = Quoted (init t)
117
118
  atomClass (':':t) = Comment t
  atomClass x = maybe (Other x) Number (matches Just readable x)
119

120
121
execSymbolImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (StackBuiltin b -> m ()) -> (s -> m ()) -> s -> m ()
execSymbolImpl execBuiltin' onComment atom = do
122
  st <- get
123
124
125
126
  case (atomClass atom,st^.progStack) of
    (OpenBrace,_) -> progStack =~ (StackClosure [] []:)

    (OpenSplice,StackClosure cs p:ps) ->
Marc Coiffier's avatar
Marc Coiffier committed
127
      progStack =- StackClosure [] []:StackClosure ((reverse p,StackClosure [] []):cs) []:ps
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
    (CloseSplice,StackClosure cs p:StackClosure cs' p':ps) ->
      progStack =- StackClosure (set (t'1.l'2) (StackClosure (reverse cs) (reverse p)) cs') p':ps

    (CloseBrace,StackClosure cs p:ps) -> do
      progStack =- ps
      let c = StackClosure (reverse cs) (reverse p)
      execStep ps (ClosureStep (not $ has (closureSplices .+ (from i'StackClosure.l'1.each.l'2)) c) c)
    (CloseBrace,[]) -> unit
    (OpenSplice,[]) -> unit
    (CloseSplice,_) -> unit

    (Quoted a,ps) -> execStep ps (ConstStep (StackSymbol a))
    (Comment a,ps) -> execStep ps (CommentStep a)
    (Number n,ps) -> execStep ps (ConstStep (StackInt n))
    (Other s,ps) -> execStep ps (VerbStep s)
  where execStep [] stp = runStep execBuiltin' onComment stp
        execStep (StackClosure cs p:ps) stp = progStack =- (StackClosure cs (stp:p):ps)
145

146
147
execBuiltinImpl :: (StackSymbol s, MonadState (StackState st s b a) m) => (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
execBuiltinImpl runExtra onComment = go
148
149
150
151
152
  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:)
153
154
155
156
    go Builtin_ListEnd = stack =~ \st -> let ex acc (StackBuiltin Builtin_ListBegin:t) = (acc,t)
                                             ex acc (h:t) = ex (h:acc) t
                                             ex acc [] = (acc,[])
                                         in let (h,t) = ex [] st in StackList h:t
157
    go Builtin_Stack = stack =~ \x -> StackList x:x
158
    go Builtin_Clear = stack =- []
159
160
    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
161
    go Builtin_Pop = stack =~ drop 1
162
    go Builtin_PopN = stack =~ \st -> case st of StackInt n:t | (h,_:t') <- splitAt n t -> h+t' ; _ -> st
163
164
165
166
167
168
169
    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
170
171
172
173
174
175
    go Builtin_Shift = stack =~ \case
      StackInt n:st' | (h,v:t) <- splitAt n st' -> v:(h+t)
      st -> st
    go Builtin_Shaft = stack =~ \case
      StackInt n:v:st' | (h,t) <- splitAt n st' -> h+(v:t)
      st -> st
176
    go Builtin_Dup = stack =~ \st -> case st of x:t -> x:x:t ; _ -> st
177
    go Builtin_DupN = stack =~ \st -> case st of StackInt n:t | x:_ <- drop n t -> x:t ; _ -> st
178
    go Builtin_Range = stack =~ \st -> case st of StackInt n:t -> StackList [StackInt i | i <- [0..n-1]]:t ; _ -> st
179
180
181
182
183
    go Builtin_Each = do
      st <- get
      case st^.stack of
        e:StackList l:t -> do
          stack =- t
184
          for_ l $ \x -> do stack =~ (x:) ; execVal e
185
        _ -> return ()
186
187
188
189
190
191
192
193
194

    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
195
196
197
198
199
200
    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 ())
201
202
203
204
205
206
207
208
209
210
211
212
213
214
    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

215
216
217
218
219
220
221
222
    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
223
224
        StackProg p:t -> do stack =- t ; execVal (StackProg p)
        StackBuiltin p:t -> do stack =- t ; execVal (StackBuiltin p)
225
        _ -> return ()
226
    go Builtin_Quote = stack =~ \case
227
      StackList l:t -> StackProg (map ConstStep l):t
228
229
      st -> st
      
230
231
    go (Builtin_Extra x) = runExtra x

232
    execVal (StackProg p) = traverse_ (runStep go onComment) p
233
234
    execVal (StackBuiltin b) = go b
    execVal _ = return ()
235
236

class (StackSymbol s,Monad m) => MonadStack st s b a m | m -> st s b a where
237
  execSymbol :: (b -> m ()) -> (s -> m ()) -> s -> m ()
238
  execProgram :: (b -> m ()) -> (s -> m ()) -> StackProgram s b a -> m ()
239
  execBuiltin :: (b -> m ()) -> (s -> m ()) -> StackBuiltin b -> m ()
240
241
  runStackState :: State [StackVal s b a] x -> m x
  runExtraState :: State st x -> m x
242
  runDictState :: State (Map s (StackVal s b a)) x -> m x
243

244
245
246
247
execValue runExtra onComment (StackProg p) = execProgram runExtra onComment p
execValue runExtra onComment (StackBuiltin b) = execBuiltin runExtra onComment b
execValue _ _ _ = unit

248
newtype ConcatT st b o s m a = ConcatT { _concatT :: StateT (StackState st s b o) m a }
249
                          deriving (Functor,SemiApplicative,Unit,Applicative,MonadTrans)
250
251
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
252
253
254
  execSymbol x y z = ConcatT $ execSymbolImpl (execBuiltinImpl (map _concatT x) (map _concatT y)) (map _concatT y) z
  execProgram x y p = ConcatT $ traverse_ (runStep (execBuiltinImpl (map _concatT x) (map _concatT y)) (map _concatT y)) p
  execBuiltin x y b = ConcatT $ execBuiltinImpl (map _concatT x) (map _concatT y) b
255
256
  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
257
  runDictState st = ConcatT $ (\x -> return (swap $ dict (map swap (st^..state)) x))^.stateT
258

259
defaultState = StackState [] []
260
261
262

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)