プログラミング言語のようなゴミ

Readme.md

普通にどうでもいいような言語作ろうとしたら型なしラムダ計算に余計なもの足しただけみたいになってしまった。 再帰も単純にはできない。

Data 宣言はただの代入の糖衣構文です。 例えば Data just _ | nothing は just = (\x c1 c2 -> c1 x); nothing = (\c1 c2 -> c2) を意味します。 just, _, nothing は任意の識別子です。 _の部分は名前であれば意味は変わりません。 Data の直後に | があってもなくても構いません。

lang.hs

{-# LANGUAGE FlexibleContexts, RankNTypes, OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Applicative
import Control.Monad.Error
import qualified Text.Trifecta as T
import qualified Text.Parser.Token.Style as TS
import qualified Text.Parser.Token.Highlight as Highlight
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Data.Monoid
import Data.IORef
import System.Environment (getArgs)

newtype Env t = Env (IORef (M.Map B.ByteString (IORef t)))

data Value = Int Integer
  | String B.ByteString
  | Fun (M.Map B.ByteString (IORef Value)) B.ByteString [Expr]
  | PrimFun (forall m. (MonadIO m, Applicative m, MonadError RuntimeError m) => Value -> m Value)
  | VTrue
  | VFalse
  | Unit
instance Show Value where
  show (Int i) = show i
  show (String s) = B.unpack s
  show (Fun _ v e) = "<<Fun>>"
  show (PrimFun _) = "<<Fun>>"
  show VTrue = "True"
  show VFalse = "False"
  show Unit = "()"

data Expr = Value Value
  | Var B.ByteString
  | App Expr Expr
  | Assn B.ByteString Expr
  deriving (Show)

data RuntimeError = TypeMismatch B.ByteString B.ByteString
  | UnknownName B.ByteString
  | Default String
  deriving (Show)
instance Error RuntimeError where
  strMsg = Default

main = do
  xs <- getArgs
  let name = case xs of
        [] -> error "too few args"
        x:_ -> x
  code <- readFile name
  case T.parseString (runComment exprs) mempty code of
    T.Failure d -> print d
    T.Success s -> runErrorT (do
      env <- initEnvOfVal
      evalExprs env s
      ) >>= either print (const $ return ())

newEnv :: MonadIO m => M.Map B.ByteString (IORef t) -> m (Env t)
newEnv env = liftIO $ Env <$> newIORef env

initEnv :: MonadIO m => m (Env t)
initEnv = newEnv M.empty

mkFunIntInt :: (MonadIO m, MonadError RuntimeError m) => (Integer -> Integer -> Integer) -> Value -> m Value
mkFunIntInt f (Int i) = return $ PrimFun g
  where
    g (Int j) = return $ Int $ f i j
    g v = throwError $ TypeMismatch (typeOf v) "Int"
mkFunIntInt _ v = throwError $ TypeMismatch (typeOf v) "Int"

mkFunIntBool :: (MonadIO m, MonadError RuntimeError m) => (Integer -> Integer -> Bool) -> Value -> m Value
mkFunIntBool f (Int i) = return $ PrimFun g
  where
    g (Int j) = return $ if f i j then VTrue else VFalse
    g v = throwError $ TypeMismatch (typeOf v) "Int"
mkFunIntBool _ v = throwError $ TypeMismatch (typeOf v) "Int"

ifFun :: (MonadIO m, MonadError RuntimeError m) => Value -> m Value
ifFun VTrue  = return $ PrimFun $ \t -> return $ PrimFun $ \f -> return t
ifFun VFalse = return $ PrimFun $ \t -> return $ PrimFun $ \f -> return f
ifFun v = throwError $ TypeMismatch (typeOf v) "Bool"

initEnvOfVal :: (MonadIO m, Applicative m) => m (Env Value)
initEnvOfVal = M.traverseWithKey (\_ -> liftIO . newIORef) (M.fromList prims) >>= newEnv
  where
    prims = [ ("print", PrimFun (\v -> liftIO (print v) >> return Unit))
            , ("print'", PrimFun (\v -> liftIO (putStr $ show v) >> return Unit))
            , ("getLine", PrimFun (\_ -> liftIO (String . B.pack <$> getLine)))
            , ("equal" , PrimFun (mkFunIntBool (==)))
            , ("nequal", PrimFun (mkFunIntBool (/=)))
            , ("lequal", PrimFun (mkFunIntBool (<=)))
            , ("gequal", PrimFun (mkFunIntBool (>=)))
            , ("add", PrimFun (mkFunIntInt (+)))
            , ("sub", PrimFun (mkFunIntInt (-)))
            , ("mul", PrimFun (mkFunIntInt (*)))
            , ("div", PrimFun (mkFunIntInt div))
            , ("pow", PrimFun (mkFunIntInt (^)))
            , ("if", PrimFun ifFun)
            ]

lookupRef :: Env t -> B.ByteString -> IO (Maybe (IORef t))
lookupRef (Env env) s = M.lookup s <$> readIORef env

lookupValue :: MonadIO m => Env t -> B.ByteString -> m (Maybe t)
lookupValue env s = liftIO $ do
  ref' <- lookupRef env s
  case ref' of
    Nothing -> return Nothing
    Just ref -> Just <$> readIORef ref

modifyEnv :: MonadIO m => Env t -> (M.Map B.ByteString (IORef t) -> M.Map B.ByteString (IORef t)) -> m ()
modifyEnv (Env env) f = liftIO $ modifyIORef env f

setValue :: MonadIO m => Env t -> B.ByteString -> t -> m ()
setValue env s v = liftIO $ do
  ref' <- lookupRef env s
  case ref' of
    Nothing -> newIORef v >>= \ref -> modifyEnv env (M.insert s ref)
    Just ref -> writeIORef ref v

copyEnv :: MonadIO m => Env t -> m (Env t)
copyEnv (Env env) = liftIO $ Env <$> (readIORef env >>= newIORef)

typeOf :: Value -> B.ByteString
typeOf (Int _) = "Int"
typeOf (String _) = "String"
typeOf (Fun _ _ _) = "Fun"
typeOf (PrimFun _) = "Fun"
typeOf Unit = "Unit"

applyFun :: (MonadIO m, Applicative m, MonadError RuntimeError m) => Value -> Value -> m Value
applyFun (Fun fenv name es) x = do
  env' <- newEnv fenv
  setValue env' name x
  evalExprs env' es
applyFun (PrimFun f) x = f x
applyFun v _ = throwError $ TypeMismatch (typeOf v) "Fun"

evalExpr :: (MonadIO m, Applicative m, MonadError RuntimeError m) => Env Value -> Expr -> m Value
evalExpr (Env env) (Value (Fun fenv name es)) = do
  env' <- liftIO $ readIORef env
  return (Fun (M.union fenv env') name es)
evalExpr _ (Value v) = return v
evalExpr env (Var name) = lookupValue env name >>= maybe (throwError (UnknownName name)) return
evalExpr env (App f x) = join $ applyFun <$> evalExpr env f <*> evalExpr env x
evalExpr env (Assn name e) = do
  v <- evalExpr env e
  setValue env name v
  return v

evalExprs :: (MonadIO m, Applicative m, MonadError RuntimeError m) => Env Value -> [Expr] -> m Value
evalExprs env [] = return Unit
evalExprs env [x] = evalExpr env x
evalExprs env (x:xs) = evalExpr env x >> evalExprs env xs


mkData :: [(B.ByteString,[B.ByteString])] -> [Expr]
mkData xs = map (\((name,ys),c) -> let ys' = mkName 'x' ys in Assn name $ lam (lam (app (Var c) ys') xs') ys') (zip xs xs')
  where
    mkName c l = map (B.pack . (c :) . show) [1..length l]
    xs' = mkName 'c' xs
    lam e l  = foldr (\v e -> Value $ Fun M.empty v [e]) e l
    app = foldl (\e v -> App e (Var v))

idStyle :: T.IdentifierStyle Comment
idStyle = TS.emptyIdents { T._styleStart = T.lower <|> T.char '_' }

var :: Comment B.ByteString
var = B.pack <$> T.ident idStyle

value :: Comment Value
value = T.try (Int <$> T.integer)
  <|> (String <$> T.stringLiteral)
  <|> (mkFun <$ T.symbolic '\\' <*> some var <* T.symbol "->" <*> exprs)
  <|> (VTrue  <$ T.symbol "True")
  <|> (VFalse <$ T.symbol "False")
  <|> (Unit <$ T.symbol "()")
  <|> (Unit <$ T.symbol "†‡")
  where
    mkFun [v] es = Fun M.empty v es
    mkFun (v:vs) es = Fun M.empty v [Value $ mkFun vs es]

cStyle :: TS.CommentStyle
cStyle = TS.haskellCommentStyle

newtype Comment a = Comment { runComment :: T.Parser a }
  deriving (Functor,Applicative,Alternative,Monad,MonadPlus,T.Parsing,T.CharParsing)

instance T.TokenParsing Comment where
  nesting (Comment m) = Comment (T.nesting m)
  someSpace = TS.buildSomeSpaceParser (Comment T.someSpace) cStyle
  semi = Comment T.semi
  highlight h (Comment m) = Comment (T.highlight h m)

oper :: Expr -> Expr -> Expr -> Expr
oper f a b = App (App f a) b

comp :: Comment Expr
comp = T.chainl1 addSub ((oper (Var "equal") <$ T.symbol "==")
  <|> (oper (Var "nequal") <$ T.symbol "!=")
  <|> (oper (Var "lequal") <$ T.symbol "<=")
  <|> (oper (Var "gequal") <$ T.symbol ">="))

addSub :: Comment Expr
addSub = T.chainl1 mulDiv ((oper (Var "add") <$ T.symbol "+")
  <|> (oper (Var "sub") <$ T.symbol "-"))

mulDiv :: Comment Expr
mulDiv = T.chainl1 power ((oper (Var "mul") <$ T.symbol "*")
  <|> (oper (Var "div") <$ T.symbol "/"))

power :: Comment Expr
power = T.chainr1 expr' (oper (Var "pow") <$ T.symbol "^")

expr' :: Comment Expr
expr' = T.chainl1 fact (pure App)

fact :: Comment Expr
fact =  (Var <$> var)
  <|> (Value <$> value)
  <|> T.parens expr
  <|> T.between (T.symbolic '†') (T.symbolic '‡') expr

expr :: Comment Expr
expr = T.try (Assn <$> var <* T.symbol "=" <*> expr)
  <|> comp

exprs' :: Comment [Expr]
exprs' = ((:[]) <$> expr)
  <|> (mkData <$ T.symbol "Data" <* optional (T.symbolic '|')
    <*> T.sepBy ((,) <$> var <*> many var) (T.symbolic '|'))

exprs :: Comment [Expr]
exprs = concat <$ optional T.someSpace <*> T.sepEndBy exprs' (T.symbol ";")

test

-- †
fact_ = (\f n -> if (n <= 0) (\_ -> 1) (\_ -> n * f f (n - 1) ()));
fact = (\n -> fact_ fact_ n ());
print' "10! = "; print †fact 10‡;
print' "2 ^ 3 - 2 * 2 = "; print (2 ^ 3 - 2 * 2);
s = getLine ();
{- hogehoge -} print' {- hello -} "input = " {- v('ω')v -};
print s; -- うし