module Language.Haskell.Meta.QQ.SKI (SKI(..),ski) where
import Language.Haskell.Meta
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
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
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
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 (n1) (']':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 ']'