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
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
-- TODO: knock out these warnings
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TemplateHaskell #-}
module SKI
( SKI(..)
, ski
, parse
, bracksP
, obrackP
, cbrackP
) where
import qualified Control.Monad.Fail as Fail
import Data.Generics (Data)
import Data.Typeable (Typeable)
import Language.Haskell.Meta (parseExp, parsePat)
import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unsafeRunQ)
import Language.Haskell.TH.Lib hiding (parensP)
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Text.ParserCombinators.ReadP
import Text.PrettyPrint (render)
-- TODO: narrow type & move to shared module
quoteTypeNotImplemented :: Fail.MonadFail m => String -> m a
quoteTypeNotImplemented = fail . ("type quoter not implemented: " ++)
-- TODO: narrow type & move to shared module
quoteDecNotImplemented :: Fail.MonadFail m => String -> m a
quoteDecNotImplemented = fail . ("dec quoter not implemented: " ++ )
data SKI = S | K | I | E Exp | SKI :$ SKI
deriving (Eq,Data,Typeable)
run :: String -> [SKI]
run = fmap eval . fst . parse
-- I x = x
-- K x y = x
-- S x y z = (x z) (y z)
eval :: SKI -> SKI
eval (I :$ x) = eval x
eval ((K :$ x) :$ y) = eval x
eval (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))
eval (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|])
eval (x :$ y) = eval0 ((eval x) :$ (eval y))
eval x = x
eval0 (I :$ x) = eval x
eval0 ((K :$ x) :$ y) = eval x
eval0 (((S :$ x) :$ y :$ z)) = eval (eval (x :$ z) :$ eval (y :$ z))
eval0 (E e :$ E e') = E (unsafeRunQ[|$(return e) $(return e')|])
eval0 x = x
ski :: QuasiQuoter
ski = QuasiQuoter
{ quoteExp = skiExpQ
, quotePat = skiPatQ
, quoteType = quoteTypeNotImplemented
, quoteDec = quoteDecNotImplemented
}
instance Lift SKI where
lift = liftSKI
#if MIN_VERSION_template_haskell(2,17,0)
liftTyped = unsafeCodeCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
liftTyped = unsafeTExpCoerce . lift -- TODO: the right way?
#endif
liftSKI (E e) = return e
liftSKI a = go a
where go S = [|S|]
go K = [|K|]
go I = [|I|]
go (E e) = [|E e|]
go (x:$y) = [|$(go x) :$ $(go y)|]
instance Show SKI where
showsPrec p (S) = showString "S"
showsPrec p (K) = showString "K"
showsPrec p (I) = showString "I"
showsPrec p (E x1)
= showParen (p > 10)
(showString (render (ppDoc x1)))
showsPrec p ((:$) x1 x2)
= showParen (p > 10)
(showsPrec 11 x1 . (showString " :$ " . showsPrec 10 x2))
skiExpQ :: String -> ExpQ
skiExpQ s = case run s of
[] -> fail "ski: parse error"
e:_ -> lift (cleanNames e)
skiPatQ :: String -> PatQ
skiPatQ s = do
e <- skiExpQ s
let p = (parsePat
. pprint
. cleanNames) e
case p of
Left e -> fail e
Right p -> return p
-- ghci> parse "S(SS)IK(SK)"
-- ([(((S :$ (S :$ S)) :$ I) :$ K) :$ (S :$ K)],"")
parse :: String -> ([SKI], String)
parse = runP skiP
skiP :: ReadP SKI
skiP = nestedP parensP
(let go a = (do b <- lexemeP (oneP <++ skiP)
go (a:$b)) <++ return a
in lexemeP (go =<< lexemeP oneP))
oneP :: ReadP SKI
oneP = nestedP parensP
(lexemeP (choice [sP
,kP
,iP
,spliceP =<< look
]))
spliceP :: String -> ReadP SKI
spliceP s
| '[':s <- s = skip 1 >> go 1 [] s
| otherwise = pfail
where go _ _ [] = pfail
go 1 acc (']':_) = do skip (1 + length acc)
either (const pfail)
(return . E)
(parseExp (reverse acc))
go n acc ('[':s) = go (n+1) ('[':acc) s
go n acc (']':s) = go (n-1) (']':acc) s
go n acc (c:s) = go n (c:acc) s
sP = (char 's' +++ char 'S') >> return S
kP = (char 'k' +++ char 'K') >> return K
iP = (char 'i' +++ char 'I') >> return I
runP :: ReadP a -> String -> ([a], String)
runP p s = case readP_to_S p s of
[] -> ([],[])
xs -> mapfst (:[]) (last xs)
where mapfst f (a,b) = (f a,b)
skip :: Int -> ReadP ()
skip n = count n get >> return ()
lexemeP :: ReadP a -> ReadP a
lexemeP p = p >>= \x -> skipSpaces >> return x
nestedP :: (ReadP a -> ReadP a) -> (ReadP a -> ReadP a)
nestedP nest p = p <++ nest (skipSpaces >> nestedP nest p)
parensP = between oparenP cparenP
bracksP = between oparenP cparenP
oparenP = char '('
cparenP = char ')'
obrackP = char '['
cbrackP = char ']'
{-
import Prelude hiding (($))
data Komb = S (Maybe (Komb, Maybe Komb)) | K (Maybe Komb) deriving Show
S Nothing $ x = S (Just (x, Nothing))
S (Just (x, Nothing)) $ y = S (Just (x, Just y))
S (Just (x, Just y)) $ z = x $ z $ (y $ z)
K Nothing $ x = K (Just x)
K (Just x) $ y = y
q x = x $ (c $ k) $ k $ k $ s
where s = S Nothing
k = K Nothing
c = s $ (b $ b $ s) $ k $ k
b = s $ (k $ s) $ k
-}
|
