Combinators.hs

module Main where

data SK = S | K | App SK SK deriving Eq

data CC = CCAtom Combinator | CCApp CC CC

data Combinator = Comb String SK deriving Eq

data BaseCombinator = BC String CC

data CombinatorDef = CombDef String [Char] DefBody deriving Show

data DefBody = DefAtom Char | DefApp DefBody DefBody

instance Show SK where
    show S = "S"
    show K = "K"
    show (App l r) = "(" ++ show l ++ show r ++ ")"

instance Show Combinator where
    show (Comb s d) = s ++ " = " ++ show d

instance Show BaseCombinator where
    show (BC s d) = s ++ " = " ++ show d

instance Show DefBody where
    show (DefAtom x) = [x]
    show (DefApp l r) = '\'':show l ++ show r

s = Comb "S" S
k = Comb "K" K
i = Comb "I" (App (App S K) K)

instance Show CC where
    show (CCAtom (Comb s _)) = s
    show (CCApp ca cb) = "(" ++ show ca ++ show cb ++")"

parseDefBody :: String -> ((DefBody,String) -> r) -> (String -> r) -> r
parseDefBody [] _ error = error "Expected Token!"
parseDefBody ('\'':xs) ok error = parseDefBody xs (\(d,s) -> parseDefBody s (\(d',s') -> ok (DefApp d d', s')) error) error
parseDefBody (x:xs) ok error = ok $ (DefAtom x, xs)

parseCombDef :: String -> ((CombinatorDef,String) -> r) -> (String -> r) -> r
parseCombDef xs ok error = parseStringTo ':' xs (\(n,':':s) -> parseStringTo '=' s (\(l,'=':s) -> parseDefBody s (\(d,s) -> ok ((CombDef n l d),s)) error) error) error

parseStringTo :: Char -> String -> ((String,String) -> r) -> (String -> r) -> r
parseStringTo c [] _ error = error $ "Expected '" ++ [c] ++ "'!"
parseStringTo c (x:xs) ok error | c == x = ok ("",(x:xs))
parseStringTo c (x:xs) ok error = parseStringTo c xs (\(s,r) -> ok ((x:s),r)) error

translateComb :: CombinatorDef -> Combinator
translateComb (CombDef n l d) = Comb n (translateBody l d)

translateBody :: [Char] -> DefBody -> SK
translateBody xs b = simplify . skify $ foldr reduce b xs

reduce :: Char -> DefBody -> DefBody
reduce c (DefAtom c') | c == c' = DefAtom 'I'
reduce c (DefAtom c') = DefApp (DefAtom 'K') (DefAtom c')
reduce c (DefApp r (DefAtom c')) | (c == c') && (not $ contained c r) = r
reduce c b | not $ contained c b = DefApp (DefAtom 'K') b
reduce c (DefApp l r) = DefApp (DefApp (DefAtom 'S') (reduce c l)) (reduce c r)

contained :: Char -> DefBody -> Bool
contained c (DefAtom c') = c == c'
contained c (DefApp l r) = contained c l || contained c r

skify :: DefBody -> SK
skify (DefAtom 'I') = App (App S K) K
skify (DefAtom 'K') = K
skify (DefAtom 'S') = S
skify (DefApp l r) = App (skify l) (skify r)

simplify :: SK -> SK
simplify K = K
simplify S = S
simplify (App (App K x) _) = simplify x
simplify (App (App (App S x) y) z) = simplify (App (App x z) (App y z))
simplify (App l r) = App (simplify l) (simplify r)

replace :: [Combinator] -> SK -> CC
replace _ K = CCAtom k
replace _ S = CCAtom s
replace cs sk | any (cmatch sk) cs = creplace sk cs
replace cs (App l r) = CCApp (replace cs l) (replace cs r)

cmatch :: SK -> Combinator -> Bool
cmatch sk (Comb _ b) = sk == b

creplace :: SK -> [Combinator] -> CC
creplace sk (c:cs) | cmatch sk c = CCAtom c
creplace sk (_:cs) = creplace sk cs

parseComb s = translateComb $ parseCombDef s fst (const $ CombDef "ERROR" "ERROR" $ DefAtom ' ')

parseSK :: String -> ((SK,String) -> r) -> r
parseSK ('\'':r) ok = parseSK r (\(sk,s) -> parseSK s (\(sk',s') -> ok (App sk sk', s')))
parseSK ('S':r) ok = ok (S,r)
parseSK ('K':r) ok = ok (K,r)

basedParse :: [Combinator] -> String -> BaseCombinator
basedParse cs s = (\(Comb n sk) -> BC n (replace cs sk)) $ parseComb s

intLoop :: [Combinator] -> IO ([Combinator])
intLoop cs = do
    putStrLn "Enter Combinator:"
    c <- getLine
    let bc = basedParse cs c
    let nc = parseComb c
    putStrLn (show bc)
    intLoop (nc:cs)

main :: IO()
main = intLoop [] >>= (const $ return ())