    -- |
    -- Module      :  $Header$
    -- Copyright   :  (c) 2013-2015 Galois, Inc.
    -- License     :  BSD3
    -- Maintainer  :  cryptol@galois.com
    -- Stability   :  provisional
    -- Portability :  portable

    {-# LANGUAGE PatternGuards #-}
    module Cryptol.ModuleSystem.Interface (
        Iface(..)
      , IfaceDecls(..)
      , IfaceTySyn, ifTySynName
      , IfaceNewtype
      , IfaceDecl(..), mkIfaceDecl

      , shadowing
      , interpImport
      , unqualified
      , genIface
      ) where

    import           Cryptol.Parser.AST (mkQual)
    import           Cryptol.TypeCheck.AST

    import qualified Data.Map as Map

    #if __GLASGOW_HASKELL__ < 710
    import           Data.Monoid (Monoid(..))
    #endif

    -- | The resulting interface generated by a module that has been typechecked.
    data Iface = Iface
      { ifModName :: ModName
      , ifPublic  :: IfaceDecls
      , ifPrivate :: IfaceDecls
      } deriving (Show)

    data IfaceDecls = IfaceDecls
      { ifTySyns :: Map.Map QName    [IfaceTySyn]
      , ifNewtypes  :: Map.Map QName [IfaceNewtype]
      , ifDecls  :: Map.Map QName    [IfaceDecl]
      } deriving (Show)

    instance Monoid IfaceDecls where
      mempty      = IfaceDecls Map.empty Map.empty Map.empty
      mappend l r = IfaceDecls
        { ifTySyns   = Map.unionWith (mergeByName ifTySynName) (ifTySyns l)   (ifTySyns r)
        , ifNewtypes = Map.unionWith (mergeByName ntName)      (ifNewtypes l) (ifNewtypes r)
        , ifDecls    = Map.unionWith (mergeByName ifDeclName)  (ifDecls l)    (ifDecls r)
        }
      mconcat ds  = IfaceDecls
        { ifTySyns   = Map.unionsWith (mergeByName ifTySynName) (map ifTySyns ds)
        , ifNewtypes = Map.unionsWith (mergeByName ntName)      (map ifNewtypes ds)
        , ifDecls    = Map.unionsWith (mergeByName ifDeclName)  (map ifDecls  ds)
        }

    -- | Merge the entries in the simple case.
    mergeByName :: (a -> QName) -> [a] -> [a] -> [a]
    mergeByName f ls rs
      | [l] <- ls, [r] <- rs, f l == f r = ls
      | otherwise                        = ls ++ rs

    -- | Like mappend for IfaceDecls, but preferring entries on the left.
    shadowing :: IfaceDecls -> IfaceDecls -> IfaceDecls
    shadowing l r = IfaceDecls
      { ifTySyns = Map.union (ifTySyns l) (ifTySyns r)
      , ifNewtypes = Map.union (ifNewtypes l) (ifNewtypes r)
      , ifDecls  = Map.union (ifDecls  l) (ifDecls  r)
      }

    type IfaceTySyn = TySyn

    ifTySynName :: TySyn -> QName
    ifTySynName = tsName

    type IfaceNewtype = Newtype

    data IfaceDecl = IfaceDecl
      { ifDeclName    :: QName
      , ifDeclSig     :: Schema
      , ifDeclPragmas :: [Pragma]
      } deriving (Show)

    mkIfaceDecl :: Decl -> IfaceDecl
    mkIfaceDecl d = IfaceDecl
      { ifDeclName    = dName d
      , ifDeclSig     = dSignature d
      , ifDeclPragmas = dPragmas d
      }

    mapIfaceDecls :: (QName -> QName) -> IfaceDecls -> IfaceDecls
    mapIfaceDecls f decls = IfaceDecls
      { ifTySyns = Map.mapKeys f (ifTySyns decls)
      , ifNewtypes = Map.mapKeys f (ifNewtypes decls)
      , ifDecls  = Map.mapKeys f (ifDecls decls)
      }

    filterIfaceDecls :: (QName -> Bool) -> IfaceDecls -> IfaceDecls
    filterIfaceDecls p decls = IfaceDecls
      { ifTySyns = Map.filterWithKey check (ifTySyns decls)
      , ifNewtypes = Map.filterWithKey check (ifNewtypes decls)
      , ifDecls  = Map.filterWithKey check (ifDecls decls)
      }
      where
      check :: QName -> a -> Bool
      check k _ = p k

    unqualified :: IfaceDecls -> IfaceDecls
    unqualified  = mapIfaceDecls (mkUnqual . unqual)

    -- | Generate an Iface from a typechecked module.
    genIface :: Module -> Iface
    genIface m = Iface
      { ifModName = mName m
      , ifPublic  = IfaceDecls
        { ifTySyns = tsPub
        , ifNewtypes = ntPub
        , ifDecls  = dPub
        }
      , ifPrivate = IfaceDecls
        { ifTySyns = tsPriv
        , ifNewtypes = ntPriv
        , ifDecls  = dPriv
        }
      }
      where

      (tsPub,tsPriv) =
          Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
          $ fmap return (mTySyns m)

      (ntPub,ntPriv) =
          Map.partitionWithKey (\ qn _ -> qn `isExportedType` mExports m )
          $ fmap return (mNewtypes m)

      (dPub,dPriv) =
          Map.partitionWithKey (\ qn _ -> qn `isExportedBind` mExports m)
          $ Map.fromList [ (qn,[mkIfaceDecl d]) | dg <- mDecls m
                                                , d  <- groupDecls dg
                                                , let qn = dName d
                                                ]

    -- | Interpret an import declaration in the scope of the interface it targets.
    interpImport :: Import -> Iface -> Iface
    interpImport i iface = Iface
      { ifModName = ifModName iface
      , ifPublic  = qualify restricted
      , ifPrivate = mempty
      }
      where
      -- the initial set of names is {unqualified => qualified}
      public = unqualified (ifPublic iface)

      -- qualify imported names
      qualify | Just n <- iAs i = \ names -> qualifyNames n names
              | otherwise       = id

      -- interpret an import spec to quotient a naming map
      restricted
        | Just (Hiding names) <- iSpec i =
          let qnames = map mkUnqual names
           in filterIfaceDecls (\qn -> not (qn `elem` qnames)) public

        | Just (Only names) <- iSpec i =
          let qnames = map mkUnqual names
           in filterIfaceDecls (\qn -> qn `elem` qnames) public

        | otherwise = public

      -- this assumes that it's getting a list of _only_ unqualified names
      qualifyNames pfx = mapIfaceDecls (\ n -> mkQual pfx (unqual n))