-- |
-- Module      :  Cryptol.TypeCheck.Depends
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE Safe #-}
{-# LANGUAGE FlexibleInstances #-}
module Cryptol.TypeCheck.Depends where

import           Cryptol.ModuleSystem.Name (Name)
import qualified Cryptol.Parser.AST as P
import           Cryptol.Parser.Position(Range, Located(..), thing)
import           Cryptol.Parser.Names (namesB, tnamesT, tnamesC,
                                      boundNamesSet, boundNames)
import           Cryptol.TypeCheck.Monad( InferM, getTVars )
import           Cryptol.TypeCheck.Error(Error(..))
import           Cryptol.Utils.Panic(panic)
import           Cryptol.Utils.RecordMap(recordElements)

import           Data.List(sortBy, groupBy)
import           Data.Function(on)
import           Data.Maybe(mapMaybe)
import           Data.Graph.SCC(stronglyConnComp)
import           Data.Graph (SCC(..))
import           Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import           Data.Text (Text)
import           MonadLib (ExceptionT, runExceptionT, raise)

data TyDecl =
    TS (P.TySyn Name) (Maybe Text)          -- ^ Type synonym
  | NT (P.Newtype Name) (Maybe Text)        -- ^ Newtype
  | AT (P.ParameterType Name) (Maybe Text)  -- ^ Parameter type
  | PS (P.PropSyn Name) (Maybe Text)        -- ^ Property synonym
  | PT (P.PrimType Name) (Maybe Text)       -- ^ A primitive/abstract typee
    deriving Int -> TyDecl -> ShowS
[TyDecl] -> ShowS
TyDecl -> String
(Int -> TyDecl -> ShowS)
-> (TyDecl -> String) -> ([TyDecl] -> ShowS) -> Show TyDecl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TyDecl] -> ShowS
$cshowList :: [TyDecl] -> ShowS
show :: TyDecl -> String
$cshow :: TyDecl -> String
showsPrec :: Int -> TyDecl -> ShowS
$cshowsPrec :: Int -> TyDecl -> ShowS
Show

setDocString :: Maybe Text -> TyDecl -> TyDecl
setDocString :: Maybe Text -> TyDecl -> TyDecl
setDocString Maybe Text
x TyDecl
d =
  case TyDecl
d of
    TS TySyn Name
a Maybe Text
_ -> TySyn Name -> Maybe Text -> TyDecl
TS TySyn Name
a Maybe Text
x
    PS PropSyn Name
a Maybe Text
_ -> PropSyn Name -> Maybe Text -> TyDecl
PS PropSyn Name
a Maybe Text
x
    NT Newtype Name
a Maybe Text
_ -> Newtype Name -> Maybe Text -> TyDecl
NT Newtype Name
a Maybe Text
x
    AT ParameterType Name
a Maybe Text
_ -> ParameterType Name -> Maybe Text -> TyDecl
AT ParameterType Name
a Maybe Text
x
    PT PrimType Name
a Maybe Text
_ -> PrimType Name -> Maybe Text -> TyDecl
PT PrimType Name
a Maybe Text
x

-- | Check for duplicate and recursive type synonyms.
-- Returns the type-synonyms in dependency order.
orderTyDecls :: [TyDecl] -> InferM (Either Error [TyDecl])
orderTyDecls :: [TyDecl] -> InferM (Either Error [TyDecl])
orderTyDecls [TyDecl]
ts =
  do Set Name
vs <- InferM (Set Name)
getTVars
     Map Name (Located (TyDecl, [Name]))
ds <- [(Name, Located (TyDecl, [Name]))]
-> InferM (Map Name (Located (TyDecl, [Name])))
forall a. [(Name, Located a)] -> InferM (Map Name (Located a))
combine ([(Name, Located (TyDecl, [Name]))]
 -> InferM (Map Name (Located (TyDecl, [Name]))))
-> [(Name, Located (TyDecl, [Name]))]
-> InferM (Map Name (Located (TyDecl, [Name])))
forall a b. (a -> b) -> a -> b
$ (TyDecl -> (Name, Located (TyDecl, [Name])))
-> [TyDecl] -> [(Name, Located (TyDecl, [Name]))]
forall a b. (a -> b) -> [a] -> [b]
map (Set Name -> TyDecl -> (Name, Located (TyDecl, [Name]))
toMap Set Name
vs) [TyDecl]
ts
     let ordered :: [SCC TyDecl]
ordered = [(TyDecl, [Name], [Name])] -> [SCC TyDecl]
forall a. [(a, [Name], [Name])] -> [SCC a]
mkScc [ (TyDecl
t,[Name
x],[Name]
deps)
                              | (Name
x,(TyDecl
t,[Name]
deps)) <- Map Name (TyDecl, [Name]) -> [(Name, (TyDecl, [Name]))]
forall k a. Map k a -> [(k, a)]
Map.toList ((Located (TyDecl, [Name]) -> (TyDecl, [Name]))
-> Map Name (Located (TyDecl, [Name])) -> Map Name (TyDecl, [Name])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Located (TyDecl, [Name]) -> (TyDecl, [Name])
forall a. Located a -> a
thing Map Name (Located (TyDecl, [Name]))
ds) ]
     ExceptionT Error InferM [TyDecl] -> InferM (Either Error [TyDecl])
forall i (m :: * -> *) a. ExceptionT i m a -> m (Either i a)
runExceptionT ([[TyDecl]] -> [TyDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TyDecl]] -> [TyDecl])
-> ExceptionT Error InferM [[TyDecl]]
-> ExceptionT Error InferM [TyDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SCC TyDecl -> ExceptionT Error InferM [TyDecl])
-> [SCC TyDecl] -> ExceptionT Error InferM [[TyDecl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SCC TyDecl -> ExceptionT Error InferM [TyDecl]
check [SCC TyDecl]
ordered)

  where
  toMap :: Set Name -> TyDecl -> (Name, Located (TyDecl, [Name]))
toMap Set Name
vs ty :: TyDecl
ty@(PT PrimType Name
p Maybe Text
_) =
    let x :: Located Name
x       = PrimType Name -> Located Name
forall name. PrimType name -> Located name
P.primTName PrimType Name
p
        ([TParam Name]
as,[Prop Name]
cs) = PrimType Name -> ([TParam Name], [Prop Name])
forall name. PrimType name -> ([TParam name], [Prop name])
P.primTCts PrimType Name
p
    in  ( Located Name -> Name
forall a. Located a -> a
thing Located Name
x
        , Located Name
x { thing :: (TyDecl, [Name])
thing = (TyDecl
ty, Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$
                           Set Name -> Set Name -> Set Name
forall name. Ord name => Set name -> Set name -> Set name
boundNamesSet Set Name
vs (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           [Name] -> Set Name -> Set Name
forall name. Ord name => [name] -> Set name -> Set name
boundNames ((TParam Name -> Name) -> [TParam Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TParam Name -> Name
forall n. TParam n -> n
P.tpName [TParam Name]
as) (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$
                           (Prop Name -> Set Name) -> [Prop Name] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
map Prop Name -> Set Name
forall name. Ord name => Prop name -> Set name
tnamesC [Prop Name]
cs
                      )
             }
        )


  toMap Set Name
_ ty :: TyDecl
ty@(AT ParameterType Name
a Maybe Text
_) =
    let x :: Located Name
x = ParameterType Name -> Located Name
forall name. ParameterType name -> Located name
P.ptName ParameterType Name
a
    in ( Located Name -> Name
forall a. Located a -> a
thing Located Name
x, Located Name
x { thing :: (TyDecl, [Name])
thing = (TyDecl
ty, []) } )

  toMap Set Name
vs ty :: TyDecl
ty@(NT (P.Newtype Located Name
x [TParam Name]
as Rec (Type Name)
fs) Maybe Text
_) =
    ( Located Name -> Name
forall a. Located a -> a
thing Located Name
x
    , Located Name
x { thing :: (TyDecl, [Name])
thing = (TyDecl
ty, Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$
                       Set Name -> Set Name -> Set Name
forall name. Ord name => Set name -> Set name -> Set name
boundNamesSet Set Name
vs (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                       [Name] -> Set Name -> Set Name
forall name. Ord name => [name] -> Set name -> Set name
boundNames ((TParam Name -> Name) -> [TParam Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TParam Name -> Name
forall n. TParam n -> n
P.tpName [TParam Name]
as) (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                       [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$
                       ((Range, Type Name) -> Set Name)
-> [(Range, Type Name)] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
map (Type Name -> Set Name
forall name. Ord name => Type name -> Set name
tnamesT (Type Name -> Set Name)
-> ((Range, Type Name) -> Type Name)
-> (Range, Type Name)
-> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range, Type Name) -> Type Name
forall a b. (a, b) -> b
snd) (Rec (Type Name) -> [(Range, Type Name)]
forall a b. RecordMap a b -> [b]
recordElements Rec (Type Name)
fs)
                  )
        }
    )

  toMap Set Name
vs ty :: TyDecl
ty@(TS (P.TySyn Located Name
x Maybe Fixity
_ [TParam Name]
as Type Name
t) Maybe Text
_) =
        (Located Name -> Name
forall a. Located a -> a
thing Located Name
x
        , Located Name
x { thing :: (TyDecl, [Name])
thing = (TyDecl
ty, Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$
                           Set Name -> Set Name -> Set Name
forall name. Ord name => Set name -> Set name -> Set name
boundNamesSet Set Name
vs (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           [Name] -> Set Name -> Set Name
forall name. Ord name => [name] -> Set name -> Set name
boundNames ((TParam Name -> Name) -> [TParam Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TParam Name -> Name
forall n. TParam n -> n
P.tpName [TParam Name]
as) (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           Type Name -> Set Name
forall name. Ord name => Type name -> Set name
tnamesT Type Name
t
                      )
             }
        )

  toMap Set Name
vs ty :: TyDecl
ty@(PS (P.PropSyn Located Name
x Maybe Fixity
_ [TParam Name]
as [Prop Name]
ps) Maybe Text
_) =
        (Located Name -> Name
forall a. Located a -> a
thing Located Name
x
        , Located Name
x { thing :: (TyDecl, [Name])
thing = (TyDecl
ty, Set Name -> [Name]
forall a. Set a -> [a]
Set.toList (Set Name -> [Name]) -> Set Name -> [Name]
forall a b. (a -> b) -> a -> b
$
                           Set Name -> Set Name -> Set Name
forall name. Ord name => Set name -> Set name -> Set name
boundNamesSet Set Name
vs (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           [Name] -> Set Name -> Set Name
forall name. Ord name => [name] -> Set name -> Set name
boundNames ((TParam Name -> Name) -> [TParam Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TParam Name -> Name
forall n. TParam n -> n
P.tpName [TParam Name]
as) (Set Name -> Set Name) -> Set Name -> Set Name
forall a b. (a -> b) -> a -> b
$
                           [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Name] -> Set Name) -> [Set Name] -> Set Name
forall a b. (a -> b) -> a -> b
$
                           (Prop Name -> Set Name) -> [Prop Name] -> [Set Name]
forall a b. (a -> b) -> [a] -> [b]
map Prop Name -> Set Name
forall name. Ord name => Prop name -> Set name
tnamesC [Prop Name]
ps
                      )
             }
        )
  getN :: TyDecl -> Name
getN (TS TySyn Name
x Maybe Text
_) = Located Name -> Name
forall a. Located a -> a
thing (TySyn Name -> Located Name
forall name. TySyn name -> Located name
P.tsName TySyn Name
x)
  getN (PS PropSyn Name
x Maybe Text
_) = Located Name -> Name
forall a. Located a -> a
thing (PropSyn Name -> Located Name
forall name. PropSyn name -> Located name
P.psName PropSyn Name
x)
  getN (NT Newtype Name
x Maybe Text
_) = Located Name -> Name
forall a. Located a -> a
thing (Newtype Name -> Located Name
forall name. Newtype name -> Located name
P.nName Newtype Name
x)
  getN (AT ParameterType Name
x Maybe Text
_) = Located Name -> Name
forall a. Located a -> a
thing (ParameterType Name -> Located Name
forall name. ParameterType name -> Located name
P.ptName ParameterType Name
x)
  getN (PT PrimType Name
x Maybe Text
_) = Located Name -> Name
forall a. Located a -> a
thing (PrimType Name -> Located Name
forall name. PrimType name -> Located name
P.primTName PrimType Name
x)

  check :: SCC TyDecl -> ExceptionT Error InferM [TyDecl]
  check :: SCC TyDecl -> ExceptionT Error InferM [TyDecl]
check (AcyclicSCC TyDecl
x) = [TyDecl] -> ExceptionT Error InferM [TyDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [TyDecl
x]

  -- We don't support any recursion, for now.
  -- We could support recursion between newtypes, or newtypes and tysysn.
  check (CyclicSCC [TyDecl]
xs) = Error -> ExceptionT Error InferM [TyDecl]
forall (m :: * -> *) i a. ExceptionM m i => i -> m a
raise ([Name] -> Error
RecursiveTypeDecls ((TyDecl -> Name) -> [TyDecl] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyDecl -> Name
getN [TyDecl]
xs))

-- | Associate type signatures with bindings and order bindings by dependency.
orderBinds :: [P.Bind Name] -> [SCC (P.Bind Name)]
orderBinds :: [Bind Name] -> [SCC (Bind Name)]
orderBinds [Bind Name]
bs = [(Bind Name, [Name], [Name])] -> [SCC (Bind Name)]
forall a. [(a, [Name], [Name])] -> [SCC a]
mkScc [ (Bind Name
b, (Located Name -> Name) -> [Located Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Located Name -> Name
forall a. Located a -> a
thing [Located Name]
defs, Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
uses)
                      | Bind Name
b <- [Bind Name]
bs
                      , let ([Located Name]
defs,Set Name
uses) = Bind Name -> ([Located Name], Set Name)
forall name. Ord name => Bind name -> ([Located name], Set name)
namesB Bind Name
b
                      ]

class FromDecl d where
  toBind             :: d -> Maybe (P.Bind Name)
  toParamFun         :: d -> Maybe (P.ParameterFun Name)
  toParamConstraints :: d -> [P.Located (P.Prop Name)]
  toTyDecl           :: d -> Maybe TyDecl
  isTopDecl          :: d -> Bool

instance FromDecl (P.TopDecl Name) where
  toBind :: TopDecl Name -> Maybe (Bind Name)
toBind (P.Decl TopLevel (Decl Name)
x)         = Decl Name -> Maybe (Bind Name)
forall d. FromDecl d => d -> Maybe (Bind Name)
toBind (TopLevel (Decl Name) -> Decl Name
forall a. TopLevel a -> a
P.tlValue TopLevel (Decl Name)
x)
  toBind TopDecl Name
_                  = Maybe (Bind Name)
forall a. Maybe a
Nothing

  toParamFun :: TopDecl Name -> Maybe (ParameterFun Name)
toParamFun (P.DParameterFun ParameterFun Name
d)  = ParameterFun Name -> Maybe (ParameterFun Name)
forall a. a -> Maybe a
Just ParameterFun Name
d
  toParamFun TopDecl Name
_                    = Maybe (ParameterFun Name)
forall a. Maybe a
Nothing

  toParamConstraints :: TopDecl Name -> [Located (Prop Name)]
toParamConstraints (P.DParameterConstraint [Located (Prop Name)]
xs) = [Located (Prop Name)]
xs
  toParamConstraints TopDecl Name
_                           = []

  toTyDecl :: TopDecl Name -> Maybe TyDecl
toTyDecl (P.DPrimType TopLevel (PrimType Name)
p)      = TyDecl -> Maybe TyDecl
forall a. a -> Maybe a
Just (PrimType Name -> Maybe Text -> TyDecl
PT (TopLevel (PrimType Name) -> PrimType Name
forall a. TopLevel a -> a
P.tlValue TopLevel (PrimType Name)
p) (Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (PrimType Name) -> Maybe (Located Text)
forall a. TopLevel a -> Maybe (Located Text)
P.tlDoc TopLevel (PrimType Name)
p))
  toTyDecl (P.DParameterType ParameterType Name
d) = TyDecl -> Maybe TyDecl
forall a. a -> Maybe a
Just (ParameterType Name -> Maybe Text -> TyDecl
AT ParameterType Name
d (ParameterType Name -> Maybe Text
forall name. ParameterType name -> Maybe Text
P.ptDoc ParameterType Name
d))
  toTyDecl (P.TDNewtype TopLevel (Newtype Name)
d)      = TyDecl -> Maybe TyDecl
forall a. a -> Maybe a
Just (Newtype Name -> Maybe Text -> TyDecl
NT (TopLevel (Newtype Name) -> Newtype Name
forall a. TopLevel a -> a
P.tlValue TopLevel (Newtype Name)
d) (Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (Newtype Name) -> Maybe (Located Text)
forall a. TopLevel a -> Maybe (Located Text)
P.tlDoc TopLevel (Newtype Name)
d))
  toTyDecl (P.Decl TopLevel (Decl Name)
x)           = Maybe Text -> TyDecl -> TyDecl
setDocString (Located Text -> Text
forall a. Located a -> a
thing (Located Text -> Text) -> Maybe (Located Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TopLevel (Decl Name) -> Maybe (Located Text)
forall a. TopLevel a -> Maybe (Located Text)
P.tlDoc TopLevel (Decl Name)
x)
                                  (TyDecl -> TyDecl) -> Maybe TyDecl -> Maybe TyDecl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decl Name -> Maybe TyDecl
forall d. FromDecl d => d -> Maybe TyDecl
toTyDecl (TopLevel (Decl Name) -> Decl Name
forall a. TopLevel a -> a
P.tlValue TopLevel (Decl Name)
x)
  toTyDecl TopDecl Name
_                    = Maybe TyDecl
forall a. Maybe a
Nothing

  isTopDecl :: TopDecl Name -> Bool
isTopDecl TopDecl Name
_               = Bool
True

instance FromDecl (P.Decl Name) where
  toBind :: Decl Name -> Maybe (Bind Name)
toBind (P.DLocated Decl Name
d Range
_) = Decl Name -> Maybe (Bind Name)
forall d. FromDecl d => d -> Maybe (Bind Name)
toBind Decl Name
d
  toBind (P.DBind Bind Name
b)      = Bind Name -> Maybe (Bind Name)
forall (m :: * -> *) a. Monad m => a -> m a
return Bind Name
b
  toBind Decl Name
_                = Maybe (Bind Name)
forall a. Maybe a
Nothing

  toParamFun :: Decl Name -> Maybe (ParameterFun Name)
toParamFun Decl Name
_ = Maybe (ParameterFun Name)
forall a. Maybe a
Nothing
  toParamConstraints :: Decl Name -> [Located (Prop Name)]
toParamConstraints Decl Name
_ = []

  toTyDecl :: Decl Name -> Maybe TyDecl
toTyDecl (P.DLocated Decl Name
d Range
_) = Decl Name -> Maybe TyDecl
forall d. FromDecl d => d -> Maybe TyDecl
toTyDecl Decl Name
d
  toTyDecl (P.DType TySyn Name
x)      = TyDecl -> Maybe TyDecl
forall a. a -> Maybe a
Just (TySyn Name -> Maybe Text -> TyDecl
TS TySyn Name
x Maybe Text
forall a. Maybe a
Nothing)
  toTyDecl (P.DProp PropSyn Name
x)      = TyDecl -> Maybe TyDecl
forall a. a -> Maybe a
Just (PropSyn Name -> Maybe Text -> TyDecl
PS PropSyn Name
x Maybe Text
forall a. Maybe a
Nothing)
  toTyDecl Decl Name
_                = Maybe TyDecl
forall a. Maybe a
Nothing

  isTopDecl :: Decl Name -> Bool
isTopDecl Decl Name
_               = Bool
False

{- | Given a list of declarations, annoted with (i) the names that they
define, and (ii) the names that they use, we compute a list of strongly
connected components of the declarations.  The SCCs are in dependency order. -}
mkScc :: [(a,[Name],[Name])] -> [SCC a]
mkScc :: [(a, [Name], [Name])] -> [SCC a]
mkScc [(a, [Name], [Name])]
ents = [(a, Integer, [Integer])] -> [SCC a]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp ([(a, Integer, [Integer])] -> [SCC a])
-> [(a, Integer, [Integer])] -> [SCC a]
forall a b. (a -> b) -> a -> b
$ (Integer -> (a, [Name], [Name]) -> (a, Integer, [Integer]))
-> [Integer] -> [(a, [Name], [Name])] -> [(a, Integer, [Integer])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> (a, [Name], [Name]) -> (a, Integer, [Integer])
forall b a b. b -> (a, b, [Name]) -> (a, b, [Integer])
mkGr [Integer]
keys [(a, [Name], [Name])]
ents
  where
  keys :: [Integer]
keys                    = [ Integer
0 :: Integer .. ]

  mkGr :: b -> (a, b, [Name]) -> (a, b, [Integer])
mkGr b
i (a
x,b
_,[Name]
uses)       = (a
x,b
i,(Name -> Maybe Integer) -> [Name] -> [Integer]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name -> Map Name Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Name Integer
nodeMap) [Name]
uses)

  -- Maps names to node ids.
  nodeMap :: Map Name Integer
nodeMap                 = [(Name, Integer)] -> Map Name Integer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Integer)] -> Map Name Integer)
-> [(Name, Integer)] -> Map Name Integer
forall a b. (a -> b) -> a -> b
$ [[(Name, Integer)]] -> [(Name, Integer)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Name, Integer)]] -> [(Name, Integer)])
-> [[(Name, Integer)]] -> [(Name, Integer)]
forall a b. (a -> b) -> a -> b
$ (Integer -> (a, [Name], [Name]) -> [(Name, Integer)])
-> [Integer] -> [(a, [Name], [Name])] -> [[(Name, Integer)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Integer -> (a, [Name], [Name]) -> [(Name, Integer)]
forall b a a c. b -> (a, [a], c) -> [(a, b)]
mkNode [Integer]
keys [(a, [Name], [Name])]
ents
  mkNode :: b -> (a, [a], c) -> [(a, b)]
mkNode b
i (a
_,[a]
defs,c
_)     = [ (a
d,b
i) | a
d <- [a]
defs ]

{- | Combine a bunch of definitions into a single map.  Here we check
that each name is defined only onces. -}
combineMaps :: [Map Name (Located a)] -> InferM (Map Name (Located a))
combineMaps :: [Map Name (Located a)] -> InferM (Map Name (Located a))
combineMaps [Map Name (Located a)]
ms = if [(Name, [Range])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, [Range])]
bad then Map Name (Located a) -> InferM (Map Name (Located a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Map Name (Located a)] -> Map Name (Located a)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [Map Name (Located a)]
ms)
                             else String -> [String] -> InferM (Map Name (Located a))
forall a. HasCallStack => String -> [String] -> a
panic String
"combineMaps" ([String] -> InferM (Map Name (Located a)))
-> [String] -> InferM (Map Name (Located a))
forall a b. (a -> b) -> a -> b
$ String
"Multiple definitions"
                                                      String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Name, [Range]) -> String) -> [(Name, [Range])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Range]) -> String
forall a. Show a => a -> String
show [(Name, [Range])]
bad
  where
  bad :: [(Name, [Range])]
bad = do Map Name (Located a)
m <- [Map Name (Located a)]
ms
           [Located Name] -> [(Name, [Range])]
forall a. Ord a => [Located a] -> [(a, [Range])]
duplicates [ Located a
a { thing :: Name
thing = Name
x } | (Name
x,Located a
a) <- Map Name (Located a) -> [(Name, Located a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Name (Located a)
m ]

{- | Combine a bunch of definitions into a single map.  Here we check
that each name is defined only onces. -}
combine :: [(Name, Located a)] -> InferM (Map Name (Located a))
combine :: [(Name, Located a)] -> InferM (Map Name (Located a))
combine [(Name, Located a)]
m = if [(Name, [Range])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, [Range])]
bad then Map Name (Located a) -> InferM (Map Name (Located a))
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Located a)] -> Map Name (Located a)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Name, Located a)]
m)
                        else String -> [String] -> InferM (Map Name (Located a))
forall a. HasCallStack => String -> [String] -> a
panic String
"combine" ([String] -> InferM (Map Name (Located a)))
-> [String] -> InferM (Map Name (Located a))
forall a b. (a -> b) -> a -> b
$ String
"Multiple definitions"
                                             String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((Name, [Range]) -> String) -> [(Name, [Range])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Range]) -> String
forall a. Show a => a -> String
show [(Name, [Range])]
bad
  where
  bad :: [(Name, [Range])]
bad = [Located Name] -> [(Name, [Range])]
forall a. Ord a => [Located a] -> [(a, [Range])]
duplicates [ Located a
a { thing :: Name
thing = Name
x } | (Name
x,Located a
a) <- [(Name, Located a)]
m ]

-- | Identify multiple occurances of something.
duplicates :: Ord a => [Located a] -> [(a,[Range])]
duplicates :: [Located a] -> [(a, [Range])]
duplicates = ([Located a] -> Maybe (a, [Range]))
-> [[Located a]] -> [(a, [Range])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Located a] -> Maybe (a, [Range])
forall a. [Located a] -> Maybe (a, [Range])
multiple
           ([[Located a]] -> [(a, [Range])])
-> ([Located a] -> [[Located a]]) -> [Located a] -> [(a, [Range])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located a -> Located a -> Bool) -> [Located a] -> [[Located a]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool)
-> (Located a -> a) -> Located a -> Located a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Located a -> a
forall a. Located a -> a
thing)
           ([Located a] -> [[Located a]])
-> ([Located a] -> [Located a]) -> [Located a] -> [[Located a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Located a -> Located a -> Ordering) -> [Located a] -> [Located a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a -> Ordering)
-> (Located a -> a) -> Located a -> Located a -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Located a -> a
forall a. Located a -> a
thing)
  where
  multiple :: [Located a] -> Maybe (a, [Range])
multiple xs :: [Located a]
xs@(Located a
x : Located a
_ : [Located a]
_) = (a, [Range]) -> Maybe (a, [Range])
forall a. a -> Maybe a
Just (Located a -> a
forall a. Located a -> a
thing Located a
x, (Located a -> Range) -> [Located a] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Located a -> Range
forall a. Located a -> Range
srcRange [Located a]
xs)
  multiple [Located a]
_              = Maybe (a, [Range])
forall a. Maybe a
Nothing