{- |
    Module      :  $Header$
    Description :  Environment containing the module's information
    Copyright   :  (c) 2011 - 2015 Björn Peemöller
    License     :  BSD-3-clause

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    This module defines the compilation environment for a single module,
     containing the information needed throughout the compilation process.
-}
module CompilerEnv where

import qualified Data.Map as Map (Map, keys, toList)

import Curry.Base.Ident    (ModuleIdent, moduleName)
import Curry.Base.Pretty
import Curry.Base.Span   (Span)
import Curry.Syntax

import Base.TopEnv (allBindings, allLocalBindings)

import Env.Class
import Env.Instance
import Env.Interface
import Env.ModuleAlias (AliasEnv, initAliasEnv)
import Env.OpPrec
import Env.TypeConstructor
import Env.Value

type CompEnv a = (CompilerEnv, a)

-- |A compiler environment contains information about the module currently
--  compiled. The information is updated during the different stages of
--  compilation.
data CompilerEnv = CompilerEnv
  { CompilerEnv -> ModuleIdent
moduleIdent  :: ModuleIdent         -- ^ identifier of the module
  , CompilerEnv -> FilePath
filePath     :: FilePath            -- ^ 'FilePath' of compilation target
  , CompilerEnv -> [KnownExtension]
extensions   :: [KnownExtension]    -- ^ enabled language extensions
  , CompilerEnv -> [(Span, Token)]
tokens       :: [(Span, Token)]     -- ^ token list of module
  , CompilerEnv -> InterfaceEnv
interfaceEnv :: InterfaceEnv        -- ^ declarations of imported interfaces
  , CompilerEnv -> AliasEnv
aliasEnv     :: AliasEnv            -- ^ aliases for imported modules
  , CompilerEnv -> TCEnv
tyConsEnv    :: TCEnv               -- ^ type constructors and type classes
  , CompilerEnv -> ClassEnv
classEnv     :: ClassEnv            -- ^ all type classes with their super classes
  , CompilerEnv -> InstEnv
instEnv      :: InstEnv             -- ^ instances
  , CompilerEnv -> ValueEnv
valueEnv     :: ValueEnv            -- ^ functions and data constructors
  , CompilerEnv -> OpPrecEnv
opPrecEnv    :: OpPrecEnv           -- ^ operator precedences
  }

-- |Initial 'CompilerEnv'
initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv :: ModuleIdent -> CompilerEnv
initCompilerEnv mid :: ModuleIdent
mid = CompilerEnv :: ModuleIdent
-> FilePath
-> [KnownExtension]
-> [(Span, Token)]
-> InterfaceEnv
-> AliasEnv
-> TCEnv
-> ClassEnv
-> InstEnv
-> ValueEnv
-> OpPrecEnv
-> CompilerEnv
CompilerEnv
  { moduleIdent :: ModuleIdent
moduleIdent  = ModuleIdent
mid
  , filePath :: FilePath
filePath     = []
  , extensions :: [KnownExtension]
extensions   = []
  , tokens :: [(Span, Token)]
tokens       = []
  , interfaceEnv :: InterfaceEnv
interfaceEnv = InterfaceEnv
initInterfaceEnv
  , aliasEnv :: AliasEnv
aliasEnv     = AliasEnv
initAliasEnv
  , tyConsEnv :: TCEnv
tyConsEnv    = TCEnv
initTCEnv
  , classEnv :: ClassEnv
classEnv     = ClassEnv
initClassEnv
  , instEnv :: InstEnv
instEnv      = InstEnv
initInstEnv
  , valueEnv :: ValueEnv
valueEnv     = ValueEnv
initDCEnv
  , opPrecEnv :: OpPrecEnv
opPrecEnv    = OpPrecEnv
initOpPrecEnv
  }

-- |Show the 'CompilerEnv'
showCompilerEnv :: CompilerEnv -> Bool -> Bool -> String
showCompilerEnv :: CompilerEnv -> Bool -> Bool -> FilePath
showCompilerEnv env :: CompilerEnv
env allBinds :: Bool
allBinds simpleEnv :: Bool
simpleEnv = Doc -> FilePath
forall a. Show a => a -> FilePath
show (Doc -> FilePath) -> Doc -> FilePath
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
  [ FilePath -> Doc -> Doc
header "Module Identifier  " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text  (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ ModuleIdent -> FilePath
moduleName (ModuleIdent -> FilePath) -> ModuleIdent -> FilePath
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> ModuleIdent
moduleIdent CompilerEnv
env
  , FilePath -> Doc -> Doc
header "FilePath"            (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text  (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> FilePath
filePath    CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Language Extensions" (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ FilePath -> Doc
text  (FilePath -> Doc) -> FilePath -> Doc
forall a b. (a -> b) -> a -> b
$ [KnownExtension] -> FilePath
forall a. Show a => a -> FilePath
show ([KnownExtension] -> FilePath) -> [KnownExtension] -> FilePath
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> [KnownExtension]
extensions  CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Interfaces         " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat  ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
comma
                                         ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ModuleIdent -> Doc) -> [ModuleIdent] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Doc
text (FilePath -> Doc)
-> (ModuleIdent -> FilePath) -> ModuleIdent -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleIdent -> FilePath
moduleName)
                                         ([ModuleIdent] -> [Doc]) -> [ModuleIdent] -> [Doc]
forall a b. (a -> b) -> a -> b
$ InterfaceEnv -> [ModuleIdent]
forall k a. Map k a -> [k]
Map.keys (InterfaceEnv -> [ModuleIdent]) -> InterfaceEnv -> [ModuleIdent]
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> InterfaceEnv
interfaceEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Module Aliases     " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> AliasEnv -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> Map a b -> Doc
ppMap Bool
simpleEnv (AliasEnv -> Doc) -> AliasEnv -> Doc
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> AliasEnv
aliasEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Precedences        " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [(QualIdent, PrecInfo)] -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> [(a, b)] -> Doc
ppAL Bool
simpleEnv ([(QualIdent, PrecInfo)] -> Doc) -> [(QualIdent, PrecInfo)] -> Doc
forall a b. (a -> b) -> a -> b
$ OpPrecEnv -> [(QualIdent, PrecInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
bindings (OpPrecEnv -> [(QualIdent, PrecInfo)])
-> OpPrecEnv -> [(QualIdent, PrecInfo)]
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> OpPrecEnv
opPrecEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Type Constructors  " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [(QualIdent, TypeInfo)] -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> [(a, b)] -> Doc
ppAL Bool
simpleEnv ([(QualIdent, TypeInfo)] -> Doc) -> [(QualIdent, TypeInfo)] -> Doc
forall a b. (a -> b) -> a -> b
$ TCEnv -> [(QualIdent, TypeInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
bindings (TCEnv -> [(QualIdent, TypeInfo)])
-> TCEnv -> [(QualIdent, TypeInfo)]
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> TCEnv
tyConsEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Classes            " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> ClassEnv -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> Map a b -> Doc
ppMap Bool
simpleEnv (ClassEnv -> Doc) -> ClassEnv -> Doc
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> ClassEnv
classEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Instances          " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> InstEnv -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> Map a b -> Doc
ppMap Bool
simpleEnv (InstEnv -> Doc) -> InstEnv -> Doc
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> InstEnv
instEnv CompilerEnv
env
  , FilePath -> Doc -> Doc
header "Values             " (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Bool -> [(QualIdent, ValueInfo)] -> Doc
forall a b.
(Show a, Pretty a, Show b, Pretty b) =>
Bool -> [(a, b)] -> Doc
ppAL Bool
simpleEnv ([(QualIdent, ValueInfo)] -> Doc)
-> [(QualIdent, ValueInfo)] -> Doc
forall a b. (a -> b) -> a -> b
$ ValueEnv -> [(QualIdent, ValueInfo)]
forall a. TopEnv a -> [(QualIdent, a)]
bindings (ValueEnv -> [(QualIdent, ValueInfo)])
-> ValueEnv -> [(QualIdent, ValueInfo)]
forall a b. (a -> b) -> a -> b
$ CompilerEnv -> ValueEnv
valueEnv  CompilerEnv
env
  ]
  where
  header :: FilePath -> Doc -> Doc
header hdr :: FilePath
hdr content :: Doc
content = Doc -> Int -> Doc -> Doc
hang (FilePath -> Doc
text FilePath
hdr Doc -> Doc -> Doc
<+> Doc
colon) 4 Doc
content
  bindings :: TopEnv a -> [(QualIdent, a)]
bindings = if Bool
allBinds then TopEnv a -> [(QualIdent, a)]
forall a. TopEnv a -> [(QualIdent, a)]
allBindings else TopEnv a -> [(QualIdent, a)]
forall a. TopEnv a -> [(QualIdent, a)]
allLocalBindings

-- |Pretty print a 'Map'
ppMap :: (Show a, Pretty a, Show b, Pretty b) => Bool-> Map.Map a b -> Doc
ppMap :: Bool -> Map a b -> Doc
ppMap True  = Map a b -> Doc
forall a b. (Pretty a, Pretty b) => Map a b -> Doc
ppMapPretty
ppMap False = Map a b -> Doc
forall a b. (Show a, Show b) => Map a b -> Doc
ppMapShow

ppMapShow :: (Show a, Show b) => Map.Map a b -> Doc
ppMapShow :: Map a b -> Doc
ppMapShow = [(a, b)] -> Doc
forall a b. (Show a, Show b) => [(a, b)] -> Doc
ppALShow ([(a, b)] -> Doc) -> (Map a b -> [(a, b)]) -> Map a b -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList

ppMapPretty :: (Pretty a, Pretty b) => Map.Map a b -> Doc
ppMapPretty :: Map a b -> Doc
ppMapPretty = [(a, b)] -> Doc
forall a b. (Pretty a, Pretty b) => [(a, b)] -> Doc
ppALPretty ([(a, b)] -> Doc) -> (Map a b -> [(a, b)]) -> Map a b -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList

-- |Pretty print an association list
ppAL :: (Show a, Pretty a, Show b, Pretty b) => Bool -> [(a, b)] -> Doc
ppAL :: Bool -> [(a, b)] -> Doc
ppAL True  = [(a, b)] -> Doc
forall a b. (Pretty a, Pretty b) => [(a, b)] -> Doc
ppALPretty
ppAL False = [(a, b)] -> Doc
forall a b. (Show a, Show b) => [(a, b)] -> Doc
ppALShow

ppALShow :: (Show a, Show b) => [(a, b)] -> Doc
ppALShow :: [(a, b)] -> Doc
ppALShow xs :: [(a, b)]
xs = [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Doc) -> [(FilePath, FilePath)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: FilePath
a,b :: FilePath
b) -> FilePath -> Doc
text (FilePath -> Int -> FilePath
pad FilePath
a Int
keyWidth) Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
b) [(FilePath, FilePath)]
showXs
  where showXs :: [(FilePath, FilePath)]
showXs   = ((a, b) -> (FilePath, FilePath))
-> [(a, b)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: a
a,b :: b
b) -> (a -> FilePath
forall a. Show a => a -> FilePath
show a
a, b -> FilePath
forall a. Show a => a -> FilePath
show b
b)) [(a, b)]
xs
        keyWidth :: Int
keyWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((FilePath, FilePath) -> Int) -> [(FilePath, FilePath)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
showXs)
        pad :: FilePath -> Int -> FilePath
pad s :: FilePath
s n :: Int
n  = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
n (FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char -> FilePath
forall a. a -> [a]
repeat ' ')

ppALPretty :: (Pretty a, Pretty b) => [(a, b)] -> Doc
ppALPretty :: [(a, b)] -> Doc
ppALPretty xs :: [(a, b)]
xs = [Doc] -> Doc
vcat
        ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> Doc) -> [(FilePath, FilePath)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: FilePath
a,b :: FilePath
b) -> FilePath -> Doc
text (FilePath -> Int -> FilePath
pad FilePath
a Int
keyWidth) Doc -> Doc -> Doc
<+> Doc
equals Doc -> Doc -> Doc
<+> FilePath -> Doc
text FilePath
b) [(FilePath, FilePath)]
showXs
  where showXs :: [(FilePath, FilePath)]
showXs   = ((a, b) -> (FilePath, FilePath))
-> [(a, b)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a :: a
a,b :: b
b) -> (Doc -> FilePath
render (a -> Doc
forall a. Pretty a => a -> Doc
pPrint a
a), Doc -> FilePath
render (b -> Doc
forall a. Pretty a => a -> Doc
pPrint b
b))) [(a, b)]
xs
        keyWidth :: Int
keyWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: ((FilePath, FilePath) -> Int) -> [(FilePath, FilePath)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (FilePath -> Int)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
showXs)
        pad :: FilePath -> Int -> FilePath
pad s :: FilePath
s n :: Int
n  = Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
take Int
n (FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char -> FilePath
forall a. a -> [a]
repeat ' ')