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

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

import           HieTypes

import           Name
import           FastString
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 !FastString !(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
(Sig varIx -> Sig varIx -> Bool)
-> (Sig varIx -> Sig varIx -> Bool) -> Eq (Sig varIx)
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, Eq (Sig varIx)
Eq (Sig varIx)
-> (Sig varIx -> Sig varIx -> Ordering)
-> (Sig varIx -> Sig varIx -> Bool)
-> (Sig varIx -> Sig varIx -> Bool)
-> (Sig varIx -> Sig varIx -> Bool)
-> (Sig varIx -> Sig varIx -> Bool)
-> (Sig varIx -> Sig varIx -> Sig varIx)
-> (Sig varIx -> Sig varIx -> Sig varIx)
-> Ord (Sig varIx)
Sig varIx -> Sig varIx -> Bool
Sig varIx -> Sig varIx -> Ordering
Sig varIx -> Sig varIx -> Sig varIx
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
$cp1Ord :: forall varIx. Ord varIx => Eq (Sig varIx)
Ord, Sig a -> Bool
(a -> m) -> Sig a -> m
(a -> b -> b) -> b -> Sig a -> b
(forall m. Monoid m => Sig m -> m)
-> (forall m a. Monoid m => (a -> m) -> Sig a -> m)
-> (forall m a. Monoid m => (a -> m) -> Sig a -> m)
-> (forall a b. (a -> b -> b) -> b -> Sig a -> b)
-> (forall a b. (a -> b -> b) -> b -> Sig a -> b)
-> (forall b a. (b -> a -> b) -> b -> Sig a -> b)
-> (forall b a. (b -> a -> b) -> b -> Sig a -> b)
-> (forall a. (a -> a -> a) -> Sig a -> a)
-> (forall a. (a -> a -> a) -> Sig a -> a)
-> (forall a. Sig a -> [a])
-> (forall a. Sig a -> Bool)
-> (forall a. Sig a -> Int)
-> (forall a. Eq a => a -> Sig a -> Bool)
-> (forall a. Ord a => Sig a -> a)
-> (forall a. Ord a => Sig a -> a)
-> (forall a. Num a => Sig a -> a)
-> (forall a. Num a => Sig a -> a)
-> Foldable Sig
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 :: Sig a -> a
$cproduct :: forall a. Num a => Sig a -> a
sum :: Sig a -> a
$csum :: forall a. Num a => Sig a -> a
minimum :: Sig a -> a
$cminimum :: forall a. Ord a => Sig a -> a
maximum :: Sig a -> a
$cmaximum :: forall a. Ord a => Sig a -> a
elem :: a -> Sig a -> Bool
$celem :: forall a. Eq a => a -> Sig a -> Bool
length :: Sig a -> Int
$clength :: forall a. Sig a -> Int
null :: Sig a -> Bool
$cnull :: forall a. Sig a -> Bool
toList :: Sig a -> [a]
$ctoList :: forall a. Sig a -> [a]
foldl1 :: (a -> a -> a) -> Sig a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Sig a -> a
foldr1 :: (a -> a -> a) -> Sig a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Sig a -> a
foldl' :: (b -> a -> b) -> b -> Sig a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Sig a -> b
foldl :: (b -> a -> b) -> b -> Sig a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Sig a -> b
foldr' :: (a -> b -> b) -> b -> Sig a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Sig a -> b
foldr :: (a -> b -> b) -> b -> Sig a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Sig a -> b
foldMap' :: (a -> m) -> Sig a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Sig a -> m
foldMap :: (a -> m) -> Sig a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Sig a -> m
fold :: Sig m -> m
$cfold :: forall m. Monoid m => Sig m -> m
Foldable, a -> Sig b -> Sig a
(a -> b) -> Sig a -> Sig b
(forall a b. (a -> b) -> Sig a -> Sig b)
-> (forall a b. a -> Sig b -> Sig a) -> Functor Sig
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
<$ :: a -> Sig b -> Sig a
$c<$ :: forall a b. a -> Sig b -> Sig a
fmap :: (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 FastString
fs Maybe Name
_) = String
"TyDescriptor " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FastString -> String
forall a. Show a => a -> String
show FastString
fs
  show (FreeVar varIx
ix) = String
"Var " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> varIx -> String
forall a. Show a => a -> String
show varIx
ix
  show (Arg [Sig varIx]
a) = [Sig varIx] -> String
forall a. Show a => a -> String
show [Sig varIx]
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> "
  show (Qual [Sig varIx]
q) = [Sig varIx] -> String
forall a. Show a => a -> String
show [Sig varIx]
q String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" => "
  show (Apply [Sig varIx]
c [[Sig varIx]]
args) = String
"App " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Sig varIx] -> String
forall a. Show a => a -> String
show [Sig varIx]
c String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Sig varIx]] -> String
forall a. Show a => a -> String
show [[Sig varIx]]
args
  show (VarCtx [varIx]
a) = String
"forall " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [varIx] -> String
forall a. Show a => a -> String
show [varIx]
a String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". "
  show (Tuple [[Sig varIx]]
t) = String
"Tuple " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [[Sig varIx]] -> String
forall a. Show a => a -> String
show [[Sig varIx]]
t
  show (KindSig [Sig varIx]
x [Sig varIx]
s) = [Sig varIx] -> String
forall a. Show a => a -> String
show [Sig varIx]
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" :: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Sig varIx] -> String
forall a. Show a => a -> String
show [Sig varIx]
s

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

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

  | Bool
otherwise = Map Name [Sig Int]
forall a. Monoid a => a
mempty

  where
    extractFreeVars :: Map Name Int
extractFreeVars = [(Name, Int)] -> Map Name Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Name, Int)] -> Map Name Int)
-> (NodeInfo a -> [(Name, Int)]) -> NodeInfo a -> Map Name Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name] -> [Int] -> [(Name, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..])
                    ([Name] -> [(Name, Int)])
-> (NodeInfo a -> [Name]) -> NodeInfo a -> [(Name, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier] -> [Name]
forall a b. [Either a b] -> [b]
rights ([Identifier] -> [Name])
-> (NodeInfo a -> [Identifier]) -> NodeInfo a -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Identifier (IdentifierDetails a) -> [Identifier]
forall k a. Map k a -> [k]
M.keys
                    (Map Identifier (IdentifierDetails a) -> [Identifier])
-> (NodeInfo a -> Map Identifier (IdentifierDetails a))
-> NodeInfo a
-> [Identifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo a -> Map Identifier (IdentifierDetails a)
forall a. NodeInfo a -> NodeIdentifiers a
nodeIdentifiers
                    (NodeInfo a -> Map Name Int) -> NodeInfo a -> Map Name Int
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo 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 :: HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
node
  -- function ty
  | String -> String -> HieAST a -> Bool
forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"HsFunTy" String
"HsType" HieAST a
node
  , HieAST a
arg : HieAST a
rest : [HieAST a]
_ <- HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
node
  = do
    [Sig Int]
sigArg <- HieAST a -> State (Map Name Int) [Sig Int]
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 ([[Sig Int]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Sig Int]]
xs) -> [Sig Int] -> Sig Int
forall varIx. [Sig varIx] -> Sig varIx
Arg ([Sig Int] -> Sig Int) -> [[Sig Int]] -> [Sig Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig Int]]
xs
                    [Sig Int]
a -> [[Sig Int] -> Sig Int
forall varIx. [Sig varIx] -> Sig varIx
Arg [Sig Int]
a]
    ([Sig Int]
sigArg' [Sig Int] -> [Sig Int] -> [Sig Int]
forall a. [a] -> [a] -> [a]
++) ([Sig Int] -> [Sig Int])
-> State (Map Name Int) [Sig Int] -> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieAST a -> State (Map Name Int) [Sig Int]
forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig HieAST a
rest

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

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

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

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

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

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

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

  -- any other type
  | (FastString
ty, FastString
"HsType") : [(FastString, FastString)]
_ <- Set (FastString, FastString) -> [(FastString, FastString)]
forall a. Set a -> [a]
S.toList (Set (FastString, FastString) -> [(FastString, FastString)])
-> (NodeInfo a -> Set (FastString, FastString))
-> NodeInfo a
-> [(FastString, FastString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo a -> Set (FastString, FastString)
forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations (NodeInfo a -> [(FastString, FastString)])
-> NodeInfo a -> [(FastString, FastString)]
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo HieAST a
node
  , let mbName :: Maybe Name
mbName = HieAST a -> Maybe Name
forall a. HieAST a -> Maybe Name
extractName HieAST a
node
  = do
    Map Name Int
freeVars <- StateT (Map Name Int) Identity (Map Name Int)
forall s (m :: * -> *). MonadState s m => m s
get
    case Maybe Name
mbName of
      Just Name
name
        | Just Int
idx <- Map Name Int
freeVars Map Name Int -> Name -> Maybe Int
forall k a. Ord k => Map k a -> k -> Maybe a
M.!? Name
name
        -> [Sig Int] -> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Int -> Sig Int
forall varIx. varIx -> Sig varIx
FreeVar Int
idx]
      Maybe Name
_ -> [Sig Int] -> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FastString -> Maybe Name -> Sig Int
forall varIx. FastString -> Maybe Name -> Sig varIx
TyDescriptor FastString
ty Maybe Name
mbName]

  | Bool
otherwise = [Sig Int] -> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

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

    extractFreeVar :: [Int] -> HieAST a -> m [Int]
extractFreeVar [Int]
ixs HieAST a
n
      | String -> String -> HieAST a -> Bool
forall a. String -> String -> HieAST a -> Bool
nodeHasAnnotation String
"UserTyVar" String
"HsTyVarBndr" HieAST a
n
      , Just Name
name <- HieAST a -> Maybe Name
forall a. HieAST a -> Maybe Name
extractName HieAST a
n
      = do
        Int
ix <- (Map Name Int -> Int) -> m Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Map Name Int -> Int
forall k a. Map k a -> Int
M.size
        Int
ix Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
ixs [Int] -> m () -> m [Int]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Map Name Int -> Map Name Int) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (Name -> Int -> Map Name Int -> Map Name Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name Int
ix)
      | Bool
otherwise = [Int] -> m [Int]
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
      | Set (FastString, FastString) -> Bool
forall a. Set a -> Bool
S.null (Set (FastString, FastString) -> Bool)
-> (NodeInfo a -> Set (FastString, FastString))
-> NodeInfo a
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeInfo a -> Set (FastString, FastString)
forall a. NodeInfo a -> Set (FastString, FastString)
nodeAnnotations (NodeInfo a -> Bool) -> NodeInfo a -> Bool
forall a b. (a -> b) -> a -> b
$ HieAST a -> NodeInfo a
forall a. HieAST a -> NodeInfo a
nodeInfo HieAST a
c
      = ([Sig Int] -> Sig Int) -> [[Sig Int]] -> [Sig Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Sig Int] -> Sig Int
forall varIx. [Sig varIx] -> Sig varIx
Qual ([[Sig Int]] -> [Sig Int])
-> StateT (Map Name Int) Identity [[Sig Int]]
-> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (HieAST a -> State (Map Name Int) [Sig Int])
-> [HieAST a] -> StateT (Map Name Int) Identity [[Sig Int]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse HieAST a -> State (Map Name Int) [Sig Int]
forall a. HieAST a -> State (Map Name Int) [Sig Int]
mkSig (HieAST a -> [HieAST a]
forall a. HieAST a -> [HieAST a]
nodeChildren HieAST a
c)
      | Bool
otherwise = (Sig Int -> [Sig Int])
-> StateT (Map Name Int) Identity (Sig Int)
-> State (Map Name Int) [Sig Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Sig Int -> [Sig Int] -> [Sig Int]
forall a. a -> [a] -> [a]
:[]) (StateT (Map Name Int) Identity (Sig Int)
 -> State (Map Name Int) [Sig Int])
-> StateT (Map Name Int) Identity (Sig Int)
-> State (Map Name Int) [Sig Int]
forall a b. (a -> b) -> a -> b
$ [Sig Int] -> Sig Int
forall varIx. [Sig varIx] -> Sig varIx
Qual ([Sig Int] -> Sig Int)
-> State (Map Name Int) [Sig Int]
-> StateT (Map Name Int) Identity (Sig Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HieAST a -> State (Map Name Int) [Sig Int]
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 :: ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f = [Sig a] -> [Sig a]
f ([Sig a] -> [Sig a]) -> ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig a -> Sig a) -> [Sig a] -> [Sig a]
forall a b. (a -> b) -> [a] -> [b]
map Sig a -> Sig a
go where
  go :: Sig a -> Sig a
go (Arg [Sig a]
s) = [Sig a] -> Sig a
forall varIx. [Sig varIx] -> Sig varIx
Arg ([Sig a] -> Sig a) -> [Sig a] -> Sig a
forall a b. (a -> b) -> a -> b
$ ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
s
  go (Qual [Sig a]
s) = [Sig a] -> Sig a
forall varIx. [Sig varIx] -> Sig varIx
Qual ([Sig a] -> Sig a) -> [Sig a] -> Sig a
forall a b. (a -> b) -> a -> b
$ ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
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) =
    [Sig a] -> [[Sig a]] -> Sig a
forall varIx. [Sig varIx] -> [[Sig varIx]] -> Sig varIx
Apply (([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
a)
          (([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f ([Sig a] -> [Sig a]) -> [[Sig a]] -> [[Sig a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig a]]
as)
  go (Tuple [[Sig a]]
es) =
    [[Sig a]] -> Sig a
forall varIx. [[Sig varIx]] -> Sig varIx
Tuple (([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f ([Sig a] -> [Sig a]) -> [[Sig a]] -> [[Sig a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Sig a]]
es)
  go (KindSig [Sig a]
ty [Sig a]
ks) =
    [Sig a] -> [Sig a] -> Sig a
forall varIx. [Sig varIx] -> [Sig varIx] -> Sig varIx
KindSig (([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
f [Sig a]
ty)
            (([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
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 :: [Sig a] -> [Sig ()]
sigFingerprint = ([Sig ()] -> [Sig ()]) -> [Sig ()] -> [Sig ()]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig ()] -> [Sig ()]
go ([Sig ()] -> [Sig ()])
-> ([Sig a] -> [Sig ()]) -> [Sig a] -> [Sig ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig a -> Sig ()) -> [Sig a] -> [Sig ()]
forall a b. (a -> b) -> [a] -> [b]
map Sig a -> Sig ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
  where
    go :: [Sig ()] -> [Sig ()]
go = [Sig ()] -> [Sig ()]
forall a. Ord a => [a] -> [a]
sort ([Sig ()] -> [Sig ()])
-> ([Sig ()] -> [Sig ()]) -> [Sig ()] -> [Sig ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig () -> Sig ()) -> [Sig ()] -> [Sig ()]
forall a b. (a -> b) -> [a] -> [b]
map Sig () -> Sig ()
forall varIx. Ord varIx => Sig varIx -> Sig varIx
sortTuple
    sortTuple :: Sig varIx -> Sig varIx
sortTuple (Tuple [[Sig varIx]]
es) = [[Sig varIx]] -> Sig varIx
forall varIx. [[Sig varIx]] -> Sig varIx
Tuple ([[Sig varIx]] -> Sig varIx) -> [[Sig varIx]] -> Sig varIx
forall a b. (a -> b) -> a -> b
$ [[Sig varIx]] -> [[Sig varIx]]
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 :: [Sig a] -> [Sig a]
frontLoadQuals = ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
forall a. [Sig a] -> [Sig a]
go where
  go :: [Sig a] -> [Sig a]
go = ([Sig a] -> [Sig a] -> [Sig a]) -> ([Sig a], [Sig a]) -> [Sig a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Sig a] -> [Sig a] -> [Sig a]
forall a. [a] -> [a] -> [a]
(++) (([Sig a], [Sig a]) -> [Sig a])
-> ([Sig a] -> ([Sig a], [Sig a])) -> [Sig a] -> [Sig a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig a -> Bool) -> [Sig a] -> ([Sig a], [Sig a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Sig a -> Bool
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 :: [Sig a] -> [Sig a]
frontLoadVarDecls = ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
forall a. ([Sig a] -> [Sig a]) -> [Sig a] -> [Sig a]
recurseSig [Sig a] -> [Sig a]
forall a. [Sig a] -> [Sig a]
go
  where
  go :: [Sig varIx] -> [Sig varIx]
go [Sig varIx]
sig =
    let ([Sig varIx]
varSigs, [Sig varIx]
rest) = (Sig varIx -> Bool) -> [Sig varIx] -> ([Sig varIx], [Sig varIx])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Sig varIx -> Bool
forall a. Sig a -> Bool
isVarDecl [Sig varIx]
sig
     in [Sig varIx] -> Sig varIx
forall varIx. [Sig varIx] -> Sig varIx
collapseVarCtx [Sig varIx]
varSigs Sig varIx -> [Sig varIx] -> [Sig varIx]
forall a. a -> [a] -> [a]
: [Sig varIx]
rest

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