language-lua2-0.1.0.3: test/Instances.hs

{-# LANGUAGE CPP             #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Instances where

import Language.Lua.Syntax

import           Control.Applicative
import           Data.Char                  (isAsciiLower, isAsciiUpper, isDigit)
import           Data.HashSet               (HashSet)
import qualified Data.HashSet               as HS
import           Data.List.NonEmpty         (NonEmpty)
import qualified Data.List.NonEmpty         as NE
import           Test.QuickCheck.Arbitrary
import           Test.QuickCheck.Gen

#if !MIN_VERSION_base(4,8,0)
import Data.Typeable (Typeable)
type C a = (Arbitrary a, Typeable a)
#else
type C a = Arbitrary a
#endif

instance C a => Arbitrary (Ident a) where
    arbitrary = Ident <$> arbitrary <*> genIdent
      where
        genIdent :: Gen String
        genIdent = liftA2 (:) first rest `suchThat` \s -> not (HS.member s keywords)
          where
            first :: Gen Char
            first = frequency [(5, pure '_'), (95, arbitrary `suchThat` isAsciiLetter)]

            rest :: Gen String
            rest = listOf $
                frequency [ (10, pure '_')
                          , (45, arbitrary `suchThat` isAsciiLetter)
                          , (45, arbitrary `suchThat` isDigit)
                          ]

            -- Meh, forget unicode for now.
            isAsciiLetter :: Char -> Bool
            isAsciiLetter c = isAsciiLower c || isAsciiUpper c

        keywords :: HashSet String
        keywords = HS.fromList
            [ "and", "break", "do", "else", "elseif", "end", "false"
            , "for", "function", "goto", "if", "in", "local", "nil"
            , "not", "or", "repeat", "return", "then", "true", "until", "while"
            ]

instance C a => Arbitrary (IdentList a) where
    arbitrary = IdentList <$> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (IdentList1 a) where
    arbitrary = IdentList1 <$> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (Block a) where
    arbitrary = Block <$> arbitrary <*> listOf1 arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (Statement a) where
    arbitrary = oneof
        [ EmptyStmt      <$> arbitrary
        , Assign         <$> arbitrary <*> arbitrary <*> arbitrary
        , FunCall        <$> arbitrary <*> arbitrary
        , Label          <$> arbitrary <*> arbitrary
        , Break          <$> arbitrary
        , Goto           <$> arbitrary <*> arbitrary
        , Do             <$> arbitrary <*> arbitrary
        , While          <$> arbitrary <*> arbitrary <*> arbitrary
        , Repeat         <$> arbitrary <*> arbitrary <*> arbitrary
        , If             <$> arbitrary <*> arbitrary <*> arbitrary
        , For            <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
        , ForIn          <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
        , FunAssign      <$> arbitrary <*> arbitrary <*> arbitrary
        , LocalFunAssign <$> arbitrary <*> arbitrary <*> arbitrary
        , LocalAssign    <$> arbitrary <*> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (ReturnStatement a) where
    arbitrary = ReturnStatement <$> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (FunctionName a) where
    arbitrary = FunctionName <$> arbitrary <*> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (Variable a) where
    arbitrary = oneof
        [ VarIdent     <$> arbitrary <*> arbitrary
        , VarField     <$> arbitrary <*> arbitrary <*> arbitrary
        , VarFieldName <$> arbitrary <*> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (VariableList1 a) where
    arbitrary = VariableList1 <$> arbitrary <*> arbitrary

instance C a => Arbitrary (Expression a) where
    arbitrary = oneof
        [ Nil       <$> arbitrary
        , Bool      <$> arbitrary <*> arbitrary
        , Integer   <$> arbitrary <*> (show <$> (arbitrary :: Gen Int)) -- TODO: Make these better
        , Float     <$> arbitrary <*> (show <$> (arbitrary :: Gen Float))
        , String    <$> arbitrary <*> arbitrary
        , Vararg    <$> arbitrary
        , FunDef    <$> arbitrary <*> arbitrary
        , PrefixExp <$> arbitrary <*> arbitrary
        , TableCtor <$> arbitrary <*> arbitrary
        , Binop     <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
        , Unop      <$> arbitrary <*> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (ExpressionList a) where
    arbitrary = ExpressionList <$> arbitrary <*> arbitrary

instance C a => Arbitrary (ExpressionList1 a) where
    arbitrary = ExpressionList1 <$> arbitrary <*> arbitrary

instance C a => Arbitrary (PrefixExpression a) where
    arbitrary = oneof
        [ PrefixVar     <$> arbitrary <*> arbitrary
        , PrefixFunCall <$> arbitrary <*> arbitrary
        , Parens        <$> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (FunctionCall a) where
    arbitrary = oneof
        [ FunctionCall <$> arbitrary <*> arbitrary <*> arbitrary
        , MethodCall   <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (FunctionArgs a) where
    arbitrary = oneof
        [ Args       <$> arbitrary <*> arbitrary
        , ArgsTable  <$> arbitrary <*> arbitrary
        , ArgsString <$> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (FunctionBody a) where
    arbitrary = FunctionBody <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (TableConstructor a) where
    arbitrary = TableConstructor <$> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (Field a) where
    arbitrary = oneof
        [ FieldExp   <$> arbitrary <*> arbitrary <*> arbitrary
        , FieldIdent <$> arbitrary <*> arbitrary <*> arbitrary
        , Field      <$> arbitrary <*> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (FieldList a) where
    arbitrary = FieldList <$> arbitrary <*> arbitrary
    shrink = genericShrink

instance C a => Arbitrary (Binop a) where
    arbitrary = oneof
        [ Plus       <$> arbitrary
        , Minus      <$> arbitrary
        , Mult       <$> arbitrary
        , FloatDiv   <$> arbitrary
        , FloorDiv   <$> arbitrary
        , Exponent   <$> arbitrary
        , Modulo     <$> arbitrary
        , BitwiseAnd <$> arbitrary
        , BitwiseXor <$> arbitrary
        , BitwiseOr  <$> arbitrary
        , Rshift     <$> arbitrary
        , Lshift     <$> arbitrary
        , Concat     <$> arbitrary
        , Lt         <$> arbitrary
        , Leq        <$> arbitrary
        , Gt         <$> arbitrary
        , Geq        <$> arbitrary
        , Eq         <$> arbitrary
        , Neq        <$> arbitrary
        , And        <$> arbitrary
        , Or         <$> arbitrary
        ]

    shrink = genericShrink

instance C a => Arbitrary (Unop a) where
    arbitrary = oneof
        [ Negate     <$> arbitrary
        , Not        <$> arbitrary
        , Length     <$> arbitrary
        , BitwiseNot <$> arbitrary
        ]

    shrink = genericShrink

-- Orphans

instance Arbitrary a => Arbitrary (NonEmpty a) where
    arbitrary = NE.fromList <$> listOf1 arbitrary