Skip to content

Commit

Permalink
Merge branch 'length-operator'
Browse files Browse the repository at this point in the history
  • Loading branch information
@bananu7
bananu7 committed Jul 26, 2018
2 parents 193c771 + 8b1d75c commit ce3c29d
Show file tree
Hide file tree
Showing 6 changed files with 106 additions and 29 deletions.
26 changes: 21 additions & 5 deletions Test/TestEval.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,6 +38,17 @@ spec = do
it "<" $ runParse "return 1 < 2, 2 < 1, 1 < 1" `shouldBe` (map Boolean [True, False, False])
it "concat (..)" $ runParse "return \"abc\" .. \"def\"" `shouldBe` [Str "abcdef"]

describe "length operator" $ do
describe "tables" $ do
it "empty table literal" $ runParse "return #{}" `shouldBe` [Number 0.0]
it "simple table literal" $ runParse "return #{1,2,3}" `shouldBe` [Number 3.0]
it "table in a variable" $ runParse "x = {1,2}; return #x" `shouldBe` [Number 2.0]
it "table with mixed keys" $ runParse "t = {1, a=2, 3}; return #t" `shouldBe` [Number 2.0]
it "table with holes" $ runParse "t = {[1]=1, [3]=2, [4]=3}; return #t" `shouldSatisfy` (\[Number i] -> i `elem` [1.0, 4.0])
describe "strings" $ do
it "empty string literal" $ runParse "return #\"\"" `shouldBe` [Number 0.0]
it "simple string literal" $ runParse "return #\"abc\"" `shouldBe` [Number 3.0]

describe "equality" $ do
it "numbers" $ runParse "return 1 == 1, 1 == -1, 1 == 2, 2 == 1"
`shouldBe` (map Boolean [True, False, False, False])
Expand Down Expand Up @@ -423,14 +434,19 @@ spec = do
,"return t / 2"
]) `shouldBe` [Number 21.0]

{-
it "should allow setting __concat metafunction" $
it "should allow setting the __concat metafunction" $
runParse (unlines [
"t = { x = \"456\" }"
,"setmetatable(t, { __concat = function(a,b) return a .. b.x })"
,"setmetatable(t, { __concat = function(a,b) return a .. b.x end })"
,"return \"123\" .. t"
]) `shouldBe` [Boolean True]
-}
]) `shouldBe` [Str "123456"]

it "should allow setting __len metafunction" $
runParse (unlines [
"t = { x = 42 }"
,"setmetatable(t, { __len = function(a) return a.x end })"
,"return #t"
]) `shouldBe` [Number 42.0]

describe "metatable comparators" $ do
it "should allow setting the __lt metafunction" $
Expand Down
34 changes: 32 additions & 2 deletions Test/TestParser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,9 @@ successful (Left err) = error $ show err

parse = successful . parseLua

-- helper for string literals, assumes 1-liners
pos = newPos "" 1

spec :: Spec
spec = do
describe "Parser.parseLua" $ do
Expand All @@ -22,6 +25,20 @@ spec = do
parse "return -2.9" `shouldBe` Block [Return [UnOp "-" (Number 2.9)]]
it "should parse strings" $ parse "return \"test\"" `shouldSatisfy` (\(Block [Return [StringLiteral _ s]]) -> s == "test")

describe "tables" $ do
it "empty table literal" $ parse "return {}" `shouldBe` Block [Return [TableCons []]]
it "table literal without keys" $
parse "return {1, nil, x}" `shouldBe` Block [Return [TableCons [(Nothing, Number 1.0), (Nothing, Nil), (Nothing, Var "x")]]]
it "table literal with keys" $
parse "return {x = 42}" `shouldBe` Block [Return [TableCons [(Just $ StringLiteral (pos 9) "x", Number 42.0)]]]
it "table literal with expression keys" $
parse "return {[1] = 1, [x] = x, [\"a space\"] = false}" `shouldBe`
Block [Return [TableCons [
(Just $ Number 1.0, Number 1.0),
(Just $ Var "x", Var "x"),
(Just $ StringLiteral (pos 28) "a space", Bool False)
]]]

describe "should parse simple assignments" $ do
it "a number to a variable" $
parse "x = 5" `shouldBe` (Block [Assignment [LVar "x"] [Number 5.0]])
Expand All @@ -32,6 +49,19 @@ spec = do
it "a lambda function to a variable" $
parse "f = function() end" `shouldBe` Block [Assignment [LVar "f"] [Lambda [] False $ Block []]]

describe "should parse length operator" $ do
it "on string literal (#\"abc\"" $
parse "return #\"abc\"" `shouldBe` Block [Return [UnOp "#" (StringLiteral (pos 9) "abc")]]
it "on variables" $
parse "return #x" `shouldBe` Block [Return [UnOp "#" (Var "x")]]
it "on table literals" $
parse "return #{1,2,3}" `shouldBe` Block [Return [UnOp "#" (TableCons [(Nothing, Number 1.0), (Nothing, Number 2.0), (Nothing, Number 3.0)])]]
it "on function calls" $ do
parse "return #f()" `shouldBe` Block [Return [UnOp "#" (Call (Var "f") [])]]
parse "return #f.g()" `shouldBe` Block [Return [UnOp "#" (Call (FieldRef (Var "f") (StringLiteral (pos 11) "g")) [])]]
it "mixed with concat" $
parse "return #x..y" `shouldBe` Block [Return [BinOp ".." (UnOp "#" (Var "x")) (Var "y")]]

describe "should parse multiple assignments" $ do
it "equal arity of lhs and rhs" $
parse "x,y=1,2" `shouldBe` (Block [Assignment [LVar "x", LVar "y"] [Number 1.0, Number 2.0]])
Expand Down Expand Up @@ -63,8 +93,8 @@ spec = do
it "simple usage" $ parse "return a .. b" `shouldBe` (Block [Return [BinOp ".." (Var "a") (Var "b")]])
it "mixed with other dots" $ parse "return a.x..b.y" `shouldBe`
(Block [Return [BinOp ".."
(FieldRef (Var "a") (StringLiteral (newPos "" 1 10) "x"))
(FieldRef (Var "b") (StringLiteral (newPos "" 1 15) "y"))
(FieldRef (Var "a") (StringLiteral (pos 10) "x"))
(FieldRef (Var "b") (StringLiteral (pos 15) "y"))
]])
it "associativity" $ parse "return a .. b .. c" `shouldBe`
(Block [Return [BinOp ".." (Var "a") (BinOp ".." (Var "b") (Var "c"))]])
Expand Down
27 changes: 25 additions & 2 deletions src/Turnip/Eval/Lib.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,9 +10,11 @@ import Turnip.Eval.Util
import Turnip.Eval.Eval (callRef)
import Turnip.Eval.Metatables
import Control.Monad.Except
import Control.Lens ((^.), at)
import Data.Map (lookupMax)
import Data.Maybe (isJust)

-- math helpers
deg :: Floating a => a -> a
deg x = x / pi * 180

$(do
Expand Down Expand Up @@ -47,6 +49,7 @@ luaCmpEQ (a : b : _)
| otherwise = luaEQHelper a b
luaCmpEQ _ = throwErrorStr "Comparison requires at least two values"

luaEQHelper :: Value -> Value -> LuaM [Value]
luaEQHelper a b = do
maybeEqA <- getMetaFunction "__eq" a
maybeEqB <- getMetaFunction "__eq" b
Expand All @@ -60,7 +63,7 @@ luaCmpGT :: NativeFunction
luaCmpGT (Number a : Number b : _) = return [Boolean $ a > b]
luaCmpGT (Str a : Str b : _) = return [Boolean $ a > b]
luaCmpGT (a : b : _) = luametaop "__lt" [b,a] -- order reversed
luaCmpGT xs = throwErrorStr "Can't compare those values"
luaCmpGT _ = throwErrorStr "Can't compare those values"

luaCmpLT :: NativeFunction
luaCmpLT (Number a : Number b : _) = return [Boolean $ a < b]
Expand Down Expand Up @@ -163,22 +166,42 @@ luadiv _ = throwErrorStr "Div operator needs at least two values"
luaminus :: NativeFunction
luaminus (Number a : []) = return $ [Number (-a)] --unary negate
luaminus (a : []) = luametaop "__unm" [a]
luaminus [] = throwErrorStr "Minus operator called on 0 arguments"

luaminus (Number a : Number b : _) = return $ [Number (a - b)]
luaminus (a : b : _) = luametaop "__sub" [a,b]
luaminus _ = throwErrorStr "Can't subtract those things"

luaconcat :: NativeFunction
luaconcat (Str a : Str b : _) = return [Str $ a ++ b]
luaconcat (a : b : _) = luametaop "__concat" [a,b]
luaconcat _ = throwErrorStr "Concat operator needs at least two values"

lualen :: NativeFunction
lualen (Str a : _) = return [Number . fromIntegral $ length a]
lualen (Table tr : _) = do
hasMetaLen <- isJust <$> getMetaFunction "__len" (Table tr)
if hasMetaLen
then luametaop "__len" [Table tr]
else do
(TableData td _) <- getTableData tr
case lookupMax td of
Just (Number x, _) -> return [Number x]
_ -> return [Number 0]

lualen (Nil : _) = throwErrorStr "Attempt to get length of a nil value"
lualen (a : _) = luametaop "__len" [a]
lualen [] = throwErrorStr "Length operator called on 0 arguments"

loadBaseLibrary :: LuaM ()
loadBaseLibrary = do
loadBaseLibraryGen
addNativeFunction "==" (BuiltinFunction luaCmpEQ)
addNativeFunction ">" (BuiltinFunction luaCmpGT)
addNativeFunction "<" (BuiltinFunction luaCmpLT)

addNativeFunction "#" (BuiltinFunction lualen)

addNativeFunction "-" (BuiltinFunction luaminus)
addNativeFunction "+" (BuiltinFunction luaplus)
addNativeFunction "*" (BuiltinFunction luamult)
Expand Down
1 change: 0 additions & 1 deletion src/Turnip/Eval/TH.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@ import Language.Haskell.TH

import Control.Applicative
import Control.Monad
import Data.Typeable
import Data.Char

-- |Function signature has n params and one return value
Expand Down
4 changes: 2 additions & 2 deletions src/Turnip/Eval/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -36,12 +36,12 @@ instance MonadTrans LuaMT where
type LuaM a = forall m. Monad m => LuaMT m a

data Value where {
Nil :: Value;
Table :: TableRef -> Value;
Function :: FunctionRef -> Value;
Str :: String -> Value;
Number :: Double -> Value;
Boolean :: Bool -> Value;
Nil :: Value;
Number :: Double -> Value;
} deriving (Ord, Eq, Show)

-- I don't think it's supposed to be an existential
Expand Down
43 changes: 26 additions & 17 deletions src/Turnip/Parser.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -342,23 +342,32 @@ exp_exp = choice [
expr :: Parser Expr
expr = buildExpressionParser optable exp_exp

optable = [ [Infix (reservedOp "^" >> return (BinOp "^")) AssocRight ]
, [Prefix (reservedOp "-" >> return (UnOp "-")) ]
, [Infix (reservedOp "*" >> return (BinOp "*")) AssocLeft]
, [Infix (reservedOp "/" >> return (BinOp "/")) AssocLeft]
, [Infix (reservedOp "%" >> return (BinOp "%" )) AssocLeft]
, [Infix (reservedOp "+" >> return (BinOp "+")) AssocLeft]
, [Infix (reservedOp "-" >> return (BinOp "-")) AssocLeft]
, [Infix (reservedOp ".." >> return (BinOp "..")) AssocRight]
, [Infix (reservedOp "<" >> return (BinOp "<" )) AssocLeft]
, [Infix (reservedOp ">" >> return (BinOp ">" )) AssocLeft]
, [Infix (reservedOp "<=" >> return (BinOp "<=")) AssocLeft]
, [Infix (reservedOp ">=" >> return (BinOp ">=")) AssocLeft]
, [Infix (reservedOp "~=" >> return (BinOp "~=")) AssocLeft]
, [Infix (reservedOp "==" >> return (BinOp "==")) AssocLeft]
, [Infix (reservedOp "and" >> return (BinOp "and")) AssocLeft]
, [Infix (reservedOp "or" >> return (BinOp "or")) AssocLeft]
, [Prefix (reservedOp "not" >> return (UnOp "not"))]
optable = [ [ Infix (reservedOp "^" >> return (BinOp "^")) AssocRight
]
, [ Prefix (reservedOp "not" >> return (UnOp "not"))
, Prefix (reservedOp "#" >> return (UnOp "#"))
, Prefix (reservedOp "-" >> return (UnOp "-"))
]
, [ Infix (reservedOp "*" >> return (BinOp "*")) AssocLeft
, Infix (reservedOp "/" >> return (BinOp "/")) AssocLeft
, Infix (reservedOp "%" >> return (BinOp "%" )) AssocLeft
]
, [ Infix (reservedOp "+" >> return (BinOp "+")) AssocLeft
, Infix (reservedOp "-" >> return (BinOp "-")) AssocLeft
]
, [ Infix (reservedOp ".." >> return (BinOp "..")) AssocRight
]
, [ Infix (reservedOp "<=" >> return (BinOp "<=")) AssocLeft
, Infix (reservedOp ">=" >> return (BinOp ">=")) AssocLeft
, Infix (reservedOp "~=" >> return (BinOp "~=")) AssocLeft
, Infix (reservedOp "==" >> return (BinOp "==")) AssocLeft
, Infix (reservedOp "<" >> return (BinOp "<" )) AssocLeft
, Infix (reservedOp ">" >> return (BinOp ">" )) AssocLeft
]
, [ Infix (reservedOp "and" >> return (BinOp "and")) AssocLeft
]
, [ Infix (reservedOp "or" >> return (BinOp "or")) AssocLeft
]
]
--------------------------------------------
-- The Lexer
Expand Down

0 comments on commit ce3c29d

Please sign in to comment.