unique-lang (empty) → 0.1.0.0
raw patch · 6 files changed
+551/−0 lines, 6 filesdep +basedep +neat-interpolationdep +text
Dependencies added: base, neat-interpolation, text, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- README.md +3/−0
- app/Examples.hs +86/−0
- app/Main.hs +403/−0
- unique-lang.cabal +34/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for unique-lang++## 0.1.0.0 -- 2022-07-28++* First published version.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2022 Owen Bechtel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,3 @@+# Unique++Unique is an esoteric programming language where each number can only occur once. Every variable in Unique is stored in a single data structure: a stack of integer arrays. You can find a description of how the language works [here](https://owenbechtel.com/unique).
+ app/Examples.hs view
@@ -0,0 +1,86 @@+{-+ (c) 2022 Owen Bechtel+ License: MIT (see LICENSE file)+-}++{-# LANGUAGE QuasiQuotes #-}++module Examples (copy) where++import NeatInterpolation (text)++import Data.Text (Text)+import qualified Data.Text.IO as IO++copy :: IO ()+copy = do+ IO.writeFile "truth-machine.uniq" truthMachine+ IO.writeFile "fibonacci.uniq" fibonacci+ IO.writeFile "hello-world.uniq" helloWorld+ putStrLn "Created truth-machine.uniq"+ putStrLn "Created fibonacci.uniq"+ putStrLn "Created hello-world.uniq"++truthMachine :: Text+truthMachine = [text|+ # get input+ 42++ # print 1 indefinitely+ 0 11 [+ 70 -70 + 1 50 49 - 4+ 69 -69 + 3 [ 24 20 - 64 60 - 44 ] 34 9+ ] 16 18 +++ # print 0+ 68 -68 + 84 80 - [+ 67 -67 + 91 90 - 66 -66 + 21 23 ++ ] 15 19 +++ # create if/else statement+ 8+ |]++fibonacci :: Text+fibonacci = [text|+ # add 1 0 1 to stack+ 0 3 [ 1 50 -50 + 61 60 - ] 6++ 51 -51 + 11 [+ # save a copy of the top number+ 4 73 70 - 74 71 -++ # add and print+ 10 84 80 - 85 81 - 44++ # stop when numbers get too large+ 52 -52 + 63 62 - 1000000000000000000 26+ ] 34++ # create while loop+ 9+ |]++helloWorld :: Text+helloWorld = [text|+ # add array of characters to stack+ 0 14 [+ 10+ 33 # !+ 100 # d+ 108 # l+ 114 # r+ 111 # o+ 119 # w+ 32+ 44 # ,+ 37 3 * # o+ 27 4 * # l+ 12 9 * # l+ 101 # e+ 104 # h+ ]++ # print characters+ 43+ |]
+ app/Main.hs view
@@ -0,0 +1,403 @@+{-+ (c) 2022 Owen Bechtel+ License: MIT (see LICENSE file)+-}++{-# LANGUAGE LambdaCase #-}++module Main (main) where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import Control.Monad.Trans.State (StateT, runStateT, gets, modify)++import Text.Read (readMaybe)+import Data.List (nub)+import Data.Char (ord, chr)+import Data.Function (on)+import Data.Bifunctor (first, second)+import Control.Applicative (liftA2)+import Control.Monad (foldM, void, when)+import Control.Exception (IOException, catch)+import System.Environment (getArgs, getProgName)++import qualified Examples++main :: IO ()+main = getArgs >>= \case+ ["run", path] -> runFile path+ ["examples"] -> Examples.copy+ _ -> do+ name <- getProgName+ putStrLn "Unique version 0.1.0.0"+ putStrLn "Commands: "+ putStrLn (" " ++ name ++ " run <file> interpret a Unique file")+ putStrLn (" " ++ name ++ " examples create example programs")+++runFile :: FilePath -> IO ()+runFile path = safeReadFile path >>= \case+ Nothing -> putStrLn ("ERROR: file '" ++ path ++ "' does not exist")+ Just program -> do+ runUnique (runProgram program) >>= \case+ Left err -> putStrLn ("ERROR: " ++ err)+ Right () -> return ()++safeReadFile :: FilePath -> IO (Maybe String)+safeReadFile path =+ fmap Just (readFile path) `catch`+ \e -> return (const Nothing (e :: IOException))++type Stack = [[Int]]+data Mode = CommandMode | LengthMode | PushMode Int+type Unique = ExceptT String (StateT (Stack, Mode) IO)++runUnique :: Unique a -> IO (Either String a)+runUnique u = fmap fst+ (runStateT (runExceptT u) ([], CommandMode))++fromIO :: IO a -> Unique a+fromIO = lift . lift++getStack :: Unique Stack+getStack = lift (gets fst)++putStack :: Stack -> Unique ()+putStack = modifyStack . const++modifyStack :: (Stack -> Stack) -> Unique ()+modifyStack = lift . modify . first++getMode :: Unique Mode+getMode = lift (gets snd)++putMode :: Mode -> Unique ()+putMode = modifyMode . const++modifyMode :: (Mode -> Mode) -> Unique ()+modifyMode = lift . modify . second++runProgram :: String -> Unique ()+runProgram program = do+ case evalProgram (removeComments program) of+ Left err -> throwE err+ Right commands -> execCommands commands++removeComments :: String -> String+removeComments =+ unlines . map removeComment . lines+ where removeComment = takeWhile (/= '#')++execCommands :: [Int] -> Unique ()+execCommands commands = do+ mapM_ execute commands+ mode <- getMode+ case mode of+ CommandMode -> return ()+ _ -> throwE "fewer numbers in array than expected"++execute :: Int -> Unique ()+execute num = getMode >>= \case+ CommandMode -> execCommand num+ LengthMode ->+ if num <= 0+ then throwE "array length must be positive"+ else putMode (PushMode num)+ PushMode len -> do+ modifyStack (insert num)+ putMode (if len == 1+ then CommandMode+ else PushMode (len - 1))++execCommand :: Int -> Unique ()+execCommand = \case+ --PUSH+ 0 -> do+ push []+ putMode LengthMode++ --DELETE+ 1 -> void pop++ --SWAP+ 2 -> do+ xs <- pop+ ys <- pop+ push xs+ push ys++ --ROTATE+ 3 -> do+ xs <- pop+ ys <- pop+ zs <- pop+ push ys+ push xs+ push zs++ --DUPLICATE+ 4 -> do+ xs <- pop+ push xs+ push xs++ --APPEND+ 5 -> do+ xs <- pop+ ys <- pop+ push (xs ++ ys)++ --UNFOLD+ 6 -> do+ xs <- pop+ mapM_ (push . return) (reverse xs)++ --IF+ 7 -> do+ commands <- pop+ conditions <- pop+ when (all truthy conditions)+ (execCommands commands)++ --IF ELSE+ 8 -> do+ elseCommands <- pop+ commands <- pop+ conditions <- pop+ if all truthy conditions+ then execCommands commands+ else execCommands elseCommands++ --WHILE+ 9 -> do+ commands <- pop+ whileLoop commands++ --ADD+ 10 -> apOp (+)+ 11 -> zipOp (+)++ --SUBTRACT+ 12 -> apOp (-)+ 13 -> zipOp (-)++ --MULTIPLY+ 14 -> apOp (*)+ 15 -> zipOp (*)++ --DIVIDE+ 16 -> apOpM divide+ 17 -> zipOpM divide++ --MODULO+ 18 -> apOpM modulo+ 19 -> zipOpM modulo++ --POWER+ 20 -> apOpM power+ 21 -> zipOpM power++ --OR+ 22 -> boolApOp ((||) `on` truthy)+ 23 -> boolZipOp ((||) `on` truthy)++ --AND+ 24 -> boolApOp ((&&) `on` truthy)+ 25 -> boolZipOp ((&&) `on` truthy)++ --LESS THAN+ 26 -> boolApOp (<)+ 27 -> boolZipOp (<)++ --GREATER THAN+ 28 -> boolApOp (>)+ 29 -> boolZipOp (>)++ --EQUAL TO+ 30 -> boolApOp (==)+ 31 -> boolZipOp (==)++ --NEGATE+ 32 -> do+ xs <- pop+ push (map negate xs)++ --NOT+ 33 -> do+ xs <- pop+ push (map (toInt . not . truthy) xs)++ --REVERSE+ 34 -> do+ xs <- pop+ push (reverse xs)++ --LENGTH+ 35 -> foldOp length++ --SUM+ 36 -> foldOp sum++ --PRODUCT+ 37 -> foldOp product++ --ANY+ 38 -> foldOp (toInt . any truthy)++ --ALL+ 39 -> foldOp (toInt . all truthy)++ --INPUT CHARACTER+ 40 -> do+ ch <- fromIO getChar+ push [ord ch]++ --INPUT STRING+ 41 -> do+ str <- fromIO getLine+ push (map ord str)++ --INPUT NUMBER+ 42 -> do+ num <- fromIO getLine+ case readMaybe num of+ Nothing -> throwE "input is not a number"+ Just x -> push [x]++ --OUTPUT CHARACTERS+ 43 -> do+ xs <- pop+ fromIO (putStr (map chr xs))++ --OUTPUT NUMBERS+ 44 -> do+ xs <- pop+ fromIO (mapM_ print xs)++ --OTHER+ num -> throwE+ ("no command associated with number '" ++ show num ++ "'")++truthy :: Int -> Bool+truthy = (/= 0)++toInt :: Bool -> Int+toInt False = 0+toInt True = 1++insert :: Int -> Stack -> Stack+insert num = \case+ [] -> [[num]]+ ([] : stack) -> [num] : stack+ (xs : stack) -> (num : xs) : stack++pop :: Unique [Int]+pop = getStack >>= \case+ [] -> throwE "no values in stack to pop"+ (xs : new) -> do+ putStack new+ return xs++push :: [Int] -> Unique ()+push xs = modifyStack (xs:)++apOp :: (Int -> Int -> Int) -> Unique ()+apOp f = do+ xs <- pop+ ys <- pop+ push (liftA2 f ys xs)++zipOp :: (Int -> Int -> Int) -> Unique ()+zipOp f = do+ xs <- pop+ ys <- pop+ push (zipWith f ys xs)++apOpM :: (Int -> Int -> Unique Int) -> Unique ()+apOpM f = do+ xs <- pop+ ys <- pop+ res <- sequence (liftA2 f ys xs)+ push res++zipOpM :: (Int -> Int -> Unique Int) -> Unique ()+zipOpM f = do+ xs <- pop+ ys <- pop+ res <- sequence (zipWith f ys xs)+ push res++boolApOp :: (Int -> Int -> Bool) -> Unique ()+boolApOp f = apOp (\x y -> toInt (f x y))++boolZipOp :: (Int -> Int -> Bool) -> Unique ()+boolZipOp f = zipOp (\x y -> toInt (f x y))++foldOp :: ([Int] -> Int) -> Unique ()+foldOp f = do+ xs <- pop+ push [f xs]++divide :: Int -> Int -> Unique Int+divide x y =+ if y == 0+ then throwE "division by zero"+ else return (div x y)++modulo :: Int -> Int -> Unique Int+modulo x y =+ if y == 0+ then throwE "modulo by zero"+ else return (mod x y)++power :: Int -> Int -> Unique Int+power x y =+ if y < 0+ then throwE "negative exponent"+ else return (x ^ y)++whileLoop :: [Int] -> Unique ()+whileLoop commands = do+ conditions <- pop+ when (all truthy conditions) $ do+ execCommands commands+ whileLoop commands++data Symbol = Lit Int | Add | Subtract | Multiply | Ignore++evalProgram :: String -> Either String [Int]+evalProgram program = do+ symbols <- mapM readSymbol (words program)+ if getNums symbols == nub (getNums symbols)+ then reverse <$> foldM execSymbol [] symbols+ else Left "number occurs more than once"++getNums :: [Symbol] -> [Int]+getNums = \case+ [] -> []+ (Lit x : ss) -> x : getNums ss+ (_ : ss) -> getNums ss++readSymbol :: String -> Either String Symbol+readSymbol = \case+ "+" -> return Add+ "-" -> return Subtract+ "*" -> return Multiply+ "[" -> return Ignore+ "]" -> return Ignore+ sym -> case readMaybe sym of+ Nothing -> Left ("cannot parse symbol '" ++ sym ++ "'")+ Just x -> return (Lit x)++execSymbol :: [Int] -> Symbol -> Either String [Int]+execSymbol xs = \case+ Lit x -> return (x : xs)+ Add -> operation (+) "add"+ Subtract -> operation (-) "subtract"+ Multiply -> operation (*) "multiply"+ Ignore -> return xs+ where+ operation f name =+ case xs of+ (x : y : t) -> return (f y x : t)+ _ -> Left ("not enough numbers to " ++ name)
+ unique-lang.cabal view
@@ -0,0 +1,34 @@+cabal-version: 2.4+name: unique-lang+version: 0.1.0.0+author: Owen Bechtel+maintainer: ombspring@gmail.com++category: Compilers/Interpreters+synopsis: Esoteric programming language where each number can only appear once++description:+ Unique is an esoteric programming language where each number can only occur once. Every variable in Unique is stored in a single data structure: a stack of integer arrays. You can find a description of how the language works [here](https://owenbechtel.com/unique).++homepage: https://github.com/UnaryPlus/unique+bug-reports: https://github.com/UnaryPlus/unique/issues+license: MIT+license-file: LICENSE+extra-source-files: CHANGELOG.md, README.md++source-repository head+ type: git+ location: https://github.com/UnaryPlus/unique.git++executable unique+ hs-source-dirs: app+ default-language: Haskell2010+ ghc-options: -Wall+ main-is: Main.hs+ other-modules: Examples++ build-depends:+ base >= 4.11 && < 5,+ transformers >= 0.4 && < 0.7,+ text >= 0.7 && < 2.1,+ neat-interpolation >= 0.1.1 && < 0.6