-- | Definitions of various semantic objects (*not* the Futhark
-- semantics themselves).
module Language.Futhark.Semantic
  ( ImportName,
    mkInitialImport,
    mkImportFrom,
    includeToFilePath,
    includeToString,
    includeToText,
    FileModule (..),
    Imports,
    Namespace (..),
    Env (..),
    TySet,
    FunSig (..),
    NameMap,
    BoundV (..),
    Mod (..),
    TypeBinding (..),
    MTy (..),
  )
where

import Data.Map.Strict qualified as M
import Data.Text qualified as T
import Futhark.Util (dropLast, fromPOSIX, toPOSIX)
import Futhark.Util.Loc
import Futhark.Util.Pretty
import Language.Futhark
import System.FilePath qualified as Native
import System.FilePath.Posix qualified as Posix
import Prelude hiding (mod)

-- | Canonical reference to a Futhark code file.  Does not include the
-- @.fut@ extension.  This is most often a path relative to the
-- current working directory of the compiler.
data ImportName = ImportName Posix.FilePath SrcLoc
  deriving (ImportName -> ImportName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ImportName -> ImportName -> Bool
$c/= :: ImportName -> ImportName -> Bool
== :: ImportName -> ImportName -> Bool
$c== :: ImportName -> ImportName -> Bool
Eq, Eq ImportName
ImportName -> ImportName -> Bool
ImportName -> ImportName -> Ordering
ImportName -> ImportName -> ImportName
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 :: ImportName -> ImportName -> ImportName
$cmin :: ImportName -> ImportName -> ImportName
max :: ImportName -> ImportName -> ImportName
$cmax :: ImportName -> ImportName -> ImportName
>= :: ImportName -> ImportName -> Bool
$c>= :: ImportName -> ImportName -> Bool
> :: ImportName -> ImportName -> Bool
$c> :: ImportName -> ImportName -> Bool
<= :: ImportName -> ImportName -> Bool
$c<= :: ImportName -> ImportName -> Bool
< :: ImportName -> ImportName -> Bool
$c< :: ImportName -> ImportName -> Bool
compare :: ImportName -> ImportName -> Ordering
$ccompare :: ImportName -> ImportName -> Ordering
Ord, Int -> ImportName -> ShowS
[ImportName] -> ShowS
ImportName -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ImportName] -> ShowS
$cshowList :: [ImportName] -> ShowS
show :: ImportName -> FilePath
$cshow :: ImportName -> FilePath
showsPrec :: Int -> ImportName -> ShowS
$cshowsPrec :: Int -> ImportName -> ShowS
Show)

instance Located ImportName where
  locOf :: ImportName -> Loc
locOf (ImportName FilePath
_ SrcLoc
loc) = forall a. Located a => a -> Loc
locOf SrcLoc
loc

-- | Create an import name immediately from a file path specified by
-- the user.
mkInitialImport :: Native.FilePath -> ImportName
mkInitialImport :: FilePath -> ImportName
mkInitialImport FilePath
s = FilePath -> SrcLoc -> ImportName
ImportName (ShowS
Posix.normalise forall a b. (a -> b) -> a -> b
$ ShowS
toPOSIX FilePath
s) forall a. IsLocation a => a
noLoc

-- | We resolve '..' paths here and assume that no shenanigans are
-- going on with symbolic links.  If there is, too bad.  Don't do
-- that.
mkImportFrom :: ImportName -> String -> SrcLoc -> ImportName
mkImportFrom :: ImportName -> FilePath -> SrcLoc -> ImportName
mkImportFrom (ImportName FilePath
includer SrcLoc
_) FilePath
includee
  | FilePath -> Bool
Posix.isAbsolute FilePath
includee = FilePath -> SrcLoc -> ImportName
ImportName FilePath
includee
  | Bool
otherwise = FilePath -> SrcLoc -> ImportName
ImportName forall a b. (a -> b) -> a -> b
$ ShowS
Posix.normalise forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
Posix.joinPath forall a b. (a -> b) -> a -> b
$ [FilePath]
includer' forall a. [a] -> [a] -> [a]
++ [FilePath]
includee'
  where
    ([FilePath]
dotdots, [FilePath]
includee') = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (FilePath
"../" ==) forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
Posix.splitPath FilePath
includee
    includer_parts :: [FilePath]
includer_parts = forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
Posix.splitPath FilePath
includer
    includer' :: [FilePath]
includer'
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
dotdots forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
includer_parts =
          forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
dotdots forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
includer_parts) FilePath
"../"
      | Bool
otherwise =
          forall a. Int -> [a] -> [a]
dropLast (forall (t :: * -> *) a. Foldable t => t a -> Int
length [FilePath]
dotdots) [FilePath]
includer_parts

-- | Create a @.fut@ file corresponding to an 'ImportName'.
includeToFilePath :: ImportName -> Native.FilePath
includeToFilePath :: ImportName -> FilePath
includeToFilePath (ImportName FilePath
s SrcLoc
_) = ShowS
fromPOSIX forall a b. (a -> b) -> a -> b
$ ShowS
Posix.normalise FilePath
s FilePath -> ShowS
Posix.<.> FilePath
"fut"

-- | Produce a human-readable canonicalized string from an
-- 'ImportName'.
includeToString :: ImportName -> String
includeToString :: ImportName -> FilePath
includeToString (ImportName FilePath
s SrcLoc
_) = ShowS
Posix.normalise FilePath
s

-- | Produce a human-readable canonicalized text from an
-- 'ImportName'.
includeToText :: ImportName -> T.Text
includeToText :: ImportName -> Text
includeToText (ImportName FilePath
s SrcLoc
_) = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ShowS
Posix.normalise FilePath
s

-- | The result of type checking some file.  Can be passed to further
-- invocations of the type checker.
data FileModule = FileModule
  { -- | Abstract types.
    FileModule -> TySet
fileAbs :: TySet,
    FileModule -> Env
fileEnv :: Env,
    FileModule -> Prog
fileProg :: Prog
  }

-- | A mapping from import names to imports.  The ordering is significant.
type Imports = [(String, FileModule)]

-- | The space inhabited by a name.
data Namespace
  = -- | Functions and values.
    Term
  | Type
  | Signature
  deriving (Namespace -> Namespace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq, Eq Namespace
Namespace -> Namespace -> Bool
Namespace -> Namespace -> Ordering
Namespace -> Namespace -> Namespace
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 :: Namespace -> Namespace -> Namespace
$cmin :: Namespace -> Namespace -> Namespace
max :: Namespace -> Namespace -> Namespace
$cmax :: Namespace -> Namespace -> Namespace
>= :: Namespace -> Namespace -> Bool
$c>= :: Namespace -> Namespace -> Bool
> :: Namespace -> Namespace -> Bool
$c> :: Namespace -> Namespace -> Bool
<= :: Namespace -> Namespace -> Bool
$c<= :: Namespace -> Namespace -> Bool
< :: Namespace -> Namespace -> Bool
$c< :: Namespace -> Namespace -> Bool
compare :: Namespace -> Namespace -> Ordering
$ccompare :: Namespace -> Namespace -> Ordering
Ord, Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Namespace] -> ShowS
$cshowList :: [Namespace] -> ShowS
show :: Namespace -> FilePath
$cshow :: Namespace -> FilePath
showsPrec :: Int -> Namespace -> ShowS
$cshowsPrec :: Int -> Namespace -> ShowS
Show, Int -> Namespace
Namespace -> Int
Namespace -> [Namespace]
Namespace -> Namespace
Namespace -> Namespace -> [Namespace]
Namespace -> Namespace -> Namespace -> [Namespace]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Namespace -> Namespace -> Namespace -> [Namespace]
$cenumFromThenTo :: Namespace -> Namespace -> Namespace -> [Namespace]
enumFromTo :: Namespace -> Namespace -> [Namespace]
$cenumFromTo :: Namespace -> Namespace -> [Namespace]
enumFromThen :: Namespace -> Namespace -> [Namespace]
$cenumFromThen :: Namespace -> Namespace -> [Namespace]
enumFrom :: Namespace -> [Namespace]
$cenumFrom :: Namespace -> [Namespace]
fromEnum :: Namespace -> Int
$cfromEnum :: Namespace -> Int
toEnum :: Int -> Namespace
$ctoEnum :: Int -> Namespace
pred :: Namespace -> Namespace
$cpred :: Namespace -> Namespace
succ :: Namespace -> Namespace
$csucc :: Namespace -> Namespace
Enum)

-- | A mapping of abstract types to their liftedness.
type TySet = M.Map (QualName VName) Liftedness

-- | Representation of a module, which is either a plain environment,
-- or a parametric module ("functor" in SML).
data Mod
  = ModEnv Env
  | ModFun FunSig
  deriving (Int -> Mod -> ShowS
[Mod] -> ShowS
Mod -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Mod] -> ShowS
$cshowList :: [Mod] -> ShowS
show :: Mod -> FilePath
$cshow :: Mod -> FilePath
showsPrec :: Int -> Mod -> ShowS
$cshowsPrec :: Int -> Mod -> ShowS
Show)

-- | A parametric functor consists of a set of abstract types, the
-- environment of its parameter, and the resulting module type.
data FunSig = FunSig
  { FunSig -> TySet
funSigAbs :: TySet,
    FunSig -> Mod
funSigMod :: Mod,
    FunSig -> MTy
funSigMty :: MTy
  }
  deriving (Int -> FunSig -> ShowS
[FunSig] -> ShowS
FunSig -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FunSig] -> ShowS
$cshowList :: [FunSig] -> ShowS
show :: FunSig -> FilePath
$cshow :: FunSig -> FilePath
showsPrec :: Int -> FunSig -> ShowS
$cshowsPrec :: Int -> FunSig -> ShowS
Show)

-- | Representation of a module type.
data MTy = MTy
  { -- | Abstract types in the module type.
    MTy -> TySet
mtyAbs :: TySet,
    MTy -> Mod
mtyMod :: Mod
  }
  deriving (Int -> MTy -> ShowS
[MTy] -> ShowS
MTy -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MTy] -> ShowS
$cshowList :: [MTy] -> ShowS
show :: MTy -> FilePath
$cshow :: MTy -> FilePath
showsPrec :: Int -> MTy -> ShowS
$cshowsPrec :: Int -> MTy -> ShowS
Show)

-- | A binding from a name to its definition as a type.  We allow a
-- return type here to support type abbreviations that hide some inner
-- sizes (these must necessarily be 'Lifted' or 'SizeLifted').
data TypeBinding = TypeAbbr Liftedness [TypeParam] StructRetType
  deriving (TypeBinding -> TypeBinding -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeBinding -> TypeBinding -> Bool
$c/= :: TypeBinding -> TypeBinding -> Bool
== :: TypeBinding -> TypeBinding -> Bool
$c== :: TypeBinding -> TypeBinding -> Bool
Eq, Int -> TypeBinding -> ShowS
[TypeBinding] -> ShowS
TypeBinding -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TypeBinding] -> ShowS
$cshowList :: [TypeBinding] -> ShowS
show :: TypeBinding -> FilePath
$cshow :: TypeBinding -> FilePath
showsPrec :: Int -> TypeBinding -> ShowS
$cshowsPrec :: Int -> TypeBinding -> ShowS
Show)

-- | Type parameters, list of parameter types (optinally named), and
-- return type.  The type parameters are in scope in both parameter
-- types and the return type.  Non-functional values have only a
-- return type.
data BoundV = BoundV [TypeParam] StructType
  deriving (Int -> BoundV -> ShowS
[BoundV] -> ShowS
BoundV -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BoundV] -> ShowS
$cshowList :: [BoundV] -> ShowS
show :: BoundV -> FilePath
$cshow :: BoundV -> FilePath
showsPrec :: Int -> BoundV -> ShowS
$cshowsPrec :: Int -> BoundV -> ShowS
Show)

-- | A mapping from names (which always exist in some namespace) to a
-- unique (tagged) name.
type NameMap = M.Map (Namespace, Name) (QualName VName)

-- | Modules produces environment with this representation.
data Env = Env
  { Env -> Map VName BoundV
envVtable :: M.Map VName BoundV,
    Env -> Map VName TypeBinding
envTypeTable :: M.Map VName TypeBinding,
    Env -> Map VName MTy
envSigTable :: M.Map VName MTy,
    Env -> Map VName Mod
envModTable :: M.Map VName Mod,
    Env -> NameMap
envNameMap :: NameMap
  }
  deriving (Int -> Env -> ShowS
[Env] -> ShowS
Env -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Env] -> ShowS
$cshowList :: [Env] -> ShowS
show :: Env -> FilePath
$cshow :: Env -> FilePath
showsPrec :: Int -> Env -> ShowS
$cshowsPrec :: Int -> Env -> ShowS
Show)

instance Semigroup Env where
  Env Map VName BoundV
vt1 Map VName TypeBinding
tt1 Map VName MTy
st1 Map VName Mod
mt1 NameMap
nt1 <> :: Env -> Env -> Env
<> Env Map VName BoundV
vt2 Map VName TypeBinding
tt2 Map VName MTy
st2 Map VName Mod
mt2 NameMap
nt2 =
    Map VName BoundV
-> Map VName TypeBinding
-> Map VName MTy
-> Map VName Mod
-> NameMap
-> Env
Env (Map VName BoundV
vt1 forall a. Semigroup a => a -> a -> a
<> Map VName BoundV
vt2) (Map VName TypeBinding
tt1 forall a. Semigroup a => a -> a -> a
<> Map VName TypeBinding
tt2) (Map VName MTy
st1 forall a. Semigroup a => a -> a -> a
<> Map VName MTy
st2) (Map VName Mod
mt1 forall a. Semigroup a => a -> a -> a
<> Map VName Mod
mt2) (NameMap
nt1 forall a. Semigroup a => a -> a -> a
<> NameMap
nt2)

instance Pretty Namespace where
  pretty :: forall ann. Namespace -> Doc ann
pretty Namespace
Term = Doc ann
"name"
  pretty Namespace
Type = Doc ann
"type"
  pretty Namespace
Signature = Doc ann
"module type"

instance Monoid Env where
  mempty :: Env
mempty = Map VName BoundV
-> Map VName TypeBinding
-> Map VName MTy
-> Map VName Mod
-> NameMap
-> Env
Env forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

instance Pretty MTy where
  pretty :: forall ann. MTy -> Doc ann
pretty = forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. MTy -> Mod
mtyMod

instance Pretty Mod where
  pretty :: forall ann. Mod -> Doc ann
pretty (ModEnv Env
e) = forall a ann. Pretty a => a -> Doc ann
pretty Env
e
  pretty (ModFun (FunSig TySet
_ Mod
mod MTy
mty)) = forall a ann. Pretty a => a -> Doc ann
pretty Mod
mod forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"->" forall ann. Doc ann -> Doc ann -> Doc ann
</> forall a ann. Pretty a => a -> Doc ann
pretty MTy
mty

instance Pretty Env where
  pretty :: forall ann. Env -> Doc ann
pretty (Env Map VName BoundV
vtable Map VName TypeBinding
ttable Map VName MTy
sigtable Map VName Mod
modtable NameMap
_) =
    forall a. Doc a -> Doc a -> Doc a -> Doc a
nestedBlock Doc ann
"{" Doc ann
"}" forall a b. (a -> b) -> a -> b
$
      forall a. [Doc a] -> Doc a
stack forall a b. (a -> b) -> a -> b
$
        forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
line forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ forall a b. (a -> b) -> [a] -> [b]
map forall {v} {ann}. IsName v => (v, TypeBinding) -> Doc ann
renderTypeBind (forall k a. Map k a -> [(k, a)]
M.toList Map VName TypeBinding
ttable),
              forall a b. (a -> b) -> [a] -> [b]
map forall {v} {ann}. IsName v => (v, BoundV) -> Doc ann
renderValBind (forall k a. Map k a -> [(k, a)]
M.toList Map VName BoundV
vtable),
              forall a b. (a -> b) -> [a] -> [b]
map forall {v} {b} {ann}. IsName v => (v, b) -> Doc ann
renderModType (forall k a. Map k a -> [(k, a)]
M.toList Map VName MTy
sigtable),
              forall a b. (a -> b) -> [a] -> [b]
map forall {v} {a} {ann}. (IsName v, Pretty a) => (v, a) -> Doc ann
renderMod (forall k a. Map k a -> [(k, a)]
M.toList Map VName Mod
modtable)
            ]
    where
      renderTypeBind :: (v, TypeBinding) -> Doc ann
renderTypeBind (v
name, TypeAbbr Liftedness
l [TypeParam]
tps StructRetType
tp) =
        forall {a}. IsString a => Liftedness -> a
p Liftedness
l
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall v a. IsName v => v -> Doc a
prettyName v
name
            forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [TypeParam]
tps)
            forall a. Semigroup a => a -> a -> a
<> Doc ann
" ="
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty StructRetType
tp
        where
          p :: Liftedness -> a
p Liftedness
Lifted = a
"type^"
          p Liftedness
SizeLifted = a
"type~"
          p Liftedness
Unlifted = a
"type"
      renderValBind :: (v, BoundV) -> Doc ann
renderValBind (v
name, BoundV [TypeParam]
tps StructType
t) =
        Doc ann
"val"
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall v a. IsName v => v -> Doc a
prettyName v
name
            forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ((Doc ann
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [TypeParam]
tps)
            forall a. Semigroup a => a -> a -> a
<> Doc ann
" ="
          forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty StructType
t
      renderModType :: (v, b) -> Doc ann
renderModType (v
name, b
_sig) =
        Doc ann
"module type" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall v a. IsName v => v -> Doc a
prettyName v
name
      renderMod :: (v, a) -> Doc ann
renderMod (v
name, a
mod) =
        Doc ann
"module" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall v a. IsName v => v -> Doc a
prettyName v
name forall a. Semigroup a => a -> a -> a
<> Doc ann
" =" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty a
mod