{-# LANGUAGE NamedFieldPuns #-}

-- | Pure functions for working with CompileState

module Fay.Compiler.State where

import           Fay.Compiler.Misc
import           Fay.Compiler.QName
import qualified Fay.Exts.NoAnnotation  as N
import           Fay.Types

import qualified Data.Map               as M
import           Data.Set               (Set)
import qualified Data.Set               as S
import           Language.Haskell.Names (sv_origName, Symbols (Symbols), SymValueInfo (SymValue, SymMethod, SymSelector, SymConstructor), OrigName, sv_typeName)

-- | Get all non local identifiers that should be exported in the JS module scope.
getNonLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)
getNonLocalExportsWithoutNewtypes :: ModuleName -> CompileState -> Maybe (Set QName)
getNonLocalExportsWithoutNewtypes ModuleName
modName CompileState
cs =
  (Symbols -> Set QName) -> Maybe Symbols -> Maybe (Set QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( (QName -> Bool) -> Set QName -> Set QName
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not (Bool -> Bool) -> (QName -> Bool) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool
isLocal)
       (Set QName -> Set QName)
-> (Symbols -> Set QName) -> Symbols -> Set QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> QName)
-> Set (SymValueInfo OrigName) -> Set QName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (OrigName -> QName
origName2QName (OrigName -> QName)
-> (SymValueInfo OrigName -> OrigName)
-> SymValueInfo OrigName
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName)
       (Set (SymValueInfo OrigName) -> Set QName)
-> (Symbols -> Set (SymValueInfo OrigName)) -> Symbols -> Set QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> Bool)
-> Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName)
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not (Bool -> Bool)
-> (SymValueInfo OrigName -> Bool) -> SymValueInfo OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> CompileState -> Bool
`isNewtype` CompileState
cs))
       (Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName))
-> (Symbols -> Set (SymValueInfo OrigName))
-> Symbols
-> Set (SymValueInfo OrigName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Symbols Set (SymValueInfo OrigName)
exports Set (SymTypeInfo OrigName)
_) -> Set (SymValueInfo OrigName)
exports)
       )
       (Maybe Symbols -> Maybe (Set QName))
-> (CompileState -> Maybe Symbols)
-> CompileState
-> Maybe (Set QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Map ModuleName Symbols -> Maybe Symbols
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
modName (Map ModuleName Symbols -> Maybe Symbols)
-> (CompileState -> Map ModuleName Symbols)
-> CompileState
-> Maybe Symbols
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileState -> Map ModuleName Symbols
stateInterfaces (CompileState -> Maybe (Set QName))
-> CompileState -> Maybe (Set QName)
forall a b. (a -> b) -> a -> b
$ CompileState
cs
  where
   isLocal :: QName -> Bool
isLocal = (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
modName Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe ModuleName -> Bool)
-> (QName -> Maybe ModuleName) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Maybe ModuleName
forall a. QName a -> Maybe (ModuleName a)
qModName

getLocalExportsWithoutNewtypes :: N.ModuleName -> CompileState -> Maybe (Set N.QName)
getLocalExportsWithoutNewtypes :: ModuleName -> CompileState -> Maybe (Set QName)
getLocalExportsWithoutNewtypes ModuleName
modName CompileState
cs =
  (Symbols -> Set QName) -> Maybe Symbols -> Maybe (Set QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( (QName -> Bool) -> Set QName -> Set QName
forall a. (a -> Bool) -> Set a -> Set a
S.filter QName -> Bool
isLocal
       (Set QName -> Set QName)
-> (Symbols -> Set QName) -> Symbols -> Set QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> QName)
-> Set (SymValueInfo OrigName) -> Set QName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (OrigName -> QName
origName2QName (OrigName -> QName)
-> (SymValueInfo OrigName -> OrigName)
-> SymValueInfo OrigName
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymValueInfo OrigName -> OrigName
forall name. SymValueInfo name -> name
sv_origName)
       (Set (SymValueInfo OrigName) -> Set QName)
-> (Symbols -> Set (SymValueInfo OrigName)) -> Symbols -> Set QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> Bool)
-> Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName)
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not (Bool -> Bool)
-> (SymValueInfo OrigName -> Bool) -> SymValueInfo OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymValueInfo OrigName -> CompileState -> Bool
`isNewtype` CompileState
cs))
       (Set (SymValueInfo OrigName) -> Set (SymValueInfo OrigName))
-> (Symbols -> Set (SymValueInfo OrigName))
-> Symbols
-> Set (SymValueInfo OrigName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Symbols Set (SymValueInfo OrigName)
exports Set (SymTypeInfo OrigName)
_) -> Set (SymValueInfo OrigName)
exports)
       )
       (Maybe Symbols -> Maybe (Set QName))
-> (CompileState -> Maybe Symbols)
-> CompileState
-> Maybe (Set QName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Map ModuleName Symbols -> Maybe Symbols
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup ModuleName
modName (Map ModuleName Symbols -> Maybe Symbols)
-> (CompileState -> Map ModuleName Symbols)
-> CompileState
-> Maybe Symbols
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileState -> Map ModuleName Symbols
stateInterfaces (CompileState -> Maybe (Set QName))
-> CompileState -> Maybe (Set QName)
forall a b. (a -> b) -> a -> b
$ CompileState
cs
  where
   isLocal :: QName -> Bool
isLocal = (ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ModuleName
modName Maybe ModuleName -> Maybe ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe ModuleName -> Bool)
-> (QName -> Maybe ModuleName) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Maybe ModuleName
forall a. QName a -> Maybe (ModuleName a)
qModName

-- | Is this *resolved* name a new type constructor or destructor?
isNewtype :: SymValueInfo OrigName -> CompileState -> Bool
isNewtype :: SymValueInfo OrigName -> CompileState -> Bool
isNewtype SymValueInfo OrigName
s CompileState
cs = case SymValueInfo OrigName
s of
  SymValue{}                          -> Bool
False
  SymMethod{}                         -> Bool
False
  SymSelector    { sv_typeName :: forall name. SymValueInfo name -> name
sv_typeName = OrigName
tn } -> Bool -> Bool
not (Bool -> Bool) -> (OrigName -> Bool) -> OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName -> CompileState -> Bool
`isNewtypeDest` CompileState
cs) (QName -> Bool) -> (OrigName -> QName) -> OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName (OrigName -> Bool) -> OrigName -> Bool
forall a b. (a -> b) -> a -> b
$ OrigName
tn
  SymConstructor { sv_typeName :: forall name. SymValueInfo name -> name
sv_typeName = OrigName
tn } -> Bool -> Bool
not (Bool -> Bool) -> (OrigName -> Bool) -> OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName -> CompileState -> Bool
`isNewtypeCons` CompileState
cs) (QName -> Bool) -> (OrigName -> QName) -> OrigName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrigName -> QName
origName2QName (OrigName -> Bool) -> OrigName -> Bool
forall a b. (a -> b) -> a -> b
$ OrigName
tn

-- | Is this *resolved* name a new type destructor?
isNewtypeDest :: N.QName -> CompileState -> Bool
isNewtypeDest :: QName -> CompileState -> Bool
isNewtypeDest QName
o = ((QName, Maybe QName, Type) -> Bool)
-> [(QName, Maybe QName, Type)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(QName
_,Maybe QName
mdest,Type
_) -> Maybe QName
mdest Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName -> Maybe QName
forall a. a -> Maybe a
Just QName
o) ([(QName, Maybe QName, Type)] -> Bool)
-> (CompileState -> [(QName, Maybe QName, Type)])
-> CompileState
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes

-- | Is this *resolved* name a new type constructor?
isNewtypeCons :: N.QName -> CompileState -> Bool
isNewtypeCons :: QName -> CompileState -> Bool
isNewtypeCons QName
o = ((QName, Maybe QName, Type) -> Bool)
-> [(QName, Maybe QName, Type)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(QName
cons,Maybe QName
_,Type
_) -> QName
cons  QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
o) ([(QName, Maybe QName, Type)] -> Bool)
-> (CompileState -> [(QName, Maybe QName, Type)])
-> CompileState
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes

-- | Add a ModulePath to CompileState, meaning it has been printed.
addModulePath :: ModulePath -> CompileState -> CompileState
addModulePath :: ModulePath -> CompileState -> CompileState
addModulePath ModulePath
mp CompileState
cs = CompileState
cs { stateJsModulePaths :: Set ModulePath
stateJsModulePaths = ModulePath
mp ModulePath -> Set ModulePath -> Set ModulePath
forall a. Ord a => a -> Set a -> Set a
`S.insert` CompileState -> Set ModulePath
stateJsModulePaths CompileState
cs }

-- | Has this ModulePath been added/printed?
addedModulePath :: ModulePath -> CompileState -> Bool
addedModulePath :: ModulePath -> CompileState -> Bool
addedModulePath ModulePath
mp CompileState { Set ModulePath
stateJsModulePaths :: Set ModulePath
stateJsModulePaths :: CompileState -> Set ModulePath
stateJsModulePaths } = ModulePath
mp ModulePath -> Set ModulePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set ModulePath
stateJsModulePaths

-- | Find the type signature of a top level name
findTypeSig :: N.QName -> CompileState -> Maybe N.Type
findTypeSig :: QName -> CompileState -> Maybe Type
findTypeSig QName
n  = QName -> Map QName Type -> Maybe Type
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup QName
n (Map QName Type -> Maybe Type)
-> (CompileState -> Map QName Type) -> CompileState -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompileState -> Map QName Type
stateTypeSigs