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.Pretty
import Language.Futhark
import System.FilePath qualified as Native
import System.FilePath.Posix qualified as Posix
import Prelude hiding (mod)
mkInitialImport :: Native.FilePath -> ImportName
mkInitialImport :: FilePath -> ImportName
mkInitialImport = FilePath -> ImportName
ImportName forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
Posix.normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
toPOSIX
mkImportFrom :: ImportName -> String -> ImportName
mkImportFrom :: ImportName -> FilePath -> ImportName
mkImportFrom (ImportName FilePath
includer) FilePath
includee
| FilePath -> Bool
Posix.isAbsolute FilePath
includee = FilePath -> ImportName
ImportName FilePath
includee
| Bool
otherwise = FilePath -> ImportName
ImportName forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
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
includeToFilePath :: ImportName -> Native.FilePath
includeToFilePath :: ImportName -> FilePath
includeToFilePath (ImportName FilePath
s) = FilePath -> FilePath
fromPOSIX forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
Posix.normalise FilePath
s FilePath -> FilePath -> FilePath
Posix.<.> FilePath
"fut"
includeToString :: ImportName -> String
includeToString :: ImportName -> FilePath
includeToString (ImportName FilePath
s) = FilePath -> FilePath
Posix.normalise FilePath
s
includeToText :: ImportName -> T.Text
includeToText :: ImportName -> Text
includeToText (ImportName FilePath
s) = FilePath -> Text
T.pack forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
Posix.normalise FilePath
s
data FileModule = FileModule
{
FileModule -> TySet
fileAbs :: TySet,
FileModule -> Env
fileEnv :: Env,
FileModule -> Prog
fileProg :: Prog,
FileModule -> Env
fileScope :: Env
}
type Imports = [(ImportName, FileModule)]
data Namespace
=
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 -> FilePath -> FilePath
[Namespace] -> FilePath -> FilePath
Namespace -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Namespace] -> FilePath -> FilePath
$cshowList :: [Namespace] -> FilePath -> FilePath
show :: Namespace -> FilePath
$cshow :: Namespace -> FilePath
showsPrec :: Int -> Namespace -> FilePath -> FilePath
$cshowsPrec :: Int -> Namespace -> FilePath -> FilePath
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)
type TySet = M.Map (QualName VName) Liftedness
data Mod
= ModEnv Env
| ModFun FunSig
deriving (Int -> Mod -> FilePath -> FilePath
[Mod] -> FilePath -> FilePath
Mod -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Mod] -> FilePath -> FilePath
$cshowList :: [Mod] -> FilePath -> FilePath
show :: Mod -> FilePath
$cshow :: Mod -> FilePath
showsPrec :: Int -> Mod -> FilePath -> FilePath
$cshowsPrec :: Int -> Mod -> FilePath -> FilePath
Show)
data FunSig = FunSig
{ FunSig -> TySet
funSigAbs :: TySet,
FunSig -> Mod
funSigMod :: Mod,
FunSig -> MTy
funSigMty :: MTy
}
deriving (Int -> FunSig -> FilePath -> FilePath
[FunSig] -> FilePath -> FilePath
FunSig -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [FunSig] -> FilePath -> FilePath
$cshowList :: [FunSig] -> FilePath -> FilePath
show :: FunSig -> FilePath
$cshow :: FunSig -> FilePath
showsPrec :: Int -> FunSig -> FilePath -> FilePath
$cshowsPrec :: Int -> FunSig -> FilePath -> FilePath
Show)
data MTy = MTy
{
MTy -> TySet
mtyAbs :: TySet,
MTy -> Mod
mtyMod :: Mod
}
deriving (Int -> MTy -> FilePath -> FilePath
[MTy] -> FilePath -> FilePath
MTy -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [MTy] -> FilePath -> FilePath
$cshowList :: [MTy] -> FilePath -> FilePath
show :: MTy -> FilePath
$cshow :: MTy -> FilePath
showsPrec :: Int -> MTy -> FilePath -> FilePath
$cshowsPrec :: Int -> MTy -> FilePath -> FilePath
Show)
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 -> FilePath -> FilePath
[TypeBinding] -> FilePath -> FilePath
TypeBinding -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [TypeBinding] -> FilePath -> FilePath
$cshowList :: [TypeBinding] -> FilePath -> FilePath
show :: TypeBinding -> FilePath
$cshow :: TypeBinding -> FilePath
showsPrec :: Int -> TypeBinding -> FilePath -> FilePath
$cshowsPrec :: Int -> TypeBinding -> FilePath -> FilePath
Show)
data BoundV = BoundV [TypeParam] StructType
deriving (Int -> BoundV -> FilePath -> FilePath
[BoundV] -> FilePath -> FilePath
BoundV -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [BoundV] -> FilePath -> FilePath
$cshowList :: [BoundV] -> FilePath -> FilePath
show :: BoundV -> FilePath
$cshow :: BoundV -> FilePath
showsPrec :: Int -> BoundV -> FilePath -> FilePath
$cshowsPrec :: Int -> BoundV -> FilePath -> FilePath
Show)
type NameMap = M.Map (Namespace, Name) (QualName VName)
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 -> FilePath -> FilePath
[Env] -> FilePath -> FilePath
Env -> FilePath
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [Env] -> FilePath -> FilePath
$cshowList :: [Env] -> FilePath -> FilePath
show :: Env -> FilePath
$cshow :: Env -> FilePath
showsPrec :: Int -> Env -> FilePath -> FilePath
$cshowsPrec :: Int -> Env -> FilePath -> FilePath
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