{-# OPTIONS_GHC -fglasgow-exts #-}
-- for deriving Data and Typeable

-- 
-- Copyright (C) 2005 Stefan Wehr - http://www.stefanwehr.de
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
-- 
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
-- 

module Phrac.UniqIdents (

  TypeVarId, TypeId, DataId, ClassId, AssocTypeId, ValId,

  isPairTypeConstructor, isFunTypeConstructor, builtinTypeId, builtinDataId,
  isMain, isError,
 
  NA, runNA, Version, initialVersion,

  defineTypeVar, undefineTypeVar, isDefinedTypeVar,

  defineValVar, 

  defineDataCon, defineTypeCon,
  defineAssocTypeCon, defineClass, 
  
  lookUpValVar, lookUpTypeVar, lookUpDataCon, lookUpTypeCon,
  lookUpAssocTypeCon, lookUpClass, 

  isAssocTypeCon,

  enterBlock, exitBlock, freshValVar,

  mkTypeVar, mkTypeId, mkValId
) where

import qualified Data.Generics as Gen
import Control.Monad.State

import Phrac.Error
import Phrac.Pretty
import qualified Phrac.NameSpaces as NS
import qualified Phrac.Map as Map
import qualified Phrac.ParseSyntax as ParseSyntax
import qualified Phrac.Builtins as Builtins

--
-- The data types for identifiers
--

type Version = Integer

data Id = Id !Version !String
        deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)

type ParseId = ParseSyntax.Id

mkId :: ParseId -> Integer -> Id
mkId i v = Id v i

newtype TypeVarId = TypeVarId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)
newtype TypeId = TypeId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)
newtype DataId = DataId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)
newtype ClassId = ClassId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)
newtype AssocTypeId = AssocTypeId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)
newtype ValId = ValId Id 
    deriving (Eq,Show,Read,Ord,Gen.Typeable,Gen.Data)

instance Pretty TypeVarId where
    ppr (TypeVarId id) = ppr id

instance Pretty TypeId where
    ppr (TypeId id) = ppr id

instance Pretty DataId where
    ppr (DataId id) = ppr id

instance Pretty ClassId where
    ppr (ClassId id) = ppr id

instance Pretty AssocTypeId where
    ppr (AssocTypeId id) = ppr id

instance Pretty ValId where
    ppr (ValId id) = ppr id

instance Pretty Id where 
    ppr (Id v s) | v /= 0 = text s <> text "[" <> text (show v)
                            <> text "]"
    ppr (Id _ s) = text s


isPairTypeConstructor (TypeId (Id v s)) = 
    v == 0 && s == Builtins.pairTypeConstructor
isFunTypeConstructor (TypeId (Id v s)) = 
    v == 0 && s == Builtins.funTypeConstructor

builtinTypeId s = if s `elem` Builtins.typeConstructors
                     then TypeId (Id 0 s)
                     else panic ("Unknown builtin: " ++ s)

builtinDataId s = if s `elem` (map fst Builtins.dataConstructors)
                     then DataId (Id 0 s)
                     else panic ("Unknown builtin: " ++ s)

isMain (ValId (Id _ s)) = s == "main"
isError (ValId (Id _ s)) = s == "error"

-- The name analysis monad
-- -----------------------

-- Provides a mapping between names produced by the parser (plain strings)
-- and unique names (strings + version number). The usual scoping rules
-- apply.

data NAState = 
    NAState { na_valueLevel :: NS.NameSpace ParseId (ValueLevelObjects),
              na_typeVars :: Map.Map ParseId TypeVarId,
              na_typeLevel :: Map.Map ParseId (TypeLevelObjects),
              na_versions :: Map.Map ParseId Integer }

emptyNAState = NAState NS.nameSpace Map.empty Map.empty Map.empty

data ValueLevelObjects = Value ValId 
                       | DataCon DataId Int{- arity -} Bool{- builtin -}

data TypeLevelObjects = TypeCon TypeId
                      | AssocTypeCon AssocTypeId Int-- number of indices
                      | Class ClassId

type NA = StateT NAState IO


-- run a name analysis in a fresh NA environment
--
runNA :: NA a -> IO a
runNA m = evalStateT m emptyNAState
  
setValueLevel x = modify (\s -> s { na_valueLevel = x })
setTypeVars x = modify (\s -> s { na_typeVars = x })
setTypeLevel x = modify (\s -> s { na_typeLevel = x })
setVersions x = modify (\s -> s { na_versions = x })

initialVersion :: Integer
initialVersion = 0

nextVersion :: ParseId -> NA Id
nextVersion id = 
    do m <- gets na_versions
       let v = Map.findWithDefault initialVersion id m
       setVersions (Map.insert id (v+1) m)
       return (mkId id v)

define :: (NAState -> m)           -- get the mapping
       -> (m -> NA ())             -- save the mapping
       -> (Id -> u)                -- create the uid
       -> (u -> w)                 -- wrap the uid
       -> (ParseId -> w -> m -> (Maybe w, m)) -- store the uid
       -> String                   -- what are we defining?
       -> ParseId                  -- the id
       -> NA u                     -- the resulting uid
define a save c w f s id = 
    do uid <- nextVersion id
       let uid' = c uid
       m <- gets a
       case f id (w uid') m of
         (Just old, _) ->
             phasefail (s ++ " `" ++ showPpr id ++ 
                        "' already defined")
         (_, m') -> do save m'
                       return uid'

defineTypeVar :: ParseId -> NA TypeVarId
defineTypeVar = define na_typeVars setTypeVars TypeVarId (\x -> x)
                  Map.insertLookup "type variable"

defineValue = define na_valueLevel setValueLevel

defineValVar :: ParseId -> NA ValId
defineValVar = defineValue ValId Value NS.defLocal "value variable"

defineDataCon :: ParseId -> Int -> Bool -> NA DataId
defineDataCon id arity b = defineValue DataId (\i -> DataCon i arity b) 
                             NS.defGlobal "data constructor" id

defineType = define na_typeLevel setTypeLevel

defineTypeCon :: ParseId -> NA TypeId
defineTypeCon = defineType TypeId TypeCon Map.insertLookup "type constructor"

defineAssocTypeCon :: ParseId -> Int -> NA AssocTypeId
defineAssocTypeCon id arity = 
    defineType AssocTypeId (flip AssocTypeCon arity)
               Map.insertLookup "associated type constructor" id

defineClass :: ParseId -> NA ClassId
defineClass = defineType ClassId Class Map.insertLookup "type class"
  

lookUp :: (NAState -> m)             -- get the mapping
       -> (ParseId -> m -> Maybe w)  -- lookup the wrapped uid
       -> (w -> Maybe u)             -- unwrap the uid
       -> String                     -- what is looked up?
       -> ParseId                    -- the id
       -> NA u                       -- the result
lookUp a l u s id = 
    do m <- gets a
       case l id m of
         Just w -> 
           case u w of
             Just uid -> return uid
             Nothing -> phasefail ("`" ++ show (ppr id) ++ "' is not a " ++ s)
         Nothing -> phasefail (s ++ " `" ++ show (ppr id) ++ "' does not exist")

lookUpValue = lookUp na_valueLevel

lookUpValVar :: ParseId -> NA ValId
lookUpValVar = lookUpValue NS.find (\w -> case w of 
                                            Value uid -> Just uid
                                            _ -> Nothing) "value variable"

lookUpDataCon :: ParseId -> NA (DataId, Int, Bool)
lookUpDataCon = lookUpValue NS.findGlobal
                  (\w -> case w of
                           DataCon uid i b -> Just (uid, i, b)
                           _ -> Nothing) "data constructor" 
                  
lookUpType = lookUp na_typeLevel Map.lookup

lookUpTypeCon :: ParseId -> NA TypeId
lookUpTypeCon = lookUpType (\w -> case w of
                                    TypeCon uid -> Just uid
                                    _ -> Nothing) "type constructor" 

lookUpAssocTypeCon :: ParseId -> NA (AssocTypeId, Int)
lookUpAssocTypeCon = lookUpType (\w -> case w of
                                         AssocTypeCon uid i -> Just (uid, i)
                                         _ -> Nothing)
                       "associated type constructor" 

lookUpClass :: ParseId -> NA ClassId
lookUpClass = lookUpType (\w -> case w of
                                  Class uid -> Just uid
                                  _ -> Nothing) "type class" 

lookUpTypeVar :: ParseId -> NA TypeVarId
lookUpTypeVar = lookUp na_typeVars Map.lookup Just "type variable"

isAssocTypeCon :: ParseId -> NA Bool
isAssocTypeCon id = 
    do m <- gets na_typeLevel
       case Map.lookup id m of
         Just (AssocTypeCon _ _) -> return True
         _ -> return False

undefineTypeVar :: TypeVarId -> NA ()
undefineTypeVar (TypeVarId (Id _ id)) = 
    do m <- gets na_typeVars
       let m' = case Map.lookup id m of
                  Nothing -> phasefail ("cannot undefine non-existing type \
                                        \variable `" ++ show (ppr id) ++ "'")
                  Just _ -> Map.delete id m
       setTypeVars m'

isDefinedTypeVar :: ParseId -> NA Bool
isDefinedTypeVar id = 
    do m <- gets na_typeVars
       case Map.lookup id m of
         Nothing -> return False
         _ -> return True

enterBlock :: NA ()
enterBlock = 
    do ns <- gets na_valueLevel
       setValueLevel (NS.enterNewRange ns)

exitBlock :: NA ()
exitBlock = 
    do ns <- gets na_valueLevel
       setValueLevel (fst $ NS.leaveRange ns)

freshValVar :: ParseId -> NA ValId
freshValVar id = 
    do uid <- nextVersion id
       return (ValId uid)

-- generates a type variable with the given version. We require the version
-- number to be smaller than 0, so that the resulting type variable
-- is fresh with respect to the type variables generated in the NA monad.
mkTypeVar :: String -> Version -> TypeVarId
mkTypeVar s v = 
    if v >= initialVersion
       then panic ("mkTypeVar called with illegal version number: " ++
                   show v)
       else (TypeVarId (Id v s))

mkTypeId :: String -> Version -> TypeId
mkTypeId s v =
    if v >= initialVersion
       then panic ("mkTypeId called with illegal version number: " ++
                   show v)
       else (TypeId (Id v s))

mkValId :: String -> Version -> ValId
mkValId s v = 
    if v >= initialVersion
       then panic ("mkValId called with illegal version number: " ++
                   show v)
       else (ValId (Id v s))