module GHC.Unit.Types
(
GenModule (..)
, Module
, InstalledModule
, InstantiatedModule
, mkModule
, pprModule
, pprInstantiatedModule
, moduleFreeHoles
, IsUnitId
, GenUnit (..)
, Unit
, UnitId (..)
, UnitKey (..)
, GenInstantiatedUnit (..)
, InstantiatedUnit
, IndefUnitId
, DefUnitId
, Instantiations
, GenInstantiations
, mkInstantiatedUnit
, mkInstantiatedUnitHash
, mkVirtUnit
, mapGenUnit
, mapInstantiations
, unitFreeModuleHoles
, fsToUnit
, unitFS
, unitString
, toUnitId
, virtualUnitId
, stringToUnit
, stableUnitCmp
, unitIsDefinite
, isHoleUnit
, unitIdString
, stringToUnitId
, Definite (..)
, Indefinite (..)
, primUnitId
, bignumUnitId
, baseUnitId
, rtsUnitId
, thUnitId
, mainUnitId
, thisGhcUnitId
, interactiveUnitId
, primUnit
, bignumUnit
, baseUnit
, rtsUnit
, thUnit
, mainUnit
, thisGhcUnit
, interactiveUnit
, isInteractiveModule
, wiredInUnitIds
, IsBootInterface (..)
, GenWithIsBoot (..)
, ModuleNameWithIsBoot
, ModuleWithIsBoot
)
where
import GHC.Prelude
import GHC.Types.Unique
import GHC.Types.Unique.DSet
import GHC.Unit.Module.Name
import GHC.Utils.Binary
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Encoding
import GHC.Utils.Fingerprint
import GHC.Utils.Misc
import Control.DeepSeq
import Data.Data
import Data.List (sortBy )
import Data.Function
import Data.Bifunctor
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS.Char8
data GenModule unit = Module
{ moduleUnit :: !unit
, moduleName :: !ModuleName
}
deriving (Eq,Ord,Data,Functor)
type Module = GenModule Unit
type InstalledModule = GenModule UnitId
type InstantiatedModule = GenModule InstantiatedUnit
mkModule :: u -> ModuleName -> GenModule u
mkModule = Module
instance Uniquable Module where
getUnique (Module p n) = getUnique (unitFS p `appendFS` moduleNameFS n)
instance Binary a => Binary (GenModule a) where
put_ bh (Module p n) = put_ bh p >> put_ bh n
get bh = do p <- get bh; n <- get bh; return (Module p n)
instance NFData (GenModule a) where
rnf (Module unit name) = unit `seq` name `seq` ()
instance Outputable Module where
ppr = pprModule
instance Outputable InstalledModule where
ppr (Module p n) =
ppr p <> char ':' <> pprModuleName n
instance Outputable InstantiatedModule where
ppr = pprInstantiatedModule
instance Outputable InstantiatedUnit where
ppr uid =
ppr cid <>
(if not (null insts)
then
brackets (hcat
(punctuate comma $
[ ppr modname <> text "=" <> pprModule m
| (modname, m) <- insts]))
else empty)
where
cid = instUnitInstanceOf uid
insts = instUnitInsts uid
class IsUnitId u where
unitFS :: u -> FastString
instance IsUnitId UnitKey where
unitFS (UnitKey fs) = fs
instance IsUnitId UnitId where
unitFS (UnitId fs) = fs
instance IsUnitId u => IsUnitId (GenUnit u) where
unitFS (VirtUnit x) = instUnitFS x
unitFS (RealUnit (Definite x)) = unitFS x
unitFS HoleUnit = holeFS
pprModule :: Module -> SDoc
pprModule mod@(Module p n) = getPprStyle doc
where
doc sty
| codeStyle sty =
(if p == mainUnit
then empty
else ztext (zEncodeFS (unitFS p)) <> char '_')
<> pprModuleName n
| qualModule sty mod =
case p of
HoleUnit -> angleBrackets (pprModuleName n)
_ -> ppr (moduleUnit mod) <> char ':' <> pprModuleName n
| otherwise =
pprModuleName n
pprInstantiatedModule :: InstantiatedModule -> SDoc
pprInstantiatedModule (Module uid m) =
ppr uid <> char ':' <> ppr m
newtype UnitKey = UnitKey FastString
data GenUnit uid
= RealUnit !(Definite uid)
| VirtUnit !(GenInstantiatedUnit uid)
| HoleUnit
data GenInstantiatedUnit unit
= InstantiatedUnit {
instUnitFS :: !FastString,
instUnitKey :: !Unique,
instUnitInstanceOf :: !(Indefinite unit),
instUnitInsts :: !(GenInstantiations unit),
instUnitHoles :: UniqDSet ModuleName
}
type Unit = GenUnit UnitId
type InstantiatedUnit = GenInstantiatedUnit UnitId
type GenInstantiations unit = [(ModuleName,GenModule (GenUnit unit))]
type Instantiations = GenInstantiations UnitId
holeUnique :: Unique
holeUnique = getUnique holeFS
holeFS :: FastString
holeFS = fsLit "<hole>"
isHoleUnit :: GenUnit u -> Bool
isHoleUnit HoleUnit = True
isHoleUnit _ = False
instance Eq (GenInstantiatedUnit unit) where
u1 == u2 = instUnitKey u1 == instUnitKey u2
instance Ord (GenInstantiatedUnit unit) where
u1 `compare` u2 = instUnitFS u1 `uniqCompareFS` instUnitFS u2
instance Binary InstantiatedUnit where
put_ bh indef = do
put_ bh (instUnitInstanceOf indef)
put_ bh (instUnitInsts indef)
get bh = do
cid <- get bh
insts <- get bh
let fs = mkInstantiatedUnitHash cid insts
return InstantiatedUnit {
instUnitInstanceOf = cid,
instUnitInsts = insts,
instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
instUnitFS = fs,
instUnitKey = getUnique fs
}
instance IsUnitId u => Eq (GenUnit u) where
uid1 == uid2 = unitUnique uid1 == unitUnique uid2
instance IsUnitId u => Uniquable (GenUnit u) where
getUnique = unitUnique
instance Ord Unit where
nm1 `compare` nm2 = stableUnitCmp nm1 nm2
instance Data Unit where
toConstr _ = abstractConstr "Unit"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "Unit"
instance NFData Unit where
rnf x = x `seq` ()
stableUnitCmp :: Unit -> Unit -> Ordering
stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2
instance Outputable Unit where
ppr pk = pprUnit pk
pprUnit :: Unit -> SDoc
pprUnit (RealUnit uid) = ppr uid
pprUnit (VirtUnit uid) = ppr uid
pprUnit HoleUnit = ftext holeFS
instance Show Unit where
show = unitString
instance Binary Unit where
put_ bh (RealUnit def_uid) = do
putByte bh 0
put_ bh def_uid
put_ bh (VirtUnit indef_uid) = do
putByte bh 1
put_ bh indef_uid
put_ bh HoleUnit =
putByte bh 2
get bh = do b <- getByte bh
case b of
0 -> fmap RealUnit (get bh)
1 -> fmap VirtUnit (get bh)
_ -> pure HoleUnit
unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName
unitFreeModuleHoles (VirtUnit x) = instUnitHoles x
unitFreeModuleHoles (RealUnit _) = emptyUniqDSet
unitFreeModuleHoles HoleUnit = emptyUniqDSet
moduleFreeHoles :: GenModule (GenUnit u) -> UniqDSet ModuleName
moduleFreeHoles (Module HoleUnit name) = unitUniqDSet name
moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u
mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u
mkInstantiatedUnit cid insts =
InstantiatedUnit {
instUnitInstanceOf = cid,
instUnitInsts = sorted_insts,
instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
instUnitFS = fs,
instUnitKey = getUnique fs
}
where
fs = mkInstantiatedUnitHash cid sorted_insts
sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit uid [] = RealUnit $ Definite (indefUnit uid)
mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts
mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString
mkInstantiatedUnitHash cid sorted_holes =
mkFastStringByteString
. fingerprintUnitId (bytesFS (unitFS cid))
$ hashInstantiations sorted_holes
hashInstantiations :: IsUnitId u => [(ModuleName, GenModule (GenUnit u))] -> Fingerprint
hashInstantiations sorted_holes =
fingerprintByteString
. BS.concat $ do
(m, b) <- sorted_holes
[ bytesFS (moduleNameFS m), BS.Char8.singleton ' ',
bytesFS (unitFS (moduleUnit b)), BS.Char8.singleton ':',
bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n']
fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString
fingerprintUnitId prefix (Fingerprint a b)
= BS.concat
$ [ prefix
, BS.Char8.singleton '-'
, BS.Char8.pack (toBase62Padded a)
, BS.Char8.pack (toBase62Padded b) ]
unitUnique :: IsUnitId u => GenUnit u -> Unique
unitUnique (VirtUnit x) = instUnitKey x
unitUnique (RealUnit (Definite x)) = getUnique (unitFS x)
unitUnique HoleUnit = holeUnique
fsToUnit :: FastString -> Unit
fsToUnit = RealUnit . Definite . UnitId
unitString :: IsUnitId u => u -> String
unitString = unpackFS . unitFS
stringToUnit :: String -> Unit
stringToUnit = fsToUnit . mkFastString
mapGenUnit :: IsUnitId v => (u -> v) -> GenUnit u -> GenUnit v
mapGenUnit f = go
where
go gu = case gu of
HoleUnit -> HoleUnit
RealUnit d -> RealUnit (fmap f d)
VirtUnit i ->
VirtUnit $ mkInstantiatedUnit
(fmap f (instUnitInstanceOf i))
(fmap (second (fmap go)) (instUnitInsts i))
mapInstantiations :: IsUnitId v => (u -> v) -> GenInstantiations u -> GenInstantiations v
mapInstantiations f = map (second (fmap (mapGenUnit f)))
toUnitId :: Unit -> UnitId
toUnitId (RealUnit (Definite iuid)) = iuid
toUnitId (VirtUnit indef) = indefUnit (instUnitInstanceOf indef)
toUnitId HoleUnit = error "Hole unit"
virtualUnitId :: InstantiatedUnit -> UnitId
virtualUnitId i = UnitId (instUnitFS i)
unitIsDefinite :: Unit -> Bool
unitIsDefinite = isEmptyUniqDSet . unitFreeModuleHoles
newtype UnitId =
UnitId {
unitIdFS :: FastString
}
instance Binary UnitId where
put_ bh (UnitId fs) = put_ bh fs
get bh = do fs <- get bh; return (UnitId fs)
instance Eq UnitId where
uid1 == uid2 = getUnique uid1 == getUnique uid2
instance Ord UnitId where
u1 `compare` u2 = unitIdFS u1 `lexicalCompareFS` unitIdFS u2
instance Uniquable UnitId where
getUnique = getUnique . unitIdFS
instance Outputable UnitId where
ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs)
type DefUnitId = Definite UnitId
unitIdString :: UnitId -> String
unitIdString = unpackFS . unitIdFS
stringToUnitId :: String -> UnitId
stringToUnitId = UnitId . mkFastString
newtype Definite unit = Definite { unDefinite :: unit }
deriving (Functor)
deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
type IndefUnitId = Indefinite UnitId
newtype Indefinite unit = Indefinite { indefUnit :: unit }
deriving (Functor)
deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)
bignumUnitId, primUnitId, baseUnitId, rtsUnitId,
thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
bignumUnit, primUnit, baseUnit, rtsUnit,
thUnit, mainUnit, thisGhcUnit, interactiveUnit :: Unit
primUnitId = UnitId (fsLit "ghc-prim")
bignumUnitId = UnitId (fsLit "ghc-bignum")
baseUnitId = UnitId (fsLit "base")
rtsUnitId = UnitId (fsLit "rts")
thisGhcUnitId = UnitId (fsLit "ghc")
interactiveUnitId = UnitId (fsLit "interactive")
thUnitId = UnitId (fsLit "template-haskell")
thUnit = RealUnit (Definite thUnitId)
primUnit = RealUnit (Definite primUnitId)
bignumUnit = RealUnit (Definite bignumUnitId)
baseUnit = RealUnit (Definite baseUnitId)
rtsUnit = RealUnit (Definite rtsUnitId)
thisGhcUnit = RealUnit (Definite thisGhcUnitId)
interactiveUnit = RealUnit (Definite interactiveUnitId)
mainUnitId = UnitId (fsLit "main")
mainUnit = RealUnit (Definite mainUnitId)
isInteractiveModule :: Module -> Bool
isInteractiveModule mod = moduleUnit mod == interactiveUnit
wiredInUnitIds :: [UnitId]
wiredInUnitIds =
[ primUnitId
, bignumUnitId
, baseUnitId
, rtsUnitId
, thUnitId
, thisGhcUnitId
]
data IsBootInterface = NotBoot | IsBoot
deriving (Eq, Ord, Show, Data)
instance Binary IsBootInterface where
put_ bh ib = put_ bh $
case ib of
NotBoot -> False
IsBoot -> True
get bh = do
b <- get bh
return $ case b of
False -> NotBoot
True -> IsBoot
data GenWithIsBoot mod = GWIB
{ gwib_mod :: mod
, gwib_isBoot :: IsBootInterface
} deriving ( Eq, Ord, Show
, Functor, Foldable, Traversable
)
type ModuleNameWithIsBoot = GenWithIsBoot ModuleName
type ModuleWithIsBoot = GenWithIsBoot Module
instance Binary a => Binary (GenWithIsBoot a) where
put_ bh (GWIB { gwib_mod, gwib_isBoot }) = do
put_ bh gwib_mod
put_ bh gwib_isBoot
get bh = do
gwib_mod <- get bh
gwib_isBoot <- get bh
pure $ GWIB { gwib_mod, gwib_isBoot }
instance Outputable a => Outputable (GenWithIsBoot a) where
ppr (GWIB { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of
IsBoot -> [ text "{-# SOURCE #-}" ]
NotBoot -> []