hat-2.7.0.0: trans/AuxTypes.hs
module AuxTypes where
import Data.Char (isDigit,isUpper)
import Data.List (isPrefixOf)
import Syntax
import AssocTree
import TokenId (TokenId(Qualified),tPrelude,visImport,t_Tuple)
import SysDeps (packString)
-- AuxiliaryInfo is the extra information we need to know about identifiers.
data AuxiliaryInfo =
Value {- variable or constructor -}
{ args :: Int
, fixity :: Fixity
, priority :: Int
, letBound :: Bool
, traced :: Bool}
| TyCls TyCls -- needed for im/export of (..)
deriving (Show,Read)
data Fixity = L | R | Pre String | Def | None deriving (Eq,Show,Read)
data TyCls = Ty [String]{- data constructors -} [String]{- field labels -}
| Cls [String]{- methods -}
| Syn Int {- no. helper type syns -} TySynBody
deriving (Show,Read)
data TySynBody =
TApp TySynBody TySynBody | TFun | THelper | TVar Int {- arg no. -}
deriving (Show,Read)
-- information needed for creating an AuixiliaryInfo
-- currently only flag if original identifier definition is traced
newtype InitAuxInfo = InitAuxInfo Bool
defaultAuxInfo :: InitAuxInfo
defaultAuxInfo = InitAuxInfo False
initAuxInfo :: Bool {-traced-} -> InitAuxInfo
initAuxInfo = InitAuxInfo
untracedEmptyAux :: AuxiliaryInfo
untracedEmptyAux =
Value { args=(-1), fixity=Def, priority=9, letBound=True, traced=False}
emptyAux :: InitAuxInfo -> AuxiliaryInfo
emptyAux (InitAuxInfo tr) =
Value { args=(-1), fixity=Def, priority=9, letBound=True, traced=tr}
patternAux :: InitAuxInfo -> AuxiliaryInfo
patternAux (InitAuxInfo tr) =
Value { args=(-1), fixity=Def, priority=9, letBound=False, traced=tr}
-- Identifier is used to distinguish varids from conids, and relate
-- conids back to the type they belong to. It also relates methods
-- to their class.
data Identifier = Var String | Con TypeSort String{-type-} String{-con-}
| Field String{-type-} String{-field-}
| Method String{-class-} String{-method-}
| TypeClass String
deriving (Show,Read,Eq,Ord)
data TypeSort = Data | Newtype deriving (Show,Read,Eq,Ord)
qual :: Identifier -> String -> Identifier
qual (Var v) m = Var (m++v)
qual (Con s t c) m = Con s t (m++c)
qual (Field t f) m = Field t (m++f)
qual (Method t f) m = Method t (m++f)
qual (TypeClass t) _ = TypeClass t
subTid :: Identifier -> TokenId
subTid (Var v) = qualTid v
subTid (Con t _ c) = possTuple c
subTid (Field t f) = qualTid f
subTid (Method c m) = qualTid m
subTid (TypeClass tc) = possTuple tc
qualTid i | isUpper (head i) && '.' `elem` i =
let (v,m) = break (=='.') (reverse i) in -- approximation
Qualified (packString (tail m)) (packString v)
| otherwise = visImport i
possTuple "()" = t_Tuple 0
possTuple s | "Prelude." `isPrefixOf` s =
let nm = drop 8 s in
if isDigit (head nm) then t_Tuple (read nm)
else visImport s
possTuple s = visImport s
-- The main Environment is composed of two pieces...
type Environment = (AuxTree,IdentMap)
-- AuxTree is an environment, associating each identifier with a unique
-- AuxiliaryInfo.
type AuxTree = AssocTree Identifier AuxiliaryInfo
-- IdentMap is an environment associating each constructor/field with
-- its type, and each method with its class. We can encounter a
-- constructor (or method) without its type (or class) in a fixity decl,
-- but we then need to know its type (or class) to know whether it
-- is exported or not. If an entity is neither a known constructor/field
-- nor a known method, we assume it is just an ordinary variable.
-- Types and classes are not stored in an IdentMap
type IdentMap = AssocTree TokenId{-con, var, or method-} Identifier
-- `mkIdentMap' makes a little lookup table from data constructors and field
-- names to their type name, and methods to their class. Additionally, it
-- builds a list of all defined types, plus synonyms and class names, used
-- to check that all exports have a referent.
mkIdentMap :: [Decl TokenId] -> (IdentMap,[TokenId])
mkIdentMap decls =
let dataDecls = concatMap dataDecl decls
classDecls = concatMap classDecl decls
in ( foldr addMethod (foldr addCon initAT dataDecls) classDecls
, map (\(x,_,_)->x) dataDecls ++ map fst classDecls
++ concatMap typeSyn decls)
where
dataDecl (DeclData Nothing _ (Simple _ typ _) tycons _) =
[(typ,Newtype,tycons)]
dataDecl (DeclData (Just _) _ (Simple _ typ _) tycons _) =
[(typ,Data,tycons)]
dataDecl _ = []
classDecl (DeclClass _ _ cls _ _ (DeclsParse decls)) = [(cls,decls)]
classDecl _ = []
typeSyn (DeclType (Simple pos id vars) _) = [id]
typeSyn _ = []
addCon :: (TokenId,TypeSort,[Constr TokenId]) -> IdentMap -> IdentMap
addCon (typ,typeSort,tycons) t = foldr doCon t tycons
where
doCon (Constr _ c fs) t = conAndFields c fs t
doCon (ConstrCtx _ _ _ c fs) t = conAndFields c fs t
conAndFields c fs t = addFields (addAT t const c
(Con typeSort styp (show c)))
styp fs
styp = show typ
addFields :: IdentMap -> String -> [(Maybe [(t, TokenId)],b)] -> IdentMap
addFields t typ [] = t
addFields t typ ((Nothing,_):_) = t
addFields t typ ((Just posids,_):cs) = foldr doField (rest t) posids
where
doField (_,f) t = addAT t const f (Field typ (show f))
rest t = addFields t typ cs
addMethod :: (TokenId,[Decl TokenId]) -> IdentMap -> IdentMap
addMethod (cls, decls) t = foldr doMethod t decls
where
doMethod (DeclVarsType pis ctxs typ) t = foldr pId t pis
doMethod _ t = t
pId (pos,meth) t = addAT t const meth
(Method (show cls) (show meth))
useIdentMap :: IdentMap -> TokenId -> Identifier
useIdentMap m v =
case lookupAT m v of
Just tc -> tc
Nothing -> Var (show v)
-- The following hack is needed, because identMap only knows about global
-- identifiers and because variables, field labels and methods share the
-- same name space.
useEnvironment :: Environment -> TokenId -> Maybe AuxiliaryInfo
useEnvironment (env,identMap) id =
let v = useIdentMap identMap id in
case v of
-- a field or method may be shadowed by a normal variable
-- hence have to search for such a variable first
Field _ name -> case lookupAT env (Var name) of
Just info -> Just info
Nothing -> lookupAT env v
Method _ name -> case lookupAT env (Var name) of
Just info -> Just info
Nothing -> lookupAT env v
_ -> lookupAT env v