├── examples ├── atom.fp ├── add.fp ├── div.fp ├── id.fp ├── insert.fp ├── multiply.fp ├── select.fp ├── subtract.fp ├── constant.fp ├── distl.fp ├── if.fp ├── composition.fp ├── trans.fp ├── apply_to_all.fp ├── nested_if.fp └── fac.fp ├── .gitignore ├── test └── Spec.hs ├── src ├── FP.hs └── FP │ ├── AST.hs │ ├── Value.hs │ ├── Interpreter.hs │ ├── Parser.hs │ ├── Env.hs │ └── Function.hs ├── README.md ├── app └── Main.hs ├── stack.yaml ├── LICENSE ├── fp.cabal └── .travis.yml /examples/atom.fp: -------------------------------------------------------------------------------- 1 | A 2 | -------------------------------------------------------------------------------- /examples/add.fp: -------------------------------------------------------------------------------- 1 | +:<1,2> 2 | -------------------------------------------------------------------------------- /examples/div.fp: -------------------------------------------------------------------------------- 1 | div:<9,3> 2 | -------------------------------------------------------------------------------- /examples/id.fp: -------------------------------------------------------------------------------- 1 | id: 2 | -------------------------------------------------------------------------------- /examples/insert.fp: -------------------------------------------------------------------------------- 1 | /+:<4,5,6> 2 | -------------------------------------------------------------------------------- /examples/multiply.fp: -------------------------------------------------------------------------------- 1 | *:<1,2> 2 | -------------------------------------------------------------------------------- /examples/select.fp: -------------------------------------------------------------------------------- 1 | 2: 2 | -------------------------------------------------------------------------------- /examples/subtract.fp: -------------------------------------------------------------------------------- 1 | -:<2,1> 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .stack-work/ 3 | -------------------------------------------------------------------------------- /examples/constant.fp: -------------------------------------------------------------------------------- 1 | _1: 2 | -------------------------------------------------------------------------------- /examples/distl.fp: -------------------------------------------------------------------------------- 1 | distl:> 2 | -------------------------------------------------------------------------------- /examples/if.fp: -------------------------------------------------------------------------------- 1 | if eq.[id,_0]->_A;_B:0 2 | -------------------------------------------------------------------------------- /examples/composition.fp: -------------------------------------------------------------------------------- 1 | (1.tl.tl): 2 | -------------------------------------------------------------------------------- /examples/trans.fp: -------------------------------------------------------------------------------- 1 | trans:<<1,2,3>,<4,5,6>,<7,8,9>> 2 | -------------------------------------------------------------------------------- /examples/apply_to_all.fp: -------------------------------------------------------------------------------- 1 | @length:<, , > 2 | -------------------------------------------------------------------------------- /examples/nested_if.fp: -------------------------------------------------------------------------------- 1 | if eq.[id,_0] -> if eq.[id,_1] -> _A; _B; _C:0 2 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /examples/fac.fp: -------------------------------------------------------------------------------- 1 | Def fac = if eq0->_1;*.[id, fac.sub1] 2 | Def eq0 = eq.[id,_0] 3 | Def sub1 = -.[id,_1] 4 | fac:5 5 | -------------------------------------------------------------------------------- /src/FP.hs: -------------------------------------------------------------------------------- 1 | module FP (module FP) where 2 | 3 | import FP.AST as FP 4 | import FP.Env as FP 5 | import FP.Function as FP 6 | import FP.Interpreter as FP 7 | import FP.Parser as FP 8 | import FP.Value as FP 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | fp 2 | == 3 | 4 | [![Build Status](https://travis-ci.org/kseo/fp.svg?branch=master)](https://travis-ci.org/kseo/fp) 5 | 6 | A Haskell implementation of John Backus' Functional Programming Systems[1] 7 | 8 | [1] [Can Programming Be Liberated from the von Neumann Style? A Functional Style and Its Algebra of Programs][CanProgrammingBeLiberated] 9 | 10 | [CanProgrammingBeLiberated]: http://worrydream.com/refs/Backus-CanProgrammingBeLiberated.pdf 11 | -------------------------------------------------------------------------------- /src/FP/AST.hs: -------------------------------------------------------------------------------- 1 | module FP.AST 2 | ( Function(..) 3 | , Definition(..) 4 | , Expression(..) 5 | , Program(..) 6 | ) where 7 | 8 | import FP.Value 9 | 10 | data Function = Function Symbol 11 | | Composition Function Function 12 | | Construction [Function] 13 | | Condition Function Function Function 14 | | Constant Object 15 | | Insert Function 16 | | ApplyToAll Function 17 | | BinaryToUnary Function Object 18 | | While Function Function 19 | deriving (Show, Eq) 20 | 21 | data Definition = Definition Symbol Function 22 | deriving (Show, Eq) 23 | 24 | data Expression = Object Object 25 | | Application Function Object 26 | deriving (Show, Eq) 27 | 28 | data Program = Program [Definition] Expression 29 | deriving (Show, Eq) 30 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import FP 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Data.Monoid 8 | import Options.Applicative 9 | 10 | data Option = Option 11 | { filename :: String 12 | , verbose :: Bool 13 | } 14 | 15 | runWithOptions :: Option -> IO () 16 | runWithOptions opts = do 17 | source <- readFile $ filename opts 18 | case parseFP source of 19 | Left e -> print e 20 | Right program -> do 21 | when (verbose opts == True) $ 22 | print program 23 | case runProgram program of 24 | Left e -> print e 25 | Right result -> print result 26 | 27 | main :: IO () 28 | main = execParser opts >>= runWithOptions 29 | where parser = Option <$> argument str (metavar "FILE") 30 | <*> switch (short 'v' <> long "verbose" <> help "Verbose mode") 31 | opts = info parser mempty 32 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-5.10 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.4.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /src/FP/Value.hs: -------------------------------------------------------------------------------- 1 | module FP.Value 2 | ( emptySeq 3 | , makeBool 4 | , makeNumber 5 | , makeSymbol 6 | , Symbol 7 | , Atom(..) 8 | , Object(..) 9 | ) where 10 | 11 | import Data.List (intercalate) 12 | 13 | type Symbol = String 14 | 15 | data Atom = BoolAtom Bool 16 | | NumberAtom Integer 17 | | SymbolAtom Symbol 18 | deriving (Eq) 19 | 20 | data Object = Bottom 21 | | AtomObject Atom 22 | | SequenceObject [Object] 23 | deriving (Eq) 24 | 25 | instance Show Atom where 26 | show (BoolAtom True) = "T" 27 | show (BoolAtom False) = "F" 28 | show (NumberAtom a) = show a 29 | show (SymbolAtom a) = a 30 | 31 | instance Show Object where 32 | show Bottom = "Bottom" 33 | show (AtomObject a) = show a 34 | show (SequenceObject os) = "<" ++ intercalate "," (map show os) ++ ">" 35 | 36 | emptySeq :: Object 37 | emptySeq = SequenceObject [] 38 | 39 | makeBool :: Bool -> Object 40 | makeBool = AtomObject . BoolAtom 41 | 42 | makeNumber :: Integer -> Object 43 | makeNumber = AtomObject . NumberAtom 44 | 45 | makeSymbol :: Symbol -> Object 46 | makeSymbol = AtomObject . SymbolAtom 47 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Kwang Yul Seo (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fp.cabal: -------------------------------------------------------------------------------- 1 | name: fp 2 | version: 0.1.0.0 3 | synopsis: John Backus's FP Interpreter 4 | description: Please see README.md 5 | homepage: http://github.com/kseo/fp#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Kwang Yul Seo 9 | maintainer: Kwang Yul Seo 10 | copyright: Kwang Yul Seo 2016 11 | category: Language 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: FP 19 | FP.AST 20 | FP.Env 21 | FP.Function 22 | FP.Interpreter 23 | FP.Parser 24 | FP.Value 25 | build-depends: base >= 4.7 && < 5 26 | , containers >= 0.5 && < 0.6 27 | , mtl >= 2.2.1 && < 2.3 28 | , parsec >= 3.1 && < 3.2 29 | default-language: Haskell2010 30 | 31 | executable fp-exe 32 | hs-source-dirs: app 33 | main-is: Main.hs 34 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 35 | build-depends: base 36 | , fp 37 | , optparse-applicative 38 | , mtl 39 | default-language: Haskell2010 40 | 41 | test-suite fp-test 42 | type: exitcode-stdio-1.0 43 | hs-source-dirs: test 44 | main-is: Spec.hs 45 | build-depends: base 46 | , fp 47 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 48 | default-language: Haskell2010 49 | 50 | source-repository head 51 | type: git 52 | location: https://github.com/kseo/fp 53 | -------------------------------------------------------------------------------- /src/FP/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module FP.Interpreter 4 | ( runProgram 5 | ) where 6 | 7 | import FP.AST 8 | import FP.Env (InterpM(..), FunDef(..), InterpError(..)) 9 | import qualified FP.Env as Env 10 | import FP.Value 11 | 12 | import Control.Applicative ((<$>), pure) 13 | import Control.Monad (forM, forM_, foldM) 14 | import Control.Monad.Except (runExceptT) 15 | import Control.Monad.Identity (runIdentity) 16 | import Control.Monad.State (evalStateT) 17 | import Prelude hiding (exp) 18 | 19 | interpFunApp :: Function -> Object -> InterpM Object 20 | interpFunApp (Function symbol) o = do 21 | funDef <- Env.lookup symbol 22 | case funDef of 23 | FunDef fun -> interpFunApp fun o 24 | PreludeFunDef preludeFun -> return $ preludeFun o 25 | 26 | interpFunApp (Composition f g) o = do 27 | o' <- interpFunApp g o 28 | interpFunApp f o' 29 | 30 | interpFunApp (Condition p f g) o = do 31 | cond <- interpFunApp p o 32 | case cond of 33 | AtomObject (BoolAtom True) -> interpFunApp f o 34 | AtomObject (BoolAtom False) -> interpFunApp g o 35 | _ -> return Bottom 36 | 37 | interpFunApp while@(While p f) o = do 38 | cond <- interpFunApp p o 39 | case cond of 40 | AtomObject (BoolAtom True) -> do 41 | o' <- interpFunApp f o 42 | interpFunApp while o' 43 | AtomObject (BoolAtom False) -> return o 44 | _ -> return Bottom 45 | 46 | interpFunApp (Constant c) o = 47 | case o of 48 | Bottom -> return Bottom 49 | _ -> return c 50 | 51 | interpFunApp (ApplyToAll f) o = 52 | case o of 53 | SequenceObject os -> SequenceObject <$> forM os (interpFunApp f) 54 | _ -> return Bottom 55 | 56 | interpFunApp (BinaryToUnary f a) o = interpFunApp f $ SequenceObject [a, o] 57 | 58 | interpFunApp (Construction fs) o = do 59 | os <- forM fs (`interpFunApp` o) 60 | return $ if Bottom `elem` os 61 | then Bottom 62 | else SequenceObject os 63 | 64 | interpFunApp (Insert f) o = 65 | case o of 66 | SequenceObject (x:xs) -> foldM f' x xs 67 | _ -> return Bottom 68 | where 69 | f' a b = interpFunApp f $ SequenceObject [a, b] 70 | 71 | interpExp :: Expression -> InterpM Object 72 | interpExp exp = case exp of 73 | Object o -> pure o 74 | Application f o -> interpFunApp f o 75 | 76 | interpProgram :: Program -> InterpM Object 77 | interpProgram (Program defs exp) = do 78 | forM_ defs (\(Definition funSymbol fun) -> Env.extend funSymbol $ FunDef fun) 79 | interpExp exp 80 | 81 | runProgram :: Program -> Either InterpError Object 82 | runProgram = runIdentity . runExceptT . flip evalStateT Env.preludeDefs . runInterp . interpProgram 83 | 84 | -------------------------------------------------------------------------------- /src/FP/Parser.hs: -------------------------------------------------------------------------------- 1 | module FP.Parser 2 | ( parseFP 3 | ) where 4 | 5 | import FP.AST 6 | import FP.Value 7 | 8 | import Control.Applicative hiding (many, (<|>)) -- conflicts with Parsec 9 | import Text.Parsec (letter, (<|>), digit, many, many1, oneOf, upper, try, ParseError, parse) 10 | import Text.Parsec.Expr (Assoc(..), Operator(..), buildExpressionParser) 11 | import Text.Parsec.Language (haskellStyle) 12 | import Text.Parsec.String (Parser) 13 | import qualified Text.Parsec.Token as P 14 | 15 | lexer :: P.TokenParser () 16 | lexer = P.makeTokenParser (haskellStyle 17 | { P.identStart = letter <|> digit 18 | , P.identLetter = letter <|> digit 19 | , P.opStart = oneOf "+-*" 20 | , P.opLetter = oneOf "" 21 | , P.reservedOpNames = ["=", "_", "->", ";"] 22 | , P.reservedNames = ["T", "F", "bu", "while", "if", "Def"] 23 | }) 24 | 25 | whiteSpace = P.whiteSpace lexer 26 | natural = P.natural lexer 27 | lexeme = P.lexeme lexer 28 | angles = P.angles lexer 29 | parens = P.parens lexer 30 | brackets = P.brackets lexer 31 | identifier = P.identifier lexer 32 | operator = P.operator lexer 33 | reserved = P.reserved lexer 34 | reservedOp = P.reservedOp lexer 35 | colon = P.colon lexer 36 | commaSep1 = P.commaSep1 lexer 37 | 38 | boolAtom :: Parser Atom 39 | boolAtom = (reserved "T" *> return (BoolAtom True)) 40 | <|> (reserved "F" *> return (BoolAtom False)) 41 | 42 | numberAtom :: Parser Atom 43 | numberAtom = NumberAtom <$> natural 44 | 45 | symbolAtom :: Parser Atom 46 | symbolAtom = SymbolAtom <$> many1 upper 47 | 48 | atomObject :: Parser Object 49 | atomObject = AtomObject <$> (numberAtom <|> boolAtom <|> symbolAtom) 50 | 51 | sequenceObject :: Parser Object 52 | sequenceObject = SequenceObject <$> angles (commaSep1 (atomObject <|> sequenceObject)) 53 | 54 | object :: Parser Object 55 | object = atomObject <|> sequenceObject 56 | 57 | functionList :: Parser [Function] 58 | functionList = brackets (commaSep1 function) 59 | 60 | term = parens function 61 | <|> Function <$> (identifier <|> operator) 62 | <|> Construction <$> functionList 63 | <|> Constant <$> (reservedOp "_" *> object) 64 | <|> BinaryToUnary <$> (reserved "bu" *> function) <*> object 65 | <|> While <$> (reserved "while" *> function) <*> function 66 | <|> Condition <$> (reserved "if" *> function <* reservedOp "->") <*> (function <* reservedOp ";") <*> function 67 | 68 | table = [ [prefix "@" ApplyToAll, prefix "/" Insert ], 69 | [binary "." Composition AssocRight] 70 | ] 71 | where prefix name fun = Prefix (fun <$ reservedOp name) 72 | binary name fun = Infix (fun <$ reservedOp name) 73 | 74 | function :: Parser Function 75 | function = buildExpressionParser table term 76 | 77 | definition :: Parser Definition 78 | definition = Definition <$> (reserved "Def" *> identifier) <*> (reservedOp "=" *> function) 79 | 80 | expression :: Parser Expression 81 | expression = try (Application <$> function <*> (colon *> object)) <|> (Object <$> object) 82 | 83 | -- Explicit whiteSpace is needed to skip any leading white space. 84 | program :: Parser Program 85 | program = Program <$> (whiteSpace *> many definition) <*> expression 86 | 87 | parseFP :: String -> Either ParseError Program 88 | parseFP = parse program "" 89 | -------------------------------------------------------------------------------- /src/FP/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | 3 | module FP.Env 4 | ( Env 5 | , preludeDefs 6 | , extend 7 | , lookup 8 | , InterpError(..) 9 | , InterpM(..) 10 | , FunDef(..) 11 | ) where 12 | 13 | import FP.AST 14 | import FP.Value 15 | import FP.Function as Function 16 | 17 | import Control.Applicative (Applicative) 18 | import Control.Monad.Except (ExceptT, MonadError, throwError) 19 | import Control.Monad.Identity (Identity) 20 | import Control.Monad.State (StateT, MonadState, get, put) 21 | import Data.Map (Map) 22 | import qualified Data.Map as Map 23 | import Prelude hiding (lookup) 24 | 25 | data InterpError = UndefinedFunction String deriving (Show) 26 | 27 | newtype InterpM a = InterpM 28 | { runInterp :: StateT Env (ExceptT InterpError Identity) a 29 | } deriving ( Functor 30 | , Applicative 31 | , Monad 32 | , MonadState Env 33 | , MonadError InterpError) 34 | 35 | data FunDef = FunDef Function 36 | | PreludeFunDef (Object -> Object) 37 | 38 | type Env = Map Symbol FunDef 39 | 40 | preludeDefs :: Env 41 | preludeDefs = Map.fromList 42 | [("tl", PreludeFunDef Function.tl), 43 | ("tlr", PreludeFunDef Function.tlr), 44 | ("id", PreludeFunDef id), 45 | ("atom", PreludeFunDef Function.atom), 46 | ("eq", PreludeFunDef Function.eq), 47 | ("null", PreludeFunDef Function.null), 48 | ("reverse", PreludeFunDef Function.reverse), 49 | ("distl", PreludeFunDef Function.distl), 50 | ("distr", PreludeFunDef Function.distr), 51 | ("length", PreludeFunDef Function.length), 52 | ("trans", PreludeFunDef Function.trans), 53 | ("and", PreludeFunDef Function.and), 54 | ("or", PreludeFunDef Function.or), 55 | ("not", PreludeFunDef Function.not), 56 | ("apndl", PreludeFunDef Function.apndl), 57 | ("apndr", PreludeFunDef Function.apndr), 58 | ("rotl", PreludeFunDef Function.rotl), 59 | ("rotr", PreludeFunDef Function.rotr), 60 | ("+", PreludeFunDef Function.add), 61 | ("-", PreludeFunDef Function.subtract), 62 | ("*", PreludeFunDef Function.multiply), 63 | ("div", PreludeFunDef Function.divide) 64 | ] 65 | 66 | extend :: Symbol -> FunDef -> InterpM () 67 | extend symbol f = do 68 | env <- get 69 | put $ Map.insert symbol f env 70 | 71 | lookup :: Symbol -> InterpM FunDef 72 | lookup symbol = do 73 | env <- get 74 | case reads symbol :: [(Integer, String)] of 75 | [(n, "")] -> return $ PreludeFunDef $ Function.select $ makeNumber n 76 | [(n, "r")] -> return $ PreludeFunDef $ Function.selectr $ makeNumber n 77 | _ -> case Map.lookup symbol env of 78 | Just f -> return f 79 | Nothing -> throwError $ UndefinedFunction symbol 80 | 81 | -------------------------------------------------------------------------------- /src/FP/Function.hs: -------------------------------------------------------------------------------- 1 | module FP.Function where 2 | 3 | import Data.List (transpose) 4 | import FP.Value 5 | 6 | tl :: Object -> Object 7 | tl (SequenceObject [_]) = emptySeq 8 | tl (SequenceObject (_:os)) = SequenceObject os 9 | tl _ = Bottom 10 | 11 | tlr :: Object -> Object 12 | tlr (SequenceObject [_]) = emptySeq 13 | tlr (SequenceObject os) = SequenceObject $ init os 14 | tlr _ = Bottom 15 | 16 | atom :: Object -> Object 17 | atom (AtomObject _) = makeBool True 18 | atom _ = makeBool False 19 | 20 | eq :: Object -> Object 21 | eq (SequenceObject [x,y]) = makeBool $ x == y 22 | eq _ = makeBool False 23 | 24 | null :: Object -> Object 25 | null = makeBool . (emptySeq==) 26 | 27 | reverse :: Object -> Object 28 | reverse (SequenceObject os) = SequenceObject $ Prelude.reverse os 29 | reverse _ = Bottom 30 | 31 | distl :: Object -> Object 32 | distl (SequenceObject [x, SequenceObject ys]) = SequenceObject $ map (\y -> SequenceObject [x, y]) ys 33 | distl _ = Bottom 34 | 35 | distr :: Object -> Object 36 | distr (SequenceObject [SequenceObject xs, y]) = SequenceObject $ map (\x -> SequenceObject [x, y]) xs 37 | distr _ = Bottom 38 | 39 | length :: Object -> Object 40 | length (SequenceObject os) = makeNumber $ fromIntegral $ Prelude.length os 41 | length _ = Bottom 42 | 43 | trans :: Object -> Object 44 | trans (SequenceObject os) = 45 | let oss = fmap unwrap os 46 | oss' = transpose oss 47 | in wrap $ fmap wrap oss' 48 | where 49 | unwrap (SequenceObject os) = os 50 | wrap = SequenceObject 51 | trans _ = Bottom 52 | 53 | and :: Object -> Object 54 | and (SequenceObject [AtomObject (BoolAtom x), AtomObject (BoolAtom y)]) = makeBool $ x && y 55 | and _ = Bottom 56 | 57 | or :: Object -> Object 58 | or (SequenceObject [AtomObject (BoolAtom x), AtomObject (BoolAtom y)]) = makeBool $ x || y 59 | or _ = Bottom 60 | 61 | not :: Object -> Object 62 | not (AtomObject (BoolAtom x)) = makeBool $ Prelude.not x 63 | not _ = Bottom 64 | 65 | apndl :: Object -> Object 66 | apndl (SequenceObject [x, SequenceObject os]) = SequenceObject $ x:os 67 | apndl _ = Bottom 68 | 69 | apndr :: Object -> Object 70 | apndr (SequenceObject [SequenceObject os, x]) = SequenceObject $ os ++ [x] 71 | apndr _ = Bottom 72 | 73 | rotl :: Object -> Object 74 | rotl (SequenceObject (o:os)) = SequenceObject $ os ++ [o] 75 | rotl _ = Bottom 76 | 77 | rotr :: Object -> Object 78 | rotr (SequenceObject os) = 79 | let lastIndex = Prelude.length os - 1 80 | (xs, ys) = splitAt lastIndex os 81 | in SequenceObject $ ys ++ xs 82 | rotr _ = Bottom 83 | 84 | select :: Object -> Object -> Object 85 | select (AtomObject (NumberAtom index)) (SequenceObject os) = 86 | let seqLength = Prelude.length os 87 | intIndex = fromIntegral index 88 | in if intIndex <= seqLength 89 | then os !! (intIndex - 1) 90 | else Bottom 91 | s _ _ = Bottom 92 | 93 | selectr :: Object -> Object -> Object 94 | selectr (AtomObject (NumberAtom index)) (SequenceObject os) = 95 | let seqLength = Prelude.length os 96 | intIndex = fromIntegral index 97 | in if intIndex <= seqLength 98 | then os !! (seqLength - intIndex) 99 | else Bottom 100 | sr _ _ = Bottom 101 | 102 | add :: Object -> Object 103 | add (SequenceObject [AtomObject (NumberAtom x), AtomObject (NumberAtom y)]) = makeNumber $ x + y 104 | add _ = Bottom 105 | 106 | subtract :: Object -> Object 107 | subtract (SequenceObject [AtomObject (NumberAtom x), AtomObject (NumberAtom y)]) = makeNumber $ x - y 108 | subtract _ = Bottom 109 | 110 | multiply :: Object -> Object 111 | multiply (SequenceObject [AtomObject (NumberAtom x), AtomObject (NumberAtom y)]) = makeNumber $ x * y 112 | multiply _ = Bottom 113 | 114 | divide :: Object -> Object 115 | divide (SequenceObject [AtomObject (NumberAtom x), AtomObject (NumberAtom y)]) = 116 | if y == 0 117 | then Bottom 118 | else makeNumber $ x `div` y 119 | divide _ = Bottom 120 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | 14 | # The different configurations we want to test. We have BUILD=cabal which uses 15 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 16 | # of those below. 17 | # 18 | # We set the compiler values here to tell Travis to use a different 19 | # cache file per set of arguments. 20 | # 21 | # If you need to have different apt packages for each combination in the 22 | # matrix, you can use a line such as: 23 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 24 | matrix: 25 | include: 26 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 27 | # https://github.com/hvr/multi-ghc-travis 28 | - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 29 | compiler: ": #GHC 7.8.4" 30 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} 31 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 32 | compiler: ": #GHC 7.10.3" 33 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 34 | 35 | # Build with the newest GHC and cabal-install. This is an accepted failure, 36 | # see below. 37 | - env: BUILD=cabal GHCVER=head CABALVER=head 38 | compiler: ": #GHC HEAD" 39 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 40 | 41 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 42 | # variable, such as using --stack-yaml to point to a different file. 43 | - env: BUILD=stack ARGS="--resolver lts-3" 44 | compiler: ": #stack 7.10.2" 45 | addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} 46 | 47 | - env: BUILD=stack ARGS="--resolver lts-5" 48 | compiler: ": #stack 7.10.3" 49 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 50 | 51 | # Nightly builds are allowed to fail 52 | - env: BUILD=stack ARGS="--resolver nightly" 53 | compiler: ": #stack nightly" 54 | addons: {apt: {packages: [libgmp-dev]}} 55 | 56 | # Build on OS X in addition to Linux 57 | - env: BUILD=stack ARGS="--resolver lts-3" 58 | compiler: ": #stack 7.10.2 osx" 59 | os: osx 60 | 61 | - env: BUILD=stack ARGS="--resolver lts-5" 62 | compiler: ": #stack 7.10.3 osx" 63 | os: osx 64 | 65 | - env: BUILD=stack ARGS="--resolver nightly" 66 | compiler: ": #stack nightly osx" 67 | os: osx 68 | 69 | allow_failures: 70 | - env: BUILD=cabal GHCVER=head CABALVER=head 71 | - env: BUILD=stack ARGS="--resolver nightly" 72 | 73 | before_install: 74 | # Using compiler above sets CC to an invalid value, so unset it 75 | - unset CC 76 | 77 | # We want to always allow newer versions of packages when building on GHC HEAD 78 | - CABALARGS="" 79 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 80 | 81 | # Download and unpack the stack executable 82 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:$PATH 83 | - mkdir -p ~/.local/bin 84 | - | 85 | if [ `uname` = "Darwin" ] 86 | then 87 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 88 | else 89 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 90 | fi 91 | 92 | install: 93 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 94 | - if [ -f configure.ac ]; then autoreconf -i; fi 95 | - | 96 | case "$BUILD" in 97 | stack) 98 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 99 | ;; 100 | cabal) 101 | cabal --version 102 | travis_retry cabal update 103 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS 104 | ;; 105 | esac 106 | 107 | script: 108 | - | 109 | case "$BUILD" in 110 | stack) 111 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 112 | ;; 113 | cabal) 114 | cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror" 115 | cabal build 116 | cabal check || [ "$CABALVER" == "1.16" ] 117 | cabal test 118 | cabal sdist 119 | cabal copy 120 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 121 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 122 | ;; 123 | esac 124 | --------------------------------------------------------------------------------