uuagc-0.9.39.3: src/CommonTypes.hs
module CommonTypes where
import Pretty
import UU.Scanner.Position(Pos,noPos)
import qualified Data.Map as Map
import Data.Map(Map)
import Data.Set(Set)
import qualified Data.Set as Set
import Data.Monoid(mappend,mempty,Monoid)
type Blocks = Map BlockInfo [([String], Pos)]
type BlockInfo = (BlockKind, Maybe NontermIdent)
data BlockKind
= BlockImport
| BlockPragma
| BlockMain
| BlockOther
deriving (Eq, Ord, Show)
data Identifier = Ident { getName::String, getPos::Pos }
instance Eq Identifier where
Ident x _ == Ident y _ = x == y
instance Ord Identifier where
compare (Ident x _) (Ident y _) = compare x y
instance Show Identifier where
show ident = getName ident
instance PP Identifier where
pp = text . getName
data Type = Haskell String
| NT Identifier [String]
Bool -- True: deforested nonterminal, False: nonterminal type
| Self -- reference to the enclosing nonterminal type
deriving (Eq)
data ComplexType = List Type
| Tuple [(Identifier, Type)]
| Maybe Type
| Either Type Type
| Map Type Type
| IntMap Type
| OrdSet Type
| IntSet
instance Show ComplexType where
show (List t ) = "[" ++ show t ++ "]"
show (Tuple ts) = "(" ++ showList [ show n ++ ": " ++ show t | (n,t) <- ts ] "" ++ ")"
show (Maybe t ) = "Maybe " ++ show t
show (Either t1 t2) = "Either " ++ show t1 ++ " " ++ show t2
show (Map t1 t2) = "Map " ++ show t1 ++ " " ++ show t2
show (IntMap t1) = "IntMap " ++ show t1
show (OrdSet t1) = "Set" ++ show t1
show IntSet = "IntSet"
instance Show Type where
show = typeToHaskellString Nothing []
type Attributes = Map Identifier Type
type TypeSyns = [(NontermIdent,ComplexType)]
type ParamMap = Map NontermIdent [Identifier]
type AttrNames = [(Identifier,Type,(String,String,String))]
type UseMap = Map NontermIdent (Map Identifier (String,String,String))
type PragmaMap = Map NontermIdent (Map ConstructorIdent (Set Identifier))
type AttrMap = Map NontermIdent (Map ConstructorIdent (Set (Identifier,Identifier)))
type UniqueMap = Map NontermIdent (Map ConstructorIdent (Map Identifier Identifier))
type Derivings = Map NontermIdent (Set Identifier)
type ClassContext = [(Identifier, [String])]
type ContextMap = Map NontermIdent ClassContext
type QuantMap = Map NontermIdent [String]
type Strings = [String]
type NontermIdent = Identifier
type ConstructorIdent = Identifier
type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency))
type VisitIdentifier = Int
type StateIdentifier = Int
data Dependency = Dependency Occurrence Occurrence deriving (Eq,Ord,Show)
data Occurrence
= OccAttr Identifier Identifier
| OccRule Identifier
deriving (Eq,Ord,Show)
type AttrEnv = ( [Identifier]
, [(Identifier,Identifier)]
)
identifier x = Ident x noPos
nullIdent = identifier ""
_LHS = identifier "lhs"
_SELF = identifier "SELF"
_LOC = identifier "loc"
_INST = identifier "inst"
_INST' = identifier "inst'"
_FIELD = identifier "field"
_FIRST = identifier "first__"
_LAST = identifier "last__"
idLateBindingAttr :: Identifier
idLateBindingAttr = identifier "lateSemDict"
lateBindingTypeNm :: String -> String
lateBindingTypeNm modNm = "Late_" ++ modNm ++ "_"
lateBindingFieldNm :: String -> String
lateBindingFieldNm modNm = "late_" ++ modNm ++ "_"
lateBindingType :: String -> Type
lateBindingType modNm = Haskell (lateBindingTypeNm modNm)
lateSemNtLabel :: NontermIdent -> String
lateSemNtLabel nt = "mk_" ++ getName nt
lateSemConLabel :: NontermIdent -> ConstructorIdent -> String
lateSemConLabel nt con = "mk_" ++ getName nt ++ "_" ++ getName con
sdtype :: NontermIdent -> String
sdtype nt = "T_"++getName nt
mkNtType :: Identifier -> [String] -> Type
mkNtType nt args
| take 2 (getName nt) == "T_" = NT nt args True
| otherwise = NT nt args False
cataname :: String -> Identifier -> String
cataname pre name = pre++getName name
conname :: Bool -> NontermIdent -> ConstructorIdent -> String
conname rename nt con | rename = getName nt ++ "_" ++ getName con
| otherwise = getName con
semname :: String -> NontermIdent -> ConstructorIdent -> String
semname pre nt con = pre ++ (getName nt ++ "_" ++ getName con)
recordFieldname :: NontermIdent -> ConstructorIdent -> Identifier -> String
recordFieldname nt con nm = getName nm ++ "_" ++ getName nt ++ "_" ++ getName con
lhsname :: Bool -> Identifier -> String
lhsname isIn = attrname isIn _LHS
attrname :: Bool -> Identifier -> Identifier -> String
attrname isIn field attr | field == _LOC = locname attr
| field == _INST = instname attr
| field == _INST' = inst'name attr
| field == _FIELD = fieldname attr
| otherwise = let direction | isIn = "I"
| otherwise = "O"
in '_' : getName field ++ direction ++ getName attr
locname v = '_' : getName v
instname v = getName v ++ "_val_"
inst'name v = getName v ++ "_inst_"
fieldname v = getName v++"_"
typeToAGString :: Type -> String
typeToAGString tp
= case tp of
Haskell t -> t
NT nt tps for -> formatNonterminalToHaskell for (getName nt) (map (\s -> "{" ++ s ++ "}") tps)
removeDeforested :: Type -> Type
removeDeforested (NT nt args _) = NT nt args False
removeDeforested tp = tp
typeToHaskellString :: Maybe NontermIdent -> [String] -> Type -> String
typeToHaskellString mbNt params tp
= case tp of
Haskell t -> t
NT nt tps for | nt == _SELF -> formatNonterminalToHaskell for (maybe "?SELF?" getName mbNt) params
| otherwise -> formatNonterminalToHaskell for (getName nt) tps
formatNonterminalToHaskell :: Bool -> String -> [String] -> String
formatNonterminalToHaskell for nt tps
= unwords ((prefix ++ nt) : tps)
where prefix | for = "T_"
| otherwise = ""
ind :: String -> String
ind s = replicate 3 ' ' ++ s
_NOCASE :: Identifier
_NOCASE = identifier "nocase"
hasPragma :: PragmaMap -> NontermIdent -> ConstructorIdent -> Identifier -> Bool
hasPragma mp nt con nm
= nm `Set.member` Map.findWithDefault Set.empty con (Map.findWithDefault Map.empty nt mp)
isNonterminal :: Type -> Bool
isNonterminal (NT _ _ _) = True
isNonterminal _ = False
isSELFNonterminal :: Type -> Bool
-- isSELFNonterminal (NT nt _ _) | nt == _SELF = True
isSELFNonterminal Self = True
isSELFNonterminal _ = False
extractNonterminal :: Type -> NontermIdent
extractNonterminal (NT n _ _) = n
nontermArgs :: Type -> [String]
nontermArgs tp
= case tp of
NT _ args _ -> args
_ -> []
deforestedNt :: Identifier -> Maybe Identifier
deforestedNt nm
| take 2 (getName nm) == "T_" = Just (Ident (drop 2 (getName nm)) (getPos nm))
| otherwise = Nothing
data StateCtx
= NoneVis
| OneVis !Int
| ManyVis
deriving (Eq, Show, Ord)
data ChildKind
= ChildSyntax -- This child is defined by syntax
| ChildAttr -- This child is defined by an attribute
| ChildReplace Type -- This child replaces a child with type Type
deriving (Eq, Show)
-- Given a map that represents a relation, returns the transitive closure of this relation
closeMap :: Ord a => Map a (Set a) -> Map a (Set a)
closeMap mp0 = close (Map.keysSet mp0) mp0 where
rev = revDeps mp0
close todo mp0 = case Set.minView todo of
Nothing -> mp0
Just (k, todo1) -> let find x = Map.findWithDefault Set.empty x mp0
vals0 = find k
valsL = Set.toList vals0
vals1 = foldr Set.union vals0 $ map find valsL
in if Set.size vals0 == Set.size vals1
then close todo1 mp0 -- note: monotonically increasing set
else let mp1 = Map.insert k vals1 mp0
refs = Map.findWithDefault Set.empty k rev
todo2 = Set.union refs todo1
in close todo2 mp1
revDeps :: Ord a => Map a (Set a) -> Map a (Set a)
revDeps mp = Map.fromListWith Set.union [ (a,Set.singleton k) | (k,s) <- Map.assocs mp, a <- Set.toList s ]
data HigherOrderInfo = HigherOrderInfo
{ hoNtDeps :: Set NontermIdent
, hoNtRevDeps :: Set NontermIdent
, hoAcyclic :: Bool
}
data VisitKind
= VisitPure Bool -- ordered or not
| VisitMonadic
deriving (Eq,Ord)
isLazyKind :: VisitKind -> Bool
isLazyKind (VisitPure False) = True
isLazyKind _ = False
instance Show VisitKind where
show (VisitPure False) = "Lazy"
show (VisitPure True) = "Ordered"
show VisitMonadic = "Monadic"
unionWithMappend :: (Monoid a, Ord k) => Map k a -> Map k a -> Map k a
unionWithMappend = Map.unionWith mappend
data FormatMode
= FormatDo
| FormatLetDecl
| FormatLetLine
deriving (Eq, Ord, Show)