diff --git a/CPL.cabal b/CPL.cabal --- a/CPL.cabal +++ b/CPL.cabal @@ -1,10 +1,11 @@ Name: CPL -Version: 0.0.5 +Version: 0.0.6 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer: masahiro.sakai@gmail.com Category: Compilers/Interpreters +Cabal-Version: >= 1.2 Synopsis: An interpreter of Hagino's Categorical Programming Language (CPL). Description: An interpreter of Hagino's Categorical Programming Language (CPL). Extra-Source-Files: @@ -24,9 +25,24 @@ src/CDT.hs-boot Build-Type: Simple -Executable: cpl -Main-is: Main.hs -HS-Source-Dirs: src -Other-Modules: AExp CDT CDTParser CPLSystem Exp ExpParser FE Funct ParserUtils Simp Statement Subst Type Typing Variance -Build-Depends: base >=4 && <5, mtl, containers, array, parsec -Extensions: CPP, GeneralizedNewtypeDeriving +Flag Readline + Description: Use Readline + Default: False + +Flag Haskeline + Description: Use Haskeline + Default: False + +Executable cpl + Main-is: Main.hs + HS-Source-Dirs: src + Other-Modules: AExp CDT CDTParser CPLSystem Exp ExpParser FE Funct ParserUtils Simp Statement Subst Type Typing Variance + Build-Depends: base >=4 && <5, mtl, containers, array, parsec + Extensions: CPP, GeneralizedNewtypeDeriving + if flag(Readline) + CPP-Options: "-DUSE_READLINE_PACKAGE" + Build-Depends: readline + else + if flag(Haskeline) + CPP-Options: "-DUSE_HASKELINE_PACKAGE" + Build-Depends: haskeline diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,8 @@ + += Changes since the 0.0.5 release + +Readline/Haskeline support. + = Changes since the 0.0.3 release Function defintions are added. diff --git a/README b/README --- a/README +++ b/README @@ -31,6 +31,9 @@ $ runhaskell Setup.hs build $ runhaskell Setup.hs install + If you want to compile with readline or haskeline, add -fReadline or + -fHaskeline respectively to configure command. + Usage ----- diff --git a/src/CPLSystem.hs b/src/CPLSystem.hs --- a/src/CPLSystem.hs +++ b/src/CPLSystem.hs @@ -71,11 +71,11 @@ Right e -> case ExpParser.evalExp (objects sys) (arityEnv sys) e of Nothing -> Left "invalid expression" -- FIXME - Just e -> + Just e2 -> Typing.runTI (tiEnv sys) $ do - t <- Typing.inferType (substIt sys e) - t <- Typing.appSubst t - return $ AExp.quantify t + t <- Typing.inferType (substIt sys e2) + t2 <- Typing.appSubst t + return $ AExp.quantify t2 type Def = (Id, [Id], AExp.AExp, FType) @@ -89,32 +89,32 @@ Just e1 -> Typing.runTI (tiEnv sys) $ do (ts, t) <- Typing.inferType2 ps e1 - ts <- Typing.appSubst ts - t@(ae :! t') <- Typing.appSubst t - let vars = Subst.tv (t' : ts) + ts2 <- Typing.appSubst ts + (ae :! t') <- Typing.appSubst t + let vars = Subst.tv (t' : ts2) s = zip vars [FE.Var i | i<-[0..]] - return (name, ps, Subst.apply s ae, FType (length vars) (Subst.apply s ts) (Subst.apply s t')) + return (name, ps, Subst.apply s ae, FType (length vars) (Subst.apply s ts2) (Subst.apply s t')) arityEnv :: System -> Map.Map Id Int arityEnv sys = if isJust (lastExp sys) then Map.insert "it" 0 env0 else env0 where env0 = Map.map (\(ps,_,_) -> length ps) (varTable sys) tiEnv :: System -> Map.Map Id (Either FType Type) -tiEnv sys = Map.map (\(ps, body, t) -> Left t) (varTable sys) +tiEnv sys = Map.map (\(_, _, t) -> Left t) (varTable sys) substIt :: System -> Exp -> Exp substIt sys e = case lastExp sys of - Just it -> f it e Nothing -> e - where - f it Identity = Identity - f it (Comp a b) = Comp (f it a) (f it b) - f it e@(Nat _) = e - f it (Fact obj args) = Fact obj $ map (f it) args - f it (Funct obj args) = Funct obj $ map (f it) args - f it (Var "it" []) = it - f it (Var v args) = Var v $ map (f it) args + Just it -> f e + where + f Identity = Identity + f (Comp a b) = Comp (f a) (f b) + f e'@(Nat _) = e' + f (Fact obj args) = Fact obj $ map f args + f (Funct obj args) = Funct obj $ map f args + f (Var "it" []) = it + f (Var v args) = Var v $ map f args checkName :: Monad m => System -> String -> m () checkName sys name = @@ -153,10 +153,10 @@ return sys{ varTable = Map.insert name (ps, AExp.skelton e, ftype) (varTable sys) } simp :: System -> Bool -> Exp -> [(Int, Simp.CompiledExp, Simp.CompiledExp)] -simp sys full exp = - let exp' = compile sys exp +simp sys full e = + let e' = compile sys e traces = if trace sys - then Simp.simpWithTrace full exp' - else [(0, compile sys Identity, Simp.simp full exp')] + then Simp.simpWithTrace full e' + else [(0, compile sys Identity, Simp.simp full e')] in traces diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -32,20 +32,24 @@ import Control.Monad.State import Control.Monad.Error import System.Console.GetOpt -#ifdef HAVE_READLINE_PACKAGE +#if defined(USE_READLINE_PACKAGE) import qualified System.Console.SimpleLineEditor as SLE +import Control.Exception (bracket) +#elif defined(USE_HASKELINE_PACKAGE) +import System.Console.Haskeline +#else +import Control.Exception (bracket) #endif -import Control.Exception ---------------------------------------------------------------------------- type UIState = Sys.System -getSystem :: (Monad m) => StateT UIState m Sys.System -getSystem = get - -putSystem :: (Monad m) => Sys.System -> StateT UIState m () -putSystem = put +#ifdef USE_HASKELINE_PACKAGE +type UI a = StateT UIState (InputT IO) a +#else +type UI a = StateT UIState IO a +#endif initialState :: UIState initialState = Sys.emptySystem @@ -106,18 +110,18 @@ LeftObject -> "L" RightObject -> "R" -readLine :: String -> IO String -#ifdef HAVE_READLINE_PACKAGE -readLine prompt = fmap (fromMaybe "") (SLE.getLineEdited prompt) +readLine :: String -> UI String +#if defined(USE_READLINE_PACKAGE) +readLine prompt = liftIO $ fmap (fromMaybe "") (SLE.getLineEdited prompt) +#elif defined(USE_HASKELINE_PACKAGE) +readLine prompt = fmap (fromMaybe "") (lift (getInputLine prompt)) #else -readLine prompt = - do putStr prompt - getLine +readLine prompt = liftIO $ putStr prompt >> getLine #endif ---------------------------------------------------------------------------- -type Command = String -> StateT UIState IO () +type Command = String -> UI () commandTable :: [(String, Command)] commandTable = @@ -137,28 +141,28 @@ , ("right", cmdRight) ] -dispatchCommand :: String -> StateT UIState IO () +dispatchCommand :: String -> UI () dispatchCommand l = case shift l of ([], _) -> return () (cmdStr, arg) -> case lookup cmdStr commandTable of Just cmd -> cmd arg - Nothing -> throwError (userError ("unknown command: " ++ l)) + Nothing -> liftIO $ ioError $ userError $ ("unknown command: " ++ l) ---------------------------------------------------------------------------- defineObject :: Command defineObject src = - do sys <- getSystem + do sys <- get obj <- Sys.parseCDT sys src sys' <- Sys.addCDT sys obj - putSystem sys' + put sys' let lr = case CDT.objectType obj of LeftObject -> "left" RightObject -> "right" msg = concat [lr, " object ", showFunctNameWithVariance obj, " is defined"] - lift $ putStrLn $ msg + liftIO $ putStrLn $ msg cmdLeft, cmdRight :: Command cmdLeft s = defineObject ("left " ++ s) @@ -168,41 +172,41 @@ cmdShow arg = case shift arg of ("object", arg') -> - do sys <- getSystem + do sys <- get let name = strip arg' objects = Sys.objects sys - lift $ putStrLn $ + liftIO $ putStrLn $ case find (\x -> CDT.functName x == name) objects of Just obj -> showObjectInfo obj Nothing -> "unknown object: " ++ name ("aexp", arg') -> do -- XXX - sys <- getSystem + sys <- get case Sys.parseExp sys (strip arg') of Left err -> fail err - Right (_, e :! t) -> lift $ do + Right (_, e :! t) -> liftIO $ do putStrLn $ show e putStrLn $ " : " ++ show t _ -> do - sys <- getSystem + sys <- get case Sys.parseExp sys (strip arg) of Left err -> fail err - Right (_, e :! t) -> lift $ do + Right (_, e :! t) -> liftIO $ do putStrLn $ show $ AExp.skelton e putStrLn $ " : " ++ show t cmdLet :: Command cmdLet arg = do - sys <- getSystem + sys <- get case Sys.parseDef sys (strip arg) of Left err -> fail err Right def@(name, args, e, FType _ args' t) -> do sys' <- Sys.letExp sys def - putSystem sys' + put sys' if null args - then lift $ do + then liftIO $ do putStrLn $ name ++ " = " ++ show (AExp.skelton e) putStrLn $ " : " ++ show t - else lift $ do + else liftIO $ do let lhs = name ++ "(" ++ intercalate "," args ++ ")" putStrLn $ lhs ++ " = " ++ show (AExp.skelton e) let upper = intercalate " " $ [p ++ ": " ++ show t | (p,t) <- zip args args'] @@ -222,7 +226,7 @@ doSimp False (strip arg) where doSimp full str = do - sys <- getSystem + sys <- get unless (any isTerminalObject (Sys.objects sys)) (fail "No terminal object is defined.") case Sys.parseExp sys str of @@ -234,24 +238,24 @@ let line = show step ++ (if depth==0 then "" else "[" ++ show depth ++ "]") ++ ":" ++ show (Simp.decompile exp) ++ "*" ++ show (Simp.decompile cexp) - when (Sys.trace sys) $ lift $ putStrLn line + when (Sys.trace sys) $ liftIO $ putStrLn line if null xs then do let it = Simp.decompile cexp - lift $ putStrLn (show it) - lift $ putStrLn (" : " ++ show t) - putSystem sys{ Sys.lastExp = Just it } + liftIO $ putStrLn (show it) + liftIO $ putStrLn (" : " ++ show t) + put sys{ Sys.lastExp = Just it } else loop xs loop (zip [(0::Int)..] traces) cmdLoad :: Command cmdLoad s = - do h <- lift $ openFile filename ReadMode - contents <- lift $ hGetContents h + do h <- liftIO $ openFile filename ReadMode + contents <- liftIO $ hGetContents h let src = unlines (map removeComment (lines contents)) cmds = split src - mapM_ (\x -> do lift $ (putStr . unlines . map ("> "++) . lines $ x) + mapM_ (\x -> do liftIO $ (putStr . unlines . map ("> "++) . lines $ x) dispatchCommand x) cmds where filename = -- FIXME @@ -270,7 +274,7 @@ cmdEdit :: Command cmdEdit _ = - do s <- lift editLoop + do s <- editLoop dispatchCommand s where editLoop = do l <- readLine "| " @@ -280,10 +284,10 @@ return $ l ++ "\n" ++ s cmdQuit :: Command -cmdQuit _ = lift $ exitWith ExitSuccess +cmdQuit _ = liftIO $ exitWith ExitSuccess cmdHelp :: Command -cmdHelp _ = lift $ mapM_ putStrLn l +cmdHelp _ = liftIO $ mapM_ putStrLn l where l = [ " exit exit the interpreter" , " quit ditto" , " bye ditto" @@ -304,25 +308,25 @@ ([], _) -> case flag of "trace" -> - do sys <- getSystem - lift $ putStrLn $ + do sys <- get + liftIO $ putStrLn $ "trace=" ++ (if Sys.trace sys then "on" else "off") _ -> - lift $ putStrLn $ "unknown flag:" ++ flag + liftIO $ putStrLn $ "unknown flag:" ++ flag (value, _) -> case flag of "trace" -> case value of "on" -> - do sys <- getSystem - putSystem (sys{ Sys.trace = True }) + do sys <- get + put (sys{ Sys.trace = True }) "off" -> - do sys <- getSystem - putSystem (sys{ Sys.trace = False }) + do sys <- get + put (sys{ Sys.trace = False }) _ -> - lift $ putStrLn ("unknown value:" ++ value) + liftIO $ putStrLn ("unknown value:" ++ value) _ -> - lift $ putStrLn ("unknown flag:" ++ flag) + liftIO $ putStrLn ("unknown flag:" ++ flag) cmdReset :: Command cmdReset _ = put initialState @@ -348,29 +352,27 @@ ] main :: IO () -main = -#ifndef HAVE_READLINE_PACKAGE +#if defined(USE_READLINE_PACKAGE) +main = bracket SLE.initialise (const SLE.restore) (const main_) +#elif defined(USE_HASKELINE_PACKAGE) +main = runInputT defaultSettings main_ +#else +main = do bracket (do x <- hGetBuffering stdout hSetBuffering stdout NoBuffering return x) (hSetBuffering stdout) (const main_) -#else - do bracket SLE.initialise - (const SLE.restore) - (const main_) #endif -main_ :: IO () main_ = - do args <- getArgs + do args <- liftIO $ getArgs case getOpt Permute options args of - (o,_,[]) | Help `elem` o -> - putStrLn (usageInfo header options) - (o,_,[]) | Version `elem` o -> - putStrLn versionStr + (o,_,[]) + | Help `elem` o -> liftIO $ putStrLn (usageInfo header options) + | Version `elem` o -> liftIO $ putStrLn versionStr (o,n,[]) -> - do putStr banner + do liftIO $ putStr banner evalStateT (do mapM_ processOpt o mapM_ cmdLoad n if null n || Interactive `elem` o @@ -378,10 +380,10 @@ else return ()) initialState (_,_,errs) -> - ioError $ userError $ concat errs ++ usageInfo header options + liftIO $ ioError $ userError $ concat errs ++ usageInfo header options version :: [Int] -version = [0,0,2] +version = [0,0,6] versionStr :: String versionStr = intercalate "." $ map show $ version @@ -397,22 +399,28 @@ "Type help for help\n" ++ "\n" -processOpt :: Flag -> StateT UIState IO () +processOpt :: Flag -> UI () processOpt (Trace s) = - do sys <- getSystem + do sys <- get val <- case s of "on" -> return True "off" -> return False _ -> fail "invalid option" - putSystem sys{ Sys.trace = val } + put sys{ Sys.trace = val } return () processOpt _ = return () -mainLoop :: StateT UIState IO () -mainLoop = - do l <- lift $ readLine "cpl> " - catchError (dispatchCommand l) - (lift . putStrLn . show) - mainLoop +mainLoop :: UI () +mainLoop = do + l <- readLine "cpl> " +#if defined(USE_HASKELINE_PACKAGE) + handle h (dispatchCommand l) +#else + dispatchCommand l `catchError` h +#endif + mainLoop + where + h :: IOError -> UI () + h = liftIO . putStrLn . show ----------------------------------------------------------------------------