diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,55 @@ +# NB: don't set `language: haskell` here + +# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. +env: +# - GHCVER=6.12.3 +# - GHCVER=7.0.1 +# - GHCVER=7.0.2 +# - GHCVER=7.0.3 +# - GHCVER=7.0.4 +# - GHCVER=7.2.1 +# - GHCVER=7.2.2 +# - GHCVER=7.4.1 + - GHCVER=7.4.2 +# - GHCVER=7.6.1 +# - GHCVER=7.6.2 + - GHCVER=7.6.3 +# - GHCVER=7.8.1 # see note about Alex/Happy + - GHCVER=7.8.2 # see note about Alex/Happy +# - GHCVER=head # see section about GHC HEAD snapshots + +# Note: the distinction between `before_install` and `install` is not important. +before_install: + - travis_retry sudo add-apt-repository -y ppa:hvr/ghc + - travis_retry sudo apt-get update + - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER # see note about happy/alex + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH + - | + if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ]; then + travis_retry sudo apt-get install happy-1.19.3 alex-3.1.3 + export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH + else + travis_retry sudo apt-get install happy alex + fi + +install: + - cabal update + - cabal install --only-dependencies --enable-tests -v2 # -v2 provides useful information for debugging + +# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. +script: + - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging + - cabal build # this builds all libraries and executables (including tests/benchmarks) + - cabal test + - cabal check + - cabal sdist # tests that a source-distribution can be generated + +# The following scriptlet checks that the resulting source distribution can be built & installed + - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ; + cd dist/; + if [ -f "$SRC_TGZ" ]; then + cabal install "$SRC_TGZ"; + else + echo "expected '$SRC_TGZ' not found"; + exit 1; + fi diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown new file mode 100644 --- /dev/null +++ b/CHANGELOG.markdown @@ -0,0 +1,29 @@ +Changes since the 0.0.6 release +------------------------------- + +* Clean up internals +* Enable `-fReadline` and `-fHaskeline` by default + +Changes since the 0.0.5 release +------------------------------- + +Readline/Haskeline support. + +Changes since the 0.0.3 release +------------------------------- + +Function defintions are added. + +Examples: + + > let uncurry(f) = eval . prod(f, I) + uncurry(f) = eval.prod(f,I) + f: *a -> exp(*b,*c) + ----------------------------- + uncurry(f): prod(*a,*b) -> *c + + > let primrec(f,g) = pi2.pr(pair(0,f), pair(s.pi1, g)) + primrec(f,g) = pi2.pr(pair(0,f),pair(s.pi1,g)) + f: 1 -> *a g: prod(nat,*a) -> *a + --------------------------------- + primrec(f,g): nat -> *a diff --git a/CPL.cabal b/CPL.cabal --- a/CPL.cabal +++ b/CPL.cabal @@ -1,16 +1,17 @@ Name: CPL -Version: 0.0.6 +Version: 0.0.7 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer: masahiro.sakai@gmail.com Category: Compilers/Interpreters -Cabal-Version: >= 1.2 +Cabal-Version: >=1.10 Synopsis: An interpreter of Hagino's Categorical Programming Language (CPL). Description: An interpreter of Hagino's Categorical Programming Language (CPL). Extra-Source-Files: - README, - NEWS, + README.markdown, + CHANGELOG.markdown, + .travis.yml, samples/ack.cpl, samples/automata.cdt, samples/ccc.cdt, @@ -25,20 +26,25 @@ src/CDT.hs-boot Build-Type: Simple +source-repository head + type: git + location: git://github.com/msakai/cpl.git + Flag Readline Description: Use Readline - Default: False + Default: True Flag Haskeline Description: Use Haskeline - Default: False + Default: True 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 + Other-Modules: AExp CDT CDTParser CPLSystem Exp ExpParser FE Funct ParserUtils Simp Statement Subst Type Typing Variance Paths_CPL + Build-Depends: base >=4 && <5, mtl >=2.0.0.0, containers, array, parsec + Default-Language: Haskell2010 + Other-Extensions: TypeSynonymInstances, FlexibleInstances, CPP, GeneralizedNewtypeDeriving if flag(Readline) CPP-Options: "-DUSE_READLINE_PACKAGE" Build-Depends: readline diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,22 +0,0 @@ - -= Changes since the 0.0.5 release - -Readline/Haskeline support. - -= Changes since the 0.0.3 release - -Function defintions are added. - -Examples: - - > let uncurry(f) = eval . prod(f, I) - uncurry(f) = eval.prod(f,I) - f: *a -> exp(*b,*c) - ----------------------------- - uncurry(f): prod(*a,*b) -> *c - - > let primrec(f,g) = pi2.pr(pair(0,f), pair(s.pi1, g)) - primrec(f,g) = pi2.pr(pair(0,f),pair(s.pi1,g)) - f: 1 -> *a g: prod(nat,*a) -> *a - --------------------------------- - primrec(f,g): nat -> *a diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,63 +0,0 @@ -An implementation of "A Categorical Programing Language". -version 0.0.5 -==================== - - This package is an implementation of "A Categorical Programing Language" - (CPL for short)[1][2] written in Haskell. - - CPL is a functional programming language based on category - theory[3]. Data types are declared in a categorical manner by - adjunctions. Data types that can be handled include the terminal - object, the initial object, the binary product functor, the binary - coproduct functor, the exponential functor, the natural number object, - the functor for finite lists, and the functor for infinite lists. - Each data type is declared with its basic operations or - morphisms. Programs consist of these morphisms, and execution of - programs is the reduction of elements (i.e. special morphisms) to - their canonical form. - -Requirements ------------- - - * GHC-6.10 - -Install -------- - - De-Compress archive and enter its top directory. - Then type: - - $ runhaskell Setup.hs configure - $ 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 ------ - - See chapter 5 of [1] - -License -------- - This program is licenced under the BSD-style license. - (See the file 'COPYING'.) - - Copyright (C) 2004-2009 Masahiro Sakai - -Author ----------- - Masahiro Sakai - -Bibliography ------------- - -[1] Tatsuya Hagino, ``A Categorical Programming Languge''. - Ph.D. Thesis, University of Edinburgh, 1987 - available at - -[2] Tatsuya Hagino, ``Categorical Functional Programming Language'' - Computer Software, Vol 7, No.1. - Advances in Software Science and Technology 4, 1992 - ISBN 0-12-037104-9 diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,61 @@ +An implementation of "A Categorical Programing Language" +======================================================== + +[![Build Status](https://secure.travis-ci.org/msakai/cpl.png?branch=master)](http://travis-ci.org/msakai/cpl) + +This package is an implementation of "A Categorical Programing Language" +(CPL for short)[1][2] written in Haskell. + +CPL is a functional programming language based on category +theory. Data types are declared in a categorical manner by +adjunctions. Data types that can be handled include the terminal +object, the initial object, the binary product functor, the binary +coproduct functor, the exponential functor, the natural number object, +the functor for finite lists, and the functor for infinite lists. +Each data type is declared with its basic operations or +morphisms. Programs consist of these morphisms, and execution of +programs is the reduction of elements (i.e. special morphisms) to +their canonical form. + +Install +------- + +De-Compress archive and enter its top directory. +Then type: + + $ cabal configure + $ cabal build + $ cabal install + +If you want to compile with readline or haskeline, add -fReadline or +-fHaskeline respectively to configure command. + +Usage +----- + +See chapter 5 of [1] + +License +------- + +This program is licenced under the BSD-style license. +(See the file 'COPYING'.) + +Copyright (C) 2004-2014 Masahiro Sakai + +Author +------ + +Masahiro Sakai + +Bibliography +------------ + +(1) Tatsuya Hagino, “A Categorical Programming Languge”. + Ph.D. Thesis, University of Edinburgh, 1987 + available at + +(2) Tatsuya Hagino, “Categorical Functional Programming Language”. + Computer Software, Vol 7, No.1. + Advances in Software Science and Technology 4, 1992 + ISBN 0-12-037104-9 diff --git a/src/CDT.hs b/src/CDT.hs --- a/src/CDT.hs +++ b/src/CDT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : CDT @@ -58,6 +59,9 @@ import Type import Subst (tv, apply) +#if __GLASGOW_HASKELL__ >= 706 +import Prelude hiding (join) +#endif import Data.List (findIndices, transpose, find, findIndex, intercalate) diff --git a/src/CDTParser.hs b/src/CDTParser.hs --- a/src/CDTParser.hs +++ b/src/CDTParser.hs @@ -76,18 +76,18 @@ type CDTEnv = [CDT] -evalCDTDecl :: Monad m => CDTEnv -> CDTDecl -> m CDT +evalCDTDecl :: CDTEnv -> CDTDecl -> Either String CDT evalCDTDecl cenv (CDTDecl lr name arity fact_name nat_decls) = do nat_decls' <- mapM (evalNatDecl cenv) nat_decls return $ mkCDT lr name arity fact_name nat_decls' -evalNatDecl :: Monad m => CDTEnv -> (String, Type) -> m (String, T.Type) +evalNatDecl :: CDTEnv -> (String, Type) -> Either String (String, T.Type) evalNatDecl cenv (name, a :-> b) = do a' <- evalFE cenv a b' <- evalFE cenv b return (name, a' :-> b') -evalFE :: Monad m => CDTEnv -> FE -> m FE.FE +evalFE :: CDTEnv -> FE -> Either String FE.FE evalFE _ (FE.Var n) = return (FE.Var n) evalFE cenv (FE.Ap sym xs) = do ys <- mapM (evalFE cenv) xs @@ -95,8 +95,8 @@ Just f -> if CDT.functArity f == length xs then return (FE.Ap f ys) - else fail "wrong number of arguments" + else Left "wrong number of arguments" Nothing -> - fail $ "no such functor or variable: " ++ sym + Left $ "no such functor or variable: " ++ sym ----------------------------------------------------------------------------- diff --git a/src/CPLSystem.hs b/src/CPLSystem.hs --- a/src/CPLSystem.hs +++ b/src/CPLSystem.hs @@ -67,7 +67,7 @@ parseExp :: System -> String -> Either String (Int, Typing) parseExp sys str = case parse ExpParser.exp "" str of - Left err -> fail (show err) + Left err -> Left (show err) Right e -> case ExpParser.evalExp (objects sys) (arityEnv sys) e of Nothing -> Left "invalid expression" -- FIXME @@ -82,7 +82,7 @@ parseDef :: System -> String -> Either String Def parseDef sys str = case parse ExpParser.def "" str of - Left err -> fail (show err) + Left err -> Left (show err) Right (name,ps,e) -> case ExpParser.evalExp (objects sys) (Map.union (Map.fromList (zip ps (repeat 0))) (arityEnv sys)) e of Nothing -> Left "invalid definition" -- FIXME @@ -116,10 +116,10 @@ f (Var "it" []) = it f (Var v args) = Var v $ map f args -checkName :: Monad m => System -> String -> m () +checkName :: System -> String -> Either String () checkName sys name = if name `elem` names - then fail ("\"" ++ name ++ "\" is already used") + then Left $ "\"" ++ name ++ "\" is already used" else return () where vt = varTable sys @@ -129,25 +129,25 @@ map CDT.factName objs ++ concatMap (map CDT.natName . CDT.nats) objs -parseCDT :: Monad m => System -> String -> m CDT.CDT +parseCDT :: System -> String -> Either String CDT.CDT parseCDT sys src = case parse CDTParser.cdtDecl "" src of - Left err -> fail (show err) + Left err -> Left (show err) Right decl -> CDTParser.evalCDTDecl (objects sys) decl -addCDT :: Monad m => System -> CDT.CDT -> m System +addCDT :: System -> CDT.CDT -> Either String System addCDT sys obj = if CDT.isComputable obj then do checkName sys (CDT.functName obj) checkName sys (CDT.factName obj) mapM_ (checkName sys . CDT.natName) (CDT.nats obj) return sys{ objects = obj : objects sys } - else fail "not a computable object" + else Left "not a computable object" compile :: System -> Exp -> Simp.CompiledExp compile sys e = Simp.compile env e where env = Map.map (\(ps,body,_) -> (ps, body)) (varTable sys) -letExp :: Monad m => System -> Def -> m System +letExp :: System -> Def -> Either String System letExp sys (name,ps,e,ftype) = do checkName sys name return sys{ varTable = Map.insert name (ps, AExp.skelton e, ftype) (varTable sys) } diff --git a/src/FE.hs b/src/FE.hs --- a/src/FE.hs +++ b/src/FE.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : FE diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,9 +1,8 @@ {-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- | -- Module : Main --- Copyright : (c) Masahiro Sakai 2004,2009 +-- Copyright : (c) Masahiro Sakai 2004,2009,2014 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com @@ -22,39 +21,82 @@ import Type import Typing (Typing(..)) import qualified Simp +import Paths_CPL import Data.Maybe import Data.List import Data.Char (isSpace) +import Data.Version import System.Environment import System.Exit import System.IO -import Control.Monad.State import Control.Monad.Error +import Control.Monad.State.Strict -- haskeline's MonadException requries strict version import System.Console.GetOpt #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 +import qualified System.Console.Haskeline as Haskeline #else import Control.Exception (bracket) #endif ---------------------------------------------------------------------------- -type UIState = Sys.System - #ifdef USE_HASKELINE_PACKAGE -type UI a = StateT UIState (InputT IO) a +type Console = Haskeline.InputT IO #else -type UI a = StateT UIState IO a +type Console = IO #endif +runConsole :: Console a -> IO a +#if defined(USE_READLINE_PACKAGE) +runConsole m = bracket SLE.initialise (const SLE.restore) (const m) +#elif defined(USE_HASKELINE_PACKAGE) +runConsole m = Haskeline.runInputT Haskeline.defaultSettings m +#else +runConsole m = bracket initialie (hSetBuffering stdout) (const m) + where + initialie = do + x <- hGetBuffering stdout + hSetBuffering stdout NoBuffering + return x +#endif + +readLine' :: String -> Console String +#if defined(USE_READLINE_PACKAGE) +readLine' prompt = liftM (fromMaybe "") $ SLE.getLineEdited prompt +#elif defined(USE_HASKELINE_PACKAGE) +readLine' prompt = liftM (fromMaybe "") $ Haskeline.getInputLine prompt +#else +readLine' prompt = putStr prompt >> getLine +#endif + +printLine' :: String -> Console () +printLine' s = liftIO $ putStrLn $ s + +---------------------------------------------------------------------------- + +type UIState = Sys.System + initialState :: UIState initialState = Sys.emptySystem ---------------------------------------------------------------------------- + +type UI a = ErrorT String (StateT UIState Console) a + +readLine :: String -> UI String +readLine prompt = lift $ lift $ readLine' prompt + +printLine :: String -> UI () +printLine s = lift $ lift $ printLine' s + +printLines :: [String] -> UI () +printLines = mapM_ printLine + +---------------------------------------------------------------------------- --- Utility shift :: String -> (String, String) @@ -110,15 +152,6 @@ LeftObject -> "L" RightObject -> "R" -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 = liftIO $ putStr prompt >> getLine -#endif - ---------------------------------------------------------------------------- type Command = String -> UI () @@ -148,21 +181,25 @@ (cmdStr, arg) -> case lookup cmdStr commandTable of Just cmd -> cmd arg - Nothing -> liftIO $ ioError $ userError $ ("unknown command: " ++ l) + Nothing -> throwError ("unknown command: " ++ l) ---------------------------------------------------------------------------- defineObject :: Command -defineObject src = - do sys <- get - obj <- Sys.parseCDT sys src - sys' <- Sys.addCDT sys obj - put sys' - let lr = case CDT.objectType obj of - LeftObject -> "left" - RightObject -> "right" - msg = concat [lr, " object ", showFunctNameWithVariance obj, " is defined"] - liftIO $ putStrLn $ msg +defineObject src = do + sys <- get + case Sys.parseCDT sys src of + Left err -> throwError err + Right obj -> do + case Sys.addCDT sys obj of + Left err -> throwError err + Right sys' -> do + put sys' + let lr = case CDT.objectType obj of + LeftObject -> "left" + RightObject -> "right" + msg = concat [lr, " object ", showFunctNameWithVariance obj, " is defined"] + printLine msg cmdLeft, cmdRight :: Command cmdLeft s = defineObject ("left " ++ s) @@ -175,47 +212,44 @@ do sys <- get let name = strip arg' objects = Sys.objects sys - liftIO $ putStrLn $ - case find (\x -> CDT.functName x == name) objects of - Just obj -> showObjectInfo obj - Nothing -> "unknown object: " ++ name + case find (\x -> CDT.functName x == name) objects of + Just obj -> printLines $ lines $ showObjectInfo obj + Nothing -> throwError $ "unknown object: " ++ name ("aexp", arg') -> do -- XXX sys <- get case Sys.parseExp sys (strip arg') of - Left err -> fail err - Right (_, e :! t) -> liftIO $ do - putStrLn $ show e - putStrLn $ " : " ++ show t + Left err -> printLines $ lines $ err + Right (_, e :! t) -> + printLines $ [show e, " : " ++ show t] _ -> do sys <- get case Sys.parseExp sys (strip arg) of - Left err -> fail err - Right (_, e :! t) -> liftIO $ do - putStrLn $ show $ AExp.skelton e - putStrLn $ " : " ++ show t + Left err -> throwError $ err + Right (_, e :! t) -> + printLines $ [show $ AExp.skelton e, " : " ++ show t] cmdLet :: Command cmdLet arg = do sys <- get case Sys.parseDef sys (strip arg) of - Left err -> fail err + Left err -> throwError err Right def@(name, args, e, FType _ args' t) -> do - sys' <- Sys.letExp sys def - put sys' - if null args - then liftIO $ do - putStrLn $ name ++ " = " ++ show (AExp.skelton e) - putStrLn $ " : " ++ show t - 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'] - lower = lhs ++ ": " ++ show t - s = upper ++ "\n" ++ - replicate (max (length upper) (length lower)) '-' ++ "\n" ++ - lower - putStrLn $ s - -- putStrLn $ " : " ++ intercalate ", " (map show args') ++ " => " ++ show t + case Sys.letExp sys def of + Left err -> throwError err + Right sys' -> do + put sys' + if null args + then printLines [name ++ " = " ++ show (AExp.skelton e), " : " ++ show t] + else do + let lhs = name ++ "(" ++ intercalate "," args ++ ")" + upper = intercalate " " $ [p ++ ": " ++ show t | (p,t) <- zip args args'] + lower = lhs ++ ": " ++ show t + printLines + [ upper + , replicate (max (length upper) (length lower)) '-' + , lower + -- , " : " ++ intercalate ", " (map show args') ++ " => " ++ show t + ] cmdSimp :: Command cmdSimp arg = @@ -227,37 +261,37 @@ where doSimp full str = do sys <- get - 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) $ liftIO $ putStrLn line - if null xs - then do - let it = Simp.decompile cexp - liftIO $ putStrLn (show it) - liftIO $ putStrLn (" : " ++ show t) - put sys{ Sys.lastExp = Just it } - else - loop xs - loop (zip [(0::Int)..] traces) + if not (any isTerminalObject (Sys.objects sys)) then do + throwError "No terminal object is defined." + else + case Sys.parseExp sys str of + Left err -> throwError err + Right (_, e :! t) -> do + if not (AExp.isElement e) then throwError "not a element" + else do + 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) $ printLine line + if null xs + then do + let it = Simp.decompile cexp + printLines [show it, " : " ++ show t] + put sys{ Sys.lastExp = Just it } + else + loop xs + loop (zip [(0::Int)..] traces) cmdLoad :: Command cmdLoad s = - do h <- liftIO $ openFile filename ReadMode - contents <- liftIO $ hGetContents h + do contents <- liftIO $ readFile filename let src = unlines (map removeComment (lines contents)) cmds = split src - mapM_ (\x -> do liftIO $ (putStr . unlines . map ("> "++) . lines $ x) - dispatchCommand x) - cmds + forM_ cmds $ \cmd -> do + printLines ["> " ++ l | l <- lines cmd] + dispatchCommand cmd where filename = -- FIXME let s' = strip s in case s' of @@ -273,22 +307,22 @@ f [] tmp = [tmp] cmdEdit :: Command -cmdEdit _ = - do s <- 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 +cmdEdit _ = loop >>= dispatchCommand + where + loop = do + l <- readLine "| " + case dropWhile isSpace (reverse l) of + ';':s -> return (reverse s) + _ -> do + s <- loop + return $ l ++ "\n" ++ s cmdQuit :: Command cmdQuit _ = liftIO $ exitWith ExitSuccess cmdHelp :: Command -cmdHelp _ = liftIO $ mapM_ putStrLn l - where l = [ " exit exit the interpreter" +cmdHelp _ = printLines + [ " exit exit the interpreter" , " quit ditto" , " bye ditto" , " edit enter editing mode" @@ -309,24 +343,18 @@ case flag of "trace" -> do sys <- get - liftIO $ putStrLn $ - "trace=" ++ (if Sys.trace sys then "on" else "off") + printLine $ "trace=" ++ (if Sys.trace sys then "on" else "off") _ -> - liftIO $ putStrLn $ "unknown flag:" ++ flag + throwError $ "unknown flag: " ++ flag (value, _) -> case flag of "trace" -> case value of - "on" -> - do sys <- get - put (sys{ Sys.trace = True }) - "off" -> - do sys <- get - put (sys{ Sys.trace = False }) - _ -> - liftIO $ putStrLn ("unknown value:" ++ value) + "on" -> modify (\sys -> sys{ Sys.trace = True }) + "off" -> modify (\sys -> sys{ Sys.trace = False }) + _ -> throwError $ "unknown value: " ++ value _ -> - liftIO $ putStrLn ("unknown flag:" ++ flag) + throwError $ "unknown flag: " ++ flag cmdReset :: Command cmdReset _ = put initialState @@ -335,7 +363,7 @@ data Flag = Help - | Version + | ShowVersion | Interactive -- | Load String | Trace String @@ -344,7 +372,7 @@ options :: [OptDescr Flag] options = [ Option ['h'] ["help"] (NoArg Help) "show help" - , Option ['v'] ["version"] (NoArg Version) "show version number" + , Option ['v'] ["version"] (NoArg ShowVersion) "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]") @@ -352,75 +380,50 @@ ] main :: IO () -#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_) -#endif - -main_ = - do args <- liftIO $ getArgs +main = + do args <- getArgs case getOpt Permute options args of - (o,_,[]) - | Help `elem` o -> liftIO $ putStrLn (usageInfo header options) - | Version `elem` o -> liftIO $ putStrLn versionStr - (o,n,[]) -> - do liftIO $ putStr banner - evalStateT (do mapM_ processOpt o - mapM_ cmdLoad n - if null n || Interactive `elem` o - then mainLoop - else return ()) - initialState - (_,_,errs) -> - liftIO $ ioError $ userError $ concat errs ++ usageInfo header options - -version :: [Int] -version = [0,0,6] - -versionStr :: String -versionStr = intercalate "." $ map show $ version + (opts,_,[]) + | Help `elem` opts -> putStrLn (usageInfo header options) + | ShowVersion `elem` opts -> putStrLn $ showVersion version + (opts,files,[]) -> + runConsole $ flip evalStateT initialState $ do + ret <- runErrorT $ do + printLines banner + mapM_ processOpt opts + mapM_ cmdLoad files + when (null files || Interactive `elem` opts) $ mainLoop + case ret of + Left err -> lift $ mapM_ printLine' (lines err) + Right () -> return () + (_,_,errs) -> do + forM_ errs $ \err -> hPutStr stderr err + hPutStrLn stderr $ usageInfo header options + exitFailure header :: String header = "Usage: cpl [OPTION...] files..." -banner :: String +banner :: [String] banner = - "Categorical Programming Language (Haskell version)\n" ++ - "version " ++ versionStr ++ "\n" ++ - "\n" ++ - "Type help for help\n" ++ - "\n" + [ "Categorical Programming Language (Haskell version)" + , "version " ++ showVersion version + , "" + , "Type help for help" + , "" + ] processOpt :: Flag -> UI () processOpt (Trace s) = - do sys <- get - val <- case s of - "on" -> return True - "off" -> return False - _ -> fail "invalid option" - put sys{ Sys.trace = val } - return () + case s of + "on" -> modify (\sys -> sys{ Sys.trace = True }) + "off" -> modify (\sys -> sys{ Sys.trace = False }) + _ -> throwError "invalid option" processOpt _ = return () mainLoop :: UI () -mainLoop = do +mainLoop = forever $ 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 + dispatchCommand l `catchError` (\err -> printLines $ lines $ err) ---------------------------------------------------------------------------- diff --git a/src/Subst.hs b/src/Subst.hs --- a/src/Subst.hs +++ b/src/Subst.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Subst @@ -28,6 +28,7 @@ import FE import {-# SOURCE #-} CDT (_eqCDT) +import Control.Monad.Error import Data.List (nub, intersect) import Data.Maybe (fromMaybe) @@ -56,44 +57,44 @@ (@@) :: Subst -> Subst -> Subst s1 @@ s2 = [(u, apply s1 t) | (u,t) <- s2] ++ s1 -merge :: Monad m => Subst -> Subst -> m Subst -merge s1 s2 = if agree then return (s1 ++ s2) else fail "merge fails" +merge :: MonadError String m => Subst -> Subst -> m Subst +merge s1 s2 = if agree then return (s1 ++ s2) else throwError "merge fails" where agree = all (\v -> apply s1 (Var v :: FE) == apply s2 (Var v)) (map fst s1 `intersect` map fst s2) -mgu :: Monad m => FE -> FE -> m Subst +mgu :: MonadError String m => FE -> FE -> m Subst mgu (Ap obj1 args1) (Ap obj2 args2) = if obj1 `_eqCDT` obj2 then mguList args1 args2 - else fail "types do not unify" + else throwError "types do not unify" mgu (Var u) t = varBind u t mgu t (Var u) = varBind u t -mguList :: Monad m => [FE] -> [FE] -> m Subst +mguList :: MonadError String m => [FE] -> [FE] -> m Subst mguList (a:as) (b:bs) = do s1 <- mgu a b s2 <- mguList (apply s1 as) (apply s1 bs) return (s2 @@ s1) mguList [] [] = return nullSubst -mguList _ _ = fail "types do not unify" +mguList _ _ = throwError "types do not unify" -match :: Monad m => FE -> FE -> m Subst +match :: MonadError String m => FE -> FE -> m Subst match (Ap obj1 args1) (Ap obj2 args2) = if obj1 `_eqCDT` obj2 then matchList args1 args2 - else fail "types do not unify" + else throwError "types do not unify" match (Var u) t = varBind u t -match _ _ = fail "types do not unify" +match _ _ = throwError "types do not unify" -matchList :: Monad m => [FE] -> [FE] -> m Subst +matchList :: MonadError String m => [FE] -> [FE] -> m Subst matchList (a:as) (b:bs) = do s1 <- match a b s2 <- matchList (apply s1 as) (apply s1 bs) return (s2 @@ s1) matchList [] [] = return nullSubst -matchList _ _ = fail "types do not unify" +matchList _ _ = throwError "types do not unify" -varBind :: Monad m => VarId -> FE -> m Subst +varBind :: MonadError String m => VarId -> FE -> m Subst varBind u t | t == Var u = return nullSubst - | u `elem` tv t = fail "occurs check fails" + | u `elem` tv t = throwError "occurs check fails" | otherwise = return (u +-> t) diff --git a/src/Type.hs b/src/Type.hs --- a/src/Type.hs +++ b/src/Type.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Type diff --git a/src/Typing.hs b/src/Typing.hs --- a/src/Typing.hs +++ b/src/Typing.hs @@ -24,6 +24,7 @@ import qualified Exp as E import Data.List (nub) +import Control.Applicative import Control.Monad.Error import Control.Monad.RWS import qualified Data.Map as Map @@ -47,7 +48,7 @@ -- Type inference monad newtype TI a = TI (RWST Env () TIState (Either String) a) - deriving (Monad, MonadState TIState, MonadReader Env, MonadError String) + deriving (Functor, Applicative, Monad, MonadReader Env, MonadError String) type Env = Map.Map E.Id (Either FType Type) type TIState = (Int, Subst) @@ -57,12 +58,12 @@ where initialState = (0, nullSubst) getSubst :: TI Subst -getSubst = do +getSubst = TI $ do (_,s) <- get return s extSubst :: Subst -> TI () -extSubst s2 = do +extSubst s2 = TI $ do (i,s1) <- get put (i, s2@@s1) return () @@ -79,7 +80,7 @@ extSubst s2 newFEVar :: TI FE.FE -newFEVar = do +newFEVar = TI $ do (i,s) <- get put (i+1,s) return $ FE.Var i @@ -152,7 +153,7 @@ iVar :: E.Id -> [Typing] -> TI Typing iVar v args = do - env <- ask + env <- TI ask case Map.lookup v env of Just (Right t) -> return $ Var v [] [] t :! t diff --git a/src/Variance.hs b/src/Variance.hs --- a/src/Variance.hs +++ b/src/Variance.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Variance @@ -23,6 +24,10 @@ , mult , mnemonic ) where + +#if __GLASGOW_HASKELL__ >= 706 +import Prelude hiding (join) +#endif data Variance = Covariance --- +