CPL 0.0.5 → 0.0.6
raw patch · 5 files changed
+134/−102 lines, 5 filesdep +haskelinedep +readline
Dependencies added: haskeline, readline
Files
- CPL.cabal +23/−7
- NEWS +5/−0
- README +3/−0
- src/CPLSystem.hs +22/−22
- src/Main.hs +81/−73
CPL.cabal view
@@ -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
NEWS view
@@ -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.
README view
@@ -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 -----
src/CPLSystem.hs view
@@ -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
src/Main.hs view
@@ -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 ----------------------------------------------------------------------------