module DSL.Intrinsics where

import DSL.Types
import DSL.Util

dump :: StackModifier
dump = StackModifier { smName="DUMP", smTypes=ts, smFunc=f }
  where
    ts = [tAny]
    f (x:xs) = putStrLn x' >> return xs
      where
        x' = case x of
          StackString s -> s
          _             -> show x
    f _      = unreachable

drop' :: StackModifier
drop' = StackModifier { smName="DROP", smTypes=ts, smFunc=f }
  where
    ts = [tAny]
    f (_:xs) = return xs
    f _      = unreachable

swap :: StackModifier
swap = StackModifier { smName="SWAP", smTypes=ts, smFunc=f }
  where
    ts = [tAny, tAny]
    f (x:y:xs) = return $ y:x:xs
    f _        = unreachable

dup :: StackModifier
dup = StackModifier { smName="DUP", smTypes=ts, smFunc=f }
  where
    ts = [tAny]
    f (x:xs) = return $ x:x:xs
    f _      = unreachable

over :: StackModifier
over = StackModifier { smName="OVER", smTypes=ts, smFunc=f }
  where
    ts = [tAny, tAny]
    f (x:y:xs) = return $ y:x:y:xs
    f _        = unreachable

rot :: StackModifier
rot = StackModifier { smName="ROT", smTypes=ts, smFunc=f }
  where
    ts = [tAny, tAny, tAny]
    f (x:y:z:xs) = return $ y:z:x:xs
    f _          = unreachable

binArithmetic :: String -> (Integer -> Integer -> [Integer]) -> StackModifier
binArithmetic name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
  where
    ts = [tInt, tInt]
    f' (StackInt x:StackInt y:xs) = return $ (StackInt <$> f x y) ++ xs
    f' _                          = unreachable

plus :: StackModifier
plus = binArithmetic "PLUS" $ \ x y -> [x + y]

minus :: StackModifier
minus = binArithmetic "MINUS" $ \ x y -> [x - y]

times :: StackModifier
times = binArithmetic "TIMES" $ \ x y -> [x * y]

divMod' :: StackModifier
divMod' = binArithmetic "DIVMOD" $ \ x y -> [mod x y, div x y]

not' :: StackModifier
not' = StackModifier { smName="NOT", smTypes=ts, smFunc=f }
  where
    ts = [tBool]
    f (StackBool x:xs) = return $ StackBool (not x):xs
    f _                = unreachable

binBoolean :: String -> (Bool -> Bool -> [Bool]) -> StackModifier
binBoolean name f = StackModifier { smName=name, smTypes=ts, smFunc=f' }
  where
    ts = [tBool, tBool]
    f' (StackBool x:StackBool y:xs) = return $ (StackBool <$> f x y) ++ xs
    f' _                            = unreachable

and' :: StackModifier
and' = binBoolean "AND" $ \ x y -> [x && y]

or' :: StackModifier
or' = binBoolean "OR" $ \ x y -> [x || y]

xor :: StackModifier
xor = binBoolean "XOR" $ \ x y -> [x /= y]

equal :: StackModifier
equal = StackModifier { smName="EQUAL", smTypes=ts, smFunc=f }
  where
    ts = [tAny, tAny]
    f (x:y:xs) = return $ StackBool (x == y):xs
    f _        = unreachable

lessThan :: StackModifier
lessThan = StackModifier { smName="LESSTHAN", smTypes=ts, smFunc=f }
  where
    ts = [tInt, tInt]
    f (StackInt x:StackInt y:xs) = return $ StackBool(x < y):xs
    f _                          = unreachable

greaterThan :: StackModifier
greaterThan = StackModifier { smName="GREATERTHAN", smTypes=ts, smFunc=f }
  where
    ts = [tInt, tInt]
    f (StackInt x:StackInt y:xs) = return $ StackBool(x > y):xs
    f _                          = unreachable