{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Ormolu.Fixity
( OpName,
pattern OpName,
unOpName,
occOpName,
FixityDirection (..),
FixityInfo (..),
defaultFixityInfo,
FixityApproximation (..),
defaultFixityApproximation,
FixityOverrides (..),
defaultFixityOverrides,
ModuleReexports (..),
defaultModuleReexports,
PackageFixityMap (..),
ModuleFixityMap (..),
inferFixity,
HackageInfo (..),
hackageInfo,
defaultDependencies,
packageFixityMap,
packageFixityMap',
moduleFixityMap,
applyFixityOverrides,
)
where
import Data.Binary qualified as Binary
import Data.Binary.Get qualified as Binary
import Data.ByteString.Lazy qualified as BL
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as Map
import Data.MemoTrie (memo)
import Data.Set (Set)
import Data.Set qualified as Set
import Distribution.ModuleName (ModuleName)
import Distribution.Types.PackageName (PackageName, mkPackageName, unPackageName)
import Language.Haskell.Syntax.ImpExp (ImportListInterpretation (..))
import Ormolu.Fixity.Imports (FixityImport (..))
import Ormolu.Fixity.Internal
#if BUNDLE_FIXITIES
import Data.FileEmbed (embedFile)
#else
import qualified Data.ByteString as B
import System.IO.Unsafe (unsafePerformIO)
#endif
hackageInfo :: HackageInfo
#if BUNDLE_FIXITIES
hackageInfo :: HackageInfo
hackageInfo =
forall a. Get a -> ByteString -> a
Binary.runGet forall t. Binary t => Get t
Binary.get forall a b. (a -> b) -> a -> b
$
ByteString -> ByteString
BL.fromStrict $(embedFile "extract-hackage-info/hackage-info.bin")
#else
hackageInfo =
unsafePerformIO $
Binary.runGet Binary.get . BL.fromStrict <$> B.readFile "hackage-info.bin"
{-# NOINLINE hackageInfo #-}
#endif
defaultDependencies :: Set PackageName
defaultDependencies :: Set PackageName
defaultDependencies = forall a. a -> Set a
Set.singleton (String -> PackageName
mkPackageName String
"base")
packageFixityMap ::
Set PackageName ->
PackageFixityMap
packageFixityMap :: Set PackageName -> PackageFixityMap
packageFixityMap = HackageInfo -> Set PackageName -> PackageFixityMap
packageFixityMap' HackageInfo
hackageInfo
packageFixityMap' ::
HackageInfo ->
Set PackageName ->
PackageFixityMap
packageFixityMap' :: HackageInfo -> Set PackageName -> PackageFixityMap
packageFixityMap' (HackageInfo Map PackageName (Map ModuleName (Map OpName FixityInfo))
m) = forall v. (Set PackageName -> v) -> Set PackageName -> v
memoSet forall a b. (a -> b) -> a -> b
$ \Set PackageName
dependencies ->
Map OpName (NonEmpty (PackageName, ModuleName, FixityInfo))
-> PackageFixityMap
PackageFixityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {b} {a} {c}. (a, (b, (a, c))) -> (a, [(a, b, c)])
rearrange
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {a} {b}. Monad m => m (a, m b) -> m (a, b)
flatten
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall {m :: * -> *} {a} {b}. Monad m => m (a, m b) -> m (a, b)
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall k a. Map k a -> [(k, a)]
Map.toList)
forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map PackageName (Map ModuleName (Map OpName FixityInfo))
m Set PackageName
dependencies
where
rearrange :: (a, (b, (a, c))) -> (a, [(a, b, c)])
rearrange (a
packageName, (b
moduleName, (a
opName, c
fixityInfo))) =
(a
opName, [(a
packageName, b
moduleName, c
fixityInfo)])
flatten :: m (a, m b) -> m (a, b)
flatten m (a, m b)
xs = do
(a
k, m b
vs) <- m (a, m b)
xs
b
v <- m b
vs
forall (m :: * -> *) a. Monad m => a -> m a
return (a
k, b
v)
moduleFixityMap ::
PackageFixityMap ->
[FixityImport] ->
ModuleFixityMap
moduleFixityMap :: PackageFixityMap -> [FixityImport] -> ModuleFixityMap
moduleFixityMap (PackageFixityMap Map OpName (NonEmpty (PackageName, ModuleName, FixityInfo))
m) [FixityImport]
imports =
Map OpName FixityProvenance -> ModuleFixityMap
ModuleFixityMap forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
OpName
":"
(FixityInfo -> FixityProvenance
Given FixityInfo
colonFixityInfo)
(forall a b k. (a -> b) -> Map k a -> Map k b
Map.map NonEmpty (FixityQualification, FixityInfo) -> FixityProvenance
FromModuleImports (forall k a b. (k -> a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybeWithKey OpName
-> NonEmpty (PackageName, ModuleName, FixityInfo)
-> Maybe (NonEmpty (FixityQualification, FixityInfo))
select Map OpName (NonEmpty (PackageName, ModuleName, FixityInfo))
m))
where
select ::
OpName ->
NonEmpty (PackageName, ModuleName, FixityInfo) ->
Maybe (NonEmpty (FixityQualification, FixityInfo))
select :: OpName
-> NonEmpty (PackageName, ModuleName, FixityInfo)
-> Maybe (NonEmpty (FixityQualification, FixityInfo))
select OpName
opName =
let f :: (PackageName, ModuleName, t) -> [(FixityQualification, t)]
f (PackageName
packageName, ModuleName
moduleName, t
fixityInfo) =
(,t
fixityInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PackageName -> ModuleName -> OpName -> [FixityQualification]
resolveThroughImports PackageName
packageName ModuleName
moduleName OpName
opName
in forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {t}.
(PackageName, ModuleName, t) -> [(FixityQualification, t)]
f
resolveThroughImports ::
PackageName ->
ModuleName ->
OpName ->
[FixityQualification]
resolveThroughImports :: PackageName -> ModuleName -> OpName -> [FixityQualification]
resolveThroughImports PackageName
packageName ModuleName
moduleName OpName
opName =
let doesImportMatch :: FixityImport -> Bool
doesImportMatch FixityImport {Maybe (ImportListInterpretation, [OpName])
Maybe PackageName
ModuleName
FixityQualification
fimportList :: FixityImport -> Maybe (ImportListInterpretation, [OpName])
fimportQualified :: FixityImport -> FixityQualification
fimportModule :: FixityImport -> ModuleName
fimportPackage :: FixityImport -> Maybe PackageName
fimportList :: Maybe (ImportListInterpretation, [OpName])
fimportQualified :: FixityQualification
fimportModule :: ModuleName
fimportPackage :: Maybe PackageName
..} =
let packageMatches :: Bool
packageMatches =
case Maybe PackageName
fimportPackage of
Maybe PackageName
Nothing -> Bool
True
Just PackageName
p -> PackageName
p forall a. Eq a => a -> a -> Bool
== PackageName
packageName
moduleMatches :: Bool
moduleMatches =
ModuleName
fimportModule forall a. Eq a => a -> a -> Bool
== ModuleName
moduleName
opMatches :: Bool
opMatches = case Maybe (ImportListInterpretation, [OpName])
fimportList of
Maybe (ImportListInterpretation, [OpName])
Nothing -> Bool
True
Just (ImportListInterpretation
Exactly, [OpName]
xs) -> OpName
opName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [OpName]
xs
Just (ImportListInterpretation
EverythingBut, [OpName]
xs) -> OpName
opName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [OpName]
xs
in Bool
packageMatches Bool -> Bool -> Bool
&& Bool
moduleMatches Bool -> Bool -> Bool
&& Bool
opMatches
in FixityImport -> FixityQualification
fimportQualified forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter FixityImport -> Bool
doesImportMatch [FixityImport]
imports
applyFixityOverrides ::
FixityOverrides ->
ModuleFixityMap ->
ModuleFixityMap
applyFixityOverrides :: FixityOverrides -> ModuleFixityMap -> ModuleFixityMap
applyFixityOverrides (FixityOverrides Map OpName FixityInfo
o) (ModuleFixityMap Map OpName FixityProvenance
m) =
Map OpName FixityProvenance -> ModuleFixityMap
ModuleFixityMap (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map FixityInfo -> FixityProvenance
Given Map OpName FixityInfo
o) Map OpName FixityProvenance
m)
memoSet :: (Set PackageName -> v) -> Set PackageName -> v
memoSet :: forall v. (Set PackageName -> v) -> Set PackageName -> v
memoSet Set PackageName -> v
f =
forall t a. HasTrie t => (t -> a) -> t -> a
memo (Set PackageName -> v
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> PackageName
mkPackageName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageName -> String
unPackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toAscList