{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveFunctor, GADTs,
             GeneralizedNewtypeDeriving, LambdaCase, RecordWildCards,
             ScopedTypeVariables, TupleSections, ViewPatterns #-}

module Output.Types(writeTypes, searchTypes, searchFingerprintsDebug) where

{-
Approach:
Each signature is stored, along with a fingerprint
A quick search finds the most promising 100 fingerprints
A slow search ranks the 100 items, excluding some
-}

import Control.Applicative
import Control.Monad.Extra
import Control.Monad.ST
import Control.Monad.Trans.Class
import Control.Monad.Trans.State.Strict
import Data.Binary hiding (get, put)
import qualified Data.ByteString.Char8 as BS
import Data.Data
import Data.Generics.Uniplate.Data
import Data.List.Extra
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.STRef
import Data.Tuple.Extra
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import Foreign.Storable
import Numeric.Extra
import Prelude
import System.FilePath
import System.IO.Extra

import General.IString
import General.Store
import General.Str
import General.Util
import Input.Item


writeTypes :: StoreWrite -> Maybe FilePath -> [(Maybe TargetId, Item)] -> IO ()
writeTypes :: StoreWrite -> Maybe FilePath -> [(Maybe TargetId, Item)] -> IO ()
writeTypes StoreWrite
store Maybe FilePath
debug [(Maybe TargetId, Item)]
xs = do
    let debugger :: FilePath -> FilePath -> IO ()
debugger FilePath
ext FilePath
body = Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe FilePath
debug ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> FilePath -> FilePath -> IO ()
writeFileUTF8 (FilePath
file FilePath -> FilePath -> FilePath
<.> FilePath
ext) FilePath
body
    Map Str Int
inst <- Map Str Int -> IO (Map Str Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Str Int -> IO (Map Str Int))
-> Map Str Int -> IO (Map Str Int)
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> [(Str, Int)] -> Map Str Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(IString -> Str
fromIString IString
x,Int
1) | (Maybe TargetId
_, IInstance (Sig [Ctx IString]
_ [TCon IString
x [Ty IString]
_])) <- [(Maybe TargetId, Item)]
xs]
    [Sig Str]
xs <- StoreWrite -> [(TargetId, Sig Str)] -> IO [Sig Str]
forall a. Ord a => StoreWrite -> [(TargetId, Sig a)] -> IO [Sig a]
writeDuplicates StoreWrite
store [(TargetId
i, IString -> Str
fromIString (IString -> Str) -> Sig IString -> Sig Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sig IString
t) | (Just TargetId
i, ISignature Sig IString
t) <- [(Maybe TargetId, Item)]
xs]
    Names
names <- StoreWrite
-> (FilePath -> FilePath -> IO ())
-> Map Str Int
-> [Sig Str]
-> IO Names
writeNames StoreWrite
store FilePath -> FilePath -> IO ()
debugger Map Str Int
inst [Sig Str]
xs
    [Sig Name]
xs <- [Sig Name] -> IO [Sig Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Sig Name] -> IO [Sig Name]) -> [Sig Name] -> IO [Sig Name]
forall a b. (a -> b) -> a -> b
$ (Sig Str -> Sig Name) -> [Sig Str] -> [Sig Name]
forall a b. (a -> b) -> [a] -> [b]
map (Names -> Name -> Sig Str -> Sig Name
lookupNames Names
names (FilePath -> Name
forall a. HasCallStack => FilePath -> a
error FilePath
"Unknown name in writeTypes")) [Sig Str]
xs
    StoreWrite -> [Sig Name] -> IO ()
writeFingerprints StoreWrite
store [Sig Name]
xs
    StoreWrite -> [Sig Name] -> IO ()
writeSignatures StoreWrite
store [Sig Name]
xs

searchTypes :: StoreRead -> Sig String -> [TargetId]
searchTypes :: StoreRead -> Sig FilePath -> [TargetId]
searchTypes StoreRead
store Sig FilePath
q =
    Int -> [TargetId] -> [TargetId]
forall a. Int -> [a] -> [a]
take Int
nMatches ([[TargetId]] -> [TargetId]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(Int, (Int, SigLoc, Fingerprint))] -> Sig Name -> [TargetId]
search [(Int, (Int, SigLoc, Fingerprint))]
fps Sig Name
qry' | [Sig Name -> [Sig Name]]
variantClass <- [[Sig Name -> [Sig Name]]]
variants
                                            , Sig Name
fpSig <- case [Sig Name -> [Sig Name]] -> Sig Name -> [Sig Name]
forall a. [a] -> a
head [Sig Name -> [Sig Name]]
variantClass Sig Name
qry of
                                                          (Sig Name
f:[Sig Name]
_) -> [Sig Name
f]
                                                          []    -> []
                                            , let fps :: [(Int, (Int, SigLoc, Fingerprint))]
fps = [(SigLoc, Fingerprint)]
-> Int -> Sig Name -> [(Int, (Int, SigLoc, Fingerprint))]
bestByFingerprint [(SigLoc, Fingerprint)]
db Int
nMatches Sig Name
fpSig
                                            , Sig Name -> [Sig Name]
variant <- [Sig Name -> [Sig Name]]
variantClass
                                            , Sig Name
qry' <- Sig Name -> [Sig Name]
variant Sig Name
qry
                                            ])
    where
        nMatches :: Int
nMatches = Int
100
        qry :: Sig Name
qry = Names -> Name -> Sig Str -> Sig Name
lookupNames Names
names Name
name0 (FilePath -> Str
strPack (FilePath -> Str) -> Sig FilePath -> Sig Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sig FilePath
q) -- map unknown fields to name0, i.e. _
        names :: Names
names = StoreRead -> Names
readNames StoreRead
store
        search :: [(Int, (Int, SigLoc, Fingerprint))] -> Sig Name -> [TargetId]
search [(Int, (Int, SigLoc, Fingerprint))]
fps Sig Name
sig = (Int -> [TargetId]) -> [Int] -> [TargetId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Duplicates -> Int -> [TargetId]
expandDuplicates (Duplicates -> Int -> [TargetId])
-> Duplicates -> Int -> [TargetId]
forall a b. (a -> b) -> a -> b
$ StoreRead -> Duplicates
readDuplicates StoreRead
store)
                         ([Int] -> [TargetId]) -> [Int] -> [TargetId]
forall a b. (a -> b) -> a -> b
$ [(Int, (Int, SigLoc, Fingerprint))]
-> (SigLoc -> Sig Name) -> Name -> Int -> Sig Name -> [Int]
searchTypeMatch [(Int, (Int, SigLoc, Fingerprint))]
fps SigLoc -> Sig Name
getSig Name
arrow Int
nMatches Sig Name
sig
        db :: [(SigLoc, Fingerprint)]
db  = [SigLoc] -> [Fingerprint] -> [(SigLoc, Fingerprint)]
forall a b. [a] -> [b] -> [(a, b)]
zip (StoreRead -> [SigLoc]
readSignatureIndex StoreRead
store)
                  (Vector Fingerprint -> [Fingerprint]
forall a. Storable a => Vector a -> [a]
V.toList (Vector Fingerprint -> [Fingerprint])
-> Vector Fingerprint -> [Fingerprint]
forall a b. (a -> b) -> a -> b
$ StoreRead
-> TypesFingerprints (Vector Fingerprint) -> Vector Fingerprint
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store TypesFingerprints (Vector Fingerprint)
TypesFingerprints :: [Fingerprint])
        getSig :: SigLoc -> Sig Name
getSig = StoreRead -> SigLoc -> Sig Name
readSignatureAt StoreRead
store
        arrow :: Name
arrow = StoreRead -> Names -> FilePath -> Name
lookupCtor StoreRead
store Names
names FilePath
"->"

        -- Different variations on the search query. Each variation is run in turn until we've gathered
        -- 100 hits or run out of variations to try.
        -- As an optimization, these are grouped by variants that have the same fingerprint, saving
        -- redundant scans through the fingerprint data.
        variants :: [[Sig Name -> [Sig Name]]]
variants = [ [ Sig Name -> [Sig Name]
forall (f :: * -> *) a. Applicative f => a -> f a
pure, Sig Name -> [Sig Name]
forall n. Sig n -> [Sig n]
permuted ],
                     [ Sig Name -> [Sig Name]
partial, Sig Name -> [Sig Name]
partial (Sig Name -> [Sig Name])
-> (Sig Name -> [Sig Name]) -> Sig Name -> [Sig Name]
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Sig Name -> [Sig Name]
forall n. Sig n -> [Sig n]
permuted ] ]

        -- Permute the arguments of a two-argument query.
        permuted :: Sig n -> [Sig n]
permuted Sig n
qq = case Sig n -> [Ty n]
forall n. Sig n -> [Ty n]
sigTy Sig n
qq of
            [Ty n
a1, Ty n
a2, Ty n
r] -> [ Sig n
qq { sigTy :: [Ty n]
sigTy = [Ty n
a2, Ty n
a1, Ty n
r] } ]
            [Ty n]
_           -> []

        -- Add a `Maybe` to the query's result type.
        partial :: Sig Name -> [Sig Name]
partial  Sig Name
qq = case Sig Name -> [Ty Name]
forall n. Sig n -> [Ty n]
sigTy Sig Name
qq of
            []  -> []
            [Ty Name]
tys -> [ Sig Name
qq { sigTy :: [Ty Name]
sigTy = [Ty Name] -> [Ty Name]
forall a. [a] -> [a]
init [Ty Name]
tys [Ty Name] -> [Ty Name] -> [Ty Name]
forall a. [a] -> [a] -> [a]
++ [Name -> [Ty Name] -> Ty Name
forall n. n -> [Ty n] -> Ty n
TCon Name
maybeCtor [[Ty Name] -> Ty Name
forall a. [a] -> a
last [Ty Name]
tys]] } ]

        maybeCtor :: Name
maybeCtor = StoreRead -> Names -> FilePath -> Name
lookupCtor StoreRead
store Names
names FilePath
"Maybe"

lookupCtor :: StoreRead -> Names -> String -> Name
lookupCtor :: StoreRead -> Names -> FilePath -> Name
lookupCtor StoreRead
store Names
names FilePath
c =
    case Sig Name -> [Ty Name]
forall n. Sig n -> [Ty n]
sigTy (Names -> Name -> Sig Str -> Sig Name
lookupNames Names
names Name
name0 Sig Str
s) of
        [TCon Name
n [Ty Name]
_] -> Name
n
        [Ty Name]
_          -> Name
name0
    where
      s :: Sig Str
s = FilePath -> Str
strPack (FilePath -> Str) -> Sig FilePath -> Sig Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sig :: forall n. [Ctx n] -> [Ty n] -> Sig n
Sig { sigCtx :: [Ctx FilePath]
sigCtx = [], sigTy :: [Ty FilePath]
sigTy = [FilePath -> [Ty FilePath] -> Ty FilePath
forall n. n -> [Ty n] -> Ty n
TCon FilePath
c []] }

searchFingerprintsDebug :: StoreRead -> (String, Sig String) -> [(String, Sig String)] -> [String]
searchFingerprintsDebug :: StoreRead
-> (FilePath, Sig FilePath)
-> [(FilePath, Sig FilePath)]
-> [FilePath]
searchFingerprintsDebug StoreRead
store (FilePath, Sig FilePath)
query [(FilePath, Sig FilePath)]
answers = [FilePath] -> [[FilePath]] -> [FilePath]
forall a. [a] -> [[a]] -> [a]
intercalate [FilePath
""] ([[FilePath]] -> [FilePath]) -> [[FilePath]] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
    Bool -> FilePath -> (FilePath, Sig FilePath) -> [FilePath]
f Bool
False FilePath
"Query" (FilePath, Sig FilePath)
query [FilePath] -> [[FilePath]] -> [[FilePath]]
forall a. a -> [a] -> [a]
: (Integer -> (FilePath, Sig FilePath) -> [FilePath])
-> Integer -> [(FilePath, Sig FilePath)] -> [[FilePath]]
forall a b c. Enum a => (a -> b -> c) -> a -> [b] -> [c]
zipWithFrom (\Integer
i -> Bool -> FilePath -> (FilePath, Sig FilePath) -> [FilePath]
f Bool
True (FilePath
"Answer " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
i)) Integer
1 [(FilePath, Sig FilePath)]
answers
    where
        qsig :: Sig Name
qsig = Names -> Name -> Sig Str -> Sig Name
lookupNames Names
names Name
name0 (Sig Str -> Sig Name) -> Sig Str -> Sig Name
forall a b. (a -> b) -> a -> b
$ FilePath -> Str
strPack (FilePath -> Str) -> Sig FilePath -> Sig Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath, Sig FilePath) -> Sig FilePath
forall a b. (a, b) -> b
snd (FilePath, Sig FilePath)
query
        names :: Names
names = StoreRead -> Names
readNames StoreRead
store

        f :: Bool -> FilePath -> (FilePath, Sig FilePath) -> [FilePath]
f Bool
match FilePath
name (FilePath
raw, Sig FilePath
sig) =
            [FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
raw
            ,FilePath
"Sig String: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Sig FilePath -> FilePath
prettySig Sig FilePath
sig
            ,FilePath
"Sig Name: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Sig FilePath -> FilePath
prettySig ((Name -> FilePath) -> Sig Name -> Sig FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> FilePath
prettyName Sig Name
sn)
            ,FilePath
"Fingerprint: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Fingerprint -> FilePath
prettyFingerprint Fingerprint
fp] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++
            if Bool -> Bool
not Bool
match then [] else
            [FilePath
"Cost: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> (Int -> FilePath) -> Maybe Int -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"X, no match" Int -> FilePath
forall a. Show a => a -> FilePath
show (Sig Name -> Fingerprint -> Maybe Int
matchFingerprint Sig Name
qsig Fingerprint
fp)
            ,FilePath
"Explain: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [Either FilePath (FilePath, Int)] -> FilePath
showExplain (Sig Name -> Fingerprint -> [Either FilePath (FilePath, Int)]
matchFingerprintDebug Sig Name
qsig Fingerprint
fp)]
            where
                sn :: Sig Name
sn = Names -> Name -> Sig Str -> Sig Name
lookupNames Names
names Name
name0 (Sig Str -> Sig Name) -> Sig Str -> Sig Name
forall a b. (a -> b) -> a -> b
$ FilePath -> Str
strPack (FilePath -> Str) -> Sig FilePath -> Sig Str
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sig FilePath
sig
                fp :: Fingerprint
fp = Sig Name -> Fingerprint
toFingerprint Sig Name
sn

                showExplain :: [Either FilePath (FilePath, Int)] -> FilePath
showExplain = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ([FilePath] -> FilePath)
-> ([Either FilePath (FilePath, Int)] -> [FilePath])
-> [Either FilePath (FilePath, Int)]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FilePath (FilePath, Int) -> FilePath)
-> [Either FilePath (FilePath, Int)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Either FilePath (FilePath, Int) -> FilePath
forall a. Show a => Either FilePath (FilePath, a) -> FilePath
g ([Either FilePath (FilePath, Int)] -> [FilePath])
-> ([Either FilePath (FilePath, Int)]
    -> [Either FilePath (FilePath, Int)])
-> [Either FilePath (FilePath, Int)]
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either FilePath (FilePath, Int) -> Int)
-> [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((FilePath -> Int)
-> ((FilePath, Int) -> Int)
-> Either FilePath (FilePath, Int)
-> Int
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int -> FilePath -> Int
forall a b. a -> b -> a
const Int
forall a. Bounded a => a
minBound) (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> ((FilePath, Int) -> Int) -> (FilePath, Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, Int) -> Int
forall a b. (a, b) -> b
snd))
                g :: Either FilePath (FilePath, a) -> FilePath
g (Left FilePath
s) = FilePath
"X " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s
                g (Right (FilePath
s, a
x)) = a -> FilePath
forall a. Show a => a -> FilePath
show a
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s


---------------------------------------------------------------------
-- NAME/CTOR INFORMATION

data TypesNames a where TypesNames :: TypesNames (BStr0, V.Vector Name) deriving Typeable

-- At around 7000 packages, Word16 becomes insufficient
-- because there are more than 2^16 Names, so we use Word32.
type NameWord = Word32

-- Must be a unique Name per String.
-- First 0-99 are variables, rest are constructors.
-- More popular type constructors have higher numbers.
-- There are currently about 14K names, so about 25% of the bit patterns are taken
newtype Name = Name NameWord deriving (Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq,Eq Name
Eq Name
-> (Name -> Name -> Ordering)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Bool)
-> (Name -> Name -> Name)
-> (Name -> Name -> Name)
-> Ord Name
Name -> Name -> Bool
Name -> Name -> Ordering
Name -> Name -> Name
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
min :: Name -> Name -> Name
$cmin :: Name -> Name -> Name
max :: Name -> Name -> Name
$cmax :: Name -> Name -> Name
>= :: Name -> Name -> Bool
$c>= :: Name -> Name -> Bool
> :: Name -> Name -> Bool
$c> :: Name -> Name -> Bool
<= :: Name -> Name -> Bool
$c<= :: Name -> Name -> Bool
< :: Name -> Name -> Bool
$c< :: Name -> Name -> Bool
compare :: Name -> Name -> Ordering
$ccompare :: Name -> Name -> Ordering
$cp1Ord :: Eq Name
Ord,Int -> Name -> FilePath -> FilePath
[Name] -> FilePath -> FilePath
Name -> FilePath
(Int -> Name -> FilePath -> FilePath)
-> (Name -> FilePath)
-> ([Name] -> FilePath -> FilePath)
-> Show Name
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Name] -> FilePath -> FilePath
$cshowList :: [Name] -> FilePath -> FilePath
show :: Name -> FilePath
$cshow :: Name -> FilePath
showsPrec :: Int -> Name -> FilePath -> FilePath
$cshowsPrec :: Int -> Name -> FilePath -> FilePath
Show,Typeable Name
DataType
Constr
Typeable Name
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Name -> c Name)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Name)
-> (Name -> Constr)
-> (Name -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Name))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Name))
-> ((forall b. Data b => b -> b) -> Name -> Name)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r)
-> (forall u. (forall d. Data d => d -> u) -> Name -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Name -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Name -> m Name)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Name -> m Name)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Name -> m Name)
-> Data Name
Name -> DataType
Name -> Constr
(forall b. Data b => b -> b) -> Name -> Name
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Name -> c Name
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Name
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Name -> u
forall u. (forall d. Data d => d -> u) -> Name -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Name -> m Name
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Name -> m Name
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Name
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Name -> c Name
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Name)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Name)
$cName :: Constr
$tName :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Name -> m Name
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Name -> m Name
gmapMp :: (forall d. Data d => d -> m d) -> Name -> m Name
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Name -> m Name
gmapM :: (forall d. Data d => d -> m d) -> Name -> m Name
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Name -> m Name
gmapQi :: Int -> (forall d. Data d => d -> u) -> Name -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Name -> u
gmapQ :: (forall d. Data d => d -> u) -> Name -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Name -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Name -> r
gmapT :: (forall b. Data b => b -> b) -> Name -> Name
$cgmapT :: (forall b. Data b => b -> b) -> Name -> Name
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Name)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Name)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Name)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Name)
dataTypeOf :: Name -> DataType
$cdataTypeOf :: Name -> DataType
toConstr :: Name -> Constr
$ctoConstr :: Name -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Name
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Name
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Name -> c Name
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Name -> c Name
$cp1Data :: Typeable Name
Data,Typeable,Ptr b -> Int -> IO Name
Ptr b -> Int -> Name -> IO ()
Ptr Name -> IO Name
Ptr Name -> Int -> IO Name
Ptr Name -> Int -> Name -> IO ()
Ptr Name -> Name -> IO ()
Name -> Int
(Name -> Int)
-> (Name -> Int)
-> (Ptr Name -> Int -> IO Name)
-> (Ptr Name -> Int -> Name -> IO ())
-> (forall b. Ptr b -> Int -> IO Name)
-> (forall b. Ptr b -> Int -> Name -> IO ())
-> (Ptr Name -> IO Name)
-> (Ptr Name -> Name -> IO ())
-> Storable Name
forall b. Ptr b -> Int -> IO Name
forall b. Ptr b -> Int -> Name -> IO ()
forall a.
(a -> Int)
-> (a -> Int)
-> (Ptr a -> Int -> IO a)
-> (Ptr a -> Int -> a -> IO ())
-> (forall b. Ptr b -> Int -> IO a)
-> (forall b. Ptr b -> Int -> a -> IO ())
-> (Ptr a -> IO a)
-> (Ptr a -> a -> IO ())
-> Storable a
poke :: Ptr Name -> Name -> IO ()
$cpoke :: Ptr Name -> Name -> IO ()
peek :: Ptr Name -> IO Name
$cpeek :: Ptr Name -> IO Name
pokeByteOff :: Ptr b -> Int -> Name -> IO ()
$cpokeByteOff :: forall b. Ptr b -> Int -> Name -> IO ()
peekByteOff :: Ptr b -> Int -> IO Name
$cpeekByteOff :: forall b. Ptr b -> Int -> IO Name
pokeElemOff :: Ptr Name -> Int -> Name -> IO ()
$cpokeElemOff :: Ptr Name -> Int -> Name -> IO ()
peekElemOff :: Ptr Name -> Int -> IO Name
$cpeekElemOff :: Ptr Name -> Int -> IO Name
alignment :: Name -> Int
$calignment :: Name -> Int
sizeOf :: Name -> Int
$csizeOf :: Name -> Int
Storable,Get Name
[Name] -> Put
Name -> Put
(Name -> Put) -> Get Name -> ([Name] -> Put) -> Binary Name
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [Name] -> Put
$cputList :: [Name] -> Put
get :: Get Name
$cget :: Get Name
put :: Name -> Put
$cput :: Name -> Put
Binary)

name0 :: Name
name0 = NameWord -> Name
Name NameWord
0 -- use to represent _

isCon, isVar :: Name -> Bool
isVar :: Name -> Bool
isVar (Name NameWord
x) = NameWord
x NameWord -> NameWord -> Bool
forall a. Ord a => a -> a -> Bool
< NameWord
100
isCon :: Name -> Bool
isCon = Bool -> Bool
not (Bool -> Bool) -> (Name -> Bool) -> Name -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
isVar

prettyName :: Name -> String
prettyName :: Name -> FilePath
prettyName x :: Name
x@(Name NameWord
i)
    | Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name0 = FilePath
"_"
    | Name -> Bool
isVar Name
x = FilePath
"v" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NameWord -> FilePath
forall a. Show a => a -> FilePath
show NameWord
i
    | Bool
otherwise = FilePath
"C" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ NameWord -> FilePath
forall a. Show a => a -> FilePath
show NameWord
i


-- | Give a name a popularity, where 0 is least popular, 1 is most popular
popularityName :: Name -> Double
popularityName :: Name -> Double
popularityName (Name NameWord
n) | Name -> Bool
isVar (Name -> Bool) -> Name -> Bool
forall a b. (a -> b) -> a -> b
$ NameWord -> Name
Name NameWord
n = FilePath -> Double
forall a. HasCallStack => FilePath -> a
error FilePath
"Can't call popularityName on a Var"
                        | Bool
otherwise = NameWord -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NameWord
n NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
- NameWord
100) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ NameWord -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NameWord
forall a. Bounded a => a
maxBound NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
- NameWord
100 :: NameWord)

newtype Names = Names {Names -> Str -> Maybe Name
lookupName :: Str -> Maybe Name}

lookupNames :: Names -> Name -> Sig Str -> Sig Name
lookupNames :: Names -> Name -> Sig Str -> Sig Name
lookupNames Names{Str -> Maybe Name
lookupName :: Str -> Maybe Name
lookupName :: Names -> Str -> Maybe Name
..} Name
def (Sig [Ctx Str]
ctx [Ty Str]
typ) = [Ctx Name] -> [Ty Name] -> Sig Name
forall n. [Ctx n] -> [Ty n] -> Sig n
Sig ((Ctx Str -> Ctx Name) -> [Ctx Str] -> [Ctx Name]
forall a b. (a -> b) -> [a] -> [b]
map Ctx Str -> Ctx Name
f [Ctx Str]
ctx) ((Ty Str -> Ty Name) -> [Ty Str] -> [Ty Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Str -> Ty Name
g [Ty Str]
typ)
    where
        vars :: [Str]
vars = [Str] -> [Str]
forall a. Ord a => [a] -> [a]
nubOrd ([Str] -> [Str]) -> [Str] -> [Str]
forall a b. (a -> b) -> a -> b
$ FilePath -> Str
strPack FilePath
"_" Str -> [Str] -> [Str]
forall a. a -> [a] -> [a]
: [Str
x | Ctx Str
_ Str
x <- [Ctx Str]
ctx] [Str] -> [Str] -> [Str]
forall a. [a] -> [a] -> [a]
++ [Str
x | TVar Str
x [Ty Str]
_ <- [Ty Str] -> [Ty Str]
forall from to. Biplate from to => from -> [to]
universeBi [Ty Str]
typ]
        var :: Str -> Name
var Str
x = NameWord -> Name
Name (NameWord -> Name) -> NameWord -> Name
forall a b. (a -> b) -> a -> b
$ NameWord -> NameWord -> NameWord
forall a. Ord a => a -> a -> a
min NameWord
99 (NameWord -> NameWord) -> NameWord -> NameWord
forall a b. (a -> b) -> a -> b
$ Int -> NameWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NameWord) -> Int -> NameWord
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Int
forall a. HasCallStack => FilePath -> a
error FilePath
"lookupNames") (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Str -> [Str] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Str
x [Str]
vars
        con :: Str -> Name
con = Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
def (Maybe Name -> Name) -> (Str -> Maybe Name) -> Str -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Str -> Maybe Name
lookupName

        f :: Ctx Str -> Ctx Name
f (Ctx Str
a Str
b) = Name -> Name -> Ctx Name
forall n. n -> n -> Ctx n
Ctx (Str -> Name
con (Str -> Name) -> Str -> Name
forall a b. (a -> b) -> a -> b
$ Char -> Str -> Str
strCons Char
'~' Str
a) (Str -> Name
var Str
b)
        g :: Ty Str -> Ty Name
g (TCon Str
x [Ty Str]
xs) = Name -> [Ty Name] -> Ty Name
forall n. n -> [Ty n] -> Ty n
TCon (Str -> Name
con Str
x) ([Ty Name] -> Ty Name) -> [Ty Name] -> Ty Name
forall a b. (a -> b) -> a -> b
$ (Ty Str -> Ty Name) -> [Ty Str] -> [Ty Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Str -> Ty Name
g [Ty Str]
xs
        g (TVar Str
x [Ty Str]
xs) = Name -> [Ty Name] -> Ty Name
forall n. n -> [Ty n] -> Ty n
TVar (Str -> Name
var Str
x) ([Ty Name] -> Ty Name) -> [Ty Name] -> Ty Name
forall a b. (a -> b) -> a -> b
$ (Ty Str -> Ty Name) -> [Ty Str] -> [Ty Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Str -> Ty Name
g [Ty Str]
xs


writeNames :: StoreWrite -> (String -> String -> IO ()) -> Map.Map Str Int -> [Sig Str] -> IO Names
writeNames :: StoreWrite
-> (FilePath -> FilePath -> IO ())
-> Map Str Int
-> [Sig Str]
-> IO Names
writeNames StoreWrite
store FilePath -> FilePath -> IO ()
debug Map Str Int
inst [Sig Str]
xs = do
    let sigNames :: Sig Str -> [Str]
sigNames (Sig [Ctx Str]
ctx [Ty Str]
typ) = [Str] -> [Str]
forall a. Ord a => [a] -> [a]
nubOrd [Char -> Str -> Str
strCons Char
'~' Str
x | Ctx Str
x Str
_ <- [Ctx Str]
ctx] [Str] -> [Str] -> [Str]
forall a. [a] -> [a] -> [a]
++ [Str] -> [Str]
forall a. Ord a => [a] -> [a]
nubOrd [Str
x | TCon Str
x [Ty Str]
_ <- [Ty Str] -> [Ty Str]
forall from to. Biplate from to => from -> [to]
universeBi [Ty Str]
typ]

    -- want to rank highly instances that have a lot of types, and a lot of definitions
    -- eg Eq is used and defined a lot. Constructor is used in 3 places but defined a lot.
    let Map Str Int
freq :: Map.Map Str Int = -- how many times each identifier occurs
            (Int -> Int -> Int) -> Map Str Int -> Map Str Int -> Map Str Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (\Int
typ Int
sig -> Int
sig Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
sig Int
typ) ((Str -> Str) -> Map Str Int -> Map Str Int
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic (Char -> Str -> Str
strCons Char
'~') Map Str Int
inst) (Map Str Int -> Map Str Int) -> Map Str Int -> Map Str Int
forall a b. (a -> b) -> a -> b
$
            (Int -> Int -> Int) -> [(Str, Int)] -> Map Str Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(Str, Int)] -> Map Str Int) -> [(Str, Int)] -> Map Str Int
forall a b. (a -> b) -> a -> b
$ (Str -> (Str, Int)) -> [Str] -> [(Str, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
1::Int) ([Str] -> [(Str, Int)]) -> [Str] -> [(Str, Int)]
forall a b. (a -> b) -> a -> b
$ (Sig Str -> [Str]) -> [Sig Str] -> [Str]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Sig Str -> [Str]
sigNames [Sig Str]
xs
    let names :: [(Str, Name)]
names = [(Str, Int)] -> [(Str, Name)]
forall a. [(a, Int)] -> [(a, Name)]
spreadNames ([(Str, Int)] -> [(Str, Name)]) -> [(Str, Int)] -> [(Str, Name)]
forall a b. (a -> b) -> a -> b
$ Map Str Int -> [(Str, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Str Int
freq
    FilePath -> FilePath -> IO ()
debug FilePath
"names" (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [Str -> FilePath
strUnpack Str
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" = " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
forall a. Show a => a -> FilePath
show Name
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (Map Str Int
freq Map Str Int -> Str -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Str
s) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" uses)" | (Str
s,Name
n) <- [(Str, Name)]
names]
    [(Str, Name)]
names <- [(Str, Name)] -> IO [(Str, Name)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Str, Name)] -> IO [(Str, Name)])
-> [(Str, Name)] -> IO [(Str, Name)]
forall a b. (a -> b) -> a -> b
$ ((Str, Name) -> Str) -> [(Str, Name)] -> [(Str, Name)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Str, Name) -> Str
forall a b. (a, b) -> a
fst [(Str, Name)]
names
    StoreWrite
-> TypesNames (BStr0, Vector Name) -> (BStr0, Vector Name) -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store TypesNames (BStr0, Vector Name)
TypesNames ([FilePath] -> BStr0
bstr0Join ([FilePath] -> BStr0) -> [FilePath] -> BStr0
forall a b. (a -> b) -> a -> b
$ ((Str, Name) -> FilePath) -> [(Str, Name)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (Str -> FilePath
strUnpack (Str -> FilePath)
-> ((Str, Name) -> Str) -> (Str, Name) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Str, Name) -> Str
forall a b. (a, b) -> a
fst) [(Str, Name)]
names, [Name] -> Vector Name
forall a. Storable a => [a] -> Vector a
V.fromList ([Name] -> Vector Name) -> [Name] -> Vector Name
forall a b. (a -> b) -> a -> b
$ ((Str, Name) -> Name) -> [(Str, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Str, Name) -> Name
forall a b. (a, b) -> b
snd [(Str, Name)]
names)
    let mp2 :: Map Str Name
mp2 = [(Str, Name)] -> Map Str Name
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(Str, Name)]
names
    Names -> IO Names
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Names -> IO Names) -> Names -> IO Names
forall a b. (a -> b) -> a -> b
$ (Str -> Maybe Name) -> Names
Names ((Str -> Maybe Name) -> Names) -> (Str -> Maybe Name) -> Names
forall a b. (a -> b) -> a -> b
$ \Str
x -> Str -> Map Str Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Str
x Map Str Name
mp2


-- | Given a list of names, spread them out uniquely over the range [Name 100 .. Name maxBound]
--   Aim for something with a count of p to be at position (p / pmax) linear interp over the range
spreadNames :: [(a, Int)] -> [(a, Name)]
spreadNames :: [(a, Int)] -> [(a, Name)]
spreadNames [] = []
spreadNames (((a, Int) -> Int) -> [(a, Int)] -> [(a, Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> ((a, Int) -> Int) -> (a, Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Int) -> Int
forall a b. (a, b) -> b
snd) -> xs :: [(a, Int)]
xs@((a
_,Int
limit):[(a, Int)]
_)) = [(a, Name)] -> [(a, Name)]
forall a. [(a, Name)] -> [(a, Name)]
check ([(a, Name)] -> [(a, Name)]) -> [(a, Name)] -> [(a, Name)]
forall a b. (a -> b) -> a -> b
$ NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
forall a. NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
f (NameWord
99 NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
+ Int -> NameWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(a, Int)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Int)]
xs)) NameWord
forall a. Bounded a => a
maxBound [(a, Int)]
xs
    where
        check :: [(a, Name)] -> [(a, Name)]
check [(a, Name)]
xs | ((a, Name) -> Bool) -> [(a, Name)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Name -> Bool
isCon (Name -> Bool) -> ((a, Name) -> Name) -> (a, Name) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Name) -> Name
forall a b. (a, b) -> b
snd) [(a, Name)]
xs Bool -> Bool -> Bool
&& [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Name] -> [Name]
forall a. Ord a => [a] -> [a]
nubOrd ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ ((a, Name) -> Name) -> [(a, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (a, Name) -> Name
forall a b. (a, b) -> b
snd [(a, Name)]
xs) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(a, Name)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Name)]
xs = [(a, Name)]
xs
                 | Bool
otherwise = FilePath -> [(a, Name)]
forall a. HasCallStack => FilePath -> a
error (FilePath -> [(a, Name)]) -> FilePath -> [(a, Name)]
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid spreadNames, length=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show ([(a, Name)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, Name)]
xs)

        -- I can only assign values between mn and mx inclusive
        f :: NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
        f :: NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
f !NameWord
mn !NameWord
mx [] = []
        f NameWord
mn NameWord
mx ((a
a,Int
i):[(a, Int)]
xs) = (a
a, NameWord -> Name
Name NameWord
real) (a, Name) -> [(a, Name)] -> [(a, Name)]
forall a. a -> [a] -> [a]
: NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
forall a. NameWord -> NameWord -> [(a, Int)] -> [(a, Name)]
f (NameWord
mnNameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
-NameWord
1) (NameWord
realNameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
-NameWord
1) [(a, Int)]
xs
            where real :: NameWord
real = NameWord -> NameWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NameWord -> NameWord) -> NameWord -> NameWord
forall a b. (a -> b) -> a -> b
$ NameWord -> NameWord -> NameWord
forall a. Ord a => a -> a -> a
max NameWord
mn (NameWord -> NameWord) -> NameWord -> NameWord
forall a b. (a -> b) -> a -> b
$ NameWord -> NameWord -> NameWord
forall a. Ord a => a -> a -> a
min NameWord
mx NameWord
ideal
                  ideal :: NameWord
ideal = NameWord
mn NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
+ Double -> NameWord
forall a b. (RealFrac a, Integral b) => a -> b
floor (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
commonNameThreshold Int
i) Double -> Double -> Double
forall a. Num a => a -> a -> a
* NameWord -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NameWord
mx NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
- NameWord
mn) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
commonNameThreshold Int
limit))

-- WARNING: Magic constant.
-- Beyond this count names don't accumulate extra points for being common.
-- Ensures that things like Bool (4523 uses) ranks much higher than ShakeOptions (24 uses) by not having
-- [] (10237 uses) skew the curve too much and use up all the available bits of discrimination.
commonNameThreshold :: Int
commonNameThreshold = Int
1024

readNames :: StoreRead -> Names
readNames :: StoreRead -> Names
readNames StoreRead
store = (Str -> Maybe Name) -> Names
Names ((Str -> Maybe Name) -> Names) -> (Str -> Maybe Name) -> Names
forall a b. (a -> b) -> a -> b
$ \Str
x -> BStr0 -> Map BStr0 Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (FilePath -> BStr0
bstrPack (FilePath -> BStr0) -> FilePath -> BStr0
forall a b. (a -> b) -> a -> b
$ Str -> FilePath
strUnpack Str
x) Map BStr0 Name
mp
    where mp :: Map BStr0 Name
mp = [(BStr0, Name)] -> Map BStr0 Name
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList ([(BStr0, Name)] -> Map BStr0 Name)
-> [(BStr0, Name)] -> Map BStr0 Name
forall a b. (a -> b) -> a -> b
$ [BStr0] -> [Name] -> [(BStr0, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip (BStr0 -> [BStr0]
bstr0Split BStr0
s) ([Name] -> [(BStr0, Name)]) -> [Name] -> [(BStr0, Name)]
forall a b. (a -> b) -> a -> b
$ Vector Name -> [Name]
forall a. Storable a => Vector a -> [a]
V.toList Vector Name
n
          (BStr0
s, Vector Name
n) = StoreRead
-> TypesNames (BStr0, Vector Name) -> (BStr0, Vector Name)
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store TypesNames (BStr0, Vector Name)
TypesNames


---------------------------------------------------------------------
-- DUPLICATION INFORMATION

data TypesDuplicates a where TypesDuplicates :: TypesDuplicates (Jagged TargetId) deriving Typeable

newtype Duplicates = Duplicates {Duplicates -> Int -> [TargetId]
expandDuplicates :: Int -> [TargetId]}

-- writeDuplicates xs == nub (map snd xs)
    -- all duplicates are removed, order of first element is preserved
-- (i,x) <- zip [0..] (writeDuplicates xs); expandDuplicates i == map fst (filter ((==) x . snd) xs)
    -- given the result at position i, expandDuplicates gives the TargetId's related to it

writeDuplicates :: Ord a => StoreWrite -> [(TargetId, Sig a)] -> IO [Sig a]
writeDuplicates :: StoreWrite -> [(TargetId, Sig a)] -> IO [Sig a]
writeDuplicates StoreWrite
store [(TargetId, Sig a)]
xs = do
    -- s=signature, t=targetid, p=popularity (incoing index), i=index (outgoing index)
    [(Sig a, [TargetId])]
xs <- [(Sig a, [TargetId])] -> IO [(Sig a, [TargetId])]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Sig a, [TargetId])] -> IO [(Sig a, [TargetId])])
-> [(Sig a, [TargetId])] -> IO [(Sig a, [TargetId])]
forall a b. (a -> b) -> a -> b
$ ((Sig a, (Int, [TargetId])) -> (Sig a, [TargetId]))
-> [(Sig a, (Int, [TargetId]))] -> [(Sig a, [TargetId])]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, [TargetId]) -> [TargetId])
-> (Sig a, (Int, [TargetId])) -> (Sig a, [TargetId])
forall b b' a. (b -> b') -> (a, b) -> (a, b')
second (Int, [TargetId]) -> [TargetId]
forall a b. (a, b) -> b
snd) ([(Sig a, (Int, [TargetId]))] -> [(Sig a, [TargetId])])
-> [(Sig a, (Int, [TargetId]))] -> [(Sig a, [TargetId])]
forall a b. (a -> b) -> a -> b
$ ((Sig a, (Int, [TargetId])) -> Int)
-> [(Sig a, (Int, [TargetId]))] -> [(Sig a, (Int, [TargetId]))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Int, [TargetId]) -> Int
forall a b. (a, b) -> a
fst ((Int, [TargetId]) -> Int)
-> ((Sig a, (Int, [TargetId])) -> (Int, [TargetId]))
-> (Sig a, (Int, [TargetId]))
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig a, (Int, [TargetId])) -> (Int, [TargetId])
forall a b. (a, b) -> b
snd) ([(Sig a, (Int, [TargetId]))] -> [(Sig a, (Int, [TargetId]))])
-> [(Sig a, (Int, [TargetId]))] -> [(Sig a, (Int, [TargetId]))]
forall a b. (a -> b) -> a -> b
$ Map (Sig a) (Int, [TargetId]) -> [(Sig a, (Int, [TargetId]))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map (Sig a) (Int, [TargetId]) -> [(Sig a, (Int, [TargetId]))])
-> Map (Sig a) (Int, [TargetId]) -> [(Sig a, (Int, [TargetId]))]
forall a b. (a -> b) -> a -> b
$
        ((Int, [TargetId]) -> (Int, [TargetId]) -> (Int, [TargetId]))
-> [(Sig a, (Int, [TargetId]))] -> Map (Sig a) (Int, [TargetId])
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\(Int
x1,[TargetId]
x2) (Int
y1,[TargetId]
y2) -> (, [TargetId]
x2 [TargetId] -> [TargetId] -> [TargetId]
forall a. [a] -> [a] -> [a]
++ [TargetId]
y2) (Int -> (Int, [TargetId])) -> Int -> (Int, [TargetId])
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x1 Int
y1)
                         [(Sig a
s,(Int
p,[TargetId
t])) | (Int
p,(TargetId
t,Sig a
s)) <- Int -> [(TargetId, Sig a)] -> [(Int, (TargetId, Sig a))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom (Int
0::Int) [(TargetId, Sig a)]
xs]
    -- give a list of TargetId's at each index
    StoreWrite
-> TypesDuplicates (Jagged TargetId) -> Jagged TargetId -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store TypesDuplicates (Jagged TargetId)
TypesDuplicates (Jagged TargetId -> IO ()) -> Jagged TargetId -> IO ()
forall a b. (a -> b) -> a -> b
$ [[TargetId]] -> Jagged TargetId
forall a. Storable a => [[a]] -> Jagged a
jaggedFromList ([[TargetId]] -> Jagged TargetId)
-> [[TargetId]] -> Jagged TargetId
forall a b. (a -> b) -> a -> b
$ ((Sig a, [TargetId]) -> [TargetId])
-> [(Sig a, [TargetId])] -> [[TargetId]]
forall a b. (a -> b) -> [a] -> [b]
map ([TargetId] -> [TargetId]
forall a. [a] -> [a]
reverse ([TargetId] -> [TargetId])
-> ((Sig a, [TargetId]) -> [TargetId])
-> (Sig a, [TargetId])
-> [TargetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sig a, [TargetId]) -> [TargetId]
forall a b. (a, b) -> b
snd) [(Sig a, [TargetId])]
xs
    [Sig a] -> IO [Sig a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Sig a] -> IO [Sig a]) -> [Sig a] -> IO [Sig a]
forall a b. (a -> b) -> a -> b
$ ((Sig a, [TargetId]) -> Sig a) -> [(Sig a, [TargetId])] -> [Sig a]
forall a b. (a -> b) -> [a] -> [b]
map (Sig a, [TargetId]) -> Sig a
forall a b. (a, b) -> a
fst [(Sig a, [TargetId])]
xs

readDuplicates :: StoreRead -> Duplicates
readDuplicates :: StoreRead -> Duplicates
readDuplicates StoreRead
store = (Int -> [TargetId]) -> Duplicates
Duplicates ((Int -> [TargetId]) -> Duplicates)
-> (Int -> [TargetId]) -> Duplicates
forall a b. (a -> b) -> a -> b
$ Vector TargetId -> [TargetId]
forall a. Storable a => Vector a -> [a]
V.toList (Vector TargetId -> [TargetId])
-> (Int -> Vector TargetId) -> Int -> [TargetId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Vector TargetId
ask
    where ask :: Int -> Vector TargetId
ask = Jagged TargetId -> Int -> Vector TargetId
forall a. Storable a => Jagged a -> Int -> Vector a
jaggedAsk (Jagged TargetId -> Int -> Vector TargetId)
-> Jagged TargetId -> Int -> Vector TargetId
forall a b. (a -> b) -> a -> b
$ StoreRead -> TypesDuplicates (Jagged TargetId) -> Jagged TargetId
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store TypesDuplicates (Jagged TargetId)
TypesDuplicates


---------------------------------------------------------------------
-- FINGERPRINT INFORMATION

data TypesFingerprints a where TypesFingerprints :: TypesFingerprints (V.Vector Fingerprint) deriving Typeable

data Fingerprint = Fingerprint
    {Fingerprint -> Name
fpRare1 :: {-# UNPACK #-} !Name -- Most rare ctor, or 0 if no rare stuff
    ,Fingerprint -> Name
fpRare2 :: {-# UNPACK #-} !Name -- 2nd rare ctor
    ,Fingerprint -> Name
fpRare3 :: {-# UNPACK #-} !Name -- 3rd rare ctor
    ,Fingerprint -> Word8
fpArity :: {-# UNPACK #-} !Word8 -- Artiy, where 0 = CAF
    ,Fingerprint -> Word8
fpTerms :: {-# UNPACK #-} !Word8 -- Number of terms (where 255 = 255 and above)
    } deriving (Fingerprint -> Fingerprint -> Bool
(Fingerprint -> Fingerprint -> Bool)
-> (Fingerprint -> Fingerprint -> Bool) -> Eq Fingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fingerprint -> Fingerprint -> Bool
$c/= :: Fingerprint -> Fingerprint -> Bool
== :: Fingerprint -> Fingerprint -> Bool
$c== :: Fingerprint -> Fingerprint -> Bool
Eq,Int -> Fingerprint -> FilePath -> FilePath
[Fingerprint] -> FilePath -> FilePath
Fingerprint -> FilePath
(Int -> Fingerprint -> FilePath -> FilePath)
-> (Fingerprint -> FilePath)
-> ([Fingerprint] -> FilePath -> FilePath)
-> Show Fingerprint
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Fingerprint] -> FilePath -> FilePath
$cshowList :: [Fingerprint] -> FilePath -> FilePath
show :: Fingerprint -> FilePath
$cshow :: Fingerprint -> FilePath
showsPrec :: Int -> Fingerprint -> FilePath -> FilePath
$cshowsPrec :: Int -> Fingerprint -> FilePath -> FilePath
Show,Typeable)

prettyFingerprint :: Fingerprint -> String
prettyFingerprint :: Fingerprint -> FilePath
prettyFingerprint Fingerprint{Word8
Name
fpTerms :: Word8
fpArity :: Word8
fpRare3 :: Name
fpRare2 :: Name
fpRare1 :: Name
fpTerms :: Fingerprint -> Word8
fpArity :: Fingerprint -> Word8
fpRare3 :: Fingerprint -> Name
fpRare2 :: Fingerprint -> Name
fpRare1 :: Fingerprint -> Name
..} =
    FilePath
"arity=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word8 -> FilePath
forall a. Show a => a -> FilePath
show Word8
fpArity FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", terms=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Word8 -> FilePath
forall a. Show a => a -> FilePath
show Word8
fpTerms FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
    FilePath
", rarity=" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords ((Name -> FilePath) -> [Name] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Name -> FilePath
prettyName [Name
fpRare1, Name
fpRare2, Name
fpRare3])


{-# INLINE fpRaresFold #-}
fpRaresFold :: (b -> b -> b) -> (Name -> b) -> Fingerprint -> b
fpRaresFold :: (b -> b -> b) -> (Name -> b) -> Fingerprint -> b
fpRaresFold b -> b -> b
g Name -> b
f Fingerprint{Word8
Name
fpTerms :: Word8
fpArity :: Word8
fpRare3 :: Name
fpRare2 :: Name
fpRare1 :: Name
fpTerms :: Fingerprint -> Word8
fpArity :: Fingerprint -> Word8
fpRare3 :: Fingerprint -> Name
fpRare2 :: Fingerprint -> Name
fpRare1 :: Fingerprint -> Name
..} = Name -> b
f Name
fpRare1 b -> b -> b
`g` Name -> b
f Name
fpRare2 b -> b -> b
`g` Name -> b
f Name
fpRare3

instance Storable Fingerprint where
    sizeOf :: Fingerprint -> Int
sizeOf Fingerprint
_ = Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Name -> Int
forall a. Storable a => a -> Int
sizeOf Name
name0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
    alignment :: Fingerprint -> Int
alignment Fingerprint
_ = Int
4
    peekByteOff :: Ptr b -> Int -> IO Fingerprint
peekByteOff Ptr b
ptr Int
i = Name -> Name -> Name -> Word8 -> Word8 -> Fingerprint
Fingerprint
        (Name -> Name -> Name -> Word8 -> Word8 -> Fingerprint)
-> IO Name -> IO (Name -> Name -> Word8 -> Word8 -> Fingerprint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr b -> Int -> IO Name
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
0) IO (Name -> Name -> Word8 -> Word8 -> Fingerprint)
-> IO Name -> IO (Name -> Word8 -> Word8 -> Fingerprint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr b -> Int -> IO Name
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) IO (Name -> Word8 -> Word8 -> Fingerprint)
-> IO Name -> IO (Word8 -> Word8 -> Fingerprint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr b -> Int -> IO Name
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w)
        IO (Word8 -> Word8 -> Fingerprint)
-> IO Word8 -> IO (Word8 -> Fingerprint)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) IO (Word8 -> Fingerprint) -> IO Word8 -> IO Fingerprint
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Ptr b -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        where w :: Int
w = Name -> Int
forall a. Storable a => a -> Int
sizeOf Name
name0
    pokeByteOff :: Ptr b -> Int -> Fingerprint -> IO ()
pokeByteOff Ptr b
ptr Int
i Fingerprint{Word8
Name
fpTerms :: Word8
fpArity :: Word8
fpRare3 :: Name
fpRare2 :: Name
fpRare1 :: Name
fpTerms :: Fingerprint -> Word8
fpArity :: Fingerprint -> Word8
fpRare3 :: Fingerprint -> Name
fpRare2 :: Fingerprint -> Name
fpRare1 :: Fingerprint -> Name
..} = do
        Ptr b -> Int -> Name -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
0) Name
fpRare1 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> Int -> Name -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) Name
fpRare2 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> Int -> Name -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) Name
fpRare3
        Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w) Word8
fpArity IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Ptr b -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr b
ptr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8
fpTerms
        where w :: Int
w = Name -> Int
forall a. Storable a => a -> Int
sizeOf Name
name0

toFingerprint :: Sig Name -> Fingerprint
toFingerprint :: Sig Name -> Fingerprint
toFingerprint Sig Name
sig = Fingerprint :: Name -> Name -> Name -> Word8 -> Word8 -> Fingerprint
Fingerprint{Word8
Name
fpTerms :: Word8
fpArity :: Word8
fpRare3 :: Name
fpRare2 :: Name
fpRare1 :: Name
fpTerms :: Word8
fpArity :: Word8
fpRare3 :: Name
fpRare2 :: Name
fpRare1 :: Name
..}
    where Name
fpRare1:Name
fpRare2:Name
fpRare3:[Name]
_ = [Name] -> [Name]
forall a. Ord a => [a] -> [a]
sort ([Name] -> [Name]
forall a. Ord a => [a] -> [a]
nubOrd ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
isCon ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ Sig Name -> [Name]
forall from to. Biplate from to => from -> [to]
universeBi Sig Name
sig) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name
name0,Name
name0,Name
name0]
          fpArity :: Word8
fpArity = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Ty Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Ty Name] -> Int) -> [Ty Name] -> Int
forall a b. (a -> b) -> a -> b
$ Sig Name -> [Ty Name]
forall n. Sig n -> [Ty n]
sigTy Sig Name
sig
          fpTerms :: Word8
fpTerms = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Sig Name -> [Name]
forall from to. Biplate from to => from -> [to]
universeBi Sig Name
sig :: [Name])

writeFingerprints :: StoreWrite -> [Sig Name] -> IO ()
writeFingerprints :: StoreWrite -> [Sig Name] -> IO ()
writeFingerprints StoreWrite
store [Sig Name]
xs = StoreWrite
-> TypesFingerprints (Vector Fingerprint)
-> Vector Fingerprint
-> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store TypesFingerprints (Vector Fingerprint)
TypesFingerprints (Vector Fingerprint -> IO ()) -> Vector Fingerprint -> IO ()
forall a b. (a -> b) -> a -> b
$ [Fingerprint] -> Vector Fingerprint
forall a. Storable a => [a] -> Vector a
V.fromList ([Fingerprint] -> Vector Fingerprint)
-> [Fingerprint] -> Vector Fingerprint
forall a b. (a -> b) -> a -> b
$ (Sig Name -> Fingerprint) -> [Sig Name] -> [Fingerprint]
forall a b. (a -> b) -> [a] -> [b]
map Sig Name -> Fingerprint
toFingerprint [Sig Name]
xs

data MatchFingerprint a ma = MatchFingerprint
    {MatchFingerprint a ma -> a -> a -> a
mfpAdd :: a -> a -> a
    ,MatchFingerprint a ma -> ma -> ma -> ma
mfpAddM :: ma -> ma -> ma
    ,MatchFingerprint a ma -> a -> ma
mfpJust :: a -> ma
    ,MatchFingerprint a ma -> FilePath -> Int -> a
mfpCost :: String -> Int -> a
    ,MatchFingerprint a ma -> FilePath -> ma
mfpMiss :: String -> ma
    }

matchFingerprint :: Sig Name -> Fingerprint -> Maybe Int
matchFingerprint :: Sig Name -> Fingerprint -> Maybe Int
matchFingerprint = MatchFingerprint Int (Maybe Int)
-> Sig Name -> Fingerprint -> Maybe Int
forall a ma. MatchFingerprint a ma -> Sig Name -> Fingerprint -> ma
matchFingerprintEx MatchFingerprint :: forall a ma.
(a -> a -> a)
-> (ma -> ma -> ma)
-> (a -> ma)
-> (FilePath -> Int -> a)
-> (FilePath -> ma)
-> MatchFingerprint a ma
MatchFingerprint{Int -> Maybe Int
Int -> Int -> Int
FilePath -> Maybe Int
FilePath -> Int -> Int
Maybe Int -> Maybe Int -> Maybe Int
forall a. a -> Maybe a
forall p a. p -> Maybe a
forall p p. p -> p -> p
mfpMiss :: forall p a. p -> Maybe a
mfpCost :: forall p p. p -> p -> p
mfpJust :: forall a. a -> Maybe a
mfpAddM :: Maybe Int -> Maybe Int -> Maybe Int
mfpAdd :: Int -> Int -> Int
mfpMiss :: FilePath -> Maybe Int
mfpCost :: FilePath -> Int -> Int
mfpJust :: Int -> Maybe Int
mfpAddM :: Maybe Int -> Maybe Int -> Maybe Int
mfpAdd :: Int -> Int -> Int
..}
    where
        mfpAdd :: Int -> Int -> Int
mfpAdd = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
        mfpAddM :: Maybe Int -> Maybe Int -> Maybe Int
mfpAddM = (Int -> Int -> Int) -> Maybe Int -> Maybe Int -> Maybe Int
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
        mfpJust :: a -> Maybe a
mfpJust = a -> Maybe a
forall a. a -> Maybe a
Just
        mfpCost :: p -> p -> p
mfpCost p
_ p
x = p
x
        mfpMiss :: p -> Maybe a
mfpMiss p
_ = Maybe a
forall a. Maybe a
Nothing

matchFingerprintDebug :: Sig Name -> Fingerprint -> [Either String (String, Int)]
matchFingerprintDebug :: Sig Name -> Fingerprint -> [Either FilePath (FilePath, Int)]
matchFingerprintDebug = MatchFingerprint
  [Either FilePath (FilePath, Int)] [Either FilePath (FilePath, Int)]
-> Sig Name -> Fingerprint -> [Either FilePath (FilePath, Int)]
forall a ma. MatchFingerprint a ma -> Sig Name -> Fingerprint -> ma
matchFingerprintEx MatchFingerprint :: forall a ma.
(a -> a -> a)
-> (ma -> ma -> ma)
-> (a -> ma)
-> (FilePath -> Int -> a)
-> (FilePath -> ma)
-> MatchFingerprint a ma
MatchFingerprint{FilePath -> [Either FilePath (FilePath, Int)]
FilePath -> Int -> [Either FilePath (FilePath, Int)]
[Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
[Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
forall a. a -> a
forall a. [a] -> [a] -> [a]
forall a b. a -> [Either a b]
forall a b a. a -> b -> [Either a (a, b)]
mfpMiss :: forall a b. a -> [Either a b]
mfpCost :: forall a b a. a -> b -> [Either a (a, b)]
mfpJust :: forall a. a -> a
mfpAddM :: forall a. [a] -> [a] -> [a]
mfpAdd :: forall a. [a] -> [a] -> [a]
mfpMiss :: FilePath -> [Either FilePath (FilePath, Int)]
mfpCost :: FilePath -> Int -> [Either FilePath (FilePath, Int)]
mfpJust :: [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
mfpAddM :: [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
mfpAdd :: [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
-> [Either FilePath (FilePath, Int)]
..}
    where
        mfpAdd :: [a] -> [a] -> [a]
mfpAdd = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
        mfpAddM :: [a] -> [a] -> [a]
mfpAddM = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)
        mfpJust :: a -> a
mfpJust = a -> a
forall a. a -> a
id
        mfpCost :: a -> b -> [Either a (a, b)]
mfpCost a
s b
x = [(a, b) -> Either a (a, b)
forall a b. b -> Either a b
Right (a
s,b
x)]
        mfpMiss :: a -> [Either a b]
mfpMiss a
s = [a -> Either a b
forall a b. a -> Either a b
Left a
s]


{-# INLINE matchFingerprintEx #-}
matchFingerprintEx :: forall a ma . MatchFingerprint a ma -> Sig Name -> Fingerprint -> ma -- lower is better
matchFingerprintEx :: MatchFingerprint a ma -> Sig Name -> Fingerprint -> ma
matchFingerprintEx MatchFingerprint{a -> ma
a -> a -> a
ma -> ma -> ma
FilePath -> ma
FilePath -> Int -> a
mfpMiss :: FilePath -> ma
mfpCost :: FilePath -> Int -> a
mfpJust :: a -> ma
mfpAddM :: ma -> ma -> ma
mfpAdd :: a -> a -> a
mfpMiss :: forall a ma. MatchFingerprint a ma -> FilePath -> ma
mfpCost :: forall a ma. MatchFingerprint a ma -> FilePath -> Int -> a
mfpJust :: forall a ma. MatchFingerprint a ma -> a -> ma
mfpAddM :: forall a ma. MatchFingerprint a ma -> ma -> ma -> ma
mfpAdd :: forall a ma. MatchFingerprint a ma -> a -> a -> a
..} sig :: Sig Name
sig@(Sig Name -> Fingerprint
toFingerprint -> Fingerprint
target) =
    \Fingerprint
candidate -> Word8 -> ma
arity (Fingerprint -> Word8
fpArity Fingerprint
candidate) ma -> ma -> ma
`mfpAddM` Word8 -> ma
terms (Fingerprint -> Word8
fpTerms Fingerprint
candidate) ma -> ma -> ma
`mfpAddM` Fingerprint -> ma
rarity Fingerprint
candidate
    where
        -- CAFs must match perfectly, otherwise too many is better than too few
        arity :: Word8 -> ma
arity | Word8
ta Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 = \Word8
ca -> if Word8
ca Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"arity equal" Int
0 else FilePath -> ma
mfpMiss FilePath
"arity different and query a CAF" -- searching for a CAF
              | Bool
otherwise = \Word8
ca -> case Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ca Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ta of
                    Int
_ | Word8
ca Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 -> FilePath -> ma
mfpMiss FilePath
"arity different and answer a CAF" -- searching for a CAF
                    Int
0  -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"arity equal" Int
0 -- perfect match
                    -1 -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"arity 1 to remove" Int
1000 -- not using something the user carefully wrote
                    Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool
allowMore -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost (FilePath
"arity " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to add with wildcard") (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Int
300 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n -- user will have to make up a lot, but they said _ in their search
                    Int
1  -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"arity 1 to add" Int
300  -- user will have to make up an extra param
                    Int
2  -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"arity 2 to add"  Int
900  -- user will have to make up two params
                    Int
_ -> FilePath -> ma
mfpMiss FilePath
""
            where
                ta :: Word8
ta = Fingerprint -> Word8
fpArity Fingerprint
target
                allowMore :: Bool
allowMore = Name -> [Ty Name] -> Ty Name
forall n. n -> [Ty n] -> Ty n
TVar Name
name0 [] Ty Name -> [Ty Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Sig Name -> [Ty Name]
forall n. Sig n -> [Ty n]
sigTy Sig Name
sig

        -- missing terms are a bit worse than invented terms, but it's fairly balanced, clip at large numbers
        terms :: Word8 -> ma
terms = \Word8
ct -> case Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
ct Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
tt of
                Int
n | Int -> Int
forall a. Num a => a -> a
abs Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
20 -> FilePath -> ma
mfpMiss (FilePath -> ma) -> FilePath -> ma
forall a b. (a -> b) -> a -> b
$ FilePath
"terms " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" different" -- too different
                  | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost FilePath
"terms equal" Int
0
                  | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost (FilePath
"terms " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to add") (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 -- candidate has more terms
                  | Bool
otherwise -> a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> a
mfpCost (FilePath
"terms " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show (-Int
n) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to remove") (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Num a => a -> a
abs Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
12 -- candidate has less terms
            where
                tt :: Word8
tt = Fingerprint -> Word8
fpTerms Fingerprint
target

        -- given two fingerprints, you have three sets:
        -- Those in common; those in one but not two; those in two but not one
        -- those that are different
        rarity :: Fingerprint -> ma
rarity = \Fingerprint
cr -> let tr :: Fingerprint
tr = Fingerprint
target in a -> ma
mfpJust (a -> ma) -> a -> ma
forall a b. (a -> b) -> a -> b
$
                Double -> Double -> Fingerprint -> Fingerprint -> a
differences Double
5000 Double
400 Fingerprint
tr Fingerprint
cr a -> a -> a
`mfpAdd` -- searched for T but its not in the candidate, bad if rare, not great if common
                Double -> Double -> Fingerprint -> Fingerprint -> a
differences Double
1000  Double
50 Fingerprint
cr Fingerprint
tr          -- T is in the candidate but I didn't search for it, bad if rare, OK if common
            where
                fpRaresElem :: Name -> Fingerprint -> Bool
                fpRaresElem :: Name -> Fingerprint -> Bool
fpRaresElem !Name
x = (Bool -> Bool -> Bool) -> (Name -> Bool) -> Fingerprint -> Bool
forall b. (b -> b -> b) -> (Name -> b) -> Fingerprint -> b
fpRaresFold Bool -> Bool -> Bool
(||) (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
x)

                differences :: Double -> Double -> Fingerprint -> Fingerprint -> a
                differences :: Double -> Double -> Fingerprint -> Fingerprint -> a
differences !Double
rare !Double
common !Fingerprint
want !Fingerprint
have = (a -> a -> a) -> (Name -> a) -> Fingerprint -> a
forall b. (b -> b -> b) -> (Name -> b) -> Fingerprint -> b
fpRaresFold a -> a -> a
mfpAdd Name -> a
f Fingerprint
want
                    where f :: Name -> a
f Name
n | Name -> Fingerprint -> Bool
fpRaresElem Name
n Fingerprint
have = FilePath -> Int -> a
mfpCost (FilePath
"term in common " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
prettyName Name
n) Int
0
                              | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name0 = FilePath -> Int -> a
mfpCost FilePath
"term _ missing" Int
0 -- will pay the cost the other way around
                              | Bool
otherwise = let p :: Double
p = Name -> Double
popularityName Name
n in FilePath -> Int -> a
mfpCost (FilePath
"term " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Name -> FilePath
prettyName Name
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> Double -> FilePath
forall a. RealFloat a => Int -> a -> FilePath
showDP Int
2 Double
p FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
") missing") (Int -> a) -> Int -> a
forall a b. (a -> b) -> a -> b
$
                                            Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Double
pDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
common) Double -> Double -> Double
forall a. Num a => a -> a -> a
+ ((Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
p)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
rare)


---------------------------------------------------------------------
-- SIGNATURES

data TypesSigPositions a where TypesSigPositions :: TypesSigPositions (V.Vector Word32) deriving Typeable
data TypesSigData a where TypesSigData :: TypesSigData BS.ByteString deriving Typeable

writeSignatures :: StoreWrite -> [Sig Name] -> IO ()
writeSignatures :: StoreWrite -> [Sig Name] -> IO ()
writeSignatures StoreWrite
store [Sig Name]
xs = do
    MVector RealWorld NameWord
v <- Int -> IO (MVector (PrimState IO) NameWord)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
VM.new (Int -> IO (MVector (PrimState IO) NameWord))
-> Int -> IO (MVector (PrimState IO) NameWord)
forall a b. (a -> b) -> a -> b
$ [Sig Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Sig Name]
xs
    [(Int, Sig Name)] -> ((Int, Sig Name) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Int -> [Sig Name] -> [(Int, Sig Name)]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [Sig Name]
xs) (((Int, Sig Name) -> IO ()) -> IO ())
-> ((Int, Sig Name) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,Sig Name
x) -> do
        let b :: BStr0
b = Sig Name -> BStr0
forall a. Binary a => a -> BStr0
encodeBS Sig Name
x
        StoreWrite -> TypesSigData BStr0 -> BStr0 -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWritePart StoreWrite
store TypesSigData BStr0
TypesSigData BStr0
b
        MVector (PrimState IO) NameWord -> Int -> NameWord -> IO ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.write MVector RealWorld NameWord
MVector (PrimState IO) NameWord
v Int
i (NameWord -> IO ()) -> NameWord -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> NameWord
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> NameWord) -> Int -> NameWord
forall a b. (a -> b) -> a -> b
$ BStr0 -> Int
BS.length BStr0
b
    Vector NameWord
v <- MVector (PrimState IO) NameWord -> IO (Vector NameWord)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
V.freeze MVector RealWorld NameWord
MVector (PrimState IO) NameWord
v
    StoreWrite
-> TypesSigPositions (Vector NameWord) -> Vector NameWord -> IO ()
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreWrite -> t a -> a -> IO ()
storeWrite StoreWrite
store TypesSigPositions (Vector NameWord)
TypesSigPositions Vector NameWord
v

type SigLoc = (Word32, Word32)

readSignatureIndex :: StoreRead -> [SigLoc] -- (offset,size) pairs for each field
readSignatureIndex :: StoreRead -> [SigLoc]
readSignatureIndex StoreRead
store = [NameWord] -> [NameWord] -> [SigLoc]
forall a b. [a] -> [b] -> [(a, b)]
zip [NameWord]
offsets (Vector NameWord -> [NameWord]
forall a. Storable a => Vector a -> [a]
V.toList Vector NameWord
sizes)
  where sizes :: Vector NameWord
sizes   = StoreRead -> TypesSigPositions (Vector NameWord) -> Vector NameWord
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store TypesSigPositions (Vector NameWord)
TypesSigPositions
        offsets :: [NameWord]
offsets = Vector NameWord -> [NameWord]
forall a. Storable a => Vector a -> [a]
V.toList (Vector NameWord -> [NameWord]) -> Vector NameWord -> [NameWord]
forall a b. (a -> b) -> a -> b
$ (NameWord -> NameWord -> NameWord)
-> NameWord -> Vector NameWord -> Vector NameWord
forall a b.
(Storable a, Storable b) =>
(a -> b -> a) -> a -> Vector b -> Vector a
V.prescanl' NameWord -> NameWord -> NameWord
forall a. Num a => a -> a -> a
(+) NameWord
0 Vector NameWord
sizes

readSignatureAt :: StoreRead -> SigLoc -> Sig Name
readSignatureAt :: StoreRead -> SigLoc -> Sig Name
readSignatureAt StoreRead
store (NameWord
offset, NameWord
size) = BStr0 -> Sig Name
forall a. Binary a => BStr0 -> a
decodeBS (Int -> BStr0 -> BStr0
BS.take (NameWord -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral NameWord
size)
                                                 (BStr0 -> BStr0) -> BStr0 -> BStr0
forall a b. (a -> b) -> a -> b
$ (BStr0, BStr0) -> BStr0
forall a b. (a, b) -> b
snd
                                                 ((BStr0, BStr0) -> BStr0) -> (BStr0, BStr0) -> BStr0
forall a b. (a -> b) -> a -> b
$ Int -> BStr0 -> (BStr0, BStr0)
BS.splitAt (NameWord -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral NameWord
offset) BStr0
bs)
  where
    bs :: BStr0
bs = StoreRead -> TypesSigData BStr0 -> BStr0
forall (t :: * -> *) a.
(Typeable (t a), Typeable a, Stored a) =>
StoreRead -> t a -> a
storeRead StoreRead
store TypesSigData BStr0
TypesSigData

---------------------------------------------------------------------
-- TYPE SEARCH

searchTypeMatch :: [ (Int, (Int, SigLoc, Fingerprint)) ]
                -> (SigLoc -> Sig Name)
                -> Name
                -> Int
                -> Sig Name
                -> [Int]
searchTypeMatch :: [(Int, (Int, SigLoc, Fingerprint))]
-> (SigLoc -> Sig Name) -> Name -> Int -> Sig Name -> [Int]
searchTypeMatch [(Int, (Int, SigLoc, Fingerprint))]
possibilities SigLoc -> Sig Name
getSig Name
arrow Int
n Sig Name
sig =
    ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> Int -> [(Int, Int)] -> [(Int, Int)]
forall k a. Ord k => (a -> k) -> Int -> [a] -> [a]
takeSortOn (Int, Int) -> Int
forall a b. (a, b) -> a
fst Int
n
      [ (Int
500 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
v Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
fv, Int
i) | (Int
fv, (Int
i, SigLoc
sigIdx, Fingerprint
f)) <- [(Int, (Int, SigLoc, Fingerprint))]
possibilities
                          , Int
v  <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList (Name -> Sig Name -> Sig Name -> Maybe Int
matchType Name
arrow Sig Name
sig (Sig Name -> Maybe Int) -> Sig Name -> Maybe Int
forall a b. (a -> b) -> a -> b
$ SigLoc -> Sig Name
getSig SigLoc
sigIdx)]

bestByFingerprint :: [(SigLoc, Fingerprint)] -> Int -> Sig Name -> [ (Int, (Int, SigLoc, Fingerprint)) ]
bestByFingerprint :: [(SigLoc, Fingerprint)]
-> Int -> Sig Name -> [(Int, (Int, SigLoc, Fingerprint))]
bestByFingerprint [(SigLoc, Fingerprint)]
db Int
n Sig Name
sig =
  ((Int, (Int, SigLoc, Fingerprint)) -> Int)
-> Int
-> [(Int, (Int, SigLoc, Fingerprint))]
-> [(Int, (Int, SigLoc, Fingerprint))]
forall k a. Ord k => (a -> k) -> Int -> [a] -> [a]
takeSortOn (Int, (Int, SigLoc, Fingerprint)) -> Int
forall a b. (a, b) -> a
fst (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
5000 Int
n)
    [ (Int
fv, (Int
i, SigLoc
sigIdx, Fingerprint
f)) | (Int
i, (SigLoc
sigIdx, Fingerprint
f)) <- Int -> [(SigLoc, Fingerprint)] -> [(Int, (SigLoc, Fingerprint))]
forall a b. Enum a => a -> [b] -> [(a, b)]
zipFrom Int
0 [(SigLoc, Fingerprint)]
db
                           , Int
fv <- Maybe Int -> [Int]
forall a. Maybe a -> [a]
maybeToList (Fingerprint -> Maybe Int
matchFp Fingerprint
f) ]
  where
    matchFp :: Fingerprint -> Maybe Int
matchFp = Sig Name -> Fingerprint -> Maybe Int
matchFingerprint Sig Name
sig

matchType :: Name -> Sig Name -> Sig Name -> Maybe Int
matchType :: Name -> Sig Name -> Sig Name -> Maybe Int
matchType Name
arr Sig Name
qry Sig Name
ans = Work -> Int
unWork (Work -> Int) -> Maybe Work -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ Name, [Ctx Name])
lhs (Typ Name, [Ctx Name]) -> (Typ Name, [Ctx Name]) -> Maybe Work
`matches` (Typ Name, [Ctx Name])
rhs
    where
      lhs :: (Typ Name, [Ctx Name])
lhs = (Name -> Sig Name -> Typ Name
toTyp Name
arr Sig Name
qry, Sig Name -> [Ctx Name]
forall n. Sig n -> [Ctx n]
sigCtx Sig Name
qry)
      rhs :: (Typ Name, [Ctx Name])
rhs = (Name -> Sig Name -> Typ Name
toTyp Name
arr Sig Name
ans, Sig Name -> [Ctx Name]
forall n. Sig n -> [Ctx n]
sigCtx Sig Name
ans)

-- Check if two types-with-context match, returning the amount of work
-- needed to create the match.
matches :: (Typ Name, [Ctx Name]) -> (Typ Name, [Ctx Name]) -> Maybe Work
matches :: (Typ Name, [Ctx Name]) -> (Typ Name, [Ctx Name]) -> Maybe Work
matches (Typ Name
lhs, [Ctx Name]
lctx) (Typ Name
rhs, [Ctx Name]
rctx) = (forall s. ST s (Maybe Work)) -> Maybe Work
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Maybe Work)) -> Maybe Work)
-> (forall s. ST s (Maybe Work)) -> Maybe Work
forall a b. (a -> b) -> a -> b
$ StateT Work (ST s) (Maybe Work) -> Work -> ST s (Maybe Work)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Work (ST s) Bool -> StateT Work (ST s) (Maybe Work)
forall (m :: * -> *) a.
Monad m =>
StateT a m Bool -> StateT a m (Maybe a)
getWork StateT Work (ST s) Bool
forall s. StateT Work (ST s) Bool
go) (Int -> Work
Work Int
0)
  where
    go :: forall s. StateT Work (ST s) Bool
    go :: StateT Work (ST s) Bool
go = do
        -- Try to unify the answer type with the query type.
        (Typ (NameRef s)
qry, [Ctx (NameRef s)]
qryC) <- ST s (Typ (NameRef s), [Ctx (NameRef s)])
-> StateT Work (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool
-> Typ Name
-> [Ctx Name]
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
forall s.
Bool
-> Typ Name
-> [Ctx Name]
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
refTyp Bool
True  Typ Name
lhs [Ctx Name]
lctx)
        (Typ (NameRef s)
ans, [Ctx (NameRef s)]
ansC) <- ST s (Typ (NameRef s), [Ctx (NameRef s)])
-> StateT Work (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool
-> Typ Name
-> [Ctx Name]
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
forall s.
Bool
-> Typ Name
-> [Ctx Name]
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
refTyp Bool
False Typ Name
rhs [Ctx Name]
rctx)
        Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp Typ (NameRef s)
qry Typ (NameRef s)
ans StateT Work (ST s) Bool
-> (Bool -> StateT Work (ST s) Bool) -> StateT Work (ST s) Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
False -> Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
            Bool
True  -> do
                -- Normalize constraints
                let normalize :: Ctx (NameRef s) -> t (ST s) (Ctx Name)
normalize (Ctx NameRef s
c NameRef s
a) = ST s (Ctx Name) -> t (ST s) (Ctx Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Name -> Name -> Ctx Name
forall n. n -> n -> Ctx n
Ctx (Name -> Name -> Ctx Name) -> ST s Name -> ST s (Name -> Ctx Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameRef s -> ST s Name
forall s. NameRef s -> ST s Name
getName NameRef s
c ST s (Name -> Ctx Name) -> ST s Name -> ST s (Ctx Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NameRef s -> ST s Name
forall s. NameRef s -> ST s Name
getName NameRef s
a)
                Set (Ctx Name)
qryNCs <- [Ctx Name] -> Set (Ctx Name)
forall a. Ord a => [a] -> Set a
Set.fromList ([Ctx Name] -> Set (Ctx Name))
-> StateT Work (ST s) [Ctx Name]
-> StateT Work (ST s) (Set (Ctx Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ctx (NameRef s) -> StateT Work (ST s) (Ctx Name))
-> [Ctx (NameRef s)] -> StateT Work (ST s) [Ctx Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ctx (NameRef s) -> StateT Work (ST s) (Ctx Name)
forall (t :: (* -> *) -> * -> *) s.
MonadTrans t =>
Ctx (NameRef s) -> t (ST s) (Ctx Name)
normalize [Ctx (NameRef s)]
qryC)
                Set (Ctx Name)
ansNCs <- [Ctx Name] -> Set (Ctx Name)
forall a. Ord a => [a] -> Set a
Set.fromList ([Ctx Name] -> Set (Ctx Name))
-> StateT Work (ST s) [Ctx Name]
-> StateT Work (ST s) (Set (Ctx Name))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Ctx (NameRef s) -> StateT Work (ST s) (Ctx Name))
-> [Ctx (NameRef s)] -> StateT Work (ST s) [Ctx Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Ctx (NameRef s) -> StateT Work (ST s) (Ctx Name)
forall (t :: (* -> *) -> * -> *) s.
MonadTrans t =>
Ctx (NameRef s) -> t (ST s) (Ctx Name)
normalize [Ctx (NameRef s)]
ansC)

                Typ Name
nqry <- ST s (Typ Name) -> StateT Work (ST s) (Typ Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (Typ Name) -> StateT Work (ST s) (Typ Name))
-> ST s (Typ Name) -> StateT Work (ST s) (Typ Name)
forall a b. (a -> b) -> a -> b
$ Typ (NameRef s) -> ST s (Typ Name)
forall s. Typ (NameRef s) -> ST s (Typ Name)
normalizeTy Typ (NameRef s)
qry
                Typ Name
nans <- ST s (Typ Name) -> StateT Work (ST s) (Typ Name)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (Typ Name) -> StateT Work (ST s) (Typ Name))
-> ST s (Typ Name) -> StateT Work (ST s) (Typ Name)
forall a b. (a -> b) -> a -> b
$ Typ (NameRef s) -> ST s (Typ Name)
forall s. Typ (NameRef s) -> ST s (Typ Name)
normalizeTy Typ (NameRef s)
ans

                -- Discharge constraints; remove any answer-constraint that is also a query-constraint,
                -- and then remove any remaining answer-constraint that is constraining a concrete type.
                -- TODO: keep constrained concrete types but weight them differently if they correspond
                --       to a known instance (e.g. free if we know the instance, rather expensive otherwise).
                let addl :: [Ctx Name]
addl = (Ctx Name -> Bool) -> [Ctx Name] -> [Ctx Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Ctx Name -> Bool
isAbstract (Set (Ctx Name) -> [Ctx Name]
forall a. Set a -> [a]
Set.toList (Set (Ctx Name) -> [Ctx Name]) -> Set (Ctx Name) -> [Ctx Name]
forall a b. (a -> b) -> a -> b
$ Set (Ctx Name)
ansNCs Set (Ctx Name) -> Set (Ctx Name) -> Set (Ctx Name)
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (Ctx Name)
qryNCs)
                    isAbstract :: Ctx Name -> Bool
isAbstract (Ctx Name
c Name
a) = Name -> Bool
isVar Name
a

                Work -> StateT Work (ST s) ()
forall (m :: * -> *). Monad m => Work -> StateT Work m ()
workDelta (Int -> Work
Work (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Ctx Name] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ctx Name]
addl))

                Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

    getWork :: StateT a m Bool -> StateT a m (Maybe a)
getWork StateT a m Bool
action = StateT a m Bool
action StateT a m Bool
-> (Bool -> StateT a m (Maybe a)) -> StateT a m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True  -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> StateT a m a -> StateT a m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT a m a
forall (m :: * -> *) s. Monad m => StateT s m s
get
        Bool
False -> Maybe a -> StateT a m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

    normalizeTy :: Typ (NameRef s) -> ST s (Typ Name)
normalizeTy = \case
        TyVar NameRef s
n [Typ (NameRef s)]
tys -> Name -> [Typ Name] -> Typ Name
forall n. n -> [Typ n] -> Typ n
TyVar (Name -> [Typ Name] -> Typ Name)
-> ST s Name -> ST s ([Typ Name] -> Typ Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameRef s -> ST s Name
forall s. NameRef s -> ST s Name
getName NameRef s
n ST s ([Typ Name] -> Typ Name) -> ST s [Typ Name] -> ST s (Typ Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Typ (NameRef s) -> ST s (Typ Name))
-> [Typ (NameRef s)] -> ST s [Typ Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ (NameRef s) -> ST s (Typ Name)
normalizeTy [Typ (NameRef s)]
tys
        TyCon NameRef s
n [Typ (NameRef s)]
tys -> Name -> [Typ Name] -> Typ Name
forall n. n -> [Typ n] -> Typ n
TyCon (Name -> [Typ Name] -> Typ Name)
-> ST s Name -> ST s ([Typ Name] -> Typ Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameRef s -> ST s Name
forall s. NameRef s -> ST s Name
getName NameRef s
n ST s ([Typ Name] -> Typ Name) -> ST s [Typ Name] -> ST s (Typ Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Typ (NameRef s) -> ST s (Typ Name))
-> [Typ (NameRef s)] -> ST s [Typ Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ (NameRef s) -> ST s (Typ Name)
normalizeTy [Typ (NameRef s)]
tys
        TyFun [Typ (NameRef s)]
args Typ (NameRef s)
retn -> [Typ Name] -> Typ Name -> Typ Name
forall n. [Typ n] -> Typ n -> Typ n
TyFun ([Typ Name] -> Typ Name -> Typ Name)
-> ST s [Typ Name] -> ST s (Typ Name -> Typ Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ (NameRef s) -> ST s (Typ Name))
-> [Typ (NameRef s)] -> ST s [Typ Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Typ (NameRef s) -> ST s (Typ Name)
normalizeTy [Typ (NameRef s)]
args ST s (Typ Name -> Typ Name) -> ST s (Typ Name) -> ST s (Typ Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Typ (NameRef s) -> ST s (Typ Name)
normalizeTy Typ (NameRef s)
retn


-- A slight variation on 'Ty', with a special term for functions.
data Typ n
    = TyFun [Typ n] (Typ n)
    | TyCon n [Typ n]
    | TyVar n [Typ n]
  deriving (Typ n -> Typ n -> Bool
(Typ n -> Typ n -> Bool) -> (Typ n -> Typ n -> Bool) -> Eq (Typ n)
forall n. Eq n => Typ n -> Typ n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Typ n -> Typ n -> Bool
$c/= :: forall n. Eq n => Typ n -> Typ n -> Bool
== :: Typ n -> Typ n -> Bool
$c== :: forall n. Eq n => Typ n -> Typ n -> Bool
Eq, Eq (Typ n)
Eq (Typ n)
-> (Typ n -> Typ n -> Ordering)
-> (Typ n -> Typ n -> Bool)
-> (Typ n -> Typ n -> Bool)
-> (Typ n -> Typ n -> Bool)
-> (Typ n -> Typ n -> Bool)
-> (Typ n -> Typ n -> Typ n)
-> (Typ n -> Typ n -> Typ n)
-> Ord (Typ n)
Typ n -> Typ n -> Bool
Typ n -> Typ n -> Ordering
Typ n -> Typ n -> Typ n
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 n. Ord n => Eq (Typ n)
forall n. Ord n => Typ n -> Typ n -> Bool
forall n. Ord n => Typ n -> Typ n -> Ordering
forall n. Ord n => Typ n -> Typ n -> Typ n
min :: Typ n -> Typ n -> Typ n
$cmin :: forall n. Ord n => Typ n -> Typ n -> Typ n
max :: Typ n -> Typ n -> Typ n
$cmax :: forall n. Ord n => Typ n -> Typ n -> Typ n
>= :: Typ n -> Typ n -> Bool
$c>= :: forall n. Ord n => Typ n -> Typ n -> Bool
> :: Typ n -> Typ n -> Bool
$c> :: forall n. Ord n => Typ n -> Typ n -> Bool
<= :: Typ n -> Typ n -> Bool
$c<= :: forall n. Ord n => Typ n -> Typ n -> Bool
< :: Typ n -> Typ n -> Bool
$c< :: forall n. Ord n => Typ n -> Typ n -> Bool
compare :: Typ n -> Typ n -> Ordering
$ccompare :: forall n. Ord n => Typ n -> Typ n -> Ordering
$cp1Ord :: forall n. Ord n => Eq (Typ n)
Ord, a -> Typ b -> Typ a
(a -> b) -> Typ a -> Typ b
(forall a b. (a -> b) -> Typ a -> Typ b)
-> (forall a b. a -> Typ b -> Typ a) -> Functor Typ
forall a b. a -> Typ b -> Typ a
forall a b. (a -> b) -> Typ a -> Typ b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Typ b -> Typ a
$c<$ :: forall a b. a -> Typ b -> Typ a
fmap :: (a -> b) -> Typ a -> Typ b
$cfmap :: forall a b. (a -> b) -> Typ a -> Typ b
Functor)

-- Rebuild a little bit of recursion-schemes machinery for Typ.
data TypF n t
    = TyFunF [t] t
    | TyConF n [t]
    | TyVarF n [t]
  deriving (TypF n t -> TypF n t -> Bool
(TypF n t -> TypF n t -> Bool)
-> (TypF n t -> TypF n t -> Bool) -> Eq (TypF n t)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n t. (Eq t, Eq n) => TypF n t -> TypF n t -> Bool
/= :: TypF n t -> TypF n t -> Bool
$c/= :: forall n t. (Eq t, Eq n) => TypF n t -> TypF n t -> Bool
== :: TypF n t -> TypF n t -> Bool
$c== :: forall n t. (Eq t, Eq n) => TypF n t -> TypF n t -> Bool
Eq, Eq (TypF n t)
Eq (TypF n t)
-> (TypF n t -> TypF n t -> Ordering)
-> (TypF n t -> TypF n t -> Bool)
-> (TypF n t -> TypF n t -> Bool)
-> (TypF n t -> TypF n t -> Bool)
-> (TypF n t -> TypF n t -> Bool)
-> (TypF n t -> TypF n t -> TypF n t)
-> (TypF n t -> TypF n t -> TypF n t)
-> Ord (TypF n t)
TypF n t -> TypF n t -> Bool
TypF n t -> TypF n t -> Ordering
TypF n t -> TypF n t -> TypF n t
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 n t. (Ord t, Ord n) => Eq (TypF n t)
forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Bool
forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Ordering
forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> TypF n t
min :: TypF n t -> TypF n t -> TypF n t
$cmin :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> TypF n t
max :: TypF n t -> TypF n t -> TypF n t
$cmax :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> TypF n t
>= :: TypF n t -> TypF n t -> Bool
$c>= :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Bool
> :: TypF n t -> TypF n t -> Bool
$c> :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Bool
<= :: TypF n t -> TypF n t -> Bool
$c<= :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Bool
< :: TypF n t -> TypF n t -> Bool
$c< :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Bool
compare :: TypF n t -> TypF n t -> Ordering
$ccompare :: forall n t. (Ord t, Ord n) => TypF n t -> TypF n t -> Ordering
$cp1Ord :: forall n t. (Ord t, Ord n) => Eq (TypF n t)
Ord, a -> TypF n b -> TypF n a
(a -> b) -> TypF n a -> TypF n b
(forall a b. (a -> b) -> TypF n a -> TypF n b)
-> (forall a b. a -> TypF n b -> TypF n a) -> Functor (TypF n)
forall a b. a -> TypF n b -> TypF n a
forall a b. (a -> b) -> TypF n a -> TypF n b
forall n a b. a -> TypF n b -> TypF n a
forall n a b. (a -> b) -> TypF n a -> TypF n b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TypF n b -> TypF n a
$c<$ :: forall n a b. a -> TypF n b -> TypF n a
fmap :: (a -> b) -> TypF n a -> TypF n b
$cfmap :: forall n a b. (a -> b) -> TypF n a -> TypF n b
Functor)

unroll :: Typ n -> TypF n (Typ n)
unroll :: Typ n -> TypF n (Typ n)
unroll = \case
    TyFun [Typ n]
args Typ n
retn -> [Typ n] -> Typ n -> TypF n (Typ n)
forall n t. [t] -> t -> TypF n t
TyFunF [Typ n]
args Typ n
retn
    TyCon n
n [Typ n]
tys     -> n -> [Typ n] -> TypF n (Typ n)
forall n t. n -> [t] -> TypF n t
TyConF n
n [Typ n]
tys
    TyVar n
n [Typ n]
tys     -> n -> [Typ n] -> TypF n (Typ n)
forall n t. n -> [t] -> TypF n t
TyVarF n
n [Typ n]
tys

foldTy :: (TypF n a -> a) -> Typ n -> a
foldTy :: (TypF n a -> a) -> Typ n -> a
foldTy TypF n a -> a
phi = TypF n a -> a
phi (TypF n a -> a) -> (Typ n -> TypF n a) -> Typ n -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Typ n -> a) -> TypF n (Typ n) -> TypF n a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TypF n a -> a) -> Typ n -> a
forall n a. (TypF n a -> a) -> Typ n -> a
foldTy TypF n a -> a
phi) (TypF n (Typ n) -> TypF n a)
-> (Typ n -> TypF n (Typ n)) -> Typ n -> TypF n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typ n -> TypF n (Typ n)
forall n. Typ n -> TypF n (Typ n)
unroll

instance Show n => Show (Typ n) where
    show :: Typ n -> FilePath
show = (TypF n FilePath -> FilePath) -> Typ n -> FilePath
forall n a. (TypF n a -> a) -> Typ n -> a
foldTy ((TypF n FilePath -> FilePath) -> Typ n -> FilePath)
-> (TypF n FilePath -> FilePath) -> Typ n -> FilePath
forall a b. (a -> b) -> a -> b
$ \case
        TyFunF [FilePath]
typs FilePath
res -> FilePath
"<" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " [FilePath]
typs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"; " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
res FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
">"
        TyConF n
n [FilePath]
args -> [FilePath] -> FilePath
unwords (n -> FilePath
forall a. Show a => a -> FilePath
show n
n FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)
        TyVarF n
n [FilePath]
args -> [FilePath] -> FilePath
unwords (n -> FilePath
forall a. Show a => a -> FilePath
show n
n FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)

-- Convert a Sig to a Typ.
toTyp :: Name -> Sig Name -> Typ Name
toTyp :: Name -> Sig Name -> Typ Name
toTyp Name
arrow Sig{[Ty Name]
[Ctx Name]
sigTy :: [Ty Name]
sigCtx :: [Ctx Name]
sigCtx :: forall n. Sig n -> [Ctx n]
sigTy :: forall n. Sig n -> [Ty n]
..} = case [Ty Name]
sigTy of
    [] -> FilePath -> Typ Name
forall a. HasCallStack => FilePath -> a
error FilePath
"no types?"
    [Ty Name]
tys -> let args :: [Ty Name]
args = [Ty Name] -> [Ty Name]
forall a. [a] -> [a]
init [Ty Name]
tys
               retn :: Ty Name
retn = [Ty Name] -> Ty Name
forall a. [a] -> a
last [Ty Name]
tys
           in [Typ Name] -> Typ Name -> Typ Name
forall n. [Typ n] -> Typ n -> Typ n
TyFun ((Ty Name -> Typ Name) -> [Ty Name] -> [Typ Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Name -> Typ Name
toTy [Ty Name]
args) (Ty Name -> Typ Name
toTy Ty Name
retn)
  where
    toTy :: Ty Name -> Typ Name
toTy = \case
      TCon Name
n []   | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
arrow -> Name -> [Typ Name] -> Typ Name
forall n. n -> [Typ n] -> Typ n
TyCon Name
n [] -- empty function type?!
      TCon Name
n [Ty Name]
tys | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
arrow -> [Typ Name] -> Typ Name -> Typ Name
forall n. [Typ n] -> Typ n -> Typ n
TyFun ((Ty Name -> Typ Name) -> [Ty Name] -> [Typ Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Name -> Typ Name
toTy ([Ty Name] -> [Ty Name]
forall a. [a] -> [a]
init [Ty Name]
tys)) (Ty Name -> Typ Name
toTy (Ty Name -> Typ Name) -> Ty Name -> Typ Name
forall a b. (a -> b) -> a -> b
$ [Ty Name] -> Ty Name
forall a. [a] -> a
last [Ty Name]
tys)
      TCon Name
n [Ty Name]
tys -> Name -> [Typ Name] -> Typ Name
forall n. n -> [Typ n] -> Typ n
TyCon Name
n ((Ty Name -> Typ Name) -> [Ty Name] -> [Typ Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Name -> Typ Name
toTy [Ty Name]
tys)
      TVar Name
n [Ty Name]
tys -> Name -> [Typ Name] -> Typ Name
forall n. n -> [Typ n] -> Typ n
TyVar Name
n ((Ty Name -> Typ Name) -> [Ty Name] -> [Typ Name]
forall a b. (a -> b) -> [a] -> [b]
map Ty Name -> Typ Name
toTy [Ty Name]
tys)


---------------------------------------------------------------------
-- UNIFICATION

-- A union-find data structure for names

type NameRef s = STRef s (NameInfo s)

data NameInfo s =
    NameInfo { NameInfo s -> Maybe (NameRef s)
niParent :: !(Maybe (NameRef s))
             , NameInfo s -> Int
niRank   :: !Int
             , NameInfo s -> Name
niName   :: !Name
             , NameInfo s -> Bool
niFree   :: !Bool
             }
  deriving NameInfo s -> NameInfo s -> Bool
(NameInfo s -> NameInfo s -> Bool)
-> (NameInfo s -> NameInfo s -> Bool) -> Eq (NameInfo s)
forall s. NameInfo s -> NameInfo s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NameInfo s -> NameInfo s -> Bool
$c/= :: forall s. NameInfo s -> NameInfo s -> Bool
== :: NameInfo s -> NameInfo s -> Bool
$c== :: forall s. NameInfo s -> NameInfo s -> Bool
Eq

-- Find the name of the equivalence class's (current) representative.
getName :: NameRef s -> ST s Name
getName :: NameRef s -> ST s Name
getName NameRef s
ref = do
    NameRef s
rep <- NameRef s -> ST s (NameRef s)
forall s. NameRef s -> ST s (NameRef s)
findRep NameRef s
ref
    NameInfo s -> Name
forall s. NameInfo s -> Name
niName (NameInfo s -> Name) -> ST s (NameInfo s) -> ST s Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameRef s -> ST s (NameInfo s)
forall s a. STRef s a -> ST s a
readSTRef NameRef s
rep

-- Create a new name reference from a name. @fixed == True@ means
-- that the reference cannot be unified with any other fixed refs.
newNameInfo :: Bool -> Name -> ST s (STRef s (NameInfo s))
newNameInfo :: Bool -> Name -> ST s (STRef s (NameInfo s))
newNameInfo Bool
fixed Name
n = NameInfo s -> ST s (STRef s (NameInfo s))
forall a s. a -> ST s (STRef s a)
newSTRef (NameInfo s -> ST s (STRef s (NameInfo s)))
-> NameInfo s -> ST s (STRef s (NameInfo s))
forall a b. (a -> b) -> a -> b
$
  NameInfo :: forall s. Maybe (NameRef s) -> Int -> Name -> Bool -> NameInfo s
NameInfo { niParent :: Maybe (STRef s (NameInfo s))
niParent = Maybe (STRef s (NameInfo s))
forall a. Maybe a
Nothing
           , niRank :: Int
niRank   = Int
0
           , niName :: Name
niName   = Name
n
           , niFree :: Bool
niFree   = Bool -> Bool
not Bool
fixed Bool -> Bool -> Bool
&& Name -> Bool
isVar Name
n
           }

-- The "find" part of union-find, with path compression.
findRep :: NameRef s -> ST s (NameRef s)
findRep :: NameRef s -> ST s (NameRef s)
findRep NameRef s
ref = do
    NameInfo s
ni <- NameRef s -> ST s (NameInfo s)
forall s a. STRef s a -> ST s a
readSTRef NameRef s
ref
    case NameInfo s -> Maybe (NameRef s)
forall s. NameInfo s -> Maybe (NameRef s)
niParent NameInfo s
ni of
        Maybe (NameRef s)
Nothing -> NameRef s -> ST s (NameRef s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameRef s
ref
        Just NameRef s
p  -> do
            NameRef s
root <- NameRef s -> ST s (NameRef s)
forall s. NameRef s -> ST s (NameRef s)
findRep NameRef s
p
            NameRef s -> NameInfo s -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef NameRef s
ref (NameInfo s
ni { niParent :: Maybe (NameRef s)
niParent = NameRef s -> Maybe (NameRef s)
forall a. a -> Maybe a
Just NameRef s
root })
            NameRef s -> ST s (NameRef s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameRef s
root

-- The "union" part of union-find, with union-by-rank.
-- Each unification is given a cost of 1 work unit.
unifyName :: NameRef s -> NameRef s -> StateT Work (ST s) Bool
unifyName :: NameRef s -> NameRef s -> StateT Work (ST s) Bool
unifyName NameRef s
lhs NameRef s
rhs = do
    NameRef s
lhs' <- ST s (NameRef s) -> StateT Work (ST s) (NameRef s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (NameRef s) -> StateT Work (ST s) (NameRef s))
-> ST s (NameRef s) -> StateT Work (ST s) (NameRef s)
forall a b. (a -> b) -> a -> b
$ NameRef s -> ST s (NameRef s)
forall s. NameRef s -> ST s (NameRef s)
findRep NameRef s
lhs
    NameRef s
rhs' <- ST s (NameRef s) -> StateT Work (ST s) (NameRef s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (NameRef s) -> StateT Work (ST s) (NameRef s))
-> ST s (NameRef s) -> StateT Work (ST s) (NameRef s)
forall a b. (a -> b) -> a -> b
$ NameRef s -> ST s (NameRef s)
forall s. NameRef s -> ST s (NameRef s)
findRep NameRef s
rhs
    NameInfo s
lInfo <- ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s))
-> ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s)
forall a b. (a -> b) -> a -> b
$ NameRef s -> ST s (NameInfo s)
forall s a. STRef s a -> ST s a
readSTRef NameRef s
lhs'
    NameInfo s
rInfo <- ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s))
-> ST s (NameInfo s) -> StateT Work (ST s) (NameInfo s)
forall a b. (a -> b) -> a -> b
$ NameRef s -> ST s (NameInfo s)
forall s a. STRef s a -> ST s a
readSTRef NameRef s
rhs'
    let lFree :: Bool
lFree = NameInfo s -> Bool
forall s. NameInfo s -> Bool
niFree NameInfo s
lInfo
        rFree :: Bool
rFree = NameInfo s -> Bool
forall s. NameInfo s -> Bool
niFree NameInfo s
rInfo
        lName :: Name
lName = NameInfo s -> Name
forall s. NameInfo s -> Name
niName NameInfo s
lInfo
        rName :: Name
rName = NameInfo s -> Name
forall s. NameInfo s -> Name
niName NameInfo s
rInfo
    let ok :: Bool
ok = Bool
lFree Bool -> Bool -> Bool
|| Bool
rFree Bool -> Bool -> Bool
|| Name
lName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
rName
    Bool -> StateT Work (ST s) () -> StateT Work (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ok Bool -> Bool -> Bool
&& NameInfo s
lInfo NameInfo s -> NameInfo s -> Bool
forall a. Eq a => a -> a -> Bool
/= NameInfo s
rInfo) (StateT Work (ST s) () -> StateT Work (ST s) ())
-> StateT Work (ST s) () -> StateT Work (ST s) ()
forall a b. (a -> b) -> a -> b
$ do
        -- Union by rank, except prefer concrete names over type variables.
        Work -> StateT Work (ST s) ()
forall (m :: * -> *). Monad m => Work -> StateT Work m ()
workDelta (Int -> Work
Work Int
1)
        let lRank :: Int
lRank = NameInfo s -> Int
forall s. NameInfo s -> Int
niRank NameInfo s
lInfo
            rRank :: Int
rRank = NameInfo s -> Int
forall s. NameInfo s -> Int
niRank NameInfo s
rInfo
        let (NameRef s
root, NameRef s
child) = if Bool -> Bool
not Bool
lFree Bool -> Bool -> Bool
|| Int
lRank Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
rRank
                            then (NameRef s
lhs', NameRef s
rhs')
                            else (NameRef s
rhs', NameRef s
lhs')
        ST s () -> StateT Work (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT Work (ST s) ())
-> ST s () -> StateT Work (ST s) ()
forall a b. (a -> b) -> a -> b
$ NameRef s -> (NameInfo s -> NameInfo s) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' NameRef s
child (\NameInfo s
n -> NameInfo s
n { niParent :: Maybe (NameRef s)
niParent = NameRef s -> Maybe (NameRef s)
forall a. a -> Maybe a
Just NameRef s
root })
        Bool -> StateT Work (ST s) () -> StateT Work (ST s) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lRank Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rRank) (StateT Work (ST s) () -> StateT Work (ST s) ())
-> StateT Work (ST s) () -> StateT Work (ST s) ()
forall a b. (a -> b) -> a -> b
$ ST s () -> StateT Work (ST s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST s () -> StateT Work (ST s) ())
-> ST s () -> StateT Work (ST s) ()
forall a b. (a -> b) -> a -> b
$ NameRef s -> (NameInfo s -> NameInfo s) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' NameRef s
root (\NameInfo s
n -> NameInfo s
n { niRank :: Int
niRank = Int
lRank Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 })

    Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
ok

-- Allocate new references for each name that appears in the type and context.
refTyp :: Bool -> Typ Name -> [Ctx Name] -> ST s (Typ (NameRef s), [Ctx (NameRef s)])
refTyp :: Bool
-> Typ Name
-> [Ctx Name]
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
refTyp Bool
fixed Typ Name
t [Ctx Name]
cs =
    StateT
  (Map Name (NameRef s)) (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
-> Map Name (NameRef s)
-> ST s (Typ (NameRef s), [Ctx (NameRef s)])
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT
  (Map Name (NameRef s)) (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
go Map Name (NameRef s)
forall k a. Map k a
Map.empty
  where
    go :: StateT
  (Map Name (NameRef s)) (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
go = do
        Typ (NameRef s)
ty  <- Typ Name -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
mkRefs Typ Name
t
        [Ctx (NameRef s)]
ctx <- [Ctx Name]
-> (Ctx Name
    -> StateT (Map Name (NameRef s)) (ST s) (Ctx (NameRef s)))
-> StateT (Map Name (NameRef s)) (ST s) [Ctx (NameRef s)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Ctx Name]
cs ((Ctx Name
  -> StateT (Map Name (NameRef s)) (ST s) (Ctx (NameRef s)))
 -> StateT (Map Name (NameRef s)) (ST s) [Ctx (NameRef s)])
-> (Ctx Name
    -> StateT (Map Name (NameRef s)) (ST s) (Ctx (NameRef s)))
-> StateT (Map Name (NameRef s)) (ST s) [Ctx (NameRef s)]
forall a b. (a -> b) -> a -> b
$ \(Ctx Name
c Name
a) -> NameRef s -> NameRef s -> Ctx (NameRef s)
forall n. n -> n -> Ctx n
Ctx (NameRef s -> NameRef s -> Ctx (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
-> StateT
     (Map Name (NameRef s)) (ST s) (NameRef s -> Ctx (NameRef s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
getRef Name
c StateT (Map Name (NameRef s)) (ST s) (NameRef s -> Ctx (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
-> StateT (Map Name (NameRef s)) (ST s) (Ctx (NameRef s))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
getRef Name
a
        (Typ (NameRef s), [Ctx (NameRef s)])
-> StateT
     (Map Name (NameRef s)) (ST s) (Typ (NameRef s), [Ctx (NameRef s)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Typ (NameRef s)
ty, [Ctx (NameRef s)]
ctx)

    mkRefs :: Typ Name -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
mkRefs = (TypF Name (StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
 -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
-> Typ Name
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
forall n a. (TypF n a -> a) -> Typ n -> a
foldTy ((TypF
    Name (StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
  -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
 -> Typ Name
 -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
-> (TypF
      Name (StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
    -> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s)))
-> Typ Name
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
forall a b. (a -> b) -> a -> b
$ \case
        TyVarF Name
n [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args    -> NameRef s -> [Typ (NameRef s)] -> Typ (NameRef s)
forall n. n -> [Typ n] -> Typ n
TyVar (NameRef s -> [Typ (NameRef s)] -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
-> StateT
     (Map Name (NameRef s))
     (ST s)
     ([Typ (NameRef s)] -> Typ (NameRef s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
getRef Name
n StateT
  (Map Name (NameRef s))
  (ST s)
  ([Typ (NameRef s)] -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args
        TyConF Name
n [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args    -> NameRef s -> [Typ (NameRef s)] -> Typ (NameRef s)
forall n. n -> [Typ n] -> Typ n
TyCon (NameRef s -> [Typ (NameRef s)] -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
-> StateT
     (Map Name (NameRef s))
     (ST s)
     ([Typ (NameRef s)] -> Typ (NameRef s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
getRef Name
n StateT
  (Map Name (NameRef s))
  (ST s)
  ([Typ (NameRef s)] -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args
        TyFunF [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
retn -> [Typ (NameRef s)] -> Typ (NameRef s) -> Typ (NameRef s)
forall n. [Typ n] -> Typ n -> Typ n
TyFun ([Typ (NameRef s)] -> Typ (NameRef s) -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
-> StateT
     (Map Name (NameRef s)) (ST s) (Typ (NameRef s) -> Typ (NameRef s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
-> StateT (Map Name (NameRef s)) (ST s) [Typ (NameRef s)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))]
args StateT
  (Map Name (NameRef s)) (ST s) (Typ (NameRef s) -> Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
-> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StateT (Map Name (NameRef s)) (ST s) (Typ (NameRef s))
retn

    getRef :: Name -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
getRef Name
n = do
        Map Name (NameRef s)
known <- StateT (Map Name (NameRef s)) (ST s) (Map Name (NameRef s))
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case Name -> Map Name (NameRef s) -> Maybe (NameRef s)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
n Map Name (NameRef s)
known of
            Just NameRef s
ref -> NameRef s -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameRef s
ref
            Maybe (NameRef s)
Nothing  -> do
                NameRef s
ref <- ST s (NameRef s)
-> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Bool -> Name -> ST s (NameRef s)
forall s. Bool -> Name -> ST s (STRef s (NameInfo s))
newNameInfo Bool
fixed Name
n)
                Map Name (NameRef s) -> StateT (Map Name (NameRef s)) (ST s) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Name -> NameRef s -> Map Name (NameRef s) -> Map Name (NameRef s)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
n NameRef s
ref Map Name (NameRef s)
known)
                NameRef s -> StateT (Map Name (NameRef s)) (ST s) (NameRef s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NameRef s
ref

-- Unify two types.
unifyTyp :: Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp :: Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp Typ (NameRef s)
lhs Typ (NameRef s)
rhs = case (Typ (NameRef s)
lhs, Typ (NameRef s)
rhs) of
    (TyCon NameRef s
n [Typ (NameRef s)]
tys, TyVar NameRef s
n' [Typ (NameRef s)]
tys') | [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys' -> do
            Bool
ok <- NameRef s -> NameRef s -> StateT Work (ST s) Bool
forall s. NameRef s -> NameRef s -> StateT Work (ST s) Bool
unifyName NameRef s
n NameRef s
n'
            if Bool -> Bool
not Bool
ok
              then Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              else [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT Work (ST s) [Bool] -> StateT Work (ST s) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool)
-> [Typ (NameRef s)]
-> [Typ (NameRef s)]
-> StateT Work (ST s) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp [Typ (NameRef s)]
tys [Typ (NameRef s)]
tys'

    (TyCon NameRef s
n [Typ (NameRef s)]
tys, TyCon NameRef s
n' [Typ (NameRef s)]
tys') | [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys' -> do
            Bool
ok <- NameRef s -> NameRef s -> StateT Work (ST s) Bool
forall s. NameRef s -> NameRef s -> StateT Work (ST s) Bool
unifyName NameRef s
n NameRef s
n'
            if Bool -> Bool
not Bool
ok
              then Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              else [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT Work (ST s) [Bool] -> StateT Work (ST s) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool)
-> [Typ (NameRef s)]
-> [Typ (NameRef s)]
-> StateT Work (ST s) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp [Typ (NameRef s)]
tys [Typ (NameRef s)]
tys'

    (TyVar NameRef s
n [Typ (NameRef s)]
tys, TyVar NameRef s
n' [Typ (NameRef s)]
tys') | [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
tys' -> do
            Bool
ok <- NameRef s -> NameRef s -> StateT Work (ST s) Bool
forall s. NameRef s -> NameRef s -> StateT Work (ST s) Bool
unifyName NameRef s
n NameRef s
n'
            if Bool -> Bool
not Bool
ok
              then Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              else [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT Work (ST s) [Bool] -> StateT Work (ST s) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool)
-> [Typ (NameRef s)]
-> [Typ (NameRef s)]
-> StateT Work (ST s) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp [Typ (NameRef s)]
tys [Typ (NameRef s)]
tys'

    (TyFun [Typ (NameRef s)]
args Typ (NameRef s)
ret, TyFun [Typ (NameRef s)]
args' Typ (NameRef s)
ret') | [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Typ (NameRef s)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Typ (NameRef s)]
args' -> do
            Bool
ok <- Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp Typ (NameRef s)
ret Typ (NameRef s)
ret'
            if Bool -> Bool
not Bool
ok
              then Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
              else [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> StateT Work (ST s) [Bool] -> StateT Work (ST s) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool)
-> [Typ (NameRef s)]
-> [Typ (NameRef s)]
-> StateT Work (ST s) [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
forall s.
Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool
unifyTyp [Typ (NameRef s)]
args [Typ (NameRef s)]
args'

    (Typ (NameRef s), Typ (NameRef s))
_ -> Bool -> StateT Work (ST s) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- The total cost of a unification operation.
newtype Work = Work Int

unWork :: Work -> Int
unWork :: Work -> Int
unWork (Work Int
w) = Int
w

workDelta :: Monad m => Work -> StateT Work m ()
workDelta :: Work -> StateT Work m ()
workDelta (Work Int
dw) = (Work -> Work) -> StateT Work m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\(Work Int
w) -> Int -> Work
Work (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dw))