{-# LANGUAGE DeriveDataTypeable, PatternGuards, TemplateHaskell #-}
module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where
import Language.Haskell.Meta (parseExp, parsePat)
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.Meta.Utils (cleanNames, ppDoc, unQ)
import Text.ParserCombinators.ReadP
import Data.Typeable(Typeable)
import Data.Generics(Data)
import Text.PrettyPrint(render)
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 (unQ[|$(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 (unQ[|$(return e) $(return e')|])
eval0 x = x
ski :: QuasiQuoter
ski = QuasiQuoter
{quoteExp = skiExpQ
,quotePat = skiPatQ}
instance Lift SKI where
lift = liftSKI
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
-}