-- |
-- 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, recordError, getTVars )
import           Cryptol.TypeCheck.Error(Error(..))
import           Cryptol.Utils.Panic(panic)

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

data TyDecl =
    TS (P.TySyn Name) (Maybe String)          -- ^ Type synonym
  | NT (P.Newtype Name) (Maybe String)        -- ^ Newtype
  | AT (P.ParameterType Name) (Maybe String)  -- ^ Parameter type
  | PS (P.PropSyn Name) (Maybe String)        -- ^ Property synonym
  | PT (P.PrimType Name) (Maybe String)       -- ^ 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 String -> TyDecl -> TyDecl
setDocString :: Maybe String -> TyDecl -> TyDecl
setDocString x :: Maybe String
x d :: TyDecl
d =
  case TyDecl
d of
    TS a :: TySyn Name
a _ -> TySyn Name -> Maybe String -> TyDecl
TS TySyn Name
a Maybe String
x
    PS a :: PropSyn Name
a _ -> PropSyn Name -> Maybe String -> TyDecl
PS PropSyn Name
a Maybe String
x
    NT a :: Newtype Name
a _ -> Newtype Name -> Maybe String -> TyDecl
NT Newtype Name
a Maybe String
x
    AT a :: ParameterType Name
a _ -> ParameterType Name -> Maybe String -> TyDecl
AT ParameterType Name
a Maybe String
x
    PT a :: PrimType Name
a _ -> PrimType Name -> Maybe String -> TyDecl
PT PrimType Name
a Maybe String
x

-- | Check for duplicate and recursive type synonyms.
-- Returns the type-synonyms in dependency order.
orderTyDecls :: [TyDecl] -> InferM [TyDecl]
orderTyDecls :: [TyDecl] -> InferM [TyDecl]
orderTyDecls ts :: [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)
                              | (x :: Name
x,(t :: TyDecl
t,deps :: [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) ]
     [[TyDecl]] -> [TyDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[TyDecl]] -> [TyDecl]) -> InferM [[TyDecl]] -> InferM [TyDecl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (SCC TyDecl -> InferM [TyDecl])
-> [SCC TyDecl] -> InferM [[TyDecl]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SCC TyDecl -> InferM [TyDecl]
check [SCC TyDecl]
ordered

  where
  toMap :: Set Name -> TyDecl -> (Name, Located (TyDecl, [Name]))
toMap vs :: Set Name
vs ty :: TyDecl
ty@(PT p :: PrimType Name
p _) =
    let x :: Located Name
x       = PrimType Name -> Located Name
forall name. PrimType name -> Located name
P.primTName PrimType Name
p
        (as :: [TParam Name]
as,cs :: [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 _ ty :: TyDecl
ty@(AT a :: ParameterType Name
a _) =
    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 vs :: Set Name
vs ty :: TyDecl
ty@(NT (P.Newtype x :: Located Name
x as :: [TParam Name]
as fs :: [Named (Type Name)]
fs) _) =
    ( 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
$
                       (Named (Type Name) -> Set Name)
-> [Named (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)
-> (Named (Type Name) -> Type Name)
-> Named (Type Name)
-> Set Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named (Type Name) -> Type Name
forall a. Named a -> a
P.value) [Named (Type Name)]
fs
                  )
        }
    )

  toMap vs :: Set Name
vs ty :: TyDecl
ty@(TS (P.TySyn x :: Located Name
x _ as :: [TParam Name]
as t :: Type Name
t) _) =
        (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 vs :: Set Name
vs ty :: TyDecl
ty@(PS (P.PropSyn x :: Located Name
x _ as :: [TParam Name]
as ps :: [Prop Name]
ps) _) =
        (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 x :: TySyn Name
x _) = 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 x :: PropSyn Name
x _) = 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 x :: Newtype Name
x _) = 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 x :: ParameterType Name
x _) = 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 x :: PrimType Name
x _) = 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 -> InferM [TyDecl]
check (AcyclicSCC x :: TyDecl
x) = [TyDecl] -> 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 xs :: [TyDecl]
xs) =
    do Error -> InferM ()
recordError ([Name] -> Error
RecursiveTypeDecls ((TyDecl -> Name) -> [TyDecl] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyDecl -> Name
getN [TyDecl]
xs))
       [TyDecl] -> InferM [TyDecl]
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- XXX: This is likely to cause fake errors for missing
                 -- type synonyms. We could avoid this by, for example, checking
                 -- for recursive synonym errors, when looking up tycons.



-- | 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 bs :: [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 (defs :: [Located Name]
defs,uses :: 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 x :: 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 _                  = Maybe (Bind Name)
forall a. Maybe a
Nothing

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

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

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

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

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

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

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

  isTopDecl :: Decl Name -> Bool
isTopDecl _               = 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 ents :: [(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                    = [ 0 :: Integer .. ]

  mkGr :: b -> (a, b, [Name]) -> (a, b, [Integer])
mkGr i :: b
i (x :: a
x,_,uses :: [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 i :: b
i (_,defs :: [a]
defs,_)     = [ (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 ms :: [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 "combineMaps" ([String] -> InferM (Map Name (Located a)))
-> [String] -> InferM (Map Name (Located a))
forall a b. (a -> b) -> a -> b
$ "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 } | (x :: Name
x,a :: 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 m :: [(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 "combine" ([String] -> InferM (Map Name (Located a)))
-> [String] -> InferM (Map Name (Located a))
forall a b. (a -> b) -> a -> b
$ "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 } | (x :: Name
x,a :: 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@(x :: Located a
x : _ : _) = (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 _              = Maybe (a, [Range])
forall a. Maybe a
Nothing