{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans -fallow-overlapping-instances -funbox-strict-fields -fallow-undecidable-instances -fallow-incoherent-instances #-}

module Pugs.MOP where

import Data.Map
import qualified Network.URI
import qualified Data.ByteString.Char8 as Str
import Data.Version

import Pugs.AST.CapInternals

type Str = Str.ByteString

-- import Pugs.MOP.Instances

pugsMetaModelVersion :: [Int]
pugsMetaModelVersion = [0, 0, 1]

{-| data types for Package, Module, Class, Grammar, and Role -}


class Boxable a where
    meta  :: a -> Class
    getId :: a -> Val

-- These will be derived by DrIFT eventually :)
instance Boxable Int where
    meta  _ = mkClass "NativeInt"
    --        vvvvvvvvvvvvvvvvvvvvvvvv we'd better come up with some convenience funcs here
    getId _ = VNative $ NInt $ 6147 -- unique per built-in Val type

{- Bootstrap initial metaobject instances -}
packageObject, packageMeta, packageRoot :: Package
packageRoot   = MkPackage (Str.pack "GLOBAL") Nothing
packageMeta   = MkPackage (Str.pack "Class")  (Just packageRoot)
packageObject = MkPackage (Str.pack "Object") (Just packageRoot)

moduleMeta, moduleObject :: Module
moduleMeta = MkModule
    { m_version   = Version pugsMetaModelVersion []
    , m_authority = Network.URI.parseURI "urn:Pugs"
    , m_package   = Just packageMeta
    }

moduleObject = moduleMeta{ m_package = Just packageObject }

classMeta, classObject :: Class
classMeta = MkClass
    { c_module              = Just moduleMeta
    , c_superClasses        = [classObject]
    , c_runtimeSuperClasses = Eval [] -- return []
    , c_methodTable         = empty
    , c_runtimeMethodtable  = Eval empty -- return empty
    , c_runtimeSlots        = Eval empty -- return empty -- stevan
    }

classObject = MkClass
    { c_module              = Just moduleObject
    , c_superClasses        = []
    , c_runtimeSuperClasses = Eval [] -- return []
    , c_methodTable         = empty
    , c_runtimeMethodtable  = Eval empty -- return empty
    , c_runtimeSlots        = Eval empty -- return empty --punt
    }


{-
 - HashCons cache, to be spelled out via DrIFT to avoid enumeration typos
defaultClassMap :: Map String Class
defaultClassMap = fromList [ (x, mkClass x) | x <- initialClasses ]
    where initialClasses =
        [ "VInt"
        , ...
        ]

getClass :: String -> Class
getClass = Map.lookup defaultClassMap
-}

getClass :: String -> Class
getClass = mkClass

mkClass :: String -> Class
mkClass name = MkClass
    { c_module = mkMod'
    , c_superClasses = [classMeta]
    , c_runtimeSuperClasses = Eval [] -- return []
    , c_methodTable = empty
    , c_runtimeMethodtable = Eval empty -- return empty
    , c_runtimeSlots = Eval empty -- return empty -- punt
    }
    where
    mkMod' = Just moduleMeta{ m_package = mkPkg' }
    mkPkg' = Just MkPackage{ p_name = Str.pack name, p_parent = Just packageMeta }

mkGrammar :: String -> Grammar
mkGrammar = MkGrammar . mkClass

mkRole :: String -> Role
mkRole = MkRole . mkClass