{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Main -- Copyright : (c) Masahiro Sakai 2004,2009 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- ----------------------------------------------------------------------------- module Main where import CDT import Exp import qualified Statement import qualified CPLSystem as Sys import qualified AExp import Type import Typing (Typing(..)) import qualified Simp import Data.Maybe import Data.List import Data.Char (isSpace) import System.Environment import System.Exit import System.IO import Control.Monad.State import Control.Monad.Error import System.Console.GetOpt #ifdef HAVE_READLINE_PACKAGE import qualified System.Console.SimpleLineEditor as SLE #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 initialState :: UIState initialState = Sys.emptySystem ---------------------------------------------------------------------------- --- Utility shift :: String -> (String, String) shift = break isSpace . dropWhile isSpace strip :: String -> String strip = reverse . f . reverse . f where f = dropWhile isSpace indent :: Int -> String -> String indent n = unlines . map (prefix++) . lines where prefix = replicate n ' ' showObjectInfo :: CDT.CDT -> String showObjectInfo obj = t ++ showFunctNameWithVariance obj ++ "\n" ++ "- natural transformations:\n" ++ natsStr ++ "- factorizer:\n" ++ factorizerInfoStr ++ "- equations:\n" ++ indent 4 equations ++ "- unconditioned: " ++ (if CDT.isUnconditioned obj then "yes" else "no") ++ "\n" ++ "- productive: (" ++ productiveStr ++ ")\n" where t = case CDT.objectType obj of LeftObject -> "left object " RightObject -> "right object " natsStr = indent 4 $ concatMap f (CDT.nats obj) where f nat = CDT.natName nat ++ ": " ++ show (CDT.natType nat) ++ "\n" productiveStr = intercalate "," (map f [0 .. CDT.functArity obj - 1]) where f n = if CDT.isProductiveIn obj n then "yes" else "no" factorizerInfoStr = indent 4 $ upper ++ "\n" ++ replicate (max (length upper) (length lower)) '-' ++ "\n" ++ lower ++ "\n" where upper = intercalate " " $ zipWith f factArgs $ factParams obj where f fact typ = show fact ++ ": " ++ show typ lower = show (Fact obj factArgs) ++ ": " ++ show (factDestType obj) factArgs = map f (CDT.nats obj) where f nat = Var ("f" ++ show (CDT.natIndex nat)) [] equations = concat (map (++"\n") (eqs ++ [feq, ceq])) where eqs = zipWith g [(1::Int)..] (Statement.eqs obj) where g n eq = "("++lr++"EQ" ++ show n ++ "): " ++ show eq feq = "("++lr++"FEQ): " ++ show (Statement.feq obj) ceq = "("++lr++"CEQ): " ++ show (Statement.ceq obj) lr = case CDT.objectType obj of LeftObject -> "L" RightObject -> "R" readLine :: String -> IO String #ifdef HAVE_READLINE_PACKAGE readLine prompt = fmap (fromMaybe "") (SLE.getLineEdited prompt) #else readLine prompt = do putStr prompt getLine #endif ---------------------------------------------------------------------------- type Command = String -> StateT UIState IO () commandTable :: [(String, Command)] commandTable = [ ("show", cmdShow) , ("edit", cmdEdit) , ("simp", cmdSimp) , ("let", cmdLet) , ("load", cmdLoad) , ("quit", cmdQuit) , ("exit", cmdQuit) , ("bye", cmdQuit) , ("help", cmdHelp) , ("set", cmdSet) , ("reset", cmdReset) , ("left", cmdLeft) , ("right", cmdRight) ] dispatchCommand :: String -> StateT UIState IO () dispatchCommand l = case shift l of ([], _) -> return () (cmdStr, arg) -> case lookup cmdStr commandTable of Just cmd -> cmd arg Nothing -> throwError (userError ("unknown command: " ++ l)) ---------------------------------------------------------------------------- defineObject :: Command defineObject src = do sys <- getSystem obj <- Sys.parseCDT sys src sys' <- Sys.addCDT sys obj putSystem sys' let lr = case CDT.objectType obj of LeftObject -> "left" RightObject -> "right" msg = concat [lr, " object ", showFunctNameWithVariance obj, " is defined"] lift $ putStrLn $ msg cmdLeft, cmdRight :: Command cmdLeft s = defineObject ("left " ++ s) cmdRight s = defineObject ("right " ++ s) cmdShow :: Command cmdShow arg = case shift arg of ("object", arg') -> do sys <- getSystem let name = strip arg' objects = Sys.objects sys lift $ putStrLn $ case find (\x -> CDT.functName x == name) objects of Just obj -> showObjectInfo obj Nothing -> "unknown object: " ++ name ("aexp", arg') -> do -- XXX sys <- getSystem case Sys.parseExp sys (strip arg') of Left err -> fail err Right (_, e :! t) -> lift $ do putStrLn $ show e putStrLn $ " : " ++ show t _ -> do sys <- getSystem case Sys.parseExp sys (strip arg) of Left err -> fail err Right (_, e :! t) -> lift $ do putStrLn $ show $ AExp.skelton e putStrLn $ " : " ++ show t cmdLet :: Command cmdLet arg = do sys <- getSystem 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' if null args then lift $ do putStrLn $ name ++ " = " ++ show (AExp.skelton e) putStrLn $ " : " ++ show t else lift $ do let lhs = name ++ "(" ++ intercalate "," args ++ ")" putStrLn $ lhs ++ " = " ++ show (AExp.skelton e) let upper = intercalate " " $ [p ++ ": " ++ show t | (p,t) <- zip args args'] lower = lhs ++ ": " ++ show t s = upper ++ "\n" ++ replicate (max (length upper) (length lower)) '-' ++ "\n" ++ lower putStrLn $ s -- putStrLn $ " : " ++ intercalate ", " (map show args') ++ " => " ++ show t cmdSimp :: Command cmdSimp arg = case shift arg of ("full", arg') -> doSimp True (strip arg') _ -> doSimp False (strip arg) where doSimp full str = do sys <- getSystem unless (any isTerminalObject (Sys.objects sys)) (fail "No terminal object is defined.") case Sys.parseExp sys str of Left err -> fail err Right (_, e :! t) -> do unless (AExp.isElement e) (fail "not a element") let traces = Sys.simp sys full (AExp.skelton e) loop ((step,(depth,exp,cexp)) : xs) = do 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 if null xs then do let it = Simp.decompile cexp lift $ putStrLn (show it) lift $ putStrLn (" : " ++ show t) putSystem 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 let src = unlines (map removeComment (lines contents)) cmds = split src mapM_ (\x -> do lift $ (putStr . unlines . map ("> "++) . lines $ x) dispatchCommand x) cmds where filename = -- FIXME let s' = strip s in case s' of '"':_ -> read s' _ -> s' removeComment [] = [] removeComment ('#':_) = [] removeComment (x:xs) = x : removeComment xs split :: String -> [String] split s = map (strip . reverse) (f s []) where f (';':xs) tmp = tmp : (f xs []) f (x:xs) tmp = f xs (x:tmp) f [] tmp = [tmp] cmdEdit :: Command cmdEdit _ = do s <- lift editLoop dispatchCommand s where editLoop = do l <- readLine "| " case dropWhile isSpace (reverse l) of ';':s -> return (reverse s) _ -> do s <- editLoop return $ l ++ "\n" ++ s cmdQuit :: Command cmdQuit _ = lift $ exitWith ExitSuccess cmdHelp :: Command cmdHelp _ = lift $ mapM_ putStrLn l where l = [ " exit exit the interpreter" , " quit ditto" , " bye ditto" , " edit enter editing mode" , " simp [full] evaluate expression" , " show print type of expression" , " show object print information of functor" , " load load from file" , " set trace [on|off] enable/disable trace" , " reset remove all definitions" ] cmdSet :: Command cmdSet arg = case shift arg of (flag, a) -> case shift a of ([], _) -> case flag of "trace" -> do sys <- getSystem lift $ putStrLn $ "trace=" ++ (if Sys.trace sys then "on" else "off") _ -> lift $ putStrLn $ "unknown flag:" ++ flag (value, _) -> case flag of "trace" -> case value of "on" -> do sys <- getSystem putSystem (sys{ Sys.trace = True }) "off" -> do sys <- getSystem putSystem (sys{ Sys.trace = False }) _ -> lift $ putStrLn ("unknown value:" ++ value) _ -> lift $ putStrLn ("unknown flag:" ++ flag) cmdReset :: Command cmdReset _ = put initialState ---------------------------------------------------------------------------- data Flag = Help | Version | Interactive -- | Load String | Trace String deriving Eq options :: [OptDescr Flag] options = [ Option ['h'] ["help"] (NoArg Help) "show help" , Option ['v'] ["version"] (NoArg Version) "show version number" , Option ['i'] ["interactive"] (NoArg Interactive) "force interactive mode" -- , Option ['l'] ["load"] (ReqArg Load "FILE") "load FILE" , Option ['t'] ["trace"] (OptArg (Trace . fromMaybe "on") "[on|off]") "enable/disable trace" ] main :: IO () main = #ifndef HAVE_READLINE_PACKAGE 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 case getOpt Permute options args of (o,_,[]) | Help `elem` o -> putStrLn (usageInfo header options) (o,_,[]) | Version `elem` o -> putStrLn versionStr (o,n,[]) -> do putStr banner evalStateT (do mapM_ processOpt o mapM_ cmdLoad n if null n || Interactive `elem` o then mainLoop else return ()) initialState (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options version :: [Int] version = [0,0,2] versionStr :: String versionStr = intercalate "." $ map show $ version header :: String header = "Usage: cpl [OPTION...] files..." banner :: String banner = "Categorical Programming Language (Haskell version)\n" ++ "version " ++ versionStr ++ "\n" ++ "\n" ++ "Type help for help\n" ++ "\n" processOpt :: Flag -> StateT UIState IO () processOpt (Trace s) = do sys <- getSystem val <- case s of "on" -> return True "off" -> return False _ -> fail "invalid option" putSystem sys{ Sys.trace = val } return () processOpt _ = return () mainLoop :: StateT UIState IO () mainLoop = do l <- lift $ readLine "cpl> " catchError (dispatchCommand l) (lift . putStrLn . show) mainLoop ----------------------------------------------------------------------------