{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module MatchSigs.Sig
  ( FreeVarIdx
  , Sig(..)
  , sigsFromHie
  , sigFingerprint
  , isQual
  ) where

import           Control.Monad
import           Control.Monad.State
import qualified Data.ByteString as BS
import           Data.Either
import           Data.List
import qualified Data.Map.Strict as M
import qualified Data.Set as S

import           GHC.Api
import           Utils

type FreeVarIdx = Int

-- TODO linear types
-- | The internal representation of a type. Function types are represented as a
-- linked list with the init elems being the context followed by arguments of
-- the function and the last being the result type.
data Sig varIx
  = TyDescriptor !BS.ByteString !(Maybe Name)
  | FreeVar !varIx
  | Arg ![Sig varIx]
  | Qual ![Sig varIx]
  | Apply ![Sig varIx] ![[Sig varIx]]
  | VarCtx ![varIx]
  | Tuple ![[Sig varIx]]
  | KindSig ![Sig varIx] ![Sig varIx]
  deriving (Sig varIx -> Sig varIx -> Bool
forall varIx. Eq varIx => Sig varIx -> Sig varIx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sig varIx -> Sig varIx -> Bool
$c/= :: forall varIx. Eq varIx => Sig varIx -> Sig varIx -> Bool
== :: Sig varIx -> Sig varIx -> Bool
$c== :: forall varIx. Eq varIx => Sig varIx -> Sig varIx -> Bool
Eq, Sig varIx -> Sig varIx -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {varIx}. Ord varIx => Eq (Sig varIx)
forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Bool
forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Ordering
forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Sig varIx
min :: Sig varIx -> Sig varIx -> Sig varIx
$cmin :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Sig varIx
max :: Sig varIx -> Sig varIx -> Sig varIx
$cmax :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Sig varIx
>= :: Sig varIx -> Sig varIx -> Bool
$c>= :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Bool
> :: Sig varIx -> Sig varIx -> Bool
$c> :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Bool
<= :: Sig varIx -> Sig varIx -> Bool
$c<= :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Bool
< :: Sig varIx -> Sig varIx -> Bool
$c< :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Bool
compare :: Sig varIx -> Sig varIx -> Ordering
$ccompare :: forall varIx. Ord varIx => Sig varIx -> Sig varIx -> Ordering
Ord, forall a. Eq a => a -> Sig a -> Bool
forall a. Num a => Sig a -> a
forall a. Ord a => Sig a -> a
forall m. Monoid m => Sig m -> m
forall a. Sig a -> Bool
forall a. Sig a -> Int
forall a. Sig a -> [a]
forall a. (a -> a -> a) -> Sig a -> a
forall m a. Monoid m => (a -> m) -> Sig a -> m
forall b a. (b -> a -> b) -> b -> Sig a -> b
forall a b. (a -> b -> b) -> b -> Sig a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Sig a -> a
$cproduct :: forall a. Num a => Sig a -> a
sum :: forall a. Num a => Sig a -> a
$csum :: forall a. Num a => Sig a -> a
minimum :: forall a. Ord a => Sig a -> a
$cminimum :: forall a. Ord a => Sig a -> a
maximum :: forall a. Ord a => Sig a -> a
$cmaximum :: forall a. Ord a => Sig a -> a
elem :: forall a. Eq a => a -> Sig a -> Bool
$celem :: forall a. Eq a => a -> Sig a -> Bool
length :: forall a. Sig a -> Int
$clength :: forall a. Sig a -> Int
null :: forall a. Sig a -> Bool
$cnull :: forall a. Sig a -> Bool
toList :: forall a. Sig a -> [a]
$ctoList :: forall a. Sig a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Sig a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Sig a -> a
foldr1 :: forall a. (a -> a -> a) -> Sig a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Sig a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Sig a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Sig a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Sig a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Sig a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Sig a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Sig a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Sig a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Sig a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Sig a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Sig a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Sig a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Sig a -> m
fold :: forall m. Monoid m => Sig m -> m
$cfold :: forall m. Monoid m => Sig m -> m
Foldable, forall a b. a -> Sig b -> Sig a
forall a b. (a -> b) -> Sig a -> Sig b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Sig b -> Sig a
$c<$ :: forall a b. a -> Sig b -> Sig a
fmap :: forall a b. (a -> b) -> Sig a -> Sig b
$cfmap :: forall a b. (a -> b) -> Sig a -> Sig b
Functor)

instance Show varIx => Show (Sig varIx) where
  show :: Sig varIx -> String
show (TyDescriptor ByteString
fs Maybe Name
_) = String
"TyDescriptor " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
fs
  show (FreeVar varIx
ix) = String
"Var " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show varIx
ix
  show (Arg [Sig varIx]
a) = forall a. Show a => a -> String
show [Sig varIx]
a forall a. Semigroup a => a -> a -> a
<> String
" -> "
  show (Qual [Sig varIx]
q) = forall a. Show a => a -> String
show [Sig varIx]
q forall a. Semigroup a => a -> a -> a
<> String
" => "
  show (Apply [Sig varIx]
c [[Sig varIx]]
args) = String
"App " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [Sig varIx]
c forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [[Sig varIx]]
args
  show (VarCtx [varIx]
a) = String
"forall " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [varIx]
a forall a. Semigroup a => a -> a -> a
<> String
". "
  show (Tuple [[Sig varIx]]
t) = String
"Tuple " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [[Sig varIx]]
t
  show (KindSig [Sig varIx]
x [Sig varIx]
s) = forall a. Show a => a -> String
show [Sig varIx]
x forall a. Semigroup a => a -> a -> a
<> String
" :: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show [Sig varIx]
s

isQual :: Sig a -> Bool
isQual :: forall a. Sig a -> Bool
isQual (Qual [Sig a]
_) = Bool
True
isQual Sig a
_ = Bool
False

isVarDecl :: Sig a -> Bool
isVarDecl :: forall a. Sig a -> Bool
isVarDecl (VarCtx [a]
_) = Bool
True
isVarDecl Sig a
_ = Bool
False

-- | Produce a 'Map' from function 'Name's to their type signature's
-- internal representation.
sigsFromHie :: HieAST a -> M.Map Name [Sig FreeVarIdx]
sigsFromHie :: forall a. HieAST a -> Map Name [Sig Int]
sigsFromHie HieAST a
node
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"TypeSig" String
"Sig" HieAST a
node
  , HieAST a
identNode : HieAST a
sigNode : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  , Right Name
name : [Identifier]
_ <- forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> NodeInfo a
getNodeInfo HieAST a
identNode
  , let freeVars :: Map Name Int
freeVars = Map Name Int
extractFreeVars
  , let sig :: [Sig Int]
sig = forall s a. State s a -> s -> a
evalState (forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
sigNode) Map Name Int
freeVars
        sig' :: [Sig Int]
sig' | forall k a. Map k a -> Bool
M.null Map Name Int
freeVars = [Sig Int]
sig
             | Bool
otherwise = forall varIx. [varIx] -> Sig varIx
VarCtx (forall k a. Map k a -> [a]
M.elems Map Name Int
freeVars) forall a. a -> [a] -> [a]
: [Sig Int]
sig
        -- move qualifiers and var decls to front, collapsing var decls
        sig'' :: [Sig Int]
sig'' = forall a. [Sig a] -> [Sig a]
frontLoadVarDecls forall a b. (a -> b) -> a -> b
$ forall a. [Sig a] -> [Sig a]
frontLoadQuals [Sig Int]
sig'
  , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Sig Int]
sig''
  = forall k a. k -> a -> Map k a
M.singleton Name
name [Sig Int]
sig''

  | Bool
otherwise = forall a. Monoid a => a
mempty

  where
    extractFreeVars :: Map Name Int
extractFreeVars = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..])
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> [b]
rights forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [k]
M.keys
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
                    forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> NodeInfo a
getNodeInfo HieAST a
node

-- | Traverses the 'HieAST', building the representation for a function sig.
-- The `State` is for tracking free vars.
mkSig :: HieAST a -> State (M.Map Name FreeVarIdx) [Sig FreeVarIdx]
mkSig :: forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
node
  -- function ty
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsFunTy" String
"HsType" HieAST a
node
  , HieAST a
arg : HieAST a
rest : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Sig Int]
sigArg <- forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
arg
    -- curry tuple arguments
    let sigArg' :: [Sig Int]
sigArg' = case [Sig Int]
sigArg of
                    [Tuple [[Sig Int]]
xs] | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Sig Int]]
xs) -> forall varIx. [Sig varIx] -> Sig varIx
Arg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig Int]]
xs
                    [Sig Int]
a -> [forall varIx. [Sig varIx] -> Sig varIx
Arg [Sig Int]
a]
    ([Sig Int]
sigArg' forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
rest

  -- application
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsAppTy" String
"HsType" HieAST a
node
  , HieAST a
con : [HieAST a]
rest <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall varIx. [Sig varIx] -> [[Sig varIx]] -> Sig varIx
Apply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
con
                       forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig [HieAST a]
rest

  -- constraint (qualifier)
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsQualTy" String
"HsType" HieAST a
node
  , HieAST a
constraint : HieAST a
rest : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Sig Int]
quals <- forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkQuals HieAST a
constraint
    ([Sig Int]
quals forall a. [a] -> [a] -> [a]
++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
rest

  -- parens
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsParTy" String
"HsType" HieAST a
node
  , HieAST a
child : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
child

  -- free var decl
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsForAllTy" String
"HsType" HieAST a
node
  , HieAST a
rest : [HieAST a]
userVarNodes <- forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Int]
vars <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {a}.
MonadState (Map Name Int) m =>
[Int] -> HieAST a -> m [Int]
extractFreeVar [] [HieAST a]
userVarNodes
    (forall varIx. [varIx] -> Sig varIx
VarCtx [Int]
vars forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
rest

  -- tuples
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsTupleTy" String
"HsType" HieAST a
node
  , let children :: [HieAST a]
children = forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall varIx. [[Sig varIx]] -> Sig varIx
Tuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig [HieAST a]
children

  -- list ty
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsListTy" String
"HsType" HieAST a
node
  , HieAST a
child : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Sig Int]
c <- forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
child
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall varIx. [Sig varIx] -> [[Sig varIx]] -> Sig varIx
Apply [forall varIx. ByteString -> Maybe Name -> Sig varIx
TyDescriptor ByteString
"HsListTy" forall a. Maybe a
Nothing] [[Sig Int]
c]]

  -- kind sigs
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsKindSig" String
"HsType" HieAST a
node
  , HieAST a
ty : HieAST a
ki : [HieAST a]
_ <- forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[])
  forall a b. (a -> b) -> a -> b
$ forall varIx. [Sig varIx] -> [Sig varIx] -> Sig varIx
KindSig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
ty
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
ki

  -- hs sig
  | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsSig" String
"HsSigType" HieAST a
node
  , HieAST a
rest : [HieAST a]
userVarNodes <- forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Int]
vars <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {m :: * -> *} {a}.
MonadState (Map Name Int) m =>
[Int] -> HieAST a -> m [Int]
extractFreeVar [] [HieAST a]
userVarNodes
    (forall varIx. [varIx] -> Sig varIx
VarCtx [Int]
vars forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
rest

  -- any other type
#if MIN_VERSION_ghc(9,2,0)
  | NodeAnnotation FastString
ty FastString
"HsType"
#else
  | (ty, "HsType")
#endif
      : [NodeAnnotation]
_ <- forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> NodeInfo a
getNodeInfo HieAST a
node
  , let mbName :: Maybe Name
mbName = forall a. HieAST a -> Maybe Name
extractName HieAST a
node
  = do
    Map Name Int
freeVars <- forall s (m :: * -> *). MonadState s m => m s
get
    case Maybe Name
mbName of
      Just Name
name
        | Just Int
idx <- Map Name Int
freeVars forall k a. Ord k => Map k a -> k -> Maybe a
M.!? Name
name
        -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall varIx. varIx -> Sig varIx
FreeVar Int
idx]
      Maybe Name
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall varIx. ByteString -> Maybe Name -> Sig varIx
TyDescriptor
#if MIN_VERSION_ghc(8,10,0)
                   (FastString -> ByteString
bytesFS FastString
ty)
#else
                   (fastStringToByteString ty)
#endif
                   Maybe Name
mbName ]

  | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure []

  where
    extractName :: HieAST a -> Maybe Name
    extractName :: forall a. HieAST a -> Maybe Name
extractName HieAST a
n
      | Right Name
name : [Identifier]
_ <- forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> NodeInfo a
getNodeInfo HieAST a
n
      = forall a. a -> Maybe a
Just Name
name
      | Bool
otherwise = forall a. Maybe a
Nothing

    extractFreeVar :: [Int] -> HieAST a -> m [Int]
extractFreeVar [Int]
ixs HieAST a
n
      | forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"UserTyVar" String
"HsTyVarBndr" HieAST a
n
      , Just Name
name <- forall a. HieAST a -> Maybe Name
extractName HieAST a
n
      = do
        Int
ix <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall k a. Map k a -> Int
M.size
        Int
ix forall a. a -> [a] -> [a]
: [Int]
ixs forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name Int
ix)
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int]
ixs

    -- produce one ore more Quals from a constraint node
    mkQuals :: HieAST a -> State (Map Name Int) [Sig Int]
mkQuals HieAST a
c
      | forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NodeInfo a -> Set NodeAnnotation
nodeAnnotations forall a b. (a -> b) -> a -> b
$ forall a. HieAST a -> NodeInfo a
getNodeInfo HieAST a
c
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall varIx. [Sig varIx] -> Sig varIx
Qual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig (forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
c)
      | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) forall a b. (a -> b) -> a -> b
$ forall varIx. [Sig varIx] -> Sig varIx
Qual forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
c

-- | Recursively transform a '[Sig a]'.
recurseSig :: ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig :: forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f = [Sig a] -> [Sig a]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Sig a -> Sig a
go where
  go :: Sig a -> Sig a
go (Arg [Sig a]
s) = forall varIx. [Sig varIx] -> Sig varIx
Arg forall a b. (a -> b) -> a -> b
$ forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
s
  go (Qual [Sig a]
s) = forall varIx. [Sig varIx] -> Sig varIx
Qual forall a b. (a -> b) -> a -> b
$ forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
s
  go (Apply [Sig a]
a [[Sig a]]
as) =
    forall varIx. [Sig varIx] -> [[Sig varIx]] -> Sig varIx
Apply (forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
a)
          (forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig a]]
as)
  go (Tuple [[Sig a]]
es) =
    forall varIx. [[Sig varIx]] -> Sig varIx
Tuple (forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig a]]
es)
  go (KindSig [Sig a]
ty [Sig a]
ks) =
    forall varIx. [Sig varIx] -> [Sig varIx] -> Sig varIx
KindSig (forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
ty)
            (forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
ks)
  go x :: Sig a
x@TyDescriptor{} = Sig a
x
  go x :: Sig a
x@FreeVar{} = Sig a
x
  go x :: Sig a
x@VarCtx{} = Sig a
x

-- | Used to produce an orderable key for matching up signatures that are
-- likely to be equivalent. To allow for this, free vars must be homogenized
-- which is what 'void' does here.
sigFingerprint :: [Sig a] -> [Sig ()]
sigFingerprint :: forall a. [Sig a] -> [Sig ()]
sigFingerprint = forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig ()] -> [Sig ()]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Functor f => f a -> f ()
void
  where
    go :: [Sig ()] -> [Sig ()]
go = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {varIx}. Ord varIx => Sig varIx -> Sig varIx
sortTuple
    sortTuple :: Sig varIx -> Sig varIx
sortTuple (Tuple [[Sig varIx]]
es) = forall varIx. [[Sig varIx]] -> Sig varIx
Tuple forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [[Sig varIx]]
es
    sortTuple Sig varIx
x = Sig varIx
x

-- | Move qualifiers to the front of a sig, and recursively for sub-sigs
frontLoadQuals :: [Sig a] -> [Sig a]
frontLoadQuals :: forall a. [Sig a] -> [Sig a]
frontLoadQuals = forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig forall a. [Sig a] -> [Sig a]
go where
  go :: [Sig a] -> [Sig a]
go = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a. Sig a -> Bool
isQual

-- | Move free var decls to the front of a sig, and recursively for sub-sigs
frontLoadVarDecls :: [Sig a] -> [Sig a]
frontLoadVarDecls :: forall a. [Sig a] -> [Sig a]
frontLoadVarDecls = forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig forall a. [Sig a] -> [Sig a]
go
  where
  go :: [Sig varIx] -> [Sig varIx]
go [Sig varIx]
sig =
    let ([Sig varIx]
varSigs, [Sig varIx]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition forall a. Sig a -> Bool
isVarDecl [Sig varIx]
sig
     in forall varIx. [Sig varIx] -> Sig varIx
collapseVarCtx [Sig varIx]
varSigs forall a. a -> [a] -> [a]
: [Sig varIx]
rest

  collapseVarCtx :: [Sig varIx] -> Sig varIx
collapseVarCtx = forall varIx. [varIx] -> Sig varIx
VarCtx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Sig a -> [a]
getVars
  getVars :: Sig varIx -> [varIx]
getVars (VarCtx [varIx]
vs) = [varIx]
vs
  getVars Sig varIx
_ = []