{-# OPTIONS -fglasgow-exts -fallow-overlapping-instances -fallow-undecidable-instances #-}

module Dictionary where

import TestMonad
import ADT
import Java

import qualified Debug.QuickCheck as Q
import Data.Maybe
import Control.Monad

-- Types ------------------------------------------------------------------

t_Key	= mkType "TString"
t_Value	= mkType "TInteger"

t_Comparator = Type
    { printType		= error "Cannot return Comparator"
    , validityChecks	= ["($s).equals(\"reverse\")"]
    , parseType		= jStatement "Comparator $x = new ReverseComparator()"
    , typeName		= "Comparator"
    , getClass		= "Comparator.class"
    , toObject		= id
    }

-- The Dictionary ADT -----------------------------------------------------

dictionaryADT :: ADT (DictADT String Int)
dictionaryADT = ADT
    { adtName	    = "SortedDictionary"
    , namePrefix    = "dict"
    , imports	    = ["java.util.Comparator", "java.util.Iterator"]
    , constructors  =	[ mkConstructor []		gNewVoid
			, mkConstructor [t_Comparator]	gNewComparator
			]
    , methods	    =
	[ mkMethod "size"	    t_int	[]		    gSize
	, mkMethod "isEmpty"	    t_boolean	[]		    gIsEmpty
	, mkMethod "elements"	    t_Iterator	[]		    gElements
	, mkMethod "keys"	    t_Iterator	[]		    gKeys
	, mkMethod "containsKey"    t_boolean	[t_Key]		    gContainsKey
	, mkMethod "findElement"    t_Value	[t_Key]		    gFindElement
	, mkMethod "insertItem"	    t_void	[t_Key, t_Value]    gInsertItem
	, mkMethod "removeElement"  t_Value	[t_Key]		    gRemoveElement
	, mkMethod "clear"	    t_void	[]		    gClear
	]
--    , methodDistr	= frequencyDistribution [ 3, 2, 4, 4, 3, 5, 10, 2, 1 ]
    , methodDistr	= frequencyDistribution [ 0, 2, 0, 0, 3, 5, 10, 2, 1 ]
    , constructorFreqs	= [ 1, 1 ]
    }

-- Generators -------------------------------------------------------------

maybeException _ "java.util.NoSuchElementException()"	= return Nothing
maybeException _ "NoSuchElementException()"		= return Nothing
maybeException r s					= r s >>= return . Just

gNewVoid	=   methodCallGen0 cNew		    return
gNewComparator	=   methodCallGen1 cNewReverse	    return		    (return "reverse")
gSize		=   methodCallGen0 cSize	    readN
gIsEmpty	=   methodCallGen0 cIsEmpty	    readB
gElements	=   methodCallGen0 cElements	    readNs
gKeys		=   methodCallGen0 cKeys	    readSs
gClear		= optionalMCall $
		    methodCallGen0 cClear	    return
gContainsKey	=   methodCallGen1 cContainsKey	    readB		    keyGen
gFindElement	=   methodCallGen1 cFindElement	    (maybeException readN)  keyGen
gInsertItem	=   methodCallGen2 cInsertItem	    return		    keyGen valGen
gRemoveElement	= optionalMCall $
		    methodCallGen1 cRemoveElement   (maybeException readN)  keyGen

keyGenR :: Float -> Q.Gen String
keyGenR r = Q.sized $ \n -> Q.elements $ take (count n) keyNames
    where
	count n = case ceiling $ fromIntegral n * r of
			0   -> 1
			c   -> c

keyGen = keyGenR 0.2

valGen :: Q.Gen Int
valGen = Q.sized $ \sz -> do
	n <- Q.arbitrary
	return $ n + sz

sizeGen :: Q.Gen Int
sizeGen = liftM abs Q.arbitrary

-- Dictionary types -------------------------------------------------------

type Dict a b	    = [(a,b)]
type Comparator a   = a -> a -> Bool
type DictADT a b    = (Dict a b, Comparator a)

type Test a b	= TestM (DictADT a b)
type Key	= String
type Value	= Int
type T		= Test Key Value

{-
instance Show (DictADT Key Value) where
    show (d,(<))
	| "a" < "b" = show d
	| otherwise = 'r':show d
-}
-- Dictionary implementation ----------------------------------------------

foldDict :: (Dict a b -> c) ->
	    ((a,b) -> c -> c) ->
	    ((a,b) -> Dict a b -> c) ->
	    a -> DictADT a b -> c
foldDict less upd eq key ((k,v):d, (<))
    | k < key	= upd (k,v) $ foldDict less upd eq key (d,(<))
    | key < k	= less $ (k,v):d
    | otherwise	= eq (k,v) d
foldDict less _ _ _ _ = less []

new :: Ord a => DictADT a b
new = ([], (<))

newReverse :: Ord a => DictADT a b
newReverse = ([], (>))

size :: DictADT a b -> Int
size = length . fst

isEmpty :: DictADT a b -> Bool
isEmpty = null . fst

elements :: DictADT a b -> [b]
elements = map snd . fst

keys :: DictADT a b -> [a]
keys = map fst . fst

containsKey :: a -> DictADT a b -> Bool
containsKey = foldDict (const False) (const id) (const $ const True)

findElement :: a -> DictADT a b -> Maybe b
findElement = foldDict (const Nothing) (const id) (\(_,v) _ -> Just v)

insertItem :: a -> b -> DictADT a b -> DictADT a b
insertItem key val d@(_,(<)) = (d', (<))
    where
--	d' = foldDict ((key,val):) (:) (\(k,_) d -> (k,val):d) key d
	d' = foldDict ((key,val):) (:) (\(k,v) d -> (key,val):(k,v):d) key d

removeElement :: a -> DictADT a b -> (Maybe b, DictADT a b)
removeElement key d@(_,(<)) = (mv, (d', (<)))
    where
	(mv,d') = foldDict  (\d		    -> (Nothing, d))
			    (\(k,v) (mv,d)  -> (mv,(k,v):d))
			    (\(_,v) d	    -> (Just v, d))
			    key d

clear :: DictADT a b -> DictADT a b
clear (_, c) = ([], c)

-- Dictionary testing functions -------------------------------------------

cNew		    = cConstructor				new
cNewReverse _	    = cConstructor				newReverse
cSize		    = cPureMethod	    "size"		size
cIsEmpty	    = cPureMethod	    "isEmpty"		isEmpty
cElements	    = cPureMethod	    "elements"		elements
cKeys		    = cPureMethod	    "keys"		keys
cContainsKey k	    = cPureMethod	    "containsKey"   $	containsKey k
cFindElement k	    = cPureMethod	    "findElement"   $	findElement k
cInsertItem k v	    = cVoidMethod	    "insertItem"    $	insertItem k v
cRemoveElement k    = cImpureMethod	    "removeElement" $	removeElement k
cClear		    = cVoidMethod	    "clear"		clear

keyNames :: [String]
keyNames =
	["suspected", "absolutely", "listening", "movements", "gather", "described", 
	"correct", "points", "complicated", "explanation", "reasonable", "hammering", 
	"escape", "struggle", "tried", "produced", "bringing", "meaning", "layman", 
	"theory", "regarded", "brotherly", "meeting", "solicitor", "unofficial", 
	"consults", "shrug", "does", "voices", "roberts", "werent", "shouted", 
	"banged", "finally", "refer", "crossed", "communicate", "addresses", 
	"objection", "suggested", "interrupt", "permission", "servants", "oclock", 
	"blackmail", "violence", "outcome", "interview", "unpleasant", "apprehension", 
	"disgust", "annoyance", "attitude", "postmark", "copied", "thereabouts", 
	"pleasure", "hope", "conceal", "able", "loving", "dirty", "sheet", "showed", 
	"hands", "spent", "anybodys", "fault", "boys", "theyd", "unduly", "unfair", 
	"opinion", "answered", "times", "occasionally", "ashamed", "convenient", 
	"wicked", "inconvenient", "twelve", "disgrace", "attentively", "pencil", 
	"sharpen", "ah", "notebook", "interested", "prepared", "armchair", "seated", 
	"spare", "genially", "wheres", "interest", "sorted", "facts", "inquiringly", 
	"birch", "wait", "latter", "entered", "dramatically", "bowed", "mouthpiece", 
	"handy", "forgive", "telegraphing", "telephoning", "regard", "orders", "alone", 
	"everyone", "nowhere", "week", "happening", "meek", "safely", "unwaveringly", 
	"hard", "anyway", "deeply", "arrange", "dust", "shake", "shall", "mistress"]