{-# LANGUAGE TypeFamilies #-}

module Drasil.GOOL.InterfaceGOOL (
  -- Types
  GSProgram, SFile, FSModule, SClass, CSStateVar, Initializers,
  -- Typeclasses
  OOProg, ProgramSym(..), FileSym(..), ModuleSym(..), ClassSym(..),
  OOTypeSym(..), OOVariableSym(..), staticVar, staticConst, ($->), OOValueSym,
  OOVariableValue, OOValueExpression(..), selfFuncApp, newObj, extNewObj,
  libNewObj, OODeclStatement(..), objDecNewNoParams, extObjDecNewNoParams,
  OOFuncAppStatement(..), GetSet(..), InternalValueExp(..), objMethodCall,
  objMethodCallNamedArgs, objMethodCallMixedArgs, objMethodCallNoParams,
  OOMethodSym(..), privMethod, pubMethod, initializer, nonInitConstructor,
  StateVarSym(..), privDVar, pubDVar, pubSVar, PermanenceSym(..),
  OOFunctionSym(..), ($.), selfAccess, ObserverPattern(..), observerListName,
  initObserverList, addObserver, StrategyPattern(..), convTypeOO
  ) where

import Drasil.GOOL.InterfaceCommon (
  -- Types
  Label, Library, MSBody, MSBlock, VSFunction, VSType, SVariable, SValue,
  MSStatement, NamedArgs, MSParameter, SMethod, MixedCall, MixedCtorCall,
  PosCall, PosCtorCall, InOutCall, InOutFunc, DocInOutFunc,
  -- Typeclasses
  SharedProg, BodySym(body), TypeSym(listType), FunctionSym, MethodSym,
  VariableSym(var), ScopeSym(..), ValueSym(valueType), VariableValue(valueOf),
  ValueExpression, List(listSize, listAdd), listOf, StatementSym(valStmt),
  DeclStatement(listDecDef), FuncAppStatement, VisibilitySym(..), convType)
import Drasil.GOOL.CodeType (CodeType(..), ClassName)
import Drasil.GOOL.Helpers (onStateValue)
import Drasil.GOOL.State (GS, FS, CS)

class (SharedProg r, ProgramSym r, OOVariableValue r, OODeclStatement r,
  OOFuncAppStatement r, OOValueExpression r, InternalValueExp r, GetSet r,
  ObserverPattern r, StrategyPattern r
  ) => OOProg r

type GSProgram a = GS (a (Program a))

class (FileSym r) => ProgramSym r where
  type Program r
  prog :: Label -> Label -> [SFile r] -> GSProgram r

type SFile a = FS (a (File a))

class (ModuleSym r) => FileSym r where 
  type File r
  fileDoc :: FSModule r -> SFile r

  -- Module description, list of author names, date as a String, file to comment
  docMod :: String -> [String] -> String -> SFile r -> SFile r

type FSModule a = FS (a (Module a))

class (ClassSym r) => ModuleSym r where
  type Module r
  -- Module name, import names, module functions, module classes
  buildModule :: Label -> [Label] -> [SMethod r] -> [SClass r] -> FSModule r

type SClass a = CS (a (Class a))

class (OOMethodSym r, StateVarSym r) => ClassSym r where
  type Class r
  -- | Main external method for creating a class.
  --   Inputs: parent class, variables, constructor(s), methods
  buildClass :: Maybe Label -> [CSStateVar r] -> [SMethod r] -> 
    [SMethod r] -> SClass r
  -- | Creates an extra class.
  --   Inputs: class name, the rest are the same as buildClass.
  extraClass :: Label -> Maybe Label -> [CSStateVar r] -> [SMethod r] -> 
    [SMethod r] -> SClass r
  -- | Creates a class implementing interfaces.
  --   Inputs: class name, interface names, variables, constructor(s), methods
  implementingClass :: Label -> [Label] -> [CSStateVar r] -> [SMethod r] -> 
    [SMethod r] -> SClass r

  docClass :: String -> SClass r -> SClass r

type Initializers r = [(SVariable r, SValue r)]

class (MethodSym r, PermanenceSym r) => OOMethodSym r where
  method      :: Label -> r (Visibility r) -> r (Permanence r) -> VSType r -> 
    [MSParameter r] -> MSBody r -> SMethod r
  getMethod   :: SVariable r -> SMethod r
  setMethod   :: SVariable r -> SMethod r 
  constructor :: [MSParameter r] -> Initializers r -> MSBody r -> SMethod r

  -- inOutMethod and docInOutMethod both need the Permanence parameter
  inOutMethod :: Label -> r (Visibility r) -> r (Permanence r) -> InOutFunc r
  docInOutMethod :: Label -> r (Visibility r) -> r (Permanence r) -> DocInOutFunc r

privMethod :: (OOMethodSym r) => Label -> VSType r -> [MSParameter r] -> MSBody r 
  -> SMethod r
privMethod :: forall (r :: * -> *).
OOMethodSym r =>
Label -> VSType r -> [MSParameter r] -> MSBody r -> SMethod r
privMethod Label
n = Label
-> r (Visibility r)
-> r (Permanence r)
-> StateT ValueState Identity (r (Type r))
-> [StateT MethodState Identity (r (Parameter r))]
-> StateT MethodState Identity (r (Body r))
-> StateT MethodState Identity (r (Method r))
forall (r :: * -> *).
OOMethodSym r =>
Label
-> r (Visibility r)
-> r (Permanence r)
-> VSType r
-> [MSParameter r]
-> MSBody r
-> SMethod r
method Label
n r (Visibility r)
forall (r :: * -> *). VisibilitySym r => r (Visibility r)
private r (Permanence r)
forall (r :: * -> *). PermanenceSym r => r (Permanence r)
dynamic

pubMethod :: (OOMethodSym r) => Label -> VSType r -> [MSParameter r] -> MSBody r 
  -> SMethod r
pubMethod :: forall (r :: * -> *).
OOMethodSym r =>
Label -> VSType r -> [MSParameter r] -> MSBody r -> SMethod r
pubMethod Label
n = Label
-> r (Visibility r)
-> r (Permanence r)
-> StateT ValueState Identity (r (Type r))
-> [StateT MethodState Identity (r (Parameter r))]
-> StateT MethodState Identity (r (Body r))
-> StateT MethodState Identity (r (Method r))
forall (r :: * -> *).
OOMethodSym r =>
Label
-> r (Visibility r)
-> r (Permanence r)
-> VSType r
-> [MSParameter r]
-> MSBody r
-> SMethod r
method Label
n r (Visibility r)
forall (r :: * -> *). VisibilitySym r => r (Visibility r)
public r (Permanence r)
forall (r :: * -> *). PermanenceSym r => r (Permanence r)
dynamic

initializer :: (OOMethodSym r) => [MSParameter r] -> Initializers r -> SMethod r
initializer :: forall (r :: * -> *).
OOMethodSym r =>
[MSParameter r] -> Initializers r -> SMethod r
initializer [MSParameter r]
ps Initializers r
is = [MSParameter r]
-> Initializers r
-> MSBody r
-> StateT MethodState Identity (r (Method r))
forall (r :: * -> *).
OOMethodSym r =>
[MSParameter r] -> Initializers r -> MSBody r -> SMethod r
constructor [MSParameter r]
ps Initializers r
is ([MSBlock r] -> MSBody r
forall (r :: * -> *). BodySym r => [MSBlock r] -> MSBody r
body [])

nonInitConstructor :: (OOMethodSym r) => [MSParameter r] -> MSBody r -> SMethod r
nonInitConstructor :: forall (r :: * -> *).
OOMethodSym r =>
[MSParameter r] -> MSBody r -> SMethod r
nonInitConstructor [MSParameter r]
ps = [MSParameter r]
-> Initializers r
-> StateT MethodState Identity (r (Body r))
-> StateT MethodState Identity (r (Method r))
forall (r :: * -> *).
OOMethodSym r =>
[MSParameter r] -> Initializers r -> MSBody r -> SMethod r
constructor [MSParameter r]
ps []

type CSStateVar a = CS (a (StateVar a))

class (VisibilitySym r, PermanenceSym r, VariableSym r) => StateVarSym r where
  type StateVar r
  stateVar :: r (Visibility r) -> r (Permanence r) -> SVariable r -> CSStateVar r
  stateVarDef :: r (Visibility r) -> r (Permanence r) -> SVariable r -> 
    SValue r -> CSStateVar r
  constVar :: r (Visibility r) ->  SVariable r -> SValue r -> CSStateVar r

privDVar :: (StateVarSym r) => SVariable r -> CSStateVar r
privDVar :: forall (r :: * -> *). StateVarSym r => SVariable r -> CSStateVar r
privDVar = r (Visibility r)
-> r (Permanence r)
-> StateT ValueState Identity (r (Variable r))
-> StateT ClassState Identity (r (StateVar r))
forall (r :: * -> *).
StateVarSym r =>
r (Visibility r) -> r (Permanence r) -> SVariable r -> CSStateVar r
stateVar r (Visibility r)
forall (r :: * -> *). VisibilitySym r => r (Visibility r)
private r (Permanence r)
forall (r :: * -> *). PermanenceSym r => r (Permanence r)
dynamic

pubDVar :: (StateVarSym r) => SVariable r -> CSStateVar r
pubDVar :: forall (r :: * -> *). StateVarSym r => SVariable r -> CSStateVar r
pubDVar = r (Visibility r)
-> r (Permanence r)
-> StateT ValueState Identity (r (Variable r))
-> StateT ClassState Identity (r (StateVar r))
forall (r :: * -> *).
StateVarSym r =>
r (Visibility r) -> r (Permanence r) -> SVariable r -> CSStateVar r
stateVar r (Visibility r)
forall (r :: * -> *). VisibilitySym r => r (Visibility r)
public r (Permanence r)
forall (r :: * -> *). PermanenceSym r => r (Permanence r)
dynamic

pubSVar :: (StateVarSym r) => SVariable r -> CSStateVar r
pubSVar :: forall (r :: * -> *). StateVarSym r => SVariable r -> CSStateVar r
pubSVar = r (Visibility r)
-> r (Permanence r)
-> StateT ValueState Identity (r (Variable r))
-> StateT ClassState Identity (r (StateVar r))
forall (r :: * -> *).
StateVarSym r =>
r (Visibility r) -> r (Permanence r) -> SVariable r -> CSStateVar r
stateVar r (Visibility r)
forall (r :: * -> *). VisibilitySym r => r (Visibility r)
public r (Permanence r)
forall (r :: * -> *). PermanenceSym r => r (Permanence r)
static

class PermanenceSym r where
  type Permanence r
  static  :: r (Permanence r)
  dynamic :: r (Permanence r)

class (TypeSym r) => OOTypeSym r where
  obj :: ClassName -> VSType r

class (ValueSym r, OOTypeSym r) => OOValueSym r

class (VariableSym r, OOTypeSym r) => OOVariableSym r where
  -- Bool: False for variable, True for constant.  Required by the Python renderer.
  staticVar'    :: Bool -> Label -> VSType r -> SVariable r
  self         :: SVariable r
  classVar     :: VSType r -> SVariable r -> SVariable r
  extClassVar  :: VSType r -> SVariable r -> SVariable r
  objVar       :: SVariable r -> SVariable r -> SVariable r
  objVarSelf   :: SVariable r -> SVariable r

staticVar :: (OOVariableSym r) => Label -> VSType r -> SVariable r
staticVar :: forall (r :: * -> *).
OOVariableSym r =>
Label -> VSType r -> SVariable r
staticVar = Bool
-> Label
-> StateT ValueState Identity (r (Type r))
-> StateT ValueState Identity (r (Variable r))
forall (r :: * -> *).
OOVariableSym r =>
Bool -> Label -> VSType r -> SVariable r
staticVar' Bool
False

staticConst :: (OOVariableSym r) => Label -> VSType r -> SVariable r
staticConst :: forall (r :: * -> *).
OOVariableSym r =>
Label -> VSType r -> SVariable r
staticConst = Bool
-> Label
-> StateT ValueState Identity (r (Type r))
-> StateT ValueState Identity (r (Variable r))
forall (r :: * -> *).
OOVariableSym r =>
Bool -> Label -> VSType r -> SVariable r
staticVar' Bool
True

($->) :: (OOVariableSym r) => SVariable r -> SVariable r -> SVariable r
infixl 9 $->
$-> :: forall (r :: * -> *).
OOVariableSym r =>
SVariable r -> SVariable r -> SVariable r
($->) = SVariable r -> SVariable r -> SVariable r
forall (r :: * -> *).
OOVariableSym r =>
SVariable r -> SVariable r -> SVariable r
objVar

class (VariableValue r, OOVariableSym r) => OOVariableValue r

-- for values that can include expressions
class (ValueExpression r, OOVariableSym r, OOValueSym r) => OOValueExpression r where
  selfFuncAppMixedArgs ::            MixedCall r
  newObjMixedArgs      ::            MixedCtorCall r
  extNewObjMixedArgs   :: Library -> MixedCtorCall r
  libNewObjMixedArgs   :: Library -> MixedCtorCall r

selfFuncApp      :: (OOValueExpression r) =>            PosCall r
selfFuncApp :: forall (r :: * -> *). OOValueExpression r => PosCall r
selfFuncApp Label
n VSType r
t [SValue r]
vs = MixedCall r
forall (r :: * -> *). OOValueExpression r => MixedCall r
selfFuncAppMixedArgs Label
n VSType r
t [SValue r]
vs []

newObj           :: (OOValueExpression r) =>            PosCtorCall r
newObj :: forall (r :: * -> *). OOValueExpression r => PosCtorCall r
newObj VSType r
t [SValue r]
vs = MixedCtorCall r
forall (r :: * -> *). OOValueExpression r => MixedCtorCall r
newObjMixedArgs VSType r
t [SValue r]
vs []

extNewObj        :: (OOValueExpression r) => Library -> PosCtorCall r
extNewObj :: forall (r :: * -> *). OOValueExpression r => PosCall r
extNewObj Label
l VSType r
t [SValue r]
vs = Label -> MixedCtorCall r
forall (r :: * -> *). OOValueExpression r => MixedCall r
extNewObjMixedArgs Label
l VSType r
t [SValue r]
vs []

libNewObj        :: (OOValueExpression r) => Library -> PosCtorCall r
libNewObj :: forall (r :: * -> *). OOValueExpression r => PosCall r
libNewObj Label
l VSType r
t [SValue r]
vs = Label -> MixedCtorCall r
forall (r :: * -> *). OOValueExpression r => MixedCall r
libNewObjMixedArgs Label
l VSType r
t [SValue r]
vs []

class (ValueSym r) => InternalValueExp r where
  -- | Generic function for calling a method.
  --   Takes the function name, the return type, the object, a list of 
  --   positional arguments, and a list of named arguments.
  objMethodCallMixedArgs' :: Label -> VSType r -> SValue r -> [SValue r] -> 
    NamedArgs r -> SValue r

-- | Calling a method. t is the return type of the method, o is the
--   object, f is the method name, and ps is a list of positional arguments.
objMethodCall :: (InternalValueExp r) => VSType r -> SValue r -> Label -> 
  [SValue r] -> SValue r
objMethodCall :: forall (r :: * -> *).
InternalValueExp r =>
VSType r -> SValue r -> Label -> [SValue r] -> SValue r
objMethodCall VSType r
t SValue r
o Label
f [SValue r]
ps = Label
-> VSType r -> SValue r -> [SValue r] -> NamedArgs r -> SValue r
forall (r :: * -> *).
InternalValueExp r =>
Label
-> VSType r -> SValue r -> [SValue r] -> NamedArgs r -> SValue r
objMethodCallMixedArgs' Label
f VSType r
t SValue r
o [SValue r]
ps []

-- | Calling a method with named arguments.
objMethodCallNamedArgs :: (InternalValueExp r) => VSType r -> SValue r -> Label 
  -> NamedArgs r -> SValue r
objMethodCallNamedArgs :: forall (r :: * -> *).
InternalValueExp r =>
VSType r -> SValue r -> Label -> NamedArgs r -> SValue r
objMethodCallNamedArgs VSType r
t SValue r
o Label
f = Label
-> VSType r
-> SValue r
-> [SValue r]
-> [(StateT ValueState Identity (r (Variable r)), SValue r)]
-> SValue r
forall (r :: * -> *).
InternalValueExp r =>
Label
-> VSType r -> SValue r -> [SValue r] -> NamedArgs r -> SValue r
objMethodCallMixedArgs' Label
f VSType r
t SValue r
o []

-- | Calling a method with a mix of positional and named arguments.
objMethodCallMixedArgs :: (InternalValueExp r) => VSType r -> SValue r -> Label 
  -> [SValue r] -> NamedArgs r -> SValue r
objMethodCallMixedArgs :: forall (r :: * -> *).
InternalValueExp r =>
VSType r
-> SValue r -> Label -> [SValue r] -> NamedArgs r -> SValue r
objMethodCallMixedArgs VSType r
t SValue r
o Label
f = Label
-> VSType r
-> SValue r
-> [SValue r]
-> [(StateT ValueState Identity (r (Variable r)), SValue r)]
-> SValue r
forall (r :: * -> *).
InternalValueExp r =>
Label
-> VSType r -> SValue r -> [SValue r] -> NamedArgs r -> SValue r
objMethodCallMixedArgs' Label
f VSType r
t SValue r
o

-- | Calling a method with no parameters.
objMethodCallNoParams :: (InternalValueExp r) => VSType r -> SValue r -> Label 
  -> SValue r
objMethodCallNoParams :: forall (r :: * -> *).
InternalValueExp r =>
VSType r -> SValue r -> Label -> SValue r
objMethodCallNoParams VSType r
t SValue r
o Label
f = VSType r -> SValue r -> Label -> [SValue r] -> SValue r
forall (r :: * -> *).
InternalValueExp r =>
VSType r -> SValue r -> Label -> [SValue r] -> SValue r
objMethodCall VSType r
t SValue r
o Label
f []

class (DeclStatement r, OOVariableSym r) => OODeclStatement r where
  objDecDef    :: SVariable r -> r (Scope r) -> SValue r -> MSStatement r
  -- Parameters: variable to store the object, scope of the variable,
  --             constructor arguments.  Object type is not needed,
  --             as it is inferred from the variable's type.
  objDecNew    :: SVariable r -> r (Scope r) -> [SValue r] -> MSStatement r
  extObjDecNew :: Library -> SVariable r -> r (Scope r) -> [SValue r]
    -> MSStatement r

objDecNewNoParams :: (OODeclStatement r) => SVariable r -> r (Scope r)
  -> MSStatement r
objDecNewNoParams :: forall (r :: * -> *).
OODeclStatement r =>
SVariable r -> r (Scope r) -> MSStatement r
objDecNewNoParams SVariable r
v r (Scope r)
s = SVariable r
-> r (Scope r)
-> [SValue r]
-> StateT MethodState Identity (r (Statement r))
forall (r :: * -> *).
OODeclStatement r =>
SVariable r -> r (Scope r) -> [SValue r] -> MSStatement r
objDecNew SVariable r
v r (Scope r)
s []

extObjDecNewNoParams :: (OODeclStatement r) => Library -> SVariable r -> 
  r (Scope r) -> MSStatement r
extObjDecNewNoParams :: forall (r :: * -> *).
OODeclStatement r =>
Label -> SVariable r -> r (Scope r) -> MSStatement r
extObjDecNewNoParams Label
l SVariable r
v r (Scope r)
s = Label
-> SVariable r
-> r (Scope r)
-> [SValue r]
-> StateT MethodState Identity (r (Statement r))
forall (r :: * -> *).
OODeclStatement r =>
Label -> SVariable r -> r (Scope r) -> [SValue r] -> MSStatement r
extObjDecNew Label
l SVariable r
v r (Scope r)
s []

class (FuncAppStatement r, OOVariableSym r) => OOFuncAppStatement r where
  selfInOutCall :: InOutCall r

class (StatementSym r, OOFunctionSym r) => ObserverPattern r where
  notifyObservers :: VSFunction r -> VSType r -> MSStatement r

observerListName :: Label
observerListName :: Label
observerListName = Label
"observerList"

initObserverList :: (DeclStatement r) => VSType r -> [SValue r] -> r (Scope r)
  -> MSStatement r
initObserverList :: forall (r :: * -> *).
DeclStatement r =>
VSType r -> [SValue r] -> r (Scope r) -> MSStatement r
initObserverList VSType r
t [SValue r]
os r (Scope r)
scp = SVariable r
-> r (Scope r)
-> [SValue r]
-> StateT MethodState Identity (r (Statement r))
forall (r :: * -> *).
DeclStatement r =>
SVariable r -> r (Scope r) -> [SValue r] -> MSStatement r
listDecDef (Label -> VSType r -> SVariable r
forall (r :: * -> *).
VariableSym r =>
Label -> VSType r -> SVariable r
var Label
observerListName (VSType r -> VSType r
forall (r :: * -> *). TypeSym r => VSType r -> VSType r
listType VSType r
t)) r (Scope r)
scp [SValue r]
os

addObserver :: (StatementSym r, OOVariableValue r, List r) => SValue r
  -> MSStatement r
addObserver :: forall (r :: * -> *).
(StatementSym r, OOVariableValue r, List r) =>
SValue r -> MSStatement r
addObserver SValue r
o = SValue r -> MSStatement r
forall (r :: * -> *). StatementSym r => SValue r -> MSStatement r
valStmt (SValue r -> MSStatement r) -> SValue r -> MSStatement r
forall a b. (a -> b) -> a -> b
$ SValue r -> SValue r -> SValue r -> SValue r
forall (r :: * -> *).
List r =>
SValue r -> SValue r -> SValue r -> SValue r
listAdd SValue r
obsList SValue r
lastelem SValue r
o
  where obsList :: SValue r
obsList = SVariable r -> SValue r
forall (r :: * -> *). VariableValue r => SVariable r -> SValue r
valueOf (SVariable r -> SValue r) -> SVariable r -> SValue r
forall a b. (a -> b) -> a -> b
$ Label -> VSType r -> SVariable r
forall (r :: * -> *).
VariableSym r =>
Label -> VSType r -> SVariable r
listOf Label
observerListName ((r (Value r) -> r (Type r)) -> SValue r -> VSType r
forall a b s. (a -> b) -> State s a -> State s b
onStateValue r (Value r) -> r (Type r)
forall (r :: * -> *). ValueSym r => r (Value r) -> r (Type r)
valueType SValue r
o)
        lastelem :: SValue r
lastelem = SValue r -> SValue r
forall (r :: * -> *). List r => SValue r -> SValue r
listSize SValue r
obsList

class (BodySym r, VariableSym r) => StrategyPattern r where
  runStrategy :: Label -> [(Label, MSBody r)] -> Maybe (SValue r) ->
    Maybe (SVariable r) -> MSBlock r

class (FunctionSym r) => OOFunctionSym r where
  func :: Label -> VSType r -> [SValue r] -> VSFunction r
  objAccess :: SValue r -> VSFunction r -> SValue r

($.) :: (OOFunctionSym r) => SValue r -> VSFunction r -> SValue r
infixl 9 $.
$. :: forall (r :: * -> *).
OOFunctionSym r =>
SValue r -> VSFunction r -> SValue r
($.) = SValue r -> VSFunction r -> SValue r
forall (r :: * -> *).
OOFunctionSym r =>
SValue r -> VSFunction r -> SValue r
objAccess

selfAccess :: (OOVariableValue r, OOFunctionSym r) => VSFunction r -> SValue r
selfAccess :: forall (r :: * -> *).
(OOVariableValue r, OOFunctionSym r) =>
VSFunction r -> SValue r
selfAccess = StateT ValueState Identity (r (Value r))
-> StateT ValueState Identity (r (Function r))
-> StateT ValueState Identity (r (Value r))
forall (r :: * -> *).
OOFunctionSym r =>
SValue r -> VSFunction r -> SValue r
objAccess (SVariable r -> StateT ValueState Identity (r (Value r))
forall (r :: * -> *). VariableValue r => SVariable r -> SValue r
valueOf SVariable r
forall (r :: * -> *). OOVariableSym r => SVariable r
self)

class (ValueSym r, VariableSym r) => GetSet r where
  get :: SValue r -> SVariable r -> SValue r
  set :: SValue r -> SVariable r -> SValue r -> SValue r

convTypeOO :: (OOTypeSym r) => CodeType -> VSType r
convTypeOO :: forall (r :: * -> *). OOTypeSym r => CodeType -> VSType r
convTypeOO (Object Label
n) = Label -> StateT ValueState Identity (r (Type r))
forall (r :: * -> *). OOTypeSym r => Label -> VSType r
obj Label
n
convTypeOO CodeType
t = CodeType -> StateT ValueState Identity (r (Type r))
forall (r :: * -> *). TypeSym r => CodeType -> VSType r
convType CodeType
t