    {-# LANGUAGE CPP, ScopedTypeVariables #-}
    {-
    Uses pattern guards

    This is an interpreter of the Unlambda language, written in
    the pure, lazy, functional language Haskell.

    Copyright (C) 2001 by Ørjan Johansen <oerjan@nvg.ntnu.no>
    Copyright (C) 2006 by Don Stewart - http://www.cse.unsw.edu.au/~dons

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
    -}

    module Language.Unlambda where

    #if !MIN_VERSION_base(4,6,0)
    import Prelude hiding(catch)
    #endif
    import Control.Applicative
    import Control.Exception (catch, IOException)
    import Control.Monad (liftM, ap)

    ------------------------------------------------------------------------
    -- Abstract syntax

    data Exp
        = App Exp Exp
        | K
        | K1 Exp
        | S
        | S1 Exp
        | S2 Exp Exp
        | I
        | V
        | C
        | Cont (Cont Exp)
        | D
        | D1 Exp
        | Dot Char
        | E
        | At
        | Ques Char
        | Pipe

    ------------------------------------------------------------------------
    -- Printing

    instance Show Exp where
      showsPrec :: Int -> Exp -> ShowS
    showsPrec Int
    _ = Exp -> ShowS
    sh

    sh :: Exp -> String -> String
    sh :: Exp -> ShowS
    sh (App Exp
    x Exp
    y)  = Char -> ShowS
    showChar Char
    '`' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    x ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    y
    sh Exp
    K          = Char -> ShowS
    showChar Char
    'k'
    sh (K1 Exp
    x)     = String -> ShowS
    showString String
    "`k" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    x
    sh Exp
    S          = Char -> ShowS
    showChar Char
    's'
    sh (S1 Exp
    x)     = String -> ShowS
    showString String
    "`s" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    x
    sh (S2 Exp
    x Exp
    y)   = String -> ShowS
    showString String
    "``s" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    x ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    y
    sh Exp
    I          = Char -> ShowS
    showChar Char
    'i'
    sh Exp
    V          = Char -> ShowS
    showChar Char
    'v'
    sh Exp
    C          = Char -> ShowS
    showChar Char
    'c'
    sh (Cont Cont Exp
    _)   = String -> ShowS
    showString String
    "<cont>"
    sh Exp
    D          = Char -> ShowS
    showChar Char
    'd'
    sh (D1 Exp
    x)     = String -> ShowS
    showString String
    "`d" ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> ShowS
    sh Exp
    x
    sh (Dot Char
    '\n') = Char -> ShowS
    showChar Char
    'r'
    sh (Dot Char
    c)    = Char -> ShowS
    showChar Char
    '.' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> ShowS
    showChar Char
    c
    sh Exp
    E          = Char -> ShowS
    showChar Char
    'e'
    sh Exp
    At         = Char -> ShowS
    showChar Char
    '@'
    sh (Ques Char
    c)   = Char -> ShowS
    showChar Char
    '?' ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> ShowS
    showChar Char
    c
    sh Exp
    Pipe       = Char -> ShowS
    showChar Char
    '|'

    ------------------------------------------------------------------------
    -- Eval monad

    newtype Eval a = Eval ((Maybe Char, Int) -> Cont a -> IO Exp)

    type Cont a = (Maybe Char, Int) -> a -> IO Exp

    instance Functor Eval where

      fmap :: forall a b. (a -> b) -> Eval a -> Eval b
    fmap = (a -> b) -> Eval a -> Eval b
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM

    instance Applicative Eval where

      pure :: forall a. a -> Eval a
    pure = a -> Eval a
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return

      <*> :: forall a b. Eval (a -> b) -> Eval a -> Eval b
    (<*>) = Eval (a -> b) -> Eval a -> Eval b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad Eval where

      (Eval (Maybe Char, Int) -> Cont a -> IO Exp
    cp1) >>= :: forall a b. Eval a -> (a -> Eval b) -> Eval b
    >>= a -> Eval b
    f = ((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b)
    -> ((Maybe Char, Int) -> Cont b -> IO Exp) -> Eval b
    forall a b. (a -> b) -> a -> b
    $ \(Maybe Char, Int)
    dat1 Cont b
    cont2 ->
                            (Maybe Char, Int) -> Cont a -> IO Exp
    cp1 (Maybe Char, Int)
    dat1 (Cont a -> IO Exp) -> Cont a -> IO Exp
    forall a b. (a -> b) -> a -> b
    $ \(Maybe Char, Int)
    dat2 a
    a ->
                                let (Eval (Maybe Char, Int) -> Cont b -> IO Exp
    cp2) = a -> Eval b
    f a
    a in (Maybe Char, Int) -> Cont b -> IO Exp
    cp2 (Maybe Char, Int)
    dat2 Cont b
    cont2

      return :: forall a. a -> Eval a
    return a
    a = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a)
    -> ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    forall a b. (a -> b) -> a -> b
    $ \(Maybe Char, Int)
    dat Cont a
    cont -> Cont a
    cont (Maybe Char, Int)
    dat a
    a

    ------------------------------------------------------------------------
    -- Basics

    currentChar :: Eval (Maybe Char)
    currentChar :: Eval (Maybe Char)
    currentChar      = ((Maybe Char, Int) -> Cont (Maybe Char) -> IO Exp)
    -> Eval (Maybe Char)
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\dat :: (Maybe Char, Int)
    dat@(Maybe Char
    c,Int
    _) Cont (Maybe Char)
    cont -> Cont (Maybe Char)
    cont (Maybe Char, Int)
    dat Maybe Char
    c)
    setCurrentChar :: Maybe Char -> Eval ()
    setCurrentChar :: Maybe Char -> Eval ()
    setCurrentChar Maybe Char
    c = ((Maybe Char, Int) -> Cont () -> IO Exp) -> Eval ()
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\(Maybe Char
    _,Int
    i) Cont ()
    cont -> Cont ()
    cont (Maybe Char
    c,Int
    i) ())
    io :: IO a -> Eval a
    io :: forall a. IO a -> Eval a
    io IO a
    iocp          = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\(Maybe Char, Int)
    dat Cont a
    cont -> IO a
    iocp IO a -> (a -> IO Exp) -> IO Exp
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Cont a
    cont (Maybe Char, Int)
    dat)
    throw :: ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
    throw :: forall t a. ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
    throw (Maybe Char, Int) -> t -> IO Exp
    c t
    x        = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\(Maybe Char, Int)
    dat Cont a
    _ -> (Maybe Char, Int) -> t -> IO Exp
    c (Maybe Char, Int)
    dat t
    x)
    exit :: Exp -> Eval a
    exit :: forall a. Exp -> Eval a
    exit Exp
    e           = ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\(Maybe Char, Int)
    _ Cont a
    _ -> Exp -> IO Exp
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    e)
    callCC :: (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
    callCC :: forall a. (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
    callCC ((Maybe Char, Int) -> a -> IO Exp) -> Eval a
    f         = ((Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
    -> Eval a
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (((Maybe Char, Int)
      -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
     -> Eval a)
    -> ((Maybe Char, Int)
        -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp)
    -> Eval a
    forall a b. (a -> b) -> a -> b
    $ \(Maybe Char, Int)
    dat (Maybe Char, Int) -> a -> IO Exp
    cont -> let Eval (Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp
    cp2 = ((Maybe Char, Int) -> a -> IO Exp) -> Eval a
    f (Maybe Char, Int) -> a -> IO Exp
    cont in (Maybe Char, Int) -> ((Maybe Char, Int) -> a -> IO Exp) -> IO Exp
    cp2 (Maybe Char, Int)
    dat (Maybe Char, Int) -> a -> IO Exp
    cont
    step :: Eval ()
    step :: Eval ()
    step             = ((Maybe Char, Int) -> Cont () -> IO Exp) -> Eval ()
    forall a. ((Maybe Char, Int) -> Cont a -> IO Exp) -> Eval a
    Eval (\(Maybe Char
    c,Int
    i) Cont ()
    cont -> if Int
    iInt -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <Int
    1 then Exp -> IO Exp
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    E else Cont ()
    cont (Maybe Char
    c,Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) ())

    ------------------------------------------------------------------------
    -- Interpretation in the Eval monad

    eval :: Exp -> Eval Exp
    eval :: Exp -> Eval Exp
    eval (App Exp
    e1 Exp
    e2) = do
      f <- Exp -> Eval Exp
    eval Exp
    e1
      case f of
        Exp
    D -> Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Exp
    D1 Exp
    e2)
        Exp
    _ -> Exp -> Eval Exp
    eval Exp
    e2 Eval Exp -> (Exp -> Eval Exp) -> Eval Exp
    forall a b. Eval a -> (a -> Eval b) -> Eval b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= Exp -> Exp -> Eval Exp
    apply Exp
    f
    eval Exp
    e = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    e

    apply :: Exp -> Exp -> Eval Exp
    apply :: Exp -> Exp -> Eval Exp
    apply Exp
    K Exp
    x        = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Exp
    K1 Exp
    x)
    apply (K1 Exp
    x) Exp
    _   = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x
    apply Exp
    S Exp
    x        = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Exp
    S1 Exp
    x)
    apply (S1 Exp
    x) Exp
    y   = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Exp -> Exp
    S2 Exp
    x Exp
    y)
    apply (S2 Exp
    x Exp
    y) Exp
    z = Exp -> Eval Exp
    eval (Exp -> Exp -> Exp
    App (Exp -> Exp -> Exp
    App Exp
    x Exp
    z) (Exp -> Exp -> Exp
    App Exp
    y Exp
    z))
    apply Exp
    I Exp
    x        = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x
    apply Exp
    V Exp
    _        = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    V
    apply Exp
    C Exp
    x        = (Cont Exp -> Eval Exp) -> Eval Exp
    forall a. (((Maybe Char, Int) -> a -> IO Exp) -> Eval a) -> Eval a
    callCC (Exp -> Exp -> Eval Exp
    apply Exp
    x (Exp -> Eval Exp) -> (Cont Exp -> Exp) -> Cont Exp -> Eval Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Cont Exp -> Exp
    Cont)
    apply (Cont Cont Exp
    c) Exp
    x = Cont Exp -> Exp -> Eval Exp
    forall t a. ((Maybe Char, Int) -> t -> IO Exp) -> t -> Eval a
    throw Cont Exp
    c Exp
    x
    apply Exp
    D Exp
    x        = Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x
    apply (D1 Exp
    e) Exp
    x   = do f <- Exp -> Eval Exp
    eval Exp
    e; apply f x
    apply (Dot Char
    c) Exp
    x  = Eval ()
    step Eval () -> Eval () -> Eval ()
    forall a b. Eval a -> Eval b -> Eval b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> IO () -> Eval ()
    forall a. IO a -> Eval a
    io (Char -> IO ()
    putChar Char
    c) Eval () -> Eval Exp -> Eval Exp
    forall a b. Eval a -> Eval b -> Eval b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Exp -> Eval Exp
    forall a. a -> Eval a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x
    apply Exp
    E Exp
    x        = Exp -> Eval Exp
    forall a. Exp -> Eval a
    exit Exp
    x
    apply Exp
    At Exp
    f = do
      dat <- IO (Maybe Char) -> Eval (Maybe Char)
    forall a. IO a -> Eval a
    io (IO (Maybe Char) -> Eval (Maybe Char))
    -> IO (Maybe Char) -> Eval (Maybe Char)
    forall a b. (a -> b) -> a -> b
    $ IO (Maybe Char)
    -> (IOException -> IO (Maybe Char)) -> IO (Maybe Char)
    forall e a. Exception e => IO a -> (e -> IO a) -> IO a
    catch ((Char -> Maybe Char) -> IO Char -> IO (Maybe Char)
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Char -> Maybe Char
    forall a. a -> Maybe a
    Just IO Char
    getChar) (\(IOException
    _ :: IOException) -> Maybe Char -> IO (Maybe Char)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Char
    forall a. Maybe a
    Nothing)
      setCurrentChar dat
      apply f (case dat of Maybe Char
    Nothing -> Exp
    V ; Just Char
    _  -> Exp
    I)
    apply (Ques Char
    c) Exp
    f = do
      cur <- Eval (Maybe Char)
    currentChar
      apply f (if cur == Just c then I else V)
    apply Exp
    Pipe Exp
    f = do
      cur <- Eval (Maybe Char)
    currentChar
      apply f (case cur of Maybe Char
    Nothing -> Exp
    V ; Just Char
    c  -> Char -> Exp
    Dot Char
    c)
    apply (App Exp
    _ Exp
    _) Exp
    _ = String -> Eval Exp
    forall a. HasCallStack => String -> a
    error String
    "Unknown application"