{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PatternGuards              #-}
{-# LANGUAGE RankNTypes                 #-}

-- | This module defines the core data types for Backpack.  For more
-- details, see:
--
--  <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>

module Distribution.Backpack (
    -- * OpenUnitId
    OpenUnitId(..),
    openUnitIdFreeHoles,
    mkOpenUnitId,

    -- * DefUnitId
    DefUnitId,
    unDefUnitId,
    mkDefUnitId,

    -- * OpenModule
    OpenModule(..),
    openModuleFreeHoles,

    -- * OpenModuleSubst
    OpenModuleSubst,
    dispOpenModuleSubst,
    dispOpenModuleSubstEntry,
    parsecOpenModuleSubst,
    parsecOpenModuleSubstEntry,
    openModuleSubstFreeHoles,

    -- * Conversions to 'UnitId'
    abstractUnitId,
    hashModuleSubst,
) where

import Distribution.Compat.Prelude hiding (mod)
import Distribution.Parsec
import Distribution.Pretty
import Prelude ()
import Text.PrettyPrint            (hcat)

import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

import Distribution.ModuleName
import Distribution.Types.ComponentId
import Distribution.Types.Module
import Distribution.Types.UnitId
import Distribution.Utils.Base62

import qualified Data.Map as Map
import qualified Data.Set as Set

-----------------------------------------------------------------------
-- OpenUnitId

-- | An 'OpenUnitId' describes a (possibly partially) instantiated
-- Backpack component, with a description of how the holes are filled
-- in.  Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured
-- form that allows for substitution (which fills in holes.) This form
-- of unit cannot be installed. It must first be converted to a
-- 'UnitId'.
--
-- In the absence of Backpack, there are no holes to fill, so any such
-- component always has an empty module substitution; thus we can lossly
-- represent it as an 'OpenUnitId uid'.
--
-- For a source component using Backpack, however, there is more
-- structure as components may be parametrized over some signatures, and
-- these \"holes\" may be partially or wholly filled.
--
-- OpenUnitId plays an important role when we are mix-in linking,
-- and is recorded to the installed packaged database for indefinite
-- packages; however, for compiled packages that are fully instantiated,
-- we instantiate 'OpenUnitId' into 'UnitId'.
--
-- For more details see the Backpack spec
-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
--

data OpenUnitId
    -- | Identifies a component which may have some unfilled holes;
    -- specifying its 'ComponentId' and its 'OpenModuleSubst'.
    -- TODO: Invariant that 'OpenModuleSubst' is non-empty?
    -- See also the Text instance.
    = IndefFullUnitId ComponentId OpenModuleSubst
    -- | Identifies a fully instantiated component, which has
    -- been compiled and abbreviated as a hash.  The embedded 'UnitId'
    -- MUST NOT be for an indefinite component; an 'OpenUnitId'
    -- is guaranteed not to have any holes.
    | DefiniteUnitId DefUnitId
  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- TODO: cache holes?

instance Binary OpenUnitId
instance Structured OpenUnitId
instance NFData OpenUnitId where
    rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
    rnf (DefiniteUnitId uid) = rnf uid

instance Pretty OpenUnitId where
    pretty (IndefFullUnitId cid insts)
        -- TODO: arguably a smart constructor to enforce invariant would be
        -- better
        | Map.null insts = pretty cid
        | otherwise      = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)
    pretty (DefiniteUnitId uid) = pretty uid

-- |
--
-- >>> eitherParsec "foobar" :: Either String OpenUnitId
--Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
--
-- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId
-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName ["Str"],OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName ["Data","Text","Text"]))]))
--
instance Parsec OpenUnitId where
    parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
      where
        parseOpenUnitId = do
            cid <- parsec
            insts <- P.between (P.char '[') (P.char ']')
                       parsecOpenModuleSubst
            return (IndefFullUnitId cid insts)

-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts
openUnitIdFreeHoles _ = Set.empty

-- | Safe constructor from a UnitId.  The only way to do this safely
-- is if the instantiation is provided.
mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId uid cid insts =
    if Set.null (openModuleSubstFreeHoles insts)
        then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
        else IndefFullUnitId cid insts

-----------------------------------------------------------------------
-- DefUnitId

-- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation
-- with no holes.
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId cid insts =
    unsafeMkDefUnitId (mkUnitId
        (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts)))
        -- impose invariant!

-----------------------------------------------------------------------
-- OpenModule

-- | Unlike a 'Module', an 'OpenModule' is either an ordinary
-- module from some unit, OR an 'OpenModuleVar', representing a
-- hole that needs to be filled in.  Substitutions are over
-- module variables.
data OpenModule
    = OpenModule OpenUnitId ModuleName
    | OpenModuleVar ModuleName
  deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)

instance Binary OpenModule
instance Structured OpenModule

instance NFData OpenModule where
    rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
    rnf (OpenModuleVar mod_name) = rnf mod_name

instance Pretty OpenModule where
    pretty (OpenModule uid mod_name) =
        hcat [pretty uid, Disp.text ":", pretty mod_name]
    pretty (OpenModuleVar mod_name) =
        hcat [Disp.char '<', pretty mod_name, Disp.char '>']

-- |
--
-- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule
-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName ["Database","MySQL"]))
--
instance Parsec OpenModule where
    parsec = parsecModuleVar <|> parsecOpenModule
      where
        parsecOpenModule = do
            uid <- parsec
            _ <- P.char ':'
            mod_name <- parsec
            return (OpenModule uid mod_name)

        parsecModuleVar = do
            _ <- P.char '<'
            mod_name <- parsec
            _ <- P.char '>'
            return (OpenModuleVar mod_name)

-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
openModuleFreeHoles :: OpenModule -> Set ModuleName
openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name
openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid

-----------------------------------------------------------------------
-- OpenModuleSubst

-- | An explicit substitution on modules.
--
-- NB: These substitutions are NOT idempotent, for example, a
-- valid substitution is (A -> B, B -> A).
type OpenModuleSubst = Map ModuleName OpenModule

-- | Pretty-print the entries of a module substitution, suitable
-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.
dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc
dispOpenModuleSubst subst
    = Disp.hcat
    . Disp.punctuate Disp.comma
    $ map dispOpenModuleSubstEntry (Map.toAscList subst)

-- | Pretty-print a single entry of a module substitution.
dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc
dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v

-- | Inverse to 'dispModSubst'.
--
-- @since 2.2
parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst
parsecOpenModuleSubst = fmap Map.fromList
      . flip P.sepBy (P.char ',')
      $ parsecOpenModuleSubstEntry

-- | Inverse to 'dispModSubstEntry'.
--
-- @since 2.2
parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule)
parsecOpenModuleSubstEntry =
    do k <- parsec
       _ <- P.char '='
       v <- parsec
       return (k, v)

-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
-- This is NOT the domain of the substitution.
openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName
openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts))

-----------------------------------------------------------------------
-- Conversions to UnitId

-- | When typechecking, we don't demand that a freshly instantiated
-- 'IndefFullUnitId' be compiled; instead, we just depend on the
-- installed indefinite unit installed at the 'ComponentId'.
abstractUnitId :: OpenUnitId -> UnitId
abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid
abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid

-- | Take a module substitution and hash it into a string suitable for
-- 'UnitId'.  Note that since this takes 'Module', not 'OpenModule',
-- you are responsible for recursively converting 'OpenModule'
-- into 'Module'.  See also "Distribution.Backpack.ReadyComponent".
hashModuleSubst :: Map ModuleName Module -> Maybe String
hashModuleSubst subst
  | Map.null subst = Nothing
  | otherwise =
      Just . hashToBase62 $
        concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
               | (mod_name, m) <- Map.toList subst]