combinator-interactive (empty) → 0.1

raw patch · 5 files changed

+377/−0 lines, 5 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, combinator-interactive, containers, directory, lens, mtl, template-haskell, th-lift, trifecta, void

Files

Data/Combinator.hs +161/−0
LICENSE +30/−0
Setup.hs +2/−0
combinator-interactive.cabal +30/−0
main.hs +154/−0

+ Data/Combinator.hs view

@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell #-}
+module Data.Combinator where
+
+import Prelude hiding (elem, notElem, foldl, foldr, length)
+import Data.Foldable
+import Control.Lens
+import Control.Applicative
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Lift
+import Data.Void
+import Text.Trifecta
+import Data.List (minimumBy)
+import Data.Function (on)
+import Data.Monoid
+
+infixl 9 :$
+
+data Expr e = Expr e :$ Expr e -- application
+            | I | K | S -- primitive combinators
+            | Var e -- external value
+              deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+
+deriveLift ''Expr
+
+instance Monad Expr where
+    return = Var
+    Var x >>= f = f x
+    (a :$ b) >>= f = (a >>= f) :$ (b >>= f)
+    I >>= _ = I
+    K >>= _ = K
+    S >>= _ = S
+
+-- Basic Functions
+-- | The 'length' function returns a length of an expression. 
+length :: Expr e -> Int
+length (f :$ g) = length f + length g + 1
+length _ = 1
+
+isPrim :: Expr e -> Bool
+isPrim S = True
+isPrim K = True
+isPrim I = True
+isPrim x = False
+
+subst :: Eq e => e -- free variable to search for
+    -> Expr e
+    -> Expr e -> Expr e
+subst v r (f :$ g) = subst v r f :$ subst v r g
+subst v r (Var v') | v == v' = r
+subst _ _ e = e
+
+-- | The 'bindee' function transforms an expression to a combinator which binds specified variable when it is applied.
+bindee :: Eq e => e -> Expr e -> Expr e
+-- refered to John Tromp "Binary Lambda Calculus and Combinatory Logic", 2011 (http://homepages.cwi.nl/~tromp/cl/LC.pdf section 3.2)
+bindee _ (S :$ K :$ _) = S :$ K
+bindee x f              | x `notElem` toList f = K :$ f
+bindee x (Var x')      | x == x' = I
+bindee x (f :$ Var x') | x `notElem` toList f && x == x' = f
+bindee x (Var y :$ f :$ Var z)
+    | x == y && x == z = bindee x $ S :$ S :$ K :$ Var x :$ f
+bindee x (f :$ (g :$ h))
+    | isPrim f && isPrim g = bindee x $ S :$ bindee x f :$ g :$ h
+bindee x ((f :$ g) :$ h)
+    | isPrim f && isPrim h = bindee x $ S :$ f :$ bindee x h :$ g
+bindee x ((f :$ g) :$ (h :$ g'))
+    | isPrim f && isPrim h && g == g' = bindee x $ S :$ f :$ h :$ g
+bindee x (f :$ g) = S :$ bindee x f :$ bindee x g
+
+apply :: Expr e -> Expr e -> Expr e
+apply I x = x
+apply (K :$ x) y = x
+apply (S :$ x :$ y) z = apply x z `apply` apply y z
+apply f g = f :$ g
+
+eval :: Expr e -> Expr e
+eval (f :$ g) = eval f `apply` eval g
+eval x = x
+
+unlambdaParser :: Parser (Expr String)
+unlambdaParser = char '`' *> ((:$) <$> unlambdaParser <*> unlambdaParser)
+    <|> char 's' *> pure S
+    <|> char 'k' *> pure K
+    <|> char 'i' *> pure I
+    <|> Var <$> (char '[' *> some (satisfy (/=']')) <* char ']')
+
+ccParser :: Parser (Expr String)
+ccParser = token $ foldl (:$) <$> term <*> many term where
+    term = token $ parens ccParser
+        <|> S <$ char 'S'
+        <|> K <$ char 'K'
+        <|> I <$ char 'I'
+        <|> lambda
+        <|> vacuous <$> stringLit
+        <|> vacuous <$> intLit
+        <|> Var <$> variable
+
+variable = token $ liftA2 (:) lower (many alphaNum)
+
+lambda :: Parser (Expr String)
+lambda = do
+    symbol "\\"
+    v <- variable
+    symbol "."
+    bindee v <$> ccParser
+
+stringLit :: Parser (Expr Void)
+stringLit = fmap (error "stringLit is buggy") $ bindee "C" <$> bindee "N"
+    <$> foldr (\x y -> Var "C" :$ x :$ y) (Var "N")
+    <$> map (encodeInt.fromEnum)
+    <$> (stringLiteral :: Parser String)
+
+intLit :: Parser (Expr Void)
+intLit = encodeInt <$> fromEnum <$> natural
+
+cc :: QuasiQuoter
+cc = QuasiQuoter { quoteExp = \s -> case parseString ccParser mempty s of
+    Success a -> lift a
+    Failure err -> fail $ show err
+    , quoteType = const $ fail "Unsupported"
+    , quoteDec = const $ fail "Unsupported"
+    , quotePat = const $ fail "Unsupported"  }
+
+showCC :: Expr String -> String
+showCC = snd . go False where
+    go _ I = (False, "I")
+    go _ K = (False, "K")
+    go _ S = (False, "S")
+    go _ (Var x) = (True, x)
+    go p (a :$ b)
+        | p = fmap (\x -> "(" ++ x ++ ")") s
+        | otherwise = s
+        where
+            s = case (go False a, go True b) of
+                ((True, l), (True, r)) -> (True, l ++ " " ++ r)
+                ((_, l), (_, r)) -> (False, l ++ r)
+
+ccExpression :: Prism' String (Expr String)
+ccExpression = prism' showCC (preview _Success . parseString (ccParser<*eof) mempty)
+
+churchNumeral :: Prism' (Expr a) Int
+churchNumeral = prism' encodeInt ((>>= decodeInt) . preview _Combinator)
+
+encodeInt :: Int -> Expr a
+encodeInt 0 = K :$ I
+encodeInt 1 = I
+encodeInt 2 = S :$ (S :$ (K :$ S) :$ K) :$ I
+encodeInt n
+    | mod n 2 == 0 = n'
+    | otherwise = S :$ (S :$ (K :$ S) :$ K) :$ n'
+    where
+        n' = S :$ (K :$ encodeInt 2) :$ encodeInt (div n 2)
+
+decodeInt :: Expr Void -> Maybe Int
+decodeInt e = go $ vacuous e `apply` Var True `apply` Var False where
+    go (Var True :$ x) = succ <$> go x
+    go (Var False) = Just 0
+    go _ = Nothing
+
+_Combinator :: Prism' (Expr a) (Expr Void)
+_Combinator = prism' vacuous (traverse (const Nothing)) where

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Fumiaki Kinoshita nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ combinator-interactive.cabal view

@@ -0,0 +1,30 @@+-- Initial combinator-interactive.cabal generated by cabal init.  For 
+-- further documentation, see http://haskell.org/cabal/users-guide/
+
+name:                combinator-interactive
+version:             0.1
+synopsis:            SKI Combinator interpreter
+description:         
+homepage:            https://github.com/fumieval/combinator-interactive
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          fumiexcel@gmail.com
+copyright:           Copyright (c) 2013 Fumiaki Kinoshita
+category:            Language
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  default-language:   Haskell2010
+  build-depends: base == 4.*, lens >=3.8 && <=4, template-haskell, th-lift, void, trifecta == 1.*
+  exposed-modules: Data.Combinator
+
+executable lazyi
+  main-is: main.hs
+  -- other-modules:       
+  other-extensions:    DeriveFunctor, DeriveFoldable, DeriveTraversable, TemplateHaskell
+  build-depends:       base == 4.*, lens >=3.8 && <=4, void, trifecta == 1.*, template-haskell, th-lift, combinator-interactive, containers, mtl == 2.*, cereal, directory, bytestring
+  -- hs-source-dirs:      
+  default-language:    Haskell2010

+ main.hs view

@@ -0,0 +1,154 @@+{-# LANGUAGE TemplateHaskell, PackageImports, FlexibleInstances #-}
+import Prelude hiding (foldr)
+import Text.Trifecta
+import System.IO
+import Control.Monad.State
+import Control.Lens
+import Data.Foldable
+import Control.Applicative
+import qualified Data.Map as Map
+import qualified Control.Exception as E
+import Data.Void
+import System.IO.Unsafe
+import System.IO.Error
+import Data.Monoid
+import qualified Data.ByteString.Lazy as BS
+import System.Directory
+import qualified Data.Serialize as S
+
+import "combinator-interactive" Data.Combinator
+
+data Command = Eval (Expr String)
+    | Run (Expr String)
+    | Define String (Expr String)
+    | Load FilePath String
+    | Save FilePath (Expr String)
+    | Del String
+    | Quit
+
+parseCommand :: Parser Command
+parseCommand = try define <|> run <|> load <|> del <|> quit <|> eval where
+    run = do
+        string ":run"
+        Run <$> ccParser
+    eval = do
+        Eval <$> ccParser
+    define = do
+        var <- variable
+        symbol "="
+        Define var <$> ccParser
+    load = do
+        string ":load"
+        path <- stringLiteral
+        name <- option "main" $ variable
+        return $ Load path name
+    save = do
+        string ":load"
+        path <- stringLiteral
+        expr <- ccParser
+        return $ Save path expr
+    del = do
+        string ":del"
+        Del <$> variable
+    quit = Quit <$ string ":quit"
+    
+consE x xs = S :$ (S :$ I :$ (K :$ x)) :$ (K :$ xs)
+
+runLazy :: Expr Void -> IO ()
+runLazy expr = input >>= output . vacuous . eval . (expr :$)
+
+end = consE (churchNumeral # 256) end
+
+input :: IO (Expr Void)
+input = unsafeInterleaveIO $ E.catch g $ \e -> if isEOFError e then return end else fail (show e) where
+    g = do
+        ch <- getChar
+        consE (_Combinator # churchNumeral # enum # ch) <$> input
+
+output :: Expr () -> IO ()
+output e = case e `apply` Var () of
+    Var () :$ x :$ xs -> case x ^? churchNumeral of
+        Just n
+            | n >= 256 -> return ()
+            | otherwise -> putChar (n ^. enum) >> output xs
+        Nothing -> fail "The result is not a number"
+    _ -> fail "The result is not a list"
+
+data Env = Env
+    { _definitions :: Map.Map String (Expr String)
+    }
+makeLenses ''Env
+
+applyDefs :: Map.Map String (Expr String) -> Expr String -> Expr String
+applyDefs = foldr (.) id . map (uncurry subst) . Map.toList
+
+prompt :: StateT Env IO ()
+prompt = do
+    lift $ putStr "lazy> "
+    lift $ hFlush stdout
+    cmd <- lift getLine
+    case parseString parseCommand mempty cmd of
+        Success a -> case a of
+            Eval expr -> do
+                m <- use definitions
+                lift $ putStrLn $ ccExpression # eval (applyDefs m expr)
+                prompt
+            Run expr -> do
+                m <- use definitions
+                lift $ runLazy (fmap (\x -> error $ "Unexpected free variable: " ++ x) (applyDefs m expr))
+                    `E.catch` \(E.ErrorCall msg) -> hPutStrLn stderr msg
+                    `E.catch` \e -> hPutStrLn stderr (show (e :: E.IOException))
+                prompt
+            Define name expr
+                | name `Data.Foldable.elem` expr -> do
+                    lift $ hPutStrLn stderr "Recursive definitions are not allowed"
+                    prompt
+                | otherwise -> do
+                    m <- use definitions
+                    definitions . at name ?= applyDefs m expr
+                    dump
+                    prompt
+            Load path name -> do
+                r <- parseFromFile ccParser path
+                case r of
+                    Just expr -> do
+                        definitions . at name ?= expr
+                        dump
+                        lift $ putStrLn $ "Loaded: " ++ name ++ "."
+                        prompt
+                    Nothing -> prompt
+            Save path expr -> do
+                m <- use definitions
+                lift $ writeFile path $ ccExpression # eval (applyDefs m expr)
+                prompt
+            Del name -> do
+                definitions . at name .= Nothing
+                prompt
+            Quit -> return ()
+        Failure doc -> do
+            lift $ hPutStrLn stderr $ show doc
+            prompt
+
+dump = do
+    path <- lift $ (++"/.lazyi-env") <$> getHomeDirectory
+    env <- get
+    lift $ BS.writeFile path $ S.encodeLazy env
+
+defaultEnv = Env Map.empty
+
+instance S.Serialize (Expr String) where
+    put expr = S.put (ccExpression # expr)
+    get = S.get >>= maybe (fail "parse error") return . preview ccExpression
+
+instance S.Serialize Env where
+    put (Env m) = S.put m
+    get = Env <$> S.get
+
+main = do
+    path <- (++"/.lazyi-env") <$> getHomeDirectory
+    b <- doesFileExist path
+    let w = hPutStrLn stderr "Warning: .lazyi-env is broken." >> return defaultEnv
+    env <- if b
+        then S.decodeLazy <$> BS.readFile path >>= either (const w) return
+        else return defaultEnv
+    evalStateT prompt env