{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

-- | Preprocessing collecting names, data types, newtypes, imports, and exports
-- for all modules recursively.
module Fay.Compiler.InitialPass
  (initialPass
  ) where

import           Fay.Compiler.Prelude

import           Fay.Compiler.Desugar
import           Fay.Compiler.GADT
import           Fay.Compiler.Import
import           Fay.Compiler.Misc
import           Fay.Compiler.Parse
import qualified Fay.Exts                        as F
import           Fay.Exts.NoAnnotation           (unAnn)
import           Fay.Types

import           Control.Monad.Except            (throwError)
import           Control.Monad.RWS               (modify)
import qualified Data.Map                        as M
import           Language.Haskell.Exts hiding (name)
import qualified Language.Haskell.Names          as HN (getInterfaces)

-- | Preprocess and collect all information needed during code generation.
initialPass :: FilePath -> Compile ()
initialPass :: FilePath -> Compile ()
initialPass = (FilePath -> FilePath -> Compile ()) -> FilePath -> Compile ()
forall a.
(FilePath -> FilePath -> Compile a) -> FilePath -> Compile a
startCompile FilePath -> FilePath -> Compile ()
preprocessFileWithSource

-- | Preprocess a module given its filepath and content.
preprocessFileWithSource :: FilePath -> String -> Compile ()
preprocessFileWithSource :: FilePath -> FilePath -> Compile ()
preprocessFileWithSource FilePath
filepath FilePath
contents = do
  (()
_,CompileState
st,CompileWriter
_) <- FilePath
-> (() -> Module -> Compile ())
-> (FilePath -> FilePath -> Compile ())
-> (X -> Module -> IO (Either CompileError Module))
-> FilePath
-> Compile ((), CompileState, CompileWriter)
forall a.
(Monoid a, Semigroup a) =>
FilePath
-> (a -> Module -> Compile a)
-> (FilePath -> FilePath -> Compile a)
-> (X -> Module -> IO (Either CompileError Module))
-> FilePath
-> Compile (a, CompileState, CompileWriter)
compileWith FilePath
filepath () -> Module -> Compile ()
preprocessAST FilePath -> FilePath -> Compile ()
preprocessFileWithSource X -> Module -> IO (Either CompileError Module)
forall l.
(Data l, Typeable l) =>
l -> Module l -> IO (Either CompileError (Module l))
desugar FilePath
contents
  -- This is the state we want to keep
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateRecords :: [(QName, [Name])]
stateRecords     = CompileState -> [(QName, [Name])]
stateRecords     CompileState
st
                   , stateRecordTypes :: [(QName, [QName])]
stateRecordTypes = CompileState -> [(QName, [QName])]
stateRecordTypes CompileState
st
                   , stateImported :: [(ModuleName, FilePath)]
stateImported    = CompileState -> [(ModuleName, FilePath)]
stateImported    CompileState
st
                   , stateNewtypes :: [(QName, Maybe QName, Type)]
stateNewtypes    = CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes    CompileState
st
                   , stateInterfaces :: Map ModuleName Symbols
stateInterfaces  = CompileState -> Map ModuleName Symbols
stateInterfaces  CompileState
st
                   , stateTypeSigs :: Map QName Type
stateTypeSigs    = CompileState -> Map QName Type
stateTypeSigs    CompileState
st
                     -- TODO This needs to be added otherwise the
                     -- "executable" generation in Fay.hs gets the
                     -- wrong name. Not sure why it works to do it
                     -- here!
                   , stateModuleName :: ModuleName
stateModuleName  = CompileState -> ModuleName
stateModuleName  CompileState
st
                   }

-- | Preprocess from an AST
preprocessAST :: () -> F.Module -> Compile ()
preprocessAST :: () -> Module -> Compile ()
preprocessAST () mod :: Module
mod@(Module X
_ Maybe (ModuleHead X)
_ [ModulePragma X]
_ [ImportDecl X]
_ [Decl X]
decls) = do
  -- This can only return one element since we only compile one module.
  ~([Symbols
exports],Set (Error X)
_) <- Language
-> [Extension] -> [Module] -> Compile ([Symbols], Set (Error X))
forall (m :: * -> *) l.
(MonadModule m, ModuleInfo m ~ Symbols, Data l, SrcInfo l,
 Ord l) =>
Language
-> [Extension] -> [Module l] -> m ([Symbols], Set (Error l))
HN.getInterfaces Language
Haskell2010 [Extension]
defaultExtensions [Module
mod]
  (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateInterfaces :: Map ModuleName Symbols
stateInterfaces = ModuleName
-> Symbols -> Map ModuleName Symbols -> Map ModuleName Symbols
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (CompileState -> ModuleName
stateModuleName CompileState
s) Symbols
exports (Map ModuleName Symbols -> Map ModuleName Symbols)
-> Map ModuleName Symbols -> Map ModuleName Symbols
forall a b. (a -> b) -> a -> b
$ CompileState -> Map ModuleName Symbols
stateInterfaces CompileState
s }
  [Decl X] -> (Decl X -> Compile ()) -> Compile ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Decl X]
decls Decl X -> Compile ()
scanTypeSigs
  [Decl X] -> (Decl X -> Compile ()) -> Compile ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Decl X]
decls Decl X -> Compile ()
scanRecordDecls
  Compile () -> Compile () -> Compile ()
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
    ([Decl X] -> (Decl X -> Compile ()) -> Compile ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Decl X]
decls Decl X -> Compile ()
scanNewtypeDecls)
    (() -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
preprocessAST () Module
mod = CompileError -> Compile ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompileError -> Compile ()) -> CompileError -> Compile ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Module -> CompileError
UnsupportedModuleSyntax FilePath
"preprocessAST" Module
mod

--------------------------------------------------------------------------------
-- | Preprocessing

-- | Find newtype declarations
scanNewtypeDecls :: F.Decl -> Compile ()
scanNewtypeDecls :: Decl X -> Compile ()
scanNewtypeDecls (DataDecl X
_ NewType{} Maybe (Context X)
_ DeclHead X
_ [QualConDecl X]
constructors [Deriving X]
_) = [QualConDecl X] -> Compile ()
compileNewtypeDecl [QualConDecl X]
constructors
scanNewtypeDecls Decl X
_ = () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Add new types to the state
compileNewtypeDecl :: [F.QualConDecl] -> Compile ()
compileNewtypeDecl :: [QualConDecl X] -> Compile ()
compileNewtypeDecl [QualConDecl X
_ Maybe [TyVarBind X]
_ Maybe (Context X)
_ ConDecl X
condecl] = case ConDecl X
condecl of
    -- newtype declaration without destructor
  ConDecl X
_ Name X
name  [Type X
ty]            -> Name X -> Maybe (Name Any) -> Type X -> Compile ()
forall a a a. Name a -> Maybe (Name a) -> Type a -> Compile ()
addNewtype Name X
name Maybe (Name Any)
forall a. Maybe a
Nothing Type X
ty
  RecDecl X
_ Name X
cname [FieldDecl X
_ [Name X
dname] Type X
ty] -> Name X -> Maybe (Name X) -> Type X -> Compile ()
forall a a a. Name a -> Maybe (Name a) -> Type a -> Compile ()
addNewtype Name X
cname (Name X -> Maybe (Name X)
forall a. a -> Maybe a
Just Name X
dname) Type X
ty
  ConDecl X
x -> FilePath -> Compile ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> Compile ()) -> FilePath -> Compile ()
forall a b. (a -> b) -> a -> b
$ FilePath
"compileNewtypeDecl case: Should be impossible (this is a bug). Got: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ConDecl X -> FilePath
forall a. Show a => a -> FilePath
show ConDecl X
x
  where
    addNewtype :: Name a -> Maybe (Name a) -> Type a -> Compile ()
addNewtype Name a
cname Maybe (Name a)
dname Type a
ty = do
      QName
qcname <- Name a -> Compile QName
forall a. Name a -> Compile QName
qualify Name a
cname
      Maybe QName
qdname <- case Maybe (Name a)
dname of
                  Maybe (Name a)
Nothing -> Maybe QName -> Compile (Maybe QName)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing
                  Just Name a
n  -> QName -> Maybe QName
forall a. a -> Maybe a
Just (QName -> Maybe QName) -> Compile QName -> Compile (Maybe QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name a -> Compile QName
forall a. Name a -> Compile QName
qualify Name a
n
      (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\cs :: CompileState
cs@CompileState{stateNewtypes :: CompileState -> [(QName, Maybe QName, Type)]
stateNewtypes=[(QName, Maybe QName, Type)]
nts} ->
               CompileState
cs{stateNewtypes :: [(QName, Maybe QName, Type)]
stateNewtypes=(QName
qcname,Maybe QName
qdname,Type a -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn Type a
ty)(QName, Maybe QName, Type)
-> [(QName, Maybe QName, Type)] -> [(QName, Maybe QName, Type)]
forall a. a -> [a] -> [a]
:[(QName, Maybe QName, Type)]
nts})
compileNewtypeDecl [QualConDecl X]
q = FilePath -> Compile ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> Compile ()) -> FilePath -> Compile ()
forall a b. (a -> b) -> a -> b
$ FilePath
"compileNewtypeDecl: Should be impossible (this is a bug). Got: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [QualConDecl X] -> FilePath
forall a. Show a => a -> FilePath
show [QualConDecl X]
q

{-# ANN scanRecordDecls ("HLint: ignore Redundant flip" :: String) #-}
-- | Add record declarations to the state
scanRecordDecls :: F.Decl -> Compile ()
scanRecordDecls :: Decl X -> Compile ()
scanRecordDecls Decl X
decl = do
  case Decl X
decl of
    DataDecl X
_loc DataOrNew X
ty Maybe (Context X)
_ctx (DeclHead X -> Name X
forall a. DeclHead a -> Name a
F.declHeadName -> Name X
name) [QualConDecl X]
qualcondecls [Deriving X]
_deriv -> do
      let addIt :: Compile ()
addIt = let ns :: [Name X]
ns = ((QualConDecl X -> Name X) -> [QualConDecl X] -> [Name X])
-> [QualConDecl X] -> (QualConDecl X -> Name X) -> [Name X]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (QualConDecl X -> Name X) -> [QualConDecl X] -> [Name X]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [QualConDecl X]
qualcondecls (\(QualConDecl X
_loc' Maybe [TyVarBind X]
_tyvarbinds Maybe (Context X)
_ctx' ConDecl X
condecl) -> ConDecl X -> Name X
forall l. ConDecl l -> Name l
conDeclName ConDecl X
condecl)
                  in Name X -> [Name X] -> Compile ()
forall a a. Name a -> [Name a] -> Compile ()
addRecordTypeState Name X
name [Name X]
ns
      case DataOrNew X
ty of
        DataType{} -> Compile ()
addIt
        NewType{} -> Compile () -> Compile () -> Compile ()
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
                       (() -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                       Compile ()
addIt
    Decl X
_ -> () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  case Decl X
decl of
    DataDecl X
_ DataOrNew X
ty Maybe (Context X)
_ DeclHead X
_ [QualConDecl X]
constructors [Deriving X]
_ ->
      case DataOrNew X
ty of
        DataType{} -> [QualConDecl X] -> Compile ()
dataDecl [QualConDecl X]
constructors
        NewType{} -> Compile () -> Compile () -> Compile ()
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
                       (() -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                       ([QualConDecl X] -> Compile ()
dataDecl [QualConDecl X]
constructors)
    GDataDecl X
_ DataOrNew X
ty Maybe (Context X)
_ DeclHead X
_ Maybe (Type X)
_ [GadtDecl X]
decls [Deriving X]
_ ->
      case DataOrNew X
ty of
        DataType{} -> [QualConDecl X] -> Compile ()
dataDecl ((GadtDecl X -> QualConDecl X) -> [GadtDecl X] -> [QualConDecl X]
forall a b. (a -> b) -> [a] -> [b]
map GadtDecl X -> QualConDecl X
forall a. GadtDecl a -> QualConDecl a
convertGADT [GadtDecl X]
decls)
        NewType{} -> Compile () -> Compile () -> Compile ()
forall a. Compile a -> Compile a -> Compile a
ifOptimizeNewtypes
                       (() -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                       ([QualConDecl X] -> Compile ()
dataDecl ((GadtDecl X -> QualConDecl X) -> [GadtDecl X] -> [QualConDecl X]
forall a b. (a -> b) -> [a] -> [b]
map GadtDecl X -> QualConDecl X
forall a. GadtDecl a -> QualConDecl a
convertGADT [GadtDecl X]
decls))
    Decl X
_ -> () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    addRecordTypeState :: Name a -> [Name a] -> Compile ()
addRecordTypeState (Name a -> Name
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name
name') ((Name a -> Name) -> [Name a] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name a -> Name
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> [Name]
cons') = do
      QName
name <- Name -> Compile QName
forall a. Name a -> Compile QName
qualify Name
name'
      [QName]
cons <- (Name -> Compile QName) -> [Name] -> Compile [QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Name -> Compile QName
forall a. Name a -> Compile QName
qualify [Name]
cons'
      (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateRecordTypes :: [(QName, [QName])]
stateRecordTypes = (QName
name, [QName]
cons) (QName, [QName]) -> [(QName, [QName])] -> [(QName, [QName])]
forall a. a -> [a] -> [a]
: CompileState -> [(QName, [QName])]
stateRecordTypes CompileState
s }

    conDeclName :: ConDecl l -> Name l
conDeclName (ConDecl l
_ Name l
n [Type l]
_) = Name l
n
    conDeclName (InfixConDecl l
_ Type l
_ Name l
n Type l
_) = Name l
n
    conDeclName (RecDecl l
_ Name l
n [FieldDecl l]
_) = Name l
n

    -- | Collect record definitions and store record name and field names.
    -- A ConDecl will have fields named slot1..slotN
    dataDecl :: [F.QualConDecl] -> Compile ()
    dataDecl :: [QualConDecl X] -> Compile ()
dataDecl [QualConDecl X]
constructors =
      [QualConDecl X] -> (QualConDecl X -> Compile ()) -> Compile ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [QualConDecl X]
constructors ((QualConDecl X -> Compile ()) -> Compile ())
-> (QualConDecl X -> Compile ()) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \(QualConDecl X
_ Maybe [TyVarBind X]
_ Maybe (Context X)
_ ConDecl X
condecl) ->
        case ConDecl X
condecl of
          ConDecl X
_ Name X
name [Type X]
types -> do
            let fields :: [Name]
fields =  ((Integer, Type X) -> Name) -> [(Integer, Type X)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (() -> FilePath -> Name
forall l. l -> FilePath -> Name l
Ident () (FilePath -> Name)
-> ((Integer, Type X) -> FilePath) -> (Integer, Type X) -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"slot"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ((Integer, Type X) -> FilePath) -> (Integer, Type X) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> FilePath)
-> ((Integer, Type X) -> Integer) -> (Integer, Type X) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, Type X) -> Integer
forall a b. (a, b) -> a
fst) ([(Integer, Type X)] -> [Name])
-> ([Type X] -> [(Integer, Type X)]) -> [Type X] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Integer] -> [Type X] -> [(Integer, Type X)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1 :: Integer ..] ([Type X] -> [Name]) -> [Type X] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Type X]
types
            Name X -> [Name] -> Compile ()
forall a a. Name a -> [Name a] -> Compile ()
addRecordState Name X
name [Name]
fields
          InfixConDecl X
_ Type X
_t1 Name X
name Type X
_t2 ->
            Name X -> [Name X] -> Compile ()
forall a a. Name a -> [Name a] -> Compile ()
addRecordState Name X
name [FilePath -> Name X
F.mkIdent FilePath
"slot1", FilePath -> Name X
F.mkIdent FilePath
"slot2"]
          RecDecl X
_ Name X
name [FieldDecl X]
fields' -> do
            let fields :: [Name X]
fields = (FieldDecl X -> [Name X]) -> [FieldDecl X] -> [Name X]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FieldDecl X -> [Name X]
forall a. FieldDecl a -> [Name a]
F.fieldDeclNames [FieldDecl X]
fields'
            Name X -> [Name X] -> Compile ()
forall a a. Name a -> [Name a] -> Compile ()
addRecordState Name X
name [Name X]
fields

      where
        addRecordState :: Name a -> [Name b] -> Compile ()
        addRecordState :: Name a -> [Name b] -> Compile ()
addRecordState Name a
name' [Name b]
fields = do
          QName
name <- Name a -> Compile QName
forall a. Name a -> Compile QName
qualify Name a
name'
          (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s
            { stateRecords :: [(QName, [Name])]
stateRecords = (QName
name,(Name b -> Name) -> [Name b] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name b -> Name
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn [Name b]
fields) (QName, [Name]) -> [(QName, [Name])] -> [(QName, [Name])]
forall a. a -> [a] -> [a]
: CompileState -> [(QName, [Name])]
stateRecords CompileState
s }

scanTypeSigs :: F.Decl -> Compile ()
scanTypeSigs :: Decl X -> Compile ()
scanTypeSigs Decl X
decl = case Decl X
decl of
  TypeSig X
_ [Name X]
names Type X
typ -> (Name X -> Compile ()) -> [Name X] -> Compile ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name X -> Type X -> Compile ()
`addTypeSig` Type X
typ) [Name X]
names
  Decl X
_ -> () -> Compile ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    addTypeSig :: F.Name -> F.Type -> Compile ()
    addTypeSig :: Name X -> Type X -> Compile ()
addTypeSig (Name X -> Name
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Name
n') (Type X -> Type
forall (f :: * -> *) a. Functor f => f a -> f ()
unAnn -> Type
t) = do
      QName
n <- Name -> Compile QName
forall a. Name a -> Compile QName
qualify Name
n'
      (CompileState -> CompileState) -> Compile ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CompileState -> CompileState) -> Compile ())
-> (CompileState -> CompileState) -> Compile ()
forall a b. (a -> b) -> a -> b
$ \CompileState
s -> CompileState
s { stateTypeSigs :: Map QName Type
stateTypeSigs = QName -> Type -> Map QName Type -> Map QName Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert QName
n Type
t (CompileState -> Map QName Type
stateTypeSigs CompileState
s) }