CPL 0.0.6 → 0.0.7
raw patch · 15 files changed
+374/−294 lines, 15 filesdep ~mtl
Dependency ranges changed: mtl
Files
- .travis.yml +55/−0
- CHANGELOG.markdown +29/−0
- CPL.cabal +15/−9
- NEWS +0/−22
- README +0/−63
- README.markdown +61/−0
- src/CDT.hs +4/−0
- src/CDTParser.hs +5/−5
- src/CPLSystem.hs +9/−9
- src/FE.hs +1/−1
- src/Main.hs +168/−165
- src/Subst.hs +15/−14
- src/Type.hs +1/−1
- src/Typing.hs +6/−5
- src/Variance.hs +5/−0
+ .travis.yml view
@@ -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
+ CHANGELOG.markdown view
@@ -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
CPL.cabal view
@@ -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
− NEWS
@@ -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
− README
@@ -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 <masahiro.sakai@gmail.com>--Author------------ Masahiro Sakai <masahiro.sakai@gmail.com>--Bibliography---------------[1] Tatsuya Hagino, ``A Categorical Programming Languge''.- Ph.D. Thesis, University of Edinburgh, 1987- available at <http://www.tom.sfc.keio.ac.jp/~hagino/index.html.en>--[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
+ README.markdown view
@@ -0,0 +1,61 @@+An implementation of "A Categorical Programing Language"+========================================================++[](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 <masahiro.sakai@gmail.com>++Author+------++Masahiro Sakai <masahiro.sakai@gmail.com>++Bibliography+------------++(1) Tatsuya Hagino, “A Categorical Programming Languge”.+ Ph.D. Thesis, University of Edinburgh, 1987+ available at <http://www.tom.sfc.keio.ac.jp/~hagino/index.html.en>++(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
src/CDT.hs view
@@ -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)
src/CDTParser.hs view
@@ -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 -----------------------------------------------------------------------------
src/CPLSystem.hs view
@@ -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) }
src/FE.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : FE
src/Main.hs view
@@ -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) ----------------------------------------------------------------------------
src/Subst.hs view
@@ -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)
src/Type.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Type
src/Typing.hs view
@@ -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
src/Variance.hs view
@@ -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 --- +