Proof-of-concept of a language that puts functions on the stack rather than values

funstack.hs

import qualified System.IO as IO
import qualified System.Environment as Env
import Control.Monad (liftM2)
import Data.Char (ord, chr, isDigit, isUpper, isLower)
import Data.List (inits, tails, sort, nub, genericIndex, genericTake, genericDrop, genericReplicate)
import qualified Data.Map as Map


--- DATA TYPES ---

data Value = Number Integer | Character Integer | List [Value]

instance Show Value where
  show (Number n) = show n
  show (Character n) = show $ integerToChar n
  show (List l)
    | null l = show l
    | isString (List l) = show $ map valToChar l
    | otherwise = show l

instance Eq Value where
  (Number x) == (Number y) = x == y
  (Character x) == (Character y) = x == y
  (List l) == (List m) = l == m
  x == y = False

instance Ord Value where
  (Character x) `compare` (Character y) = x `compare` y
  (Character _) `compare` _ = LT
  _ `compare` (Character _) = GT
  (Number x) `compare` (Number y) = x `compare` y
  (Number _) `compare` _ = LT
  _ `compare` (Number _) = GT
  (List l) `compare` (List m) = l `compare` m


data Function = Constant { extract :: Value } | Function {
  arity :: Int,
  unsafeBind :: (Value -> Function)
}

instance Show Function where
  show (Constant x) = "<const " ++ show x ++ ">"
  show (Function a _) = "<arity-" ++ show a ++ " function>"

instance Monoid Function where
  mempty = Function 1 Constant
  Constant x `mappend` _ = Constant x
  f `mappend` Constant x = unsafeBind f x
  f `mappend` g = Function (arity f + arity g - 1) (\x -> case unsafeBind g x of
      Constant y -> unsafeBind f y
      g' -> f `mappend` g')


data Modifier = Modifier1 (Function -> Function) | Modifier2 (Function -> Function -> Function) | Modifier3 (Function -> Function -> Function -> Function) | Modifier4 (Function -> Function -> Function -> Function -> Function)


type Stack = [Function]

data State = State {
  stack :: Stack,
  arguments :: [Value]
} deriving (Show)


data Command = PushFn Function | ModifyFn Modifier | BindArg Integer | BindVal Value | StackCmd (Stack -> Stack)


--- UTILITY FUNCTIONS ---

maybeToEither :: String -> Maybe a -> Either String a
maybeToEither message (Just x) = Right x
maybeToEither message Nothing = Left message


--- TYPE CHECKING AND CONVERSION ---

isCharacter :: Value -> Bool
isCharacter (Character _) = True
isCharacter _ = False

isString :: Value -> Bool
isString (List l) = and (map isCharacter $ take 1000000 l)
isString _ = False


integerToChar :: Integer -> Char
integerToChar = chr . abs . fromInteger

charToInteger :: Char -> Integer
charToInteger = toInteger . ord


valToList :: Value -> [Value]
valToList (List l) = l
valToList x = [x]

valToInteger :: Value -> Integer
valToInteger (Number n) = n
valToInteger (Character n) = n
valToInteger x = error ("Cannot convert value " ++ show x ++ " to integer")

valToChar :: Value -> Char
valToChar (Character n) = integerToChar n
valToChar _ = '\0'

valToString :: Value -> String
valToString x@(Character _) = [valToChar x]
valToString x@(List l)
  | isString x = map valToChar l
valToString x = show x

valToBool :: Value -> Bool
valToBool (Number 0) = False
valToBool (Character 0) = False
valToBool (List []) = False
valToBool _ = True


charToVal :: Char -> Value
charToVal = Character . charToInteger

stringToVal :: String -> Value
stringToVal = List . map charToVal

boolToVal :: Bool -> Value
boolToVal = Number . toInteger . fromEnum

orderingToVal :: Ordering -> Value
-- By default, fromEnum takes LT, EQ, GT to 0, 1, 2; we want -1, 0, 1, so we compose it with pred
orderingToVal = Number . toInteger . pred . fromEnum


sameTypeFalsey :: Value -> Value
sameTypeFalsey (Number _) = Number 0
sameTypeFalsey (Character _) = Character 0
sameTypeFalsey (List _) = List []


--- FUNCTION CREATION AND APPLICATION ---

monadic :: (Value -> Value) -> Function
monadic f = Function 1 (Constant . f)

dyadic :: (Value -> Value -> Value) -> Function
dyadic f = Function 2 (monadic . f)

triadic :: (Value -> Value -> Value -> Value) -> Function
triadic f = Function 3 (dyadic . f)

tetradic :: (Value -> Value -> Value -> Value -> Value) -> Function
tetradic f = Function 4 (triadic . f)


bind :: Function -> Value -> Function
bind f x = f `mappend` Constant x

bind2 :: Function -> Value -> Value -> Function
bind2 f x y = bind (bind f x) y

rbind :: Function -> Value -> Function
rbind f@Function{arity = a} x
  | a == 1 = bind f x
  | otherwise = Function (a - 1) (\y -> rbind (bind f y) x)

bindSecond :: Function -> Value -> Function
bindSecond f@Function{arity = a} x
  | a == 1 = f
  | a == 2 = rbind f x
  | otherwise = Function (a - 1) (\y -> bind2 f y x)


parallelBind :: [Function] -> Value -> [Function]
parallelBind fs x = [bind f x | f <- fs]

zipBind :: [Function] -> Value -> [Function]
zipBind fs (List l) = zipWith bind fs l
zipBind fs x = parallelBind fs x

tableBind :: Function -> [Value] -> Function
tableBind f xs
  | arity f == 1 = Constant $ List $ map (apply f) xs
  | arity f > 1 = parallel (arity f - 1) [Function (arity f - 1) (\ys -> tableBind (bind f x) (valToList ys)) | x <- xs]


apply :: Function -> Value -> Value
apply f x
  | (Constant r) <- bind f x = r
  | otherwise = error $ "Cannot apply " ++ show f ++ " to one argument (perhaps you meant to use bind instead?)"

apply2 :: Function -> Value -> Value -> Value
apply2 f x y
  | (Constant r) <- bind2 f x y = r
  | otherwise = error $ "Cannot apply " ++ show f ++ " to two arguments (perhaps you meant to use bind2 instead?)"

applyFully :: Function -> [Value] -> Value
applyFully (Constant x) _ = x
applyFully f [] = error "Cannot apply function to empty arglist"
applyFully f args
  | arity f /= length args = applyFully f $ take (arity f) (cycle args)
  | (Constant r) <- res = r
  | otherwise = error $ "Error in applyFully " ++ show f ++ " " ++ show args ++ ": returned " ++ show res
  where res = foldl bind f args


parallelApply :: [Function] -> Value -> Value
parallelApply fs x = List [apply f x | f <- fs]

zipApply :: [Function] -> Value -> Value
zipApply fs (List l) = List $ zipWith apply fs l
zipApply fs x = parallelApply fs x

iterateApply :: Function -> [Value] -> Value
iterateApply = (List .) . iterateApply'
  where iterateApply' f args = head args : iterateApply' f (tail args ++ [applyFully f args])

fixiterApply :: Function -> [Value] -> Value
fixiterApply = (List .) . fixiterApply'
  where
    fixiterApply' f args
      | all (== newVal) args = args
      | otherwise = head args : fixiterApply' f (tail args ++ [newVal])
      where newVal = applyFully f args

fixpointApply :: Function -> [Value] -> Value
fixpointApply f args
  | all (== newVal) args = newVal
  | otherwise = fixpointApply f (tail args ++ [newVal])
  where newVal = applyFully f args


mapOverList :: (Value -> Value) -> Value -> Value
mapOverList f (List l) = List $ map (mapOverList f) l
mapOverList f x = f x

mapOverLists :: (Value -> Value -> Value) -> Value -> Value -> Value
mapOverLists f (List l) (List m) = List $ zipWith (mapOverLists f) l m
mapOverLists f (List l) y = List $ map ((flip $ mapOverLists f) y) l
mapOverLists f x (List l) = List $ map (mapOverLists f x) l
mapOverLists f x y = f x y


--- FUNCTION COMPOSITION ---

compose2 :: Function -> Function -> Function
compose2 = mappend

compose3 :: Function -> Function -> Function -> Function
compose3 f g h = f `mappend` g `mappend` h

compose4 :: Function -> Function -> Function -> Function -> Function
compose4 f g h i = f `mappend` g `mappend` h `mappend` i

composeAll :: [Function] -> Function
composeAll = mconcat

rcompose2 :: Function -> Function -> Function
rcompose2 f g
  | arity f == 1 = compose2 f g
  | otherwise = Function (arity f + arity g - 1) (\x -> rcompose2 (bind f x) g)

rcompose3 :: Function -> Function -> Function -> Function
rcompose3 f g h = f `rcompose2` g `rcompose2` h


hook :: Function -> Function -> Function
hook f (Constant x) = rbind f x
hook f g
  | arity f == 1 = compose2 f g
  | arity f == 2 && arity g == 1 = Function 1 (\x -> bind2 f x (apply g x))
  | otherwise = Function (max (arity f - 1) (arity g)) (\x -> hook (bind f x) (bind g x))


over' :: Function -> Function -> Function -> Function
over' f g g'
  | arity g' == 1 = Function newArity (\x -> over (bind f (apply g' x)) g)
  | otherwise = Function newArity (\x -> over' f g (bind g' x))
  where newArity = (arity f - 1) * (arity g) + (arity g')

over :: Function -> Function -> Function
over f g
  | arity f == 1 = compose2 f g
  | otherwise = over' f g g


ifThenElse' :: Function -> Function -> Function -> Function
ifThenElse' f g h
  | arity f == 1 = Function 1 (\x -> if (valToBool $ apply f x) then (bind g x) else (bind h x))
  | otherwise = Function (arity f) (\x -> ifThenElse' (bind f x) (bind g x) (bind h x))

ifThenElse :: Function -> Function -> Function -> Function
ifThenElse f g h = ifThenElse' (convertArity a f) (convertArity a g) (convertArity a h)
  where a = maximum $ map arity [f, g, h]


--- FUNCTION MODIFICATION ---

collectArgs :: Function -> Int -> (Function -> [Value] -> Value) -> [Value] -> Value -> Function
collectArgs f a applyFn args arg
  | a <= 1 = Constant $ applyFn f $ reverse (arg : args)
  | otherwise = Function (a - 1) $ collectArgs f (a - 1) applyFn (arg : args)


convertArity :: Int -> Function -> Function
convertArity a (Constant x)
  | a < 1 = Constant x
  | otherwise = Function a (\_ -> convertArity (a - 1) (Constant x))
convertArity a' f@Function{arity = a}
  | a' < 1 = error "Cannot convert function to arity less than 1"
  | a' == a = f
  | otherwise = Function a' $ collectArgs f a' applyFully []


parallel :: Int -> [Function] -> Function
parallel a fs
  | a < 1 = error $ "Cannot call parallel with arity " ++ show a ++ " less than 1"
  | a == 1 = Function 1 (\x -> Constant $ parallelApply fs x)
  | otherwise = Function a (\x -> parallel (a - 1) (parallelBind fs x))

zipParallel :: Int -> [Function] -> Function
zipParallel a fs
  | a < 1 = error $ "Cannot call zipParallel with arity " ++ show a ++ " less than 1"
  | a == 1 = Function 1 (\x -> Constant $ zipApply fs x)
  | otherwise = Function a (\x -> zipParallel (a - 1) (zipBind fs x))


flipArgs :: Function -> Function
flipArgs f = Function (max 2 (arity f)) (\x -> bindSecond f x)

rotateArgs :: Function -> Function
rotateArgs f = Function (arity f) (\x -> rbind f x)


mapZipping :: Function -> Function
mapZipping f
  | arity f == 1 = monadic (\xs -> List [apply f x | x <- valToList xs])
  | otherwise = Function (arity f) (\xs -> zipParallel (arity f - 1) [bind f x | x <- valToList xs])

mapLeft :: Function -> Function
mapLeft f
  | arity f == 1 = monadic (\xs -> List [List [apply f x, x] | x <- valToList xs])
  | otherwise = Function (arity f) (\xs -> parallel (arity f - 1) [bind f x | x <- valToList xs])

mapRight :: Function -> Function
mapRight f
  | arity f == 1 = monadic (\xs -> List [List [x, apply f x] | x <- valToList xs])
  | arity f == 2 = dyadic (\x ys -> List [apply2 f x y | y <- valToList ys])
  | otherwise = Function (arity f) (\x -> mapRight $ bind f x)

mapWindows :: Function -> Function
mapWindows f = monadic (\xs -> List $ map (applyFully f) $ windows (toInteger $ arity f) (valToList xs))


table :: Function -> Function
table f = Function (arity f) (\xs -> tableBind f $ valToList xs)


fsTakeWhile' :: Function -> [Value] -> [Value]
fsTakeWhile' f xs
  | length args < arity f = xs
  | valToBool (applyFully f args) = head xs : fsTakeWhile' f (tail xs)
  | otherwise = init args
  where args = take (arity f) xs

fsDropWhile' :: Function -> [Value] -> [Value]
fsDropWhile' f xs
  | length args < arity f = []
  | valToBool (applyFully f args) = fsDropWhile' f (tail xs)
  | otherwise = drop (arity f - 1) xs
  where args = take (arity f) xs

fsTakeWhile :: Function -> Function
fsTakeWhile f = monadic (\xs -> List $ fsTakeWhile' f $ valToList xs)

fsDropWhile :: Function -> Function
fsDropWhile f = monadic (\xs -> List $ fsDropWhile' f $ valToList xs)


fsIterate :: Function -> Function
fsIterate f = Function (arity f) (collectArgs f (arity f) iterateApply [])

fsFixIter :: Function -> Function
fsFixIter f = Function (arity f) (collectArgs f (arity f) fixiterApply [])

fsFixPoint :: Function -> Function
fsFixPoint f = Function (arity f) (collectArgs f (arity f) fixpointApply [])


fsScanr :: Function -> Value -> [Value] -> [Value]
fsScanr f x l
  | arity f == 1 = error "Cannot scanr on arity-1 function"
  | length args < argnum = [x]
  | otherwise = applyFully f (args ++ take 1 accum) : accum
  where
    argnum = arity f - 1
    args = take argnum l
    remainder = drop argnum l
    accum = fsScanr f x remainder

fsScanr1 :: Function -> [Value] -> [Value]
fsScanr1 f l
  | arity f == 1 = error "Cannot scanr1 on arity-1 function"
  | null l = []
  | null remainder = take 1 args
  | otherwise = applyFully f (args ++ take 1 accum) : accum
  where
    argnum = arity f - 1
    args = take argnum l
    remainder = drop argnum l
    accum = fsScanr1 f remainder

fsScanl :: Function -> Value -> [Value] -> [Value]
fsScanl f x l
  | arity f == 1 = error "Cannot scanl on arity-1 function"
  | length args < argnum = [x]
  | otherwise = x : fsScanl f accum remainder
  where
    argnum = arity f - 1
    args = take argnum l
    remainder = drop argnum l
    accum = applyFully f (x : args)

fsScanl1 :: Function -> [Value] -> [Value]
fsScanl1 f l
  | arity f == 1 = error "Cannot scanl1 on arity-1 function"
  | null l = []
  | otherwise = fsScanl f (head l) (tail l)


fsFoldr :: Function -> Value -> [Value] -> Value
fsFoldr f x l
  | arity f == 1 = error "Cannot foldr on arity-1 function"
  | otherwise = head $ fsScanr f x l

fsFoldr1 :: Function -> [Value] -> Value
fsFoldr1 f l
  | arity f == 1 = error "Cannot foldr1 on arity-1 function"
  | null l = error $ "Cannot foldr1 empty list"
  | otherwise = head $ fsScanr1 f l

fsFoldl :: Function -> Value -> [Value] -> Value
fsFoldl f x l
  | arity f == 1 = error "Cannot foldl on arity-1 function"
  | otherwise = last $ fsScanl f x l

fsFoldl1 :: Function -> [Value] -> Value
fsFoldl1 f l
  | arity f == 1 = error "Cannot foldl1 on arity-1 function"
  | null l = error $ "Cannot foldl1 empty list"
  | otherwise = last $ fsScanl1 f l


-- TODO: more


--- ARITHMETIC FUNCTIONS ---

toBase :: Integer -> Integer -> [Integer]
toBase _ 0 = []
toBase 0 x = [x]
toBase b x
  | b > 0 && x < 0 = map (0 -) $ toBase b (-x)
  | b == 1 = genericReplicate x 1
  | otherwise = x `mod` b : toBase b (x `div` b)

fromBase :: Integer -> [Integer] -> Integer
fromBase b ds = foldr (\d n -> n * b + d) 0 ds


unaryArithmetic :: (Integer -> Integer) -> Value -> Value
unaryArithmetic op (Number x) = Number $ op x
unaryArithmetic op (Character c) = Character $ op c

binaryArithmetic :: (Integer -> Integer -> Integer) -> Value -> Value -> Value
binaryArithmetic op (Number x) (Number y) = Number $ op x y
binaryArithmetic op (Number x) (Character y) = Character $ op x y
binaryArithmetic op (Character x) (Number y) = Character $ op x y
binaryArithmetic op (Character x) (Character y) = Number $ op x y

unaryNumToList :: (Integer -> [Integer]) -> Value -> Value
unaryNumToList f (Number x) = List $ map Number (f x)
unaryNumToList f (Character x) = List $ map Character (f x)

binaryNumToList :: (Integer -> Integer -> [Integer]) -> Value -> Value -> Value
binaryNumToList f (Number x) (Number y) = List $ map Number (f x y)
binaryNumToList f (Number x) (Character y) = List $ map Number (f x y)
binaryNumToList f (Character x) (Number y) = List $ map Character (f x y)
binaryNumToList f (Character x) (Character y) = List $ map Character (f x y)


arithmeticMonad :: (Integer -> Integer) -> Function
arithmeticMonad = monadic . mapOverList . unaryArithmetic

arithmeticDyad :: (Integer -> Integer -> Integer) -> Function
arithmeticDyad = dyadic . mapOverLists . binaryArithmetic

numToListMonad :: (Integer -> [Integer]) -> Function
numToListMonad = monadic . mapOverList . unaryNumToList

numToListDyad :: (Integer -> Integer -> [Integer]) -> Function
numToListDyad = dyadic . mapOverLists . binaryNumToList


--- CHARACTER FUNCTIONS ---

ord' :: Char -> Integer
ord' = toInteger . fromEnum

chr' :: Integer -> Char
chr' = toEnum . fromInteger . (`mod` charMod)
  where charMod = toInteger $ 1 + fromEnum (maxBound :: Char)

character' :: Char -> Value
character' = Character . ord'

unaryCharMath :: (Integer -> Integer) -> Value -> Value
unaryCharMath f (Number n) = Number $ f n
unaryCharMath f (Character c) = (character' . chr' . f ) c

binaryCharMath :: (Integer -> Integer -> Integer) -> Value -> Value -> Value
binaryCharMath f (Number x) (Number y) = Number $ f x y
binaryCharMath f (Number x) (Character c) = character' $ chr' $ f x c
binaryCharMath f (Character c) (Number x) = character' $ chr' $ f c x
binaryCharMath f (Character c) (Character d) = Number $ f c d


--- STRING FUNCTIONS ---

linesUnlines :: Value -> Value
linesUnlines x@(List l)
  | isString x = List $ map stringToVal $ lines $ valToString x
  | and (map isString l) = stringToVal $ unlines $ map valToString l
-- TODO: Handle other cases


--- LIST FUNCTIONS ---

takeCycle :: Integer -> [a] -> [a]
takeCycle n l = genericTake n (cycle l)

indexCycle :: [a] -> Integer -> a
indexCycle l i = genericIndex (cycle l) i

groupIndices :: Ord a => [a] -> [[Integer]]
groupIndices l = Map.elems $ Map.fromListWith (flip (++)) $ zip l $ [[i] | i <- [0..]]


rotate :: Integer -> [a] -> [a]
rotate _ [] = []
rotate n l
  | n' == 0 = l
  | otherwise = genericDrop n' l ++ genericTake n' l
  where n' = n `mod` toInteger (length l)

windows :: Integer -> [a] -> [[a]]
windows n l
  | n < 0 = map reverse $ windows (abs n) (reverse l)
  | n == 0 =
      let endIndices = zipWith const [1..] l
      in [genericDrop startIndex $ genericTake endIndex l | endIndex <- endIndices, startIndex <- [0 .. endIndex - 1]]
  | not $ null $ genericDrop (n - 1) l = genericTake n l : windows n (tail l)
  | otherwise = []

interleave :: [a] -> [a] -> [a]
interleave [] l = l
interleave (h : t) l = h : interleave l t


consFalsey :: [Value] -> [Value]
consFalsey [] = [Number 0]
consFalsey (x : xs) = sameTypeFalsey x : x : xs


--- BUILTIN FUNCTIONS ---

fsFalsey = monadic (boolToVal . not . valToBool)

fsFlatten = monadic (List . (valToList =<<) . valToList)

fsPair = dyadic (\x y -> List [x, y])

fsSame = dyadic (\x y -> boolToVal $ x == y)


builtins :: Map.Map String Function
builtins = Map.fromList [
 -- Arity 1
  ("Abs", arithmeticMonad abs),
  ("All?", monadic (\l -> boolToVal $ and $ map valToBool $ valToList l)),
  ("Any?", monadic (\l -> boolToVal $ or $ map valToBool $ valToList l)),
  ("ConsFalsey", monadic (List . consFalsey . valToList)),
  ("Cycle", monadic (List . cycle . valToList)),
  ("Dec", monadic $ mapOverList $ unaryCharMath pred),
  ("Double", arithmeticMonad (* 2)),
  ("Flatten", fsFlatten),
  ("From0", numToListMonad (\x -> [0..x-1])),
  ("From1", numToListMonad (\x -> [1..x-1])),
  ("GroupIndices", monadic (List . map (List . map Number) . groupIndices . valToList)),
  ("Halve", arithmeticMonad (`div` 2)),
  ("Head", monadic (head . valToList)),
  ("IFrom0", numToListMonad (\x -> [0..x])),
  ("IFrom1", numToListMonad (\x -> [1..x])),
  ("Id", monadic id),
  ("Inc", monadic $ mapOverList $ unaryCharMath succ),
  ("Indices", monadic (\l -> List [Number i | (i, _) <- zip [0..] $ valToList l])),
  ("Init", monadic (List . reverse . drop 1 . reverse . valToList)),
  ("Last", monadic (last . valToList)),
  ("Length", monadic (Number . toInteger . length . valToList)),
  ("Lines", monadic linesUnlines),
  ("Neg", arithmeticMonad (0 -)),
  ("Negative?", arithmeticMonad $ toInteger . fromEnum . (< 0)),
  ("Nub", monadic (List . nub . valToList)),
  ("Odd?", arithmeticMonad (`mod` 2)),   -- Alias for Parity
  ("Parity", arithmeticMonad (`mod` 2)),
  ("Positive?", arithmeticMonad $ toInteger . fromEnum . (> 0)),
  ("Prefixes", monadic (List . map List . inits . valToList)),
  ("Reverse", monadic (List . reverse . valToList)),
  ("Show", monadic (stringToVal . show)),
  ("Sign", arithmeticMonad signum),
  ("Sort", monadic (List . sort . valToList)),
  ("Square", arithmeticMonad (^ 2)),
  ("Stringify", monadic (stringToVal . valToString)),
  ("Suffixes", monadic (List . map List . tails . valToList)),
  ("Tail", monadic (List . drop 1 . valToList)),
  ("TruthyIndices", monadic (\l -> List [Number i | (i, x) <- zip [0..] $ valToList l, valToBool x])),
  ("Unique", monadic (List . nub . valToList)),   -- Alias for Nub, for non-Haskellers
  ("Wrap", monadic (\x -> List [x])),
  ("Zero?", arithmeticMonad $ toInteger . fromEnum . (== 0)),
  -- TODO: Product, Sum
 -- Arity 2
  ("At", dyadic (\x y -> mapOverList (\i -> genericIndex (valToList y) (valToInteger i)) x)),
  ("AtCycle", dyadic (\x y -> mapOverList (\i -> indexCycle (valToList y) (valToInteger i)) x)),
  ("Compare", dyadic (\x y -> orderingToVal $ x `compare` y)),
  ("Concat", dyadic (\x y -> List (valToList x ++ valToList y))),
  ("Cons", dyadic (\x y -> List (x : valToList y))),
  ("Consr", dyadic (\x y -> List (valToList y ++ [x]))),
  ("Const", dyadic const),
  ("Drop", dyadic (\x y -> mapOverList (\n -> List $ genericDrop (valToInteger n) (valToList y)) x)),
  ("Equal?", arithmeticDyad (\x y -> toInteger $ fromEnum (y == x))),
  ("FromBase", dyadic (\x y -> mapOverList (\b -> Number $ fromBase (valToInteger b) (map valToInteger (valToList y))) x)),
  ("Greater?", arithmeticDyad (\x y -> toInteger $ fromEnum (y > x))),
  ("GreaterEqual?", arithmeticDyad (\x y -> toInteger $ fromEnum (y >= x))),
  ("IDiv", arithmeticDyad (flip div)),
  ("IRange", numToListDyad (\x y -> [x..y])),
  ("Interleave", dyadic (\x y -> List $ interleave (valToList x) (valToList y))),
  ("Less?", arithmeticDyad (\x y -> toInteger $ fromEnum (y < x))),
  ("LessEqual?", arithmeticDyad (\x y -> toInteger $ fromEnum (y <= x))),
  ("Minus", dyadic $ mapOverLists $ binaryCharMath $ flip (-)),
  ("Mod", arithmeticDyad $ flip mod),
  ("Pair", fsPair),
  ("Plus", dyadic $ mapOverLists $ binaryCharMath (+)),
  ("Pow", arithmeticDyad (^)),
  ("Range", numToListDyad (\x y -> [x..y-1])),
  ("Repeat", dyadic (\x y -> mapOverList (\n -> List $ id =<< (genericReplicate (valToInteger n) (valToList y))) x)),
  ("Rotate", dyadic (\x y -> mapOverList (\n -> List $ rotate (valToInteger n) (valToList y)) x)),
  ("Same?", fsSame),
  ("Take", dyadic (\x y -> mapOverList (\n -> List $ genericTake (valToInteger n) (valToList y)) x)),
  ("TakeCycle", dyadic (\x y -> mapOverList (\n -> List $ takeCycle (valToInteger n) (valToList y)) x)),
  ("Times", arithmeticDyad (*)),
  ("ToBase", numToListDyad toBase),
  ("Windows", dyadic (\x y -> mapOverList (\n -> List $ map List $ windows (valToInteger n) (valToList y)) x)),
 -- Arity 3
  ("Trio", triadic (\x y z -> List [x, y, z])),
 -- Arity 4
  ("Quartet", tetradic (\x y z w -> List [x, y, z, w]))
  ]


--- MODIFIERS ---

modify :: Stack -> Modifier -> Stack
modify (f : fs) (Modifier1 m) = m f : fs
modify (g : f : fs) (Modifier2 m) = m f g : fs
modify (h : g : f : fs) (Modifier3 m) = m f g h : fs
modify (i : h : g : f : fs) (Modifier4 m) = m f g h i : fs
modify _ _ = error "Not enough functions on stack for modifier"  -- TODO: handle this case more gracefully


modifiers :: Map.Map String Modifier
modifiers = Map.fromList [
 -- 1-modifiers
  ("flip", Modifier1 flipArgs),
  ("rotate", Modifier1 rotateArgs),
  ("self", Modifier1 $ convertArity 1),
  ("not", Modifier1 (\f -> compose2 fsFalsey f)),
  ("invariant", Modifier1 (\f -> hook fsSame f)),
  ("map", Modifier1 mapZipping),
  ("lmap", Modifier1 mapLeft),
  ("rmap", Modifier1 mapRight),
  ("mapwindows", Modifier1 mapWindows),
  ("flatmap", Modifier1 (\f -> compose2 fsFlatten $ mapZipping f)),
  ("table", Modifier1 table),
  ("selftable", Modifier1 (convertArity 1 . table)),
  ("iterate", Modifier1 fsIterate),
  ("fixiter", Modifier1 fsFixIter),
  ("fixpoint", Modifier1 fsFixPoint),
  ("takewhile", Modifier1 fsTakeWhile),
  ("dropwhile", Modifier1 fsDropWhile),
  ("scanr", Modifier1 (\f -> dyadic (\x ys -> List $ fsScanr f x $ valToList ys))),
  ("scanr1", Modifier1 (\f -> monadic (\xs -> List $ fsScanr1 f $ valToList xs))),
  ("scanl", Modifier1 (\f -> dyadic (\x ys -> List $ fsScanl f x $ valToList ys))),
  ("scanl1", Modifier1 (\f -> monadic (\xs -> List $ fsScanl1 f $ valToList xs))),
  ("foldr", Modifier1 (\f -> dyadic (\x ys -> fsFoldr f x $ valToList ys))),
  ("foldr1", Modifier1 (\f -> monadic (\xs -> fsFoldr1 f $ valToList xs))),
  ("foldl", Modifier1 (\f -> dyadic (\x ys -> fsFoldl f x $ valToList ys))),
  ("foldl1", Modifier1 (\f -> monadic (\xs -> fsFoldl1 f $ valToList xs))),
  -- TODO: filter
 -- 2-modifiers
  ("compose", Modifier2 compose2),
  ("rcompose", Modifier2 rcompose2),
  ("or", Modifier2 (\f g -> ifThenElse f f g)),
  ("and", Modifier2 (\f g -> ifThenElse f g f)),
  ("hook", Modifier2 hook),
  ("pair", Modifier2 (\f g -> hook (compose2 fsPair f) g)),
  ("over", Modifier2 over),
  ("while", Modifier2 (\f g -> compose2 (fsTakeWhile g) (fsIterate f))),
  ("until", Modifier2 (\f g -> compose2 (fsTakeWhile $ compose2 fsFalsey g) (fsIterate f))),
 -- 3-modifiers
  ("compose3", Modifier3 compose3),
  ("rcompose3", Modifier3 rcompose3),
  ("if", Modifier3 ifThenElse),
  ("fork", Modifier3 (\f g h -> hook (compose2 f g) h)),
  ("branch", Modifier3 (\f g h -> rcompose2 (compose2 f g) h)),
 -- 4-modifiers
  ("compose4", Modifier4 compose4)
  ]


--- STACK COMMANDS --

stackCommands :: Map.Map String (Stack -> Stack)
stackCommands = Map.fromList [
  ("!dup", (\s -> head s : s)),
  ("!swap", (\s -> reverse (take 2 s) ++ drop 2 s)),
  ("!tuck", (\s -> take 2 s ++ head s : drop 2 s))
  ]


--- EXECUTION ---

emptyState :: [Value] -> State
emptyState args = State [] args

executeCommand :: Command -> State -> State
executeCommand (PushFn f) state@State{stack = stack} = state {stack = f : stack}
executeCommand (ModifyFn m) state@State{stack = stack} = state {stack = modify stack m}
executeCommand (StackCmd cmd) state@State{stack = stack} = state {stack = cmd stack}
executeCommand (BindArg i) state@State{arguments = arguments} = executeCommand (BindVal $ indexCycle arguments i) state
executeCommand (BindVal x) state@State{stack = [], arguments = arguments} =
  state {arguments = arguments ++ [x]}
executeCommand (BindVal x) state@State{stack = f : fs} =
  case (bind f x) of
    Constant y -> executeCommand (BindVal y) state {stack = fs}
    g -> state {stack = g : fs}

executeLine :: [Command] -> State -> [Value]
executeLine (c : cs) state = executeLine cs $ executeCommand c state
executeLine [] state@State{stack = stack, arguments = arguments}
  | null stack = arguments
  | otherwise =
      let combinedFn = composeAll $ reverse stack
      in [applyFully combinedFn arguments]

execute :: [[Command]] -> [Value] -> [Value]
execute (topLine : _) arguments = executeLine topLine $ emptyState arguments


--- PARSING ---

specialValues = Map.fromList [
  ("\\t", Character 9),
  ("\\n", Character 10),
  ("\\s", Character 32),
  ("$A", List $ map Character [65..90]),
  ("$a", List $ map Character [97..122]),
  ("$Aa", List $ map Character $ [65..90] ++ [97..122]),
  ("$0", List $ map Character [48..57]),
  ("$P", List $ map Character [32..126]),
  ("#N", List $ map Number [0..]),
  ("#N+", List $ map Number [1..]),
  ("#Z", List $ map Number $ [1..] >>= (\n -> [1-n, n]))
  ]


toFunction :: String -> Maybe Function
toFunction s = Map.lookup s builtins

toModifier :: String -> Maybe Modifier
toModifier s = Map.lookup s modifiers

toStackCommand :: String -> Maybe (Stack -> Stack)
toStackCommand s = Map.lookup s stackCommands

toLiteral :: String -> Maybe Value
toLiteral s
  | Map.member s specialValues = Map.lookup s specialValues
  | ('\\' : n) <- s = Just $ Character $ read n
  | ('\'' : c : "'") <- s = Just $ Character $ charToInteger c
  | c == '"' = Just $ stringToVal $ read s
  | isDigit c || c == '-' = Just $ Number $ read s
  | otherwise = Nothing
  where c = head s


toCommand' :: String -> Maybe Command
toCommand' s
  | isUpper c = PushFn <$> toFunction s
  | isLower c = ModifyFn <$> toModifier s
  | c == '!' = StackCmd <$> toStackCommand s
  | c == '@' && and (map isDigit $ tail s) = Just $ BindArg $ read (tail s)
  | otherwise = BindVal <$> toLiteral s
  where c = head s

toCommand :: String -> Either String Command
toCommand s = maybeToEither ("While parsing, unrecognized token: " ++ s) (toCommand' s)


parseLine :: String -> Either String [Command]
parseLine s = mapM toCommand (words s)

parse :: String -> Either String [[Command]]
parse s = mapM parseLine (lines s)

parseArg :: String -> Either String Value
parseArg a = maybeToEither ("Could not parse argument " ++ a) (toLiteral a)

parseArgs :: [String] -> Either String [Value]
parseArgs = mapM parseArg


--- MAIN FUNCTION ---

runProgram' :: String -> [String] -> Either String String
runProgram' program args = do
  parsedProgram <- parse program
  parsedArgs <- parseArgs args
  return $ unlines $ map show $ execute parsedProgram parsedArgs

runProgram :: String -> [String] -> IO ()
runProgram program args = case runProgram' program args of
  Right result -> putStr result
  Left errMessage -> IO.hPutStrLn IO.stderr errMessage


main :: IO ()
main = do
  program <- getLine
  args <- Env.getArgs
  runProgram program args

symbols.txt

For the present, at least, borrow Husk's codepage.

»     Inc
«     Dec
_     Neg
a     Abs
±     Sign
D     Double
½     Halve
□     Square
⌐     Zero?
p     Positive?
n     Negative?
.     From0
      IFrom0
      From1
…     IFrom1
[     Wrap
←     Head
t     Tail
→     Last
h     Init
L     Length
↔     Reverse
¢     Cycle
Θ     ConsFalsey
ı     Indices
τ     TruthyIndices
      GroupIndices
ḣ     Prefixes
ṫ     Suffixes
ƒ     Flatten
O     Sort
u     Nub/Unique
Σ     Sum
Π     Product
V     Any?
Λ     All?
¶     Lines
s     Show
ς     Stringify
(spc) Id
+     Plus
-     Minus
×     Times
÷     IDiv
%     Mod
^     Pow
<     Less?
≤     LessEqual?
=     Equal?
≥     GreaterEqual?
>     Greater?
)     Range
]     IRange
B     ToBase
b     FromBase
e     Pair
:     Cons
◊     Concat
;     Consr
!     At
‼     AtCycle
↑     Take
Φ     TakeCycle
↓     Drop
ṙ     Rotate
X     Repeat
↕     Windows
Ï     Interleave
≡     Same?
ċ     Compare
K     Const
ė     Trio
ë     Quartet
~     flip
´     self/arity1
      arity2
      arity3
ρ     rotate
I     invariant
¬     not
m     map
M     mapl
Ṁ     mapr
μ     mapwindows
ṁ     flatmap
Ṫ     table
∟     selftable
f     filter
¡     iterate
Ẋ     fixiter
ẋ     fixpoint
Ẇ     takewhile
ẇ     dropwhile
      foldl1
F     foldl
      foldr1
Ḟ     foldr
G     scanl1
      scanl
Ġ     scanr1
      scanr
o     compose
·     rcompose
|     or
&     and
S     hook
,     pair
¤     over
¿     while
      until
ȯ     compose3
¨     rcompose3
?     if
§     fork
Ψ     branch
ö     compose4
ẏ     !dup
$     !swap
Ẏ     !tuck
ṅ     -1
ȷ     10
∞     1/0
Ø     0/0
Ȧ     $A
ȧ     $a
Ä     $Aa
Δ     $0
α     $P
N     #N
Ṅ     #N+
Z     #Z
ø     Empty list

⁰-⁹   Arguments
'     Character/string constants
¦     String literals
0-9   Digit literals
      Compressed numbers
      Compressed strings?

Plans for generalizing certain modifiers to work with any arity of function:

map takes a function of arity N to an arity-N function, mapping over corresponding elements from each of its arguments. (TBD: if argument is not a list, just use that argument every time?) (TBD: the default will trim to shortest length, but could there be a zip-longest version?)

> Inc map Trio 3 4 5
[4, 5, 6]
> Plus map Trio 3 4 5 "abc"
"dfh"
> Trio map Pair 1 2 '_' "abc"
[[1, '_', 'a'], [2, '_', 'b']]  (?)

mapslices takes a function of arity N to an arity-1 function, mapping over all length-N sublists of its argument. (If given an arity-1 function, perhaps it wraps each element in a list before applying the function? It wouldn't be the correct analogy to what higher-arity functions do, but the correct analogy would be identical to every other map modifier.)

> Plus mapslices Trio 3 4 5
[7, 9]
> Trio mapslices #N
[[0, 1, 2], [1, 2, 3], [2, 3, 4], ...]
> Inc mapslices Trio 3 4 5
[[4], [5], [6]]

lmap takes a function of arity N to an arity-N function, mapping over the leftmost argument; rmap does the same thing for the rightmost argument. (If given an arity-1 function, perhaps they pair the result of the function with the original argument? I.e. F lmap ≡ Pair F lhook map and F rmap ≡ Pair F rhook map?)

> Cons lmap Trio 3 4 5 Pair 6 7
[[3, 6, 7], [4, 6, 7], [5, 6, 7]]
> Trio rmap "ab" "cd" "ef"
[["ab", "cd", 'e'], ["ab", "cd", 'f']]
> Double rmap Trio 3 4 5
[[3, 6], [4, 8], [5, 10]]

iterate takes a function of arity N to an arity-N function, which returns an infinite sequence starting with its arguments and continuing with the result of calling the function on the previous N elements of the sequence.

> Plus 2 iterate 5
[5, 7, 9, 11, ...]
> Plus iterate 0 1
[0, 1, 1, 2, 3, 5, ...]
> Plus Reverse hook Cons 0 compose iterate Wrap 1
[[1], [1, 1], [1, 2, 1], [1, 3, 3, 1], ...]

GroupIndices doesn't work quite how I want it to yet... Either it should be like BQN and require the elements to be nonnegative integers so it can position the buckets at indices corresponding to their "labels," or it should order the buckets by the first occurrence of their labels in the original list. Right now, it only creates a bucket if it's nonempty, and it orders them by the compare ordering of their labels.