mirror of
https://github.com/carp-lang/Carp.git
synced 2024-09-11 05:25:28 +03:00
Refactor: clean up Env module, store type environments in modules (#1207)
* refactor: major environment mgmt refactor This big refactor primarily changes two things in terms of behavior: 1. Stores a SymPath on concretely named (non-generic) struct types; before we stored a string. 2. The SymPath mentioned in (1.) designates where the struct is stored in the current environment chain. Modules now carry a local type environment in addition to their local value environments. Any types defined in the module are added to this environment rather than the global type environment. To resolve a type such as `Foo.Bar` we now do the following: - Search the *global value environment* for the Foo module. - Get the type environment stored in the Foo module. - Search for Bar in the Foo module's type environment. Additionally, this commit eliminates the Lookup module entirely and refactors the Env module to handle all aspects of environment management in hopefully a more reusable fashion. I also took the opportunity to refactor primitiveDeftype in Primitives and qualifySym in Qualify, both of which were hefty functions that I found difficult to grok and needed refactoring anyway as a result of lookup changes (lookups now return an Either instead of a Maybe). Subsequent commits will clean up and clarify this work further. This does include one minor regression. Namely, an implementation of `hash` in core/Color that was maximally generic now needs type casting. * refactor: clean up recent Env changes This commit removes some redundant functions, unifies some logic, and renames some routines across the Env module in efforts to make it cleaner. Call sites have been updated accordingly. * chore: format code with ormolu * fix: update lookup tests Changes references to renamed functions in the Env module. * refactor: style + additional improvements from eriksvedang@ - Rename arrayTy -> arrayTyA in ArrayTemplates.hs to disambiguate. - Add maybeId util function. - Remove commented code. - Refactor a few functions for readability. * fix: fix type inference regression Recent commits introduced one minor regression whereby an instance of type inference in core/Color.carp no longer worked and required explicit type annotation. The problem ultimately had to do with qualification: - Prior to the recent changes, type inference worked because the call in question was qualified to Color.Id.get-tag, fixing the type. - Failing to copy over a local envs Use modules to function envs resulted in finding more than just Color.Id.get-tag for this instance. We now copy use modules over to function envs generated during qualification to ensure we resolve to Use'd definitions before more general cases. Similarly, I made a small change to primitiveUse to support contextual use calls (e.g. the `(use Id)` in Color.carp, which really means `(use Color.Id)`) * chore: Update some clarificatory comments * chore: fix inline comment
This commit is contained in:
parent
f90d677993
commit
e1943b29a9
@ -34,7 +34,6 @@ library
|
|||||||
Info,
|
Info,
|
||||||
InitialTypes,
|
InitialTypes,
|
||||||
Interfaces,
|
Interfaces,
|
||||||
Lookup,
|
|
||||||
Managed,
|
Managed,
|
||||||
Map,
|
Map,
|
||||||
Meta,
|
Meta,
|
||||||
|
@ -209,7 +209,7 @@ cTypeToCarpType ("long", 0) = LongTy
|
|||||||
cTypeToCarpType ("double", 0) = DoubleTy
|
cTypeToCarpType ("double", 0) = DoubleTy
|
||||||
cTypeToCarpType ("float", 0) = FloatTy
|
cTypeToCarpType ("float", 0) = FloatTy
|
||||||
cTypeToCarpType ("void", 0) = UnitTy
|
cTypeToCarpType ("void", 0) = UnitTy
|
||||||
cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy s) [])
|
cTypeToCarpType (s, 0) = (StructTy (ConcreteNameTy (SymPath [] s)) [])
|
||||||
cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1)))
|
cTypeToCarpType (x, stars) = (PointerTy (cTypeToCarpType (x, stars - 1)))
|
||||||
|
|
||||||
identifierChar :: Parsec.Parsec String () Char
|
identifierChar :: Parsec.Parsec String () Char
|
||||||
|
@ -10,6 +10,12 @@ import ToTemplate
|
|||||||
import Types
|
import Types
|
||||||
import TypesToC
|
import TypesToC
|
||||||
|
|
||||||
|
arrayTyA :: Ty
|
||||||
|
arrayTyA = StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]
|
||||||
|
|
||||||
|
arrayRef :: Ty
|
||||||
|
arrayRef = RefTy arrayTyA (VarTy "q")
|
||||||
|
|
||||||
-- | "Endofunctor Map"
|
-- | "Endofunctor Map"
|
||||||
templateEMap :: (String, Binder)
|
templateEMap :: (String, Binder)
|
||||||
templateEMap =
|
templateEMap =
|
||||||
@ -20,9 +26,8 @@ templateEMap =
|
|||||||
documentation
|
documentation
|
||||||
where
|
where
|
||||||
templateType =
|
templateType =
|
||||||
FuncTy [RefTy endomorphism (VarTy "q"), arrayTy] arrayTy StaticLifetimeTy
|
FuncTy [RefTy endomorphism (VarTy "q"), arrayTyA] arrayTyA StaticLifetimeTy
|
||||||
endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
|
endomorphism = FuncTy [VarTy "a"] (VarTy "a") (VarTy "fq")
|
||||||
arrayTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
|
||||||
documentation =
|
documentation =
|
||||||
"applies a function `f` to an array `a`. The type of the elements cannot change."
|
"applies a function `f` to an array `a`. The type of the elements cannot change."
|
||||||
creatorFunc :: TypeEnv -> Env -> Template
|
creatorFunc :: TypeEnv -> Env -> Template
|
||||||
@ -30,7 +35,7 @@ templateEMap =
|
|||||||
Template
|
Template
|
||||||
templateType
|
templateType
|
||||||
(templateLiteral "Array $NAME(Lambda *f, Array a)")
|
(templateLiteral "Array $NAME(Lambda *f, Array a)")
|
||||||
( \(FuncTy [_, StructTy (ConcreteNameTy "Array") [memberTy]] _ _) ->
|
( \(FuncTy [_, StructTy (ConcreteNameTy (SymPath [] "Array")) [memberTy]] _ _) ->
|
||||||
handleUnits memberTy
|
handleUnits memberTy
|
||||||
)
|
)
|
||||||
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
|
( \(FuncTy [RefTy t@(FuncTy fArgTys fRetTy _) _, _] _ _) ->
|
||||||
@ -64,9 +69,8 @@ templateEFilter :: (String, Binder)
|
|||||||
templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
|
templateEFilter = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq")
|
fTy = FuncTy [RefTy (VarTy "a") (VarTy "q")] BoolTy (VarTy "fq")
|
||||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
|
||||||
path = SymPath ["Array"] "endo-filter"
|
path = SymPath ["Array"] "endo-filter"
|
||||||
t = FuncTy [RefTy fTy (VarTy "w"), aTy] aTy StaticLifetimeTy
|
t = FuncTy [RefTy fTy (VarTy "w"), arrayTyA] arrayTyA StaticLifetimeTy
|
||||||
docs = "filters array members using a function. This function takes ownership."
|
docs = "filters array members using a function. This function takes ownership."
|
||||||
elt = "&((($a*)a.data)[i])"
|
elt = "&((($a*)a.data)[i])"
|
||||||
declaration :: String -> (String -> String) -> [Token]
|
declaration :: String -> (String -> String) -> [Token]
|
||||||
@ -108,9 +112,8 @@ templatePushBack =
|
|||||||
defineTypeParameterizedTemplate creator path t docs
|
defineTypeParameterizedTemplate creator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "push-back"
|
path = SymPath ["Array"] "push-back"
|
||||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
|
||||||
valTy = VarTy "a"
|
valTy = VarTy "a"
|
||||||
t = FuncTy [aTy, valTy] aTy StaticLifetimeTy
|
t = FuncTy [arrayTyA, valTy] arrayTyA StaticLifetimeTy
|
||||||
docs = "adds an element `value` to the end of an array `a`."
|
docs = "adds an element `value` to the end of an array `a`."
|
||||||
declaration :: String -> [Token]
|
declaration :: String -> [Token]
|
||||||
declaration setter =
|
declaration setter =
|
||||||
@ -146,9 +149,8 @@ templatePushBackBang =
|
|||||||
defineTypeParameterizedTemplate creator path t docs
|
defineTypeParameterizedTemplate creator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "push-back!"
|
path = SymPath ["Array"] "push-back!"
|
||||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
|
||||||
valTy = VarTy "a"
|
valTy = VarTy "a"
|
||||||
t = FuncTy [aTy, valTy] UnitTy StaticLifetimeTy
|
t = FuncTy [arrayRef, valTy] UnitTy StaticLifetimeTy
|
||||||
docs = "adds an element `value` to the end of an array `a` in-place."
|
docs = "adds an element `value` to the end of an array `a` in-place."
|
||||||
declaration :: String -> [Token]
|
declaration :: String -> [Token]
|
||||||
declaration setter =
|
declaration setter =
|
||||||
@ -182,8 +184,7 @@ templatePopBack :: (String, Binder)
|
|||||||
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
|
templatePopBack = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "pop-back"
|
path = SymPath ["Array"] "pop-back"
|
||||||
aTy = StructTy (ConcreteNameTy "Array") [VarTy "a"]
|
t = FuncTy [arrayTyA] arrayTyA StaticLifetimeTy
|
||||||
t = FuncTy [aTy] aTy StaticLifetimeTy
|
|
||||||
docs = "removes the last element of an array and returns the new array."
|
docs = "removes the last element of an array and returns the new array."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -214,8 +215,7 @@ templatePopBackBang =
|
|||||||
defineTypeParameterizedTemplate creator path t docs
|
defineTypeParameterizedTemplate creator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "pop-back!"
|
path = SymPath ["Array"] "pop-back!"
|
||||||
aTy = RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")
|
t = FuncTy [arrayRef] (VarTy "a") StaticLifetimeTy
|
||||||
t = FuncTy [aTy] (VarTy "a") StaticLifetimeTy
|
|
||||||
docs = "removes an element `value` from the end of an array `a` in-place and returns it."
|
docs = "removes an element `value` from the end of an array `a` in-place and returns it."
|
||||||
creator =
|
creator =
|
||||||
TemplateCreator $
|
TemplateCreator $
|
||||||
@ -250,7 +250,7 @@ templateNth =
|
|||||||
let t = VarTy "t"
|
let t = VarTy "t"
|
||||||
in defineTemplate
|
in defineTemplate
|
||||||
(SymPath ["Array"] "unsafe-nth")
|
(SymPath ["Array"] "unsafe-nth")
|
||||||
(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
|
(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) (VarTy "q"), IntTy] (RefTy t (VarTy "q")) StaticLifetimeTy)
|
||||||
"gets a reference to the `n`th element from an array `a`."
|
"gets a reference to the `n`th element from an array `a`."
|
||||||
(toTemplate "$t* $NAME (Array *aRef, int n)")
|
(toTemplate "$t* $NAME (Array *aRef, int n)")
|
||||||
( toTemplate $
|
( toTemplate $
|
||||||
@ -271,7 +271,7 @@ templateRaw :: (String, Binder)
|
|||||||
templateRaw =
|
templateRaw =
|
||||||
defineTemplate
|
defineTemplate
|
||||||
(SymPath ["Array"] "raw")
|
(SymPath ["Array"] "raw")
|
||||||
(FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
|
(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]] (PointerTy (VarTy "t")) StaticLifetimeTy)
|
||||||
"returns an array `a` as a raw pointer—useful for interacting with C."
|
"returns an array `a` as a raw pointer—useful for interacting with C."
|
||||||
(toTemplate "$t* $NAME (Array a)")
|
(toTemplate "$t* $NAME (Array a)")
|
||||||
(toTemplate "$DECL { return a.data; }")
|
(toTemplate "$DECL { return a.data; }")
|
||||||
@ -281,7 +281,8 @@ templateUnsafeRaw :: (String, Binder)
|
|||||||
templateUnsafeRaw =
|
templateUnsafeRaw =
|
||||||
defineTemplate
|
defineTemplate
|
||||||
(SymPath ["Array"] "unsafe-raw")
|
(SymPath ["Array"] "unsafe-raw")
|
||||||
(FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy "Array") [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
|
-- TODO: Fix me! Order of members of Ref is incorrect.
|
||||||
|
(FuncTy [RefTy (VarTy "q") (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"])] (PointerTy (VarTy "t")) StaticLifetimeTy)
|
||||||
"returns an array `a` as a raw pointer—useful for interacting with C."
|
"returns an array `a` as a raw pointer—useful for interacting with C."
|
||||||
(toTemplate "$t* $NAME (Array* a)")
|
(toTemplate "$t* $NAME (Array* a)")
|
||||||
(toTemplate "$DECL { return a->data; }")
|
(toTemplate "$DECL { return a->data; }")
|
||||||
@ -301,7 +302,7 @@ templateAset :: (String, Binder)
|
|||||||
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
|
templateAset = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "aset"
|
path = SymPath ["Array"] "aset"
|
||||||
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
|
t = FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"], IntTy, VarTy "t"] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy
|
||||||
docs = "sets an array element at the index `n` to a new value."
|
docs = "sets an array element at the index `n` to a new value."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -336,7 +337,7 @@ templateAsetBang :: (String, Binder)
|
|||||||
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
|
templateAsetBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "aset!"
|
path = SymPath ["Array"] "aset!"
|
||||||
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
|
t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
|
||||||
docs = "sets an array element at the index `n` to a new value in place."
|
docs = "sets an array element at the index `n` to a new value in place."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -372,7 +373,7 @@ templateAsetUninitializedBang :: (String, Binder)
|
|||||||
templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
|
templateAsetUninitializedBang = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "aset-uninitialized!"
|
path = SymPath ["Array"] "aset-uninitialized!"
|
||||||
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
|
t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q"), IntTy, VarTy "t"] UnitTy StaticLifetimeTy
|
||||||
docs = "sets an uninitialized array member. The old member will not be deleted."
|
docs = "sets an uninitialized array member. The old member will not be deleted."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\_ _ ->
|
\_ _ ->
|
||||||
@ -402,7 +403,7 @@ templateLength :: (String, Binder)
|
|||||||
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
|
templateLength = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "length"
|
path = SymPath ["Array"] "length"
|
||||||
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
|
t = FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) (VarTy "q")] IntTy StaticLifetimeTy
|
||||||
docs = "gets the length of the array."
|
docs = "gets the length of the array."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -418,7 +419,7 @@ templateAllocate :: (String, Binder)
|
|||||||
templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
|
templateAllocate = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "allocate"
|
path = SymPath ["Array"] "allocate"
|
||||||
t = FuncTy [IntTy] (StructTy (ConcreteNameTy "Array") [VarTy "t"]) StaticLifetimeTy
|
t = FuncTy [IntTy] (StructTy (ConcreteNameTy (SymPath [] "Array")) [VarTy "t"]) StaticLifetimeTy
|
||||||
docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
|
docs = "allocates an uninitialized array. You can initialize members using [`aset-uninitialized`](#aset-uninitialized)."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -448,7 +449,7 @@ templateDeleteArray :: (String, Binder)
|
|||||||
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
|
templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "delete"
|
path = SymPath ["Array"] "delete"
|
||||||
t = FuncTy [StructTy (ConcreteNameTy "Array") [VarTy "a"]] UnitTy StaticLifetimeTy
|
t = FuncTy [arrayTyA] UnitTy StaticLifetimeTy
|
||||||
docs = "deletes an array. This function should usually not be called manually."
|
docs = "deletes an array. This function should usually not be called manually."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -460,7 +461,7 @@ templateDeleteArray = defineTypeParameterizedTemplate templateCreator path t doc
|
|||||||
++ deleteTy typeEnv env arrayType
|
++ deleteTy typeEnv env arrayType
|
||||||
++ [TokC "}\n"]
|
++ [TokC "}\n"]
|
||||||
)
|
)
|
||||||
( \(FuncTy [StructTy (ConcreteNameTy "Array") [insideType]] UnitTy _) ->
|
( \(FuncTy [StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]] UnitTy _) ->
|
||||||
depsForDeleteFunc typeEnv env insideType
|
depsForDeleteFunc typeEnv env insideType
|
||||||
)
|
)
|
||||||
|
|
||||||
@ -474,7 +475,7 @@ deleteTy typeEnv env (StructTy _ [innerType]) =
|
|||||||
deleteTy _ _ _ = []
|
deleteTy _ _ _ = []
|
||||||
|
|
||||||
initTy :: Ty -> [String]
|
initTy :: Ty -> [String]
|
||||||
initTy (StructTy (ConcreteNameTy "Array") [innerType@FuncTy {}]) =
|
initTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType@FuncTy {}]) =
|
||||||
[ " // initialize each Lambda struct ",
|
[ " // initialize each Lambda struct ",
|
||||||
" for(int i = 0; i < a.len; i++) {",
|
" for(int i = 0; i < a.len; i++) {",
|
||||||
" " ++ insideArrayInitLambda innerType "i",
|
" " ++ insideArrayInitLambda innerType "i",
|
||||||
@ -510,7 +511,7 @@ templateCopyArray :: (String, Binder)
|
|||||||
templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath ["Array"] "copy"
|
path = SymPath ["Array"] "copy"
|
||||||
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] (StructTy (ConcreteNameTy "Array") [VarTy "a"]) StaticLifetimeTy
|
t = FuncTy [arrayRef] arrayTyA StaticLifetimeTy
|
||||||
docs = "copies an array."
|
docs = "copies an array."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
@ -528,7 +529,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
|||||||
++ [TokC "}\n"]
|
++ [TokC "}\n"]
|
||||||
)
|
)
|
||||||
( \case
|
( \case
|
||||||
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy "Array") [insideType]) _] _ _) ->
|
(FuncTy [RefTy arrayType@(StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] _ _) ->
|
||||||
depsForCopyFunc typeEnv env insideType
|
depsForCopyFunc typeEnv env insideType
|
||||||
++ depsForDeleteFunc typeEnv env arrayType
|
++ depsForDeleteFunc typeEnv env arrayType
|
||||||
err ->
|
err ->
|
||||||
@ -536,7 +537,7 @@ templateCopyArray = defineTypeParameterizedTemplate templateCreator path t docs
|
|||||||
)
|
)
|
||||||
|
|
||||||
copyTy :: TypeEnv -> Env -> Ty -> [Token]
|
copyTy :: TypeEnv -> Env -> Ty -> [Token]
|
||||||
copyTy typeEnv env (StructTy (ConcreteNameTy "Array") [innerType]) =
|
copyTy typeEnv env (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerType]) =
|
||||||
if managed
|
if managed
|
||||||
then
|
then
|
||||||
[ TokC " for(int i = 0; i < a->len; i++) {\n",
|
[ TokC " for(int i = 0; i < a->len; i++) {\n",
|
||||||
@ -580,11 +581,11 @@ templateStrArray = defineTypeParameterizedTemplate templateCreator path t docs
|
|||||||
++ strTy typeEnv env arrayType
|
++ strTy typeEnv env arrayType
|
||||||
++ [TokC "}\n"]
|
++ [TokC "}\n"]
|
||||||
)
|
)
|
||||||
( \(FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [insideType]) _] StringTy _) ->
|
( \(FuncTy [RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [insideType]) _] StringTy _) ->
|
||||||
depsForPrnFunc typeEnv env insideType
|
depsForPrnFunc typeEnv env insideType
|
||||||
)
|
)
|
||||||
path = SymPath ["Array"] "str"
|
path = SymPath ["Array"] "str"
|
||||||
t = FuncTy [RefTy (StructTy (ConcreteNameTy "Array") [VarTy "a"]) (VarTy "q")] StringTy StaticLifetimeTy
|
t = FuncTy [arrayRef] StringTy StaticLifetimeTy
|
||||||
docs = "converts an array to a string."
|
docs = "converts an array to a string."
|
||||||
|
|
||||||
-- | TODO: move this into the templateStrArray function?
|
-- | TODO: move this into the templateStrArray function?
|
||||||
|
@ -49,7 +49,7 @@ assignTypes mappings root = visit root
|
|||||||
Nothing -> pure xobj
|
Nothing -> pure xobj
|
||||||
|
|
||||||
isArrayTypeOK :: Ty -> Bool
|
isArrayTypeOK :: Ty -> Bool
|
||||||
isArrayTypeOK (StructTy (ConcreteNameTy "Array") [RefTy _ _]) = False -- An array containing refs!
|
isArrayTypeOK (StructTy (ConcreteNameTy (SymPath [] "Array")) [RefTy _ _]) = False -- An array containing refs!
|
||||||
isArrayTypeOK _ = True
|
isArrayTypeOK _ = True
|
||||||
|
|
||||||
-- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...)
|
-- | Change auto generated type names (i.e. 't0') to letters (i.e. 'a', 'b', 'c', etc...)
|
||||||
|
@ -12,8 +12,8 @@ import Data.List (elemIndex, foldl')
|
|||||||
import Data.List.Split (splitOn)
|
import Data.List.Split (splitOn)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Emit
|
import Emit
|
||||||
|
import qualified Env as E
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import qualified Meta
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
@ -283,8 +283,8 @@ commandBuild ctx [XObj (Bol shutUp) _ _] = do
|
|||||||
proj = contextProj ctx
|
proj = contextProj ctx
|
||||||
execMode = contextExecMode ctx
|
execMode = contextExecMode ctx
|
||||||
src = do
|
src = do
|
||||||
|
typeDecl <- typeEnvToDeclarations typeEnv env
|
||||||
decl <- envToDeclarations typeEnv env
|
decl <- envToDeclarations typeEnv env
|
||||||
typeDecl <- envToDeclarations typeEnv (getTypeEnv typeEnv)
|
|
||||||
c <- envToC env Functions
|
c <- envToC env Functions
|
||||||
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
|
initGlobals <- fmap (wrapInInitFunction (projectCore proj)) (globalsToC env)
|
||||||
pure
|
pure
|
||||||
@ -726,12 +726,12 @@ commandSaveDocsInternal ctx modulePath = do
|
|||||||
where
|
where
|
||||||
getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
|
getEnvironmentBinderForDocumentation :: Context -> Env -> SymPath -> Either String Binder
|
||||||
getEnvironmentBinderForDocumentation _ env path =
|
getEnvironmentBinderForDocumentation _ env path =
|
||||||
case lookupBinder path env of
|
case E.searchValueBinder env path of
|
||||||
Just foundBinder@(Binder _ (XObj (Mod _) _ _)) ->
|
Right foundBinder@(Binder _ (XObj (Mod _ _) _ _)) ->
|
||||||
Right foundBinder
|
Right foundBinder
|
||||||
Just (Binder _ x) ->
|
Right (Binder _ x) ->
|
||||||
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
|
Left ("I can’t generate documentation for `" ++ pretty x ++ "` because it isn’t a module")
|
||||||
Nothing ->
|
Left _ ->
|
||||||
Left ("I can’t find the module `" ++ show path ++ "`")
|
Left ("I can’t find the module `" ++ show path ++ "`")
|
||||||
|
|
||||||
-- | Command for emitting literal C code from Carp.
|
-- | Command for emitting literal C code from Carp.
|
||||||
@ -760,21 +760,21 @@ commandSexpression ctx xobj =
|
|||||||
|
|
||||||
commandSexpressionInternal :: Context -> XObj -> Bool -> IO (Context, Either EvalError XObj)
|
commandSexpressionInternal :: Context -> XObj -> Bool -> IO (Context, Either EvalError XObj)
|
||||||
commandSexpressionInternal ctx xobj bol =
|
commandSexpressionInternal ctx xobj bol =
|
||||||
let tyEnv = getTypeEnv $ contextTypeEnv ctx
|
let tyEnv = contextTypeEnv ctx
|
||||||
in case xobj of
|
in case xobj of
|
||||||
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
|
(XObj (Lst [inter@(XObj (Interface ty _) _ _), path]) i t) ->
|
||||||
pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
|
pure (ctx, Right (XObj (Lst [toSymbols inter, path, reify ty]) i t))
|
||||||
(XObj (Lst forms) i t) ->
|
(XObj (Lst forms) i t) ->
|
||||||
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
||||||
mdl@(XObj (Mod e) _ _) ->
|
mdl@(XObj (Mod e _) _ _) ->
|
||||||
if bol
|
if bol
|
||||||
then getMod
|
then getMod
|
||||||
else case lookupBinder (SymPath [] (fromMaybe "" (envModuleName e))) tyEnv of
|
else case E.getTypeBinder tyEnv (fromMaybe "" (envModuleName e)) of
|
||||||
Just (Binder _ (XObj (Lst forms) i t)) ->
|
Right (Binder _ (XObj (Lst forms) i t)) ->
|
||||||
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
pure (ctx, Right (XObj (Lst (map toSymbols forms)) i t))
|
||||||
Just (Binder _ xobj') ->
|
Right (Binder _ xobj') ->
|
||||||
pure (ctx, Right (toSymbols xobj'))
|
pure (ctx, Right (toSymbols xobj'))
|
||||||
Nothing ->
|
Left _ ->
|
||||||
getMod
|
getMod
|
||||||
where
|
where
|
||||||
getMod =
|
getMod =
|
||||||
@ -800,7 +800,7 @@ commandSexpressionInternal ctx xobj bol =
|
|||||||
pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo)
|
pure $ evalError ctx ("can't get an s-expression for: " ++ pretty xobj ++ " is it a bound symbol or literal s-expression?") (Just dummyInfo)
|
||||||
|
|
||||||
toSymbols :: XObj -> XObj
|
toSymbols :: XObj -> XObj
|
||||||
toSymbols (XObj (Mod e) i t) =
|
toSymbols (XObj (Mod e _) i t) =
|
||||||
XObj
|
XObj
|
||||||
( Lst
|
( Lst
|
||||||
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
|
[ XObj (Sym (SymPath [] "defmodule") Symbol) i t,
|
||||||
@ -866,7 +866,7 @@ commandType ctx (XObj x _ _) =
|
|||||||
typeOf Break = "dreak"
|
typeOf Break = "dreak"
|
||||||
typeOf If = "if"
|
typeOf If = "if"
|
||||||
typeOf (Match _) = "matxch"
|
typeOf (Match _) = "matxch"
|
||||||
typeOf (Mod _) = "module"
|
typeOf (Mod _ _) = "module"
|
||||||
typeOf (Deftype _) = "deftype"
|
typeOf (Deftype _) = "deftype"
|
||||||
typeOf (DefSumtype _) = "def-sum-type"
|
typeOf (DefSumtype _) = "def-sum-type"
|
||||||
typeOf With = "with"
|
typeOf With = "with"
|
||||||
|
@ -5,12 +5,12 @@ module Concretize where
|
|||||||
import AssignTypes
|
import AssignTypes
|
||||||
import Constraints
|
import Constraints
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
|
import Data.Either (fromRight)
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Debug.Trace
|
import Debug.Trace
|
||||||
import Env
|
import Env (envIsExternal, findPoly, getTypeBinder, getValue, insert, insertX, lookupEverywhere, searchValue)
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import Managed
|
import Managed
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import Obj
|
import Obj
|
||||||
@ -87,8 +87,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
|
let functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv 0
|
||||||
envWithArgs =
|
envWithArgs =
|
||||||
foldl'
|
foldl'
|
||||||
( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
|
( \e arg@(XObj (Sym path _) _ _) ->
|
||||||
extendEnv e argSymName arg
|
-- n.b. this won't fail since we're inserting unqualified args into a fresh env
|
||||||
|
-- TODO: Still, it'd be nicer and more flexible to catch failures here.
|
||||||
|
let Right v = insertX e path arg in v
|
||||||
)
|
)
|
||||||
functionEnv
|
functionEnv
|
||||||
argsArr
|
argsArr
|
||||||
@ -115,8 +117,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
|
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (envFunctionNestingLevel env)
|
||||||
envWithArgs =
|
envWithArgs =
|
||||||
foldl'
|
foldl'
|
||||||
( \e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) ->
|
( \e arg@(XObj (Sym path _) _ _) ->
|
||||||
extendEnv e argSymName arg
|
let Right v = insertX e path arg in v
|
||||||
)
|
)
|
||||||
functionEnv
|
functionEnv
|
||||||
argsArr
|
argsArr
|
||||||
@ -131,8 +133,10 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
-- Its name will contain the name of the (normal, non-lambda) function it's contained within,
|
-- Its name will contain the name of the (normal, non-lambda) function it's contained within,
|
||||||
-- plus the identifier of the particular s-expression that defines the lambda.
|
-- plus the identifier of the particular s-expression that defines the lambda.
|
||||||
SymPath spath name = rootDefinitionPath
|
SymPath spath name = rootDefinitionPath
|
||||||
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii))
|
lambdaPath = SymPath spath ("_Lambda_" ++ lambdaToCName name (envFunctionNestingLevel envWithArgs) ++ "_" ++ show (infoIdentifier ii) ++ "_env")
|
||||||
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
|
lambdaNameSymbol = XObj (Sym lambdaPath Symbol) (Just dummyInfo) Nothing
|
||||||
|
environmentTypeName = pathToC lambdaPath ++ "_ty"
|
||||||
|
tyPath = (SymPath [] environmentTypeName)
|
||||||
extendedArgs =
|
extendedArgs =
|
||||||
if null capturedVars
|
if null capturedVars
|
||||||
then args
|
then args
|
||||||
@ -143,7 +147,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
( XObj
|
( XObj
|
||||||
(Sym (SymPath [] "_env") Symbol)
|
(Sym (SymPath [] "_env") Symbol)
|
||||||
(Just dummyInfo)
|
(Just dummyInfo)
|
||||||
(Just (PointerTy (StructTy (ConcreteNameTy environmentTypeName) []))) :
|
(Just (PointerTy (StructTy (ConcreteNameTy tyPath) []))) :
|
||||||
argsArr
|
argsArr
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
@ -158,13 +162,12 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
[XObj (Sym path Symbol) Nothing Nothing, reify symTy]
|
[XObj (Sym path Symbol) Nothing Nothing, reify symTy]
|
||||||
)
|
)
|
||||||
capturedVars
|
capturedVars
|
||||||
environmentTypeName = pathToC lambdaPath ++ "_env"
|
environmentStructTy = StructTy (ConcreteNameTy tyPath) []
|
||||||
environmentStructTy = StructTy (ConcreteNameTy environmentTypeName) []
|
|
||||||
environmentStruct =
|
environmentStruct =
|
||||||
XObj
|
XObj
|
||||||
( Lst
|
( Lst
|
||||||
[ XObj (Deftype environmentStructTy) Nothing Nothing,
|
[ XObj (Deftype environmentStructTy) Nothing Nothing,
|
||||||
XObj (Sym (SymPath [] environmentTypeName) Symbol) Nothing Nothing,
|
XObj (Sym tyPath Symbol) Nothing Nothing,
|
||||||
XObj (Arr structMemberPairs) Nothing Nothing
|
XObj (Arr structMemberPairs) Nothing Nothing
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
@ -178,8 +181,9 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
copyFnTemplate = concreteCopyPtr typeEnv env pairs
|
copyFnTemplate = concreteCopyPtr typeEnv env pairs
|
||||||
(copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
|
(copyFn, copyDeps) = instantiateTemplate (SymPath [] (environmentTypeName ++ "_copy")) copyFnTy copyFnTemplate
|
||||||
-- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
|
-- The type env has to contain the lambdas environment struct for 'concretizeDefinition' to work:
|
||||||
extendedTypeEnv = TypeEnv (extendEnv (getTypeEnv typeEnv) environmentTypeName environmentStruct)
|
-- TODO: Fixup: Support modules in type envs.
|
||||||
in case concretizeDefinition allowAmbig extendedTypeEnv env visitedDefinitions lambdaCallback funcTy of
|
extendedTypeEnv = replaceLeft (FailedToAddLambdaStructToTyEnv tyPath environmentStruct) (insert typeEnv tyPath (toBinder environmentStruct))
|
||||||
|
in case (extendedTypeEnv >>= \ext -> concretizeDefinition allowAmbig ext env visitedDefinitions lambdaCallback funcTy) of
|
||||||
Left err -> pure (Left err)
|
Left err -> pure (Left err)
|
||||||
Right (concreteLiftedLambda, deps) ->
|
Right (concreteLiftedLambda, deps) ->
|
||||||
do
|
do
|
||||||
@ -260,14 +264,14 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
pure [okVisitedLhs, okVisitedRhs]
|
pure [okVisitedLhs, okVisitedRhs]
|
||||||
visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
visitSymbol :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||||
visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) =
|
visitSymbol allowAmbig env xobj@(XObj (Sym path lookupMode) i t) =
|
||||||
case lookupInEnv path env of
|
case searchValue env path of
|
||||||
Just (foundEnv, binder)
|
Right (foundEnv, binder)
|
||||||
| envIsExternal foundEnv ->
|
| envIsExternal foundEnv ->
|
||||||
let theXObj = binderXObj binder
|
let theXObj = binderXObj binder
|
||||||
Just theType = xobjTy theXObj
|
Just theType = xobjTy theXObj
|
||||||
typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t
|
typeOfVisited = fromMaybe (error ("Missing type on " ++ show xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " when looking up path " ++ show path)) t
|
||||||
in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
|
in if --(trace $ "CHECKING " ++ getName xobj ++ " : " ++ show theType ++ " with visited type " ++ show typeOfVisited ++ " and visited definitions: " ++ show visitedDefinitions) $
|
||||||
isTypeGeneric theType && not (isTypeGeneric typeOfVisited)
|
(isTypeGeneric theType && not (isTypeGeneric typeOfVisited))
|
||||||
then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of
|
then case concretizeDefinition allowAmbig typeEnv env visitedDefinitions theXObj typeOfVisited of
|
||||||
Left err -> pure (Left err)
|
Left err -> pure (Left err)
|
||||||
Right (concrete, deps) ->
|
Right (concrete, deps) ->
|
||||||
@ -277,7 +281,7 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
pure (Right (XObj (Sym (getPath concrete) lookupMode) i t))
|
pure (Right (XObj (Sym (getPath concrete) lookupMode) i t))
|
||||||
else pure (Right xobj)
|
else pure (Right xobj)
|
||||||
| otherwise -> pure (Right xobj)
|
| otherwise -> pure (Right xobj)
|
||||||
Nothing -> pure (Right xobj)
|
_ -> pure (Right xobj)
|
||||||
visitSymbol _ _ _ = error "Not a symbol."
|
visitSymbol _ _ _ = error "Not a symbol."
|
||||||
visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
visitMultiSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||||
visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
|
visitMultiSym allowAmbig env xobj@(XObj (MultiSym originalSymbolName paths) i t) =
|
||||||
@ -296,12 +300,13 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
Just i' = i
|
Just i' = i
|
||||||
in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of
|
in case solve [Constraint theType t' fake1 fake2 fake1 OrdMultiSym] of
|
||||||
Right mappings ->
|
Right mappings ->
|
||||||
let replaced = replaceTyVars mappings t'
|
let replaced = (replaceTyVars mappings t')
|
||||||
suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way?
|
suffixed = suffixTyVars ("_x" ++ show (infoIdentifier i')) replaced -- Make sure it gets unique type variables. TODO: Is there a better way?
|
||||||
normalSymbol = XObj (Sym singlePath mode) i (Just suffixed)
|
normalSymbol = XObj (Sym singlePath mode) i (Just suffixed)
|
||||||
in visitSymbol
|
in visitSymbol
|
||||||
allowAmbig
|
allowAmbig
|
||||||
env --(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings))
|
env
|
||||||
|
--(trace ("Disambiguated " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj ++ " to " ++ show singlePath ++ " : " ++ show suffixed ++ ", used to be " ++ show t' ++ ", theType = " ++ show theType ++ ", mappings = " ++ show mappings) normalSymbol) normalSymbol
|
||||||
normalSymbol
|
normalSymbol
|
||||||
Left failure@(UnificationFailure _ _) ->
|
Left failure@(UnificationFailure _ _) ->
|
||||||
pure $
|
pure $
|
||||||
@ -317,8 +322,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
visitMultiSym _ _ _ = error "Not a multi symbol."
|
visitMultiSym _ _ _ = error "Not a multi symbol."
|
||||||
visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
visitInterfaceSym :: Bool -> Env -> XObj -> State [XObj] (Either TypeError XObj)
|
||||||
visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
|
visitInterfaceSym allowAmbig env xobj@(XObj (InterfaceSym name) i t) =
|
||||||
case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
|
case getTypeBinder typeEnv name of
|
||||||
Just (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
|
Right (Binder _ (XObj (Lst [XObj (Interface _ interfacePaths) _ _, _]) _ _)) ->
|
||||||
let Just actualType = t
|
let Just actualType = t
|
||||||
tys = map (typeFromPath env) interfacePaths
|
tys = map (typeFromPath env) interfacePaths
|
||||||
tysToPathsDict = zip tys interfacePaths
|
tysToPathsDict = zip tys interfacePaths
|
||||||
@ -347,8 +352,8 @@ concretizeXObj allowAmbiguityRoot typeEnv rootEnv visitedDefinitions root =
|
|||||||
allowAmbig
|
allowAmbig
|
||||||
env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
|
env -- trace ("Replacing symbol " ++ pretty xobj ++ " with type " ++ show theType ++ " to single path " ++ show singlePath)
|
||||||
normalSymbol
|
normalSymbol
|
||||||
Just _ -> error "visitinterfacesym1"
|
Right _ -> error "visitinterfacesym1"
|
||||||
Nothing ->
|
Left _ ->
|
||||||
error ("No interface named '" ++ name ++ "' found.")
|
error ("No interface named '" ++ name ++ "' found.")
|
||||||
visitInterfaceSym _ _ _ = error "visitinterfacesym"
|
visitInterfaceSym _ _ _ = error "visitinterfacesym"
|
||||||
|
|
||||||
@ -363,11 +368,11 @@ collectCapturedVars root = removeDuplicates (map decreaseCaptureLevel (visit roo
|
|||||||
removeDuplicates :: Ord a => [a] -> [a]
|
removeDuplicates :: Ord a => [a] -> [a]
|
||||||
removeDuplicates = Set.toList . Set.fromList
|
removeDuplicates = Set.toList . Set.fromList
|
||||||
decreaseCaptureLevel :: XObj -> XObj
|
decreaseCaptureLevel :: XObj -> XObj
|
||||||
decreaseCaptureLevel (XObj (Sym path lookup) _ ty) =
|
decreaseCaptureLevel (XObj (Sym path lookup') _ ty) =
|
||||||
XObj
|
XObj
|
||||||
( Sym
|
( Sym
|
||||||
path
|
path
|
||||||
( case lookup of
|
( case lookup' of
|
||||||
Symbol -> Symbol
|
Symbol -> Symbol
|
||||||
LookupLocal NoCapture -> Symbol
|
LookupLocal NoCapture -> Symbol
|
||||||
LookupLocal (Capture n) ->
|
LookupLocal (Capture n) ->
|
||||||
@ -436,43 +441,41 @@ concretizeType _ ft@FuncTy {} =
|
|||||||
if isTypeGeneric ft
|
if isTypeGeneric ft
|
||||||
then Right []
|
then Right []
|
||||||
else Right [defineFunctionTypeAlias ft]
|
else Right [defineFunctionTypeAlias ft]
|
||||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "Array") varTys) =
|
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "Array")) varTys) =
|
||||||
if isTypeGeneric arrayTy
|
if isTypeGeneric arrayTy
|
||||||
then Right []
|
then Right []
|
||||||
else do
|
else do
|
||||||
deps <- mapM (concretizeType typeEnv) varTys
|
deps <- mapM (concretizeType typeEnv) varTys
|
||||||
Right (defineArrayTypeAlias arrayTy : concat deps)
|
Right (defineArrayTypeAlias arrayTy : concat deps)
|
||||||
-- TODO: Remove ugly duplication of code here:
|
-- TODO: Remove ugly duplication of code here:
|
||||||
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy "StaticArray") varTys) =
|
concretizeType typeEnv arrayTy@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) varTys) =
|
||||||
if isTypeGeneric arrayTy
|
if isTypeGeneric arrayTy
|
||||||
then Right []
|
then Right []
|
||||||
else do
|
else do
|
||||||
deps <- mapM (concretizeType typeEnv) varTys
|
deps <- mapM (concretizeType typeEnv) varTys
|
||||||
Right (defineStaticArrayTypeAlias arrayTy : concat deps)
|
Right (defineStaticArrayTypeAlias arrayTy : concat deps)
|
||||||
-- TODO: handle polymorphic constructors (a b)
|
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy (SymPath _ name)) _) =
|
||||||
concretizeType typeEnv genericStructTy@(StructTy (ConcreteNameTy name) _) =
|
-- TODO: This function only looks up direct children of the type environment.
|
||||||
case lookupInEnv (SymPath lookupPath structName) (getTypeEnv typeEnv) of
|
-- However, spath can point to types that belong to a module. Pass the global env here.
|
||||||
Just (_, Binder _ (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _)) ->
|
case (getTypeBinder typeEnv name) of
|
||||||
|
Right (Binder _ x) -> go x
|
||||||
|
_ -> Right []
|
||||||
|
where
|
||||||
|
go :: XObj -> Either TypeError [XObj]
|
||||||
|
go (XObj (Lst (XObj (Deftype originalStructTy) _ _ : _ : rest)) _ _) =
|
||||||
if isTypeGeneric originalStructTy
|
if isTypeGeneric originalStructTy
|
||||||
then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
|
then instantiateGenericStructType typeEnv originalStructTy genericStructTy rest
|
||||||
else Right []
|
else Right []
|
||||||
Just (_, Binder _ (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _)) ->
|
go (XObj (Lst (XObj (DefSumtype originalStructTy) _ _ : _ : rest)) _ _) =
|
||||||
if isTypeGeneric originalStructTy
|
if isTypeGeneric originalStructTy
|
||||||
then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
|
then instantiateGenericSumtype typeEnv originalStructTy genericStructTy rest
|
||||||
else Right []
|
else Right []
|
||||||
Just (_, Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
go (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _) = Right []
|
||||||
Right []
|
go x = error ("Non-deftype found in type env: " ++ pretty x)
|
||||||
Just (_, Binder _ x) ->
|
concretizeType t (RefTy rt _) =
|
||||||
error ("Non-deftype found in type env: " ++ show x)
|
concretizeType t rt
|
||||||
Nothing ->
|
concretizeType t (PointerTy pt) =
|
||||||
Right []
|
concretizeType t pt
|
||||||
where
|
|
||||||
lookupPath = getPathFromStructName name
|
|
||||||
structName = getNameFromStructName name
|
|
||||||
concretizeType env (RefTy rt _) =
|
|
||||||
concretizeType env rt
|
|
||||||
concretizeType env (PointerTy pt) =
|
|
||||||
concretizeType env pt
|
|
||||||
concretizeType _ _ =
|
concretizeType _ _ =
|
||||||
Right [] -- ignore all other types
|
Right [] -- ignore all other types
|
||||||
|
|
||||||
@ -592,11 +595,11 @@ replaceGenericTypeSymbolsOnCase _ unknownCase = unknownCase -- TODO: error out?
|
|||||||
-- | Get the type of a symbol at a given path.
|
-- | Get the type of a symbol at a given path.
|
||||||
typeFromPath :: Env -> SymPath -> Ty
|
typeFromPath :: Env -> SymPath -> Ty
|
||||||
typeFromPath env p =
|
typeFromPath env p =
|
||||||
case lookupInEnv p env of
|
case searchValue env p of
|
||||||
Just (e, Binder _ found)
|
Right (e, Binder _ found)
|
||||||
| envIsExternal e -> forceTy found
|
| envIsExternal e -> forceTy found
|
||||||
| otherwise -> error "Local bindings shouldn't be ambiguous."
|
| otherwise -> error "Local bindings shouldn't be ambiguous."
|
||||||
Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
|
_ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
|
||||||
|
|
||||||
-- | Get the mode of a symbol at a given path.
|
-- | Get the mode of a symbol at a given path.
|
||||||
-- |
|
-- |
|
||||||
@ -604,14 +607,14 @@ typeFromPath env p =
|
|||||||
-- | parts of doesNotBelongToAnInterface.
|
-- | parts of doesNotBelongToAnInterface.
|
||||||
modeFromPath :: Env -> SymPath -> SymbolMode
|
modeFromPath :: Env -> SymPath -> SymbolMode
|
||||||
modeFromPath env p =
|
modeFromPath env p =
|
||||||
case lookupInEnv p env of
|
case searchValue env p of
|
||||||
Just (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
|
Right (_, Binder _ (XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||||
LookupGlobalOverride overrideWithName
|
LookupGlobalOverride overrideWithName
|
||||||
Just (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
|
Right (_, Binder _ (XObj (Lst (XObj (ExternalType (Just overrideWithName)) _ _ : _)) _ _)) ->
|
||||||
LookupGlobalOverride overrideWithName
|
LookupGlobalOverride overrideWithName
|
||||||
Just (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
|
Right (_, Binder _ found@(XObj (Lst (XObj (External _) _ _ : _)) _ _)) ->
|
||||||
LookupGlobal ExternalCode (definitionMode found)
|
LookupGlobal ExternalCode (definitionMode found)
|
||||||
Just (e, Binder _ found) ->
|
Right (e, Binder _ found) ->
|
||||||
case envMode e of
|
case envMode e of
|
||||||
ExternalEnv ->
|
ExternalEnv ->
|
||||||
LookupGlobal CarpLand (definitionMode found)
|
LookupGlobal CarpLand (definitionMode found)
|
||||||
@ -622,7 +625,7 @@ modeFromPath env p =
|
|||||||
then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env)
|
then Capture (envFunctionNestingLevel e - envFunctionNestingLevel env)
|
||||||
else NoCapture
|
else NoCapture
|
||||||
)
|
)
|
||||||
Nothing -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
|
_ -> error ("Couldn't find " ++ show p ++ " in env:\n" ++ prettyEnvironmentChain env)
|
||||||
|
|
||||||
-- | Given a definition (def, defn, template, external) and
|
-- | Given a definition (def, defn, template, external) and
|
||||||
-- a concrete type (a type without any type variables)
|
-- a concrete type (a type without any type variables)
|
||||||
@ -677,26 +680,23 @@ concretizeDefinition allowAmbiguity typeEnv globalEnv visitedDefinitions definit
|
|||||||
-- For all other functions, the name must match exactly, and in all cases, the signature must match.
|
-- For all other functions, the name must match exactly, and in all cases, the signature must match.
|
||||||
allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)]
|
allImplementations :: TypeEnv -> Env -> String -> Ty -> [(Env, Binder)]
|
||||||
allImplementations typeEnv env functionName functionType =
|
allImplementations typeEnv env functionName functionType =
|
||||||
filter (predicate . xobjTy . binderXObj . snd) foundBindings
|
(filter (predicate . xobjTy . binderXObj . snd) foundBindings)
|
||||||
where
|
where
|
||||||
predicate (Just t) =
|
predicate (Just t) =
|
||||||
--trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
|
--trace ("areUnifiable? " ++ show functionType ++ " == " ++ show t ++ " " ++ show (areUnifiable functionType t)) $
|
||||||
areUnifiable functionType t
|
areUnifiable functionType t
|
||||||
predicate Nothing = error "allfunctionswithnameandsignature"
|
predicate Nothing = error "allfunctionswithnameandsignature"
|
||||||
foundBindings = case lookupBinder (SymPath [] functionName) (getTypeEnv typeEnv) of
|
foundBindings = case getTypeBinder typeEnv functionName of
|
||||||
-- this function is an interface; lookup implementations
|
-- this function is an interface; lookup implementations
|
||||||
Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||||
-- N.B./TODO: There are functions designed for this
|
case sequence $ map (\p -> searchValue env p) (paths ++ [(SymPath [] functionName)]) of
|
||||||
-- scenario--e.g. lookupImplementations, but they cause
|
Right found -> found
|
||||||
-- either entirely unacceptable behavior (not finding
|
Left _ ->
|
||||||
-- implementations, or hangs). We should be able to use
|
case findPoly env functionName functionType of
|
||||||
-- those here instead of looking up all interface paths
|
Right r -> [r]
|
||||||
-- directly, but for now we are stuck with this.
|
Left _ -> (lookupEverywhere env functionName)
|
||||||
case sequence $ map (\p -> lookupInEnv p env) (paths ++ [(SymPath [] functionName)]) of
|
|
||||||
Just found -> found
|
|
||||||
Nothing -> (multiLookupEverywhere functionName env)
|
|
||||||
-- just a regular function; look for it
|
-- just a regular function; look for it
|
||||||
_ -> (multiLookupEverywhere functionName env)
|
_ -> fromRight [] ((fmap (: []) (Env.getValue env functionName)) <> pure (lookupEverywhere env functionName))
|
||||||
|
|
||||||
-- | Find all the dependencies of a polymorphic function with a name and a desired concrete type.
|
-- | Find all the dependencies of a polymorphic function with a name and a desired concrete type.
|
||||||
depsOfPolymorphicFunction :: TypeEnv -> Env -> [SymPath] -> String -> Ty -> [XObj]
|
depsOfPolymorphicFunction :: TypeEnv -> Env -> [SymPath] -> String -> Ty -> [XObj]
|
||||||
@ -908,7 +908,7 @@ manageMemory typeEnv globalEnv root =
|
|||||||
-- We know that we want to add a deleter for the static array here
|
-- We know that we want to add a deleter for the static array here
|
||||||
do
|
do
|
||||||
let var = varOfXObj xobj
|
let var = varOfXObj xobj
|
||||||
Just (RefTy t@(StructTy (ConcreteNameTy "StaticArray") [_]) _) = xobjTy xobj
|
Just (RefTy t@(StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [_]) _) = xobjTy xobj
|
||||||
deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
|
deleter = case nameOfPolymorphicFunction typeEnv globalEnv (FuncTy [t] UnitTy StaticLifetimeTy) "delete" of
|
||||||
Just pathOfDeleteFunc ->
|
Just pathOfDeleteFunc ->
|
||||||
ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var
|
ProperDeleter pathOfDeleteFunc (getDropFunc (xobjInfo xobj) t) var
|
||||||
|
194
src/Context.hs
194
src/Context.hs
@ -1,5 +1,6 @@
|
|||||||
module Context
|
module Context
|
||||||
( replaceGlobalEnv,
|
( ContextError (..),
|
||||||
|
replaceGlobalEnv,
|
||||||
replaceInternalEnv,
|
replaceInternalEnv,
|
||||||
replaceTypeEnv,
|
replaceTypeEnv,
|
||||||
replaceHistory,
|
replaceHistory,
|
||||||
@ -9,27 +10,82 @@ module Context
|
|||||||
replaceInternalEnv',
|
replaceInternalEnv',
|
||||||
replaceTypeEnv',
|
replaceTypeEnv',
|
||||||
replaceHistory',
|
replaceHistory',
|
||||||
|
replacePath',
|
||||||
insertInGlobalEnv,
|
insertInGlobalEnv,
|
||||||
insertInGlobalEnv',
|
insertInGlobalEnv',
|
||||||
insertInTypeEnv,
|
insertTypeBinder,
|
||||||
insertInTypeEnv',
|
insertTypeBinder',
|
||||||
insertInInternalEnv,
|
insertInInternalEnv,
|
||||||
|
insertType,
|
||||||
|
replaceTypeBinder,
|
||||||
innermostModuleEnv,
|
innermostModuleEnv,
|
||||||
bindLetDeclaration,
|
bindLetDeclaration,
|
||||||
lookupInterface,
|
lookupInterface,
|
||||||
lookupBinderInGlobalEnv,
|
lookupBinderInGlobalEnv,
|
||||||
|
lookupBinderInInternalEnv,
|
||||||
lookupBinderInTypeEnv,
|
lookupBinderInTypeEnv,
|
||||||
lookupBinderInContextEnv,
|
lookupBinderInContextEnv,
|
||||||
contextualize,
|
contextualize,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Env
|
import Data.Bifunctor
|
||||||
import Lookup
|
import Debug.Trace
|
||||||
|
import qualified Env as E
|
||||||
import Obj
|
import Obj
|
||||||
import Project
|
import Project
|
||||||
import Qualify (QualifiedPath, qualifyPath, unqualify)
|
import Qualify (QualifiedPath, qualifyPath, unqualify)
|
||||||
import SymPath
|
import SymPath
|
||||||
|
import Util (joinWithPeriod, replaceLeft)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Errors
|
||||||
|
|
||||||
|
data ContextError
|
||||||
|
= FailedToInsertInGlobalEnv SymPath Binder
|
||||||
|
| FailedToInsertInTypeEnv SymPath Binder
|
||||||
|
| FailedToInsertInInternalEnv SymPath Binder
|
||||||
|
| AttemptedToInsertQualifiedInternalBinder SymPath
|
||||||
|
| NoModuleEnvs String
|
||||||
|
| NotFoundGlobal SymPath
|
||||||
|
| NotFoundType SymPath
|
||||||
|
| NotFoundContext SymPath
|
||||||
|
| NotFoundInternal SymPath
|
||||||
|
|
||||||
|
insertFailure :: SymPath -> Binder -> String
|
||||||
|
insertFailure path binder =
|
||||||
|
"Failed to insert the binder: " ++ show binder
|
||||||
|
++ " at path: "
|
||||||
|
++ show path
|
||||||
|
|
||||||
|
instance Show ContextError where
|
||||||
|
show (FailedToInsertInGlobalEnv path binder) =
|
||||||
|
insertFailure path binder
|
||||||
|
++ "in the context's global environment."
|
||||||
|
show (FailedToInsertInTypeEnv path binder) =
|
||||||
|
insertFailure path binder
|
||||||
|
++ "in the context's type environment."
|
||||||
|
show (FailedToInsertInInternalEnv path binder) =
|
||||||
|
insertFailure path binder
|
||||||
|
++ "in the context's internal environment."
|
||||||
|
show (AttemptedToInsertQualifiedInternalBinder path) =
|
||||||
|
"Attempted to insert a qualified binder: " ++ show path
|
||||||
|
++ " into a context's internal environment."
|
||||||
|
show (NoModuleEnvs pathstring) =
|
||||||
|
"Couldn't find any modules in the given context at path: "
|
||||||
|
++ pathstring
|
||||||
|
show (NotFoundGlobal path) =
|
||||||
|
"Couldn't find the symbol: " ++ show path
|
||||||
|
++ "in the context's global environment."
|
||||||
|
show (NotFoundType path) =
|
||||||
|
"Couldn't find the symbol: " ++ show path
|
||||||
|
++ "in the context's type environment."
|
||||||
|
show (NotFoundContext path) =
|
||||||
|
"Couldn't find the symbol: " ++ show path
|
||||||
|
++ "in the context's context environment."
|
||||||
|
show (NotFoundInternal path) =
|
||||||
|
"Couldn't find the symbol: " ++ show path
|
||||||
|
++ "in the context's internal environment."
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Contextual Class
|
-- Contextual Class
|
||||||
@ -113,6 +169,10 @@ replaceTypeEnv' = flip replaceTypeEnv
|
|||||||
replaceHistory' :: [XObj] -> Context -> Context
|
replaceHistory' :: [XObj] -> Context -> Context
|
||||||
replaceHistory' = flip replaceHistory
|
replaceHistory' = flip replaceHistory
|
||||||
|
|
||||||
|
-- | replacePath with arguments flipped.
|
||||||
|
replacePath' :: [String] -> Context -> Context
|
||||||
|
replacePath' = flip replacePath
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Binding Insertion Functions
|
-- Binding Insertion Functions
|
||||||
|
|
||||||
@ -121,70 +181,110 @@ replaceHistory' = flip replaceHistory
|
|||||||
-- In most cases the qualified path will have been qualified under the same
|
-- In most cases the qualified path will have been qualified under the same
|
||||||
-- context, but this constraint is *not* enforced by the definition of this
|
-- context, but this constraint is *not* enforced by the definition of this
|
||||||
-- function.
|
-- function.
|
||||||
insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Context
|
insertInGlobalEnv :: Context -> QualifiedPath -> Binder -> Either ContextError Context
|
||||||
insertInGlobalEnv ctx qpath binder =
|
insertInGlobalEnv ctx qpath binder =
|
||||||
let globalEnv = contextGlobalEnv ctx
|
replaceLeft
|
||||||
in ctx {contextGlobalEnv = envInsertAt globalEnv (unqualify qpath) binder}
|
(FailedToInsertInGlobalEnv (unqualify qpath) binder)
|
||||||
|
( E.insert (contextGlobalEnv ctx) (unqualify qpath) binder
|
||||||
|
>>= \e -> pure $! (ctx {contextGlobalEnv = e})
|
||||||
|
)
|
||||||
|
|
||||||
-- | Adds a binder to a context's type environment at a qualified path.
|
-- | Adds a binder to a context's type environment at a qualified path.
|
||||||
--
|
--
|
||||||
-- In most cases the qualified path will have been qualified under the same
|
-- In most cases the qualified path will have been qualified under the same
|
||||||
-- context, but this constraint is *not* enforced by the definition of this
|
-- context, but this constraint is *not* enforced by the definition of this
|
||||||
-- function.
|
-- function.
|
||||||
insertInTypeEnv :: Context -> QualifiedPath -> Binder -> Context
|
insertTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context
|
||||||
insertInTypeEnv ctx qpath binder =
|
insertTypeBinder ctx qpath binder =
|
||||||
let typeEnv = getTypeEnv (contextTypeEnv ctx)
|
let (SymPath path name) = unqualify qpath
|
||||||
in ctx {contextTypeEnv = TypeEnv (envInsertAt typeEnv (unqualify qpath) binder)}
|
in first
|
||||||
|
(\_ -> trace (show path) (FailedToInsertInTypeEnv (unqualify qpath) binder))
|
||||||
|
( case path of
|
||||||
|
[] ->
|
||||||
|
(E.insert (contextTypeEnv ctx) (SymPath [] name) binder)
|
||||||
|
>>= pure . (replaceTypeEnv ctx)
|
||||||
|
-- TODO: We need to 'view' the global environment as a type
|
||||||
|
-- environment here to ensure types are added to a module's type
|
||||||
|
-- environment and not its value environment (the modality is
|
||||||
|
-- correct)
|
||||||
|
-- Find a more elegant API here.
|
||||||
|
_ ->
|
||||||
|
(E.insert (TypeEnv (contextGlobalEnv ctx)) (SymPath path name) binder)
|
||||||
|
>>= pure . (replaceGlobalEnv ctx) . getTypeEnv
|
||||||
|
)
|
||||||
|
|
||||||
|
-- TODO: This function currently only handles top-level types. (fine for now,
|
||||||
|
-- as it's only called to update interfaces) Update this to handle qualified
|
||||||
|
-- types A.B
|
||||||
|
replaceTypeBinder :: Context -> QualifiedPath -> Binder -> Either ContextError Context
|
||||||
|
replaceTypeBinder ctx qpath binder =
|
||||||
|
let (SymPath _ name) = unqualify qpath
|
||||||
|
err = (FailedToInsertInTypeEnv (unqualify qpath) binder)
|
||||||
|
replacement = (E.replaceInPlace (contextTypeEnv ctx) name binder) >>= pure . (replaceTypeEnv ctx)
|
||||||
|
in replaceLeft err replacement <> insertTypeBinder ctx qpath binder
|
||||||
|
|
||||||
-- | Adds a binder to a context's internal environment at an unqualified path.
|
-- | Adds a binder to a context's internal environment at an unqualified path.
|
||||||
--
|
--
|
||||||
-- If the context does not have an internal environment, this function does nothing.
|
-- If the context does not have an internal environment, this function does nothing.
|
||||||
insertInInternalEnv :: Context -> SymPath -> Binder -> Context
|
insertInInternalEnv :: Context -> SymPath -> Binder -> Either ContextError Context
|
||||||
insertInInternalEnv ctx path@(SymPath [] _) binder =
|
insertInInternalEnv ctx path@(SymPath [] _) binder =
|
||||||
ctx {contextInternalEnv = fmap insert (contextInternalEnv ctx)}
|
maybe
|
||||||
|
(Left (FailedToInsertInInternalEnv path binder))
|
||||||
|
insert'
|
||||||
|
(contextInternalEnv ctx)
|
||||||
where
|
where
|
||||||
insert :: Env -> Env
|
insert' :: Env -> Either ContextError Context
|
||||||
insert e = envInsertAt e path binder
|
insert' e =
|
||||||
insertInInternalEnv _ _ _ =
|
replaceLeft
|
||||||
error "attempted to insert a qualified symbol into an internal environment"
|
(FailedToInsertInInternalEnv path binder)
|
||||||
|
(E.insert e path binder >>= \e' -> pure (ctx {contextInternalEnv = pure e'}))
|
||||||
|
insertInInternalEnv _ path _ = Left (AttemptedToInsertQualifiedInternalBinder path)
|
||||||
|
|
||||||
-- | insertInGlobalEnv with arguments flipped.
|
-- | insertInGlobalEnv with arguments flipped.
|
||||||
insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Context
|
insertInGlobalEnv' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
|
||||||
insertInGlobalEnv' path binder ctx = insertInGlobalEnv ctx path binder
|
insertInGlobalEnv' path binder ctx = insertInGlobalEnv ctx path binder
|
||||||
|
|
||||||
-- | insertInTypeEnv with arguments flipped.
|
-- | insertTypeBinder with arguments flipped.
|
||||||
insertInTypeEnv' :: QualifiedPath -> Binder -> Context -> Context
|
insertTypeBinder' :: QualifiedPath -> Binder -> Context -> Either ContextError Context
|
||||||
insertInTypeEnv' path binder ctx = insertInTypeEnv ctx path binder
|
insertTypeBinder' path binder ctx = insertTypeBinder ctx path binder
|
||||||
|
|
||||||
-- | Inserts a let binding into the appropriate environment in a context.
|
-- | Inserts a let binding into the appropriate environment in a context.
|
||||||
bindLetDeclaration :: Context -> String -> XObj -> Context
|
bindLetDeclaration :: Context -> String -> XObj -> Either ContextError Context
|
||||||
bindLetDeclaration ctx name xobj =
|
bindLetDeclaration ctx name xobj =
|
||||||
let binder = Binder emptyMeta (toLocalDef name xobj)
|
let binder = Binder emptyMeta (toLocalDef name xobj)
|
||||||
in insertInInternalEnv ctx (SymPath [] name) binder
|
in insertInInternalEnv ctx (SymPath [] name) binder
|
||||||
|
|
||||||
|
-- | Inserts a new type into a given context, adding a binding to the type
|
||||||
|
-- environment and a module to to value environment.
|
||||||
|
insertType :: Context -> QualifiedPath -> Binder -> Binder -> Either ContextError Context
|
||||||
|
insertType ctx qpath typeBinder modBinder =
|
||||||
|
(insertInGlobalEnv ctx qpath modBinder)
|
||||||
|
>>= \c -> (insertTypeBinder c qpath typeBinder)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Environment Retrieval Functions
|
-- Environment Retrieval Functions
|
||||||
|
|
||||||
-- | Retrieves the innermost (deepest) module environment in a context
|
-- | Retrieves the innermost (deepest) module environment in a context
|
||||||
-- according to the context's contextPath.
|
-- according to the context's contextPath.
|
||||||
--
|
--
|
||||||
-- Returns Nothing if the Context path is empty.
|
-- Returns an error if the Context path is empty.
|
||||||
innermostModuleEnv :: Context -> Maybe Env
|
innermostModuleEnv :: Context -> Either ContextError Env
|
||||||
innermostModuleEnv ctx = go (contextPath ctx)
|
innermostModuleEnv ctx = go (contextPath ctx)
|
||||||
where
|
where
|
||||||
go :: [String] -> Maybe Env
|
go :: [String] -> Either ContextError Env
|
||||||
go [] = Nothing
|
go [] = Left (NoModuleEnvs "")
|
||||||
go xs = Just $ getEnv (contextGlobalEnv ctx) xs
|
go xs = replaceLeft (NoModuleEnvs (joinWithPeriod xs)) (E.getInnerEnv (contextGlobalEnv ctx) xs)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Binder Lookup Functions
|
-- Binder Lookup Functions
|
||||||
|
|
||||||
-- | Lookup a binder with a fully determined location in a context.
|
-- | Lookup a binder with a fully determined location in a context.
|
||||||
decontextualizedLookup :: (Context -> SymPath -> Maybe Binder) -> Context -> SymPath -> Maybe Binder
|
decontextualizedLookup :: (Context -> SymPath -> Either ContextError Binder) -> Context -> SymPath -> Either ContextError Binder
|
||||||
decontextualizedLookup f ctx path =
|
decontextualizedLookup f ctx path =
|
||||||
f (replacePath ctx []) path
|
f (replacePath ctx []) path
|
||||||
|
|
||||||
lookupInterface :: Context -> SymPath -> Maybe Binder
|
-- | Lookup an interface in the given context.
|
||||||
|
lookupInterface :: Context -> SymPath -> Either ContextError Binder
|
||||||
lookupInterface ctx path =
|
lookupInterface ctx path =
|
||||||
decontextualizedLookup lookupBinderInTypeEnv ctx path
|
decontextualizedLookup lookupBinderInTypeEnv ctx path
|
||||||
|
|
||||||
@ -193,30 +293,46 @@ lookupInterface ctx path =
|
|||||||
-- Depending on the type of path passed to this function, further
|
-- Depending on the type of path passed to this function, further
|
||||||
-- contextualization of the path may be performed before the lookup is
|
-- contextualization of the path may be performed before the lookup is
|
||||||
-- performed.
|
-- performed.
|
||||||
lookupBinderInTypeEnv :: Contextual a => Context -> a -> Maybe Binder
|
lookupBinderInTypeEnv :: Contextual a => Context -> a -> Either ContextError Binder
|
||||||
lookupBinderInTypeEnv ctx path =
|
lookupBinderInTypeEnv ctx path =
|
||||||
let typeEnv = getTypeEnv (contextTypeEnv ctx)
|
let typeEnv = contextTypeEnv ctx
|
||||||
fullPath = contextualize path ctx
|
global = contextGlobalEnv ctx
|
||||||
in lookupBinder fullPath typeEnv
|
fullPath@(SymPath qualification name) = contextualize path ctx
|
||||||
|
theType =
|
||||||
|
( case qualification of
|
||||||
|
[] -> E.getTypeBinder typeEnv name
|
||||||
|
_ -> E.searchTypeBinder global fullPath
|
||||||
|
)
|
||||||
|
in replaceLeft (NotFoundType fullPath) theType
|
||||||
|
|
||||||
-- | Lookup a binder in a context's global environment.
|
-- | Lookup a binder in a context's global environment.
|
||||||
--
|
--
|
||||||
-- Depending on the type of path passed to this function, further
|
-- Depending on the type of path passed to this function, further
|
||||||
-- contextualization of the path may be performed before the lookup is
|
-- contextualization of the path may be performed before the lookup is
|
||||||
-- performed.
|
-- performed.
|
||||||
lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Maybe Binder
|
lookupBinderInGlobalEnv :: Contextual a => Context -> a -> Either ContextError Binder
|
||||||
lookupBinderInGlobalEnv ctx path =
|
lookupBinderInGlobalEnv ctx path =
|
||||||
let global = contextGlobalEnv ctx
|
let global = contextGlobalEnv ctx
|
||||||
fullPath = contextualize path ctx
|
fullPath = contextualize path ctx
|
||||||
in lookupBinder fullPath global
|
in replaceLeft (NotFoundGlobal fullPath) (E.searchValueBinder global fullPath)
|
||||||
|
|
||||||
|
-- | Lookup a binder in a context's internal environment.
|
||||||
|
lookupBinderInInternalEnv :: Contextual a => Context -> a -> Either ContextError Binder
|
||||||
|
lookupBinderInInternalEnv ctx path =
|
||||||
|
let internal = contextInternalEnv ctx
|
||||||
|
fullPath = contextualize path ctx
|
||||||
|
in maybe
|
||||||
|
(Left (NotFoundInternal fullPath))
|
||||||
|
(\e -> replaceLeft (NotFoundInternal fullPath) (E.searchValueBinder e fullPath))
|
||||||
|
internal
|
||||||
|
|
||||||
-- | Lookup a binder in a context's context environment.
|
-- | Lookup a binder in a context's context environment.
|
||||||
--
|
--
|
||||||
-- Depending on the type of path passed to this function, further
|
-- Depending on the type of path passed to this function, further
|
||||||
-- contextualization of the path may be performed before the lookup is
|
-- contextualization of the path may be performed before the lookup is
|
||||||
-- performed.
|
-- performed.
|
||||||
lookupBinderInContextEnv :: Context -> SymPath -> Maybe Binder
|
lookupBinderInContextEnv :: Context -> SymPath -> Either ContextError Binder
|
||||||
lookupBinderInContextEnv ctx path =
|
lookupBinderInContextEnv ctx path =
|
||||||
let ctxEnv = contextEnv ctx
|
let ctxEnv = (E.contextEnv ctx)
|
||||||
fullPath = contextualize path ctx
|
fullPath = contextualize path ctx
|
||||||
in lookupBinder fullPath ctxEnv
|
in replaceLeft (NotFoundContext fullPath) (E.searchValueBinder ctxEnv fullPath)
|
||||||
|
126
src/Deftype.hs
126
src/Deftype.hs
@ -2,19 +2,19 @@
|
|||||||
|
|
||||||
module Deftype
|
module Deftype
|
||||||
( moduleForDeftype,
|
( moduleForDeftype,
|
||||||
|
moduleForDeftypeInContext,
|
||||||
bindingsForRegisteredType,
|
bindingsForRegisteredType,
|
||||||
memberArg,
|
memberArg,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Concretize
|
import Concretize
|
||||||
|
import Context
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Env
|
import Env (addListOfBindings, new)
|
||||||
import Info
|
import Info
|
||||||
import Managed
|
import Managed
|
||||||
import qualified Map
|
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
|
||||||
import StructUtils
|
import StructUtils
|
||||||
import Template
|
import Template
|
||||||
import ToTemplate
|
import ToTemplate
|
||||||
@ -27,19 +27,41 @@ import Validate
|
|||||||
|
|
||||||
{-# ANN module "HLint: ignore Reduce duplication" #-}
|
{-# ANN module "HLint: ignore Reduce duplication" #-}
|
||||||
|
|
||||||
|
moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
|
||||||
|
moduleForDeftypeInContext ctx name vars members info =
|
||||||
|
let global = contextGlobalEnv ctx
|
||||||
|
types = contextTypeEnv ctx
|
||||||
|
path = contextPath ctx
|
||||||
|
inner = either (const Nothing) Just (innermostModuleEnv ctx)
|
||||||
|
previous =
|
||||||
|
either
|
||||||
|
(const Nothing)
|
||||||
|
Just
|
||||||
|
( (lookupBinderInInternalEnv ctx (SymPath path name))
|
||||||
|
<> (lookupBinderInGlobalEnv ctx (SymPath path name))
|
||||||
|
>>= \b ->
|
||||||
|
replaceLeft
|
||||||
|
(NotFoundGlobal (SymPath path name))
|
||||||
|
( case binderXObj b of
|
||||||
|
XObj (Mod ev et) _ _ -> Right (ev, et)
|
||||||
|
_ -> Left "Non module"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
in moduleForDeftype inner types global path name vars members info previous
|
||||||
|
|
||||||
-- | This function creates a "Type Module" with the same name as the type being defined.
|
-- | This function creates a "Type Module" with the same name as the type being defined.
|
||||||
-- A type module provides a namespace for all the functions that area automatically
|
-- A type module provides a namespace for all the functions that area automatically
|
||||||
-- generated by a deftype.
|
-- generated by a deftype.
|
||||||
moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
|
||||||
moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||||
let typeModuleName = typeName
|
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
||||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||||
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
|
-- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
|
||||||
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||||
insidePath = pathStrings ++ [typeModuleName]
|
insidePath = pathStrings ++ [typeName]
|
||||||
in do
|
in do
|
||||||
validateMemberCases typeEnv typeVariables rest
|
validateMemberCases typeEnv typeVariables rest
|
||||||
let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables
|
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
|
||||||
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||||
okInit <- binderForInit insidePath structTy rest
|
okInit <- binderForInit insidePath structTy rest
|
||||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||||
@ -47,29 +69,29 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
|||||||
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
|
(okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
|
||||||
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
|
(okCopy, copyDeps) <- binderForCopy typeEnv env insidePath structTy rest
|
||||||
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
|
let funcs = okInit : okStr : okPrn : okDelete : okCopy : okMembers
|
||||||
moduleEnvWithBindings = addListOfBindings typeModuleEnv funcs
|
moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs
|
||||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||||
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
|
deps = deleteDeps ++ membersDeps ++ copyDeps ++ strDeps
|
||||||
pure (typeModuleName, typeModuleXObj, deps)
|
pure (typeName, typeModuleXObj, deps)
|
||||||
|
|
||||||
-- | Will generate getters/setters/updaters when registering EXTERNAL types.
|
-- | Will generate getters/setters/updaters when registering EXTERNAL types.
|
||||||
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
|
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
|
||||||
-- | TODO: Remove duplication shared by moduleForDeftype-function.
|
-- | TODO: Remove duplication shared by moduleForDeftype-function.
|
||||||
bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
|
||||||
bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
|
||||||
let typeModuleName = typeName
|
let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv)
|
||||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) (Just env) (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||||
insidePath = pathStrings ++ [typeModuleName]
|
insidePath = pathStrings ++ [typeName]
|
||||||
in do
|
in do
|
||||||
validateMemberCases typeEnv [] rest
|
validateMemberCases typeEnv [] rest
|
||||||
let structTy = StructTy (ConcreteNameTy typeName) []
|
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
|
||||||
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||||
okInit <- binderForInit insidePath structTy rest
|
okInit <- binderForInit insidePath structTy rest
|
||||||
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
(okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
|
||||||
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
(okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
|
||||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okInit : okStr : okPrn : binders)
|
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders)
|
||||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||||
pure (typeModuleName, typeModuleXObj, deps ++ strDeps)
|
pure (typeName, typeModuleXObj, deps ++ strDeps)
|
||||||
|
|
||||||
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||||
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj])
|
templatesForMembers :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ([(String, Binder)], [XObj])
|
||||||
@ -80,7 +102,7 @@ templatesForMembers _ _ _ _ _ = error "Shouldn't reach this case (invalid type d
|
|||||||
|
|
||||||
-- | Generate the templates for a single member in a deftype declaration.
|
-- | Generate the templates for a single member in a deftype declaration.
|
||||||
templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])]
|
templatesForSingleMember :: TypeEnv -> Env -> [String] -> Ty -> (XObj, XObj) -> [((String, Binder), [XObj])]
|
||||||
templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy typeName) _) (nameXObj, typeXObj) =
|
templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy _) _) (nameXObj, typeXObj) =
|
||||||
case t of
|
case t of
|
||||||
-- Unit member types are special since we do not represent them in emitted c.
|
-- Unit member types are special since we do not represent them in emitted c.
|
||||||
-- Instead, members of type Unit are executed for their side effects and silently omitted
|
-- Instead, members of type Unit are executed for their side effects and silently omitted
|
||||||
@ -101,18 +123,18 @@ templatesForSingleMember typeEnv env insidePath p@(StructTy (ConcreteNameTy type
|
|||||||
Just t = xobjToTy typeXObj
|
Just t = xobjToTy typeXObj
|
||||||
memberName = getName nameXObj
|
memberName = getName nameXObj
|
||||||
binders getterSig setterSig mutatorSig updaterSig =
|
binders getterSig setterSig mutatorSig updaterSig =
|
||||||
[ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
|
[ instanceBinderWithDeps (SymPath insidePath memberName) getterSig (templateGetter (mangle memberName) t) ("gets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."),
|
||||||
if isTypeGeneric t
|
if isTypeGeneric t
|
||||||
then (templateGenericSetter insidePath p t memberName, [])
|
then (templateGenericSetter insidePath p t memberName, [])
|
||||||
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."),
|
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName)) setterSig (templateSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "`."),
|
||||||
if isTypeGeneric t
|
if isTypeGeneric t
|
||||||
then (templateGenericMutatingSetter insidePath p t memberName, [])
|
then (templateGenericMutatingSetter insidePath p t memberName, [])
|
||||||
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."),
|
else instanceBinderWithDeps (SymPath insidePath ("set-" ++ memberName ++ "!")) mutatorSig (templateMutatingSetter typeEnv env (mangle memberName) t) ("sets the `" ++ memberName ++ "` property of a `" ++ show p ++ "` in place."),
|
||||||
instanceBinderWithDeps
|
instanceBinderWithDeps
|
||||||
(SymPath insidePath ("update-" ++ memberName))
|
(SymPath insidePath ("update-" ++ memberName))
|
||||||
updaterSig
|
updaterSig
|
||||||
(templateUpdater (mangle memberName) t)
|
(templateUpdater (mangle memberName) t)
|
||||||
("updates the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` using a function `f`.")
|
("updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`.")
|
||||||
]
|
]
|
||||||
templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember"
|
templatesForSingleMember _ _ _ _ _ = error "templatesforsinglemember"
|
||||||
|
|
||||||
@ -176,12 +198,12 @@ templateSetter typeEnv env memberName memberTy =
|
|||||||
|
|
||||||
-- | The template for setters of a generic deftype.
|
-- | The template for setters of a generic deftype.
|
||||||
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
templateGenericSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
||||||
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
|
templateGenericSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName =
|
||||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
|
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy, membTy] originalStructTy StaticLifetimeTy) docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings ("set-" ++ memberName)
|
path = SymPath pathStrings ("set-" ++ memberName)
|
||||||
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
|
t = FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy
|
||||||
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "`."
|
docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "`."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
@ -242,12 +264,12 @@ templateMutatingSetter typeEnv env memberName memberTy =
|
|||||||
|
|
||||||
-- | The template for mutating setters of a generic deftype.
|
-- | The template for mutating setters of a generic deftype.
|
||||||
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
templateGenericMutatingSetter :: [String] -> Ty -> Ty -> String -> (String, Binder)
|
||||||
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membTy memberName =
|
templateGenericMutatingSetter pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membTy memberName =
|
||||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs
|
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q"), membTy] UnitTy StaticLifetimeTy) docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
|
path = SymPath pathStrings ("set-" ++ memberName ++ "!")
|
||||||
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
|
t = FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy
|
||||||
docs = "sets the `" ++ memberName ++ "` property of a `" ++ typeName ++ "` in place."
|
docs = "sets the `" ++ memberName ++ "` property of a `" ++ show originalStructTy ++ "` in place."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
@ -313,7 +335,7 @@ templateUpdater member _ =
|
|||||||
|
|
||||||
-- | Helper function to create the binder for the 'init' template.
|
-- | Helper function to create the binder for the 'init' template.
|
||||||
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
|
binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
|
||||||
binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
|
binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
|
||||||
if isTypeGeneric structTy
|
if isTypeGeneric structTy
|
||||||
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
|
then Right (genericInit StackAlloc insidePath structTy membersXObjs)
|
||||||
else
|
else
|
||||||
@ -322,7 +344,7 @@ binderForInit insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (
|
|||||||
(SymPath insidePath "init")
|
(SymPath insidePath "init")
|
||||||
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
|
(FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
|
||||||
(concreteInit StackAlloc structTy membersXObjs)
|
(concreteInit StackAlloc structTy membersXObjs)
|
||||||
("creates a `" ++ typeName ++ "`.")
|
("creates a `" ++ show structTy ++ "`.")
|
||||||
binderForInit _ _ _ = error "binderforinit"
|
binderForInit _ _ _ = error "binderforinit"
|
||||||
|
|
||||||
-- | Generate a list of types from a deftype declaration.
|
-- | Generate a list of types from a deftype declaration.
|
||||||
@ -332,7 +354,7 @@ initArgListTypes xobjs =
|
|||||||
|
|
||||||
-- | The template for the 'init' and 'new' functions for a concrete deftype.
|
-- | The template for the 'init' and 'new' functions for a concrete deftype.
|
||||||
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
concreteInit :: AllocationMode -> Ty -> [XObj] -> Template
|
||||||
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
|
concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
|
||||||
Template
|
Template
|
||||||
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
|
(FuncTy (map snd (memberXObjsToPairs membersXObjs)) (VarTy "p") StaticLifetimeTy)
|
||||||
( \(FuncTy _ concreteStructTy _) ->
|
( \(FuncTy _ concreteStructTy _) ->
|
||||||
@ -344,7 +366,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy typeName)
|
|||||||
( \(FuncTy _ concreteStructTy _) ->
|
( \(FuncTy _ concreteStructTy _) ->
|
||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||||
in tokensForInit allocationMode typeName correctedMembers
|
in tokensForInit allocationMode (show originalStructTy) correctedMembers
|
||||||
)
|
)
|
||||||
(\FuncTy {} -> [])
|
(\FuncTy {} -> [])
|
||||||
where
|
where
|
||||||
@ -353,12 +375,12 @@ concreteInit _ _ _ = error "concreteinit"
|
|||||||
|
|
||||||
-- | The template for the 'init' and 'new' functions for a generic deftype.
|
-- | The template for the 'init' and 'new' functions for a generic deftype.
|
||||||
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
|
genericInit :: AllocationMode -> [String] -> Ty -> [XObj] -> (String, Binder)
|
||||||
genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
|
genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
|
||||||
defineTypeParameterizedTemplate templateCreator path t docs
|
defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings "init"
|
path = SymPath pathStrings "init"
|
||||||
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
|
t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
|
||||||
docs = "creates a `" ++ typeName ++ "`."
|
docs = "creates a `" ++ show originalStructTy ++ "`."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv _ ->
|
\typeEnv _ ->
|
||||||
Template
|
Template
|
||||||
@ -372,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
|
|||||||
( \(FuncTy _ concreteStructTy _) ->
|
( \(FuncTy _ concreteStructTy _) ->
|
||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||||
in tokensForInit allocationMode typeName correctedMembers
|
in tokensForInit allocationMode (show originalStructTy) correctedMembers
|
||||||
)
|
)
|
||||||
( \(FuncTy _ concreteStructTy _) ->
|
( \(FuncTy _ concreteStructTy _) ->
|
||||||
case concretizeType typeEnv concreteStructTy of
|
case concretizeType typeEnv concreteStructTy of
|
||||||
@ -424,7 +446,7 @@ templatizeTy t = t
|
|||||||
|
|
||||||
-- | Helper function to create the binder for the 'str' template.
|
-- | Helper function to create the binder for the 'str' template.
|
||||||
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj])
|
binderForStrOrPrn :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> String -> Either TypeError ((String, Binder), [XObj])
|
||||||
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] strOrPrn =
|
||||||
if isTypeGeneric structTy
|
if isTypeGeneric structTy
|
||||||
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
|
then Right (genericStr insidePath structTy membersXObjs strOrPrn, [])
|
||||||
else
|
else
|
||||||
@ -433,18 +455,18 @@ binderForStrOrPrn typeEnv env insidePath structTy@(StructTy (ConcreteNameTy type
|
|||||||
(SymPath insidePath strOrPrn)
|
(SymPath insidePath strOrPrn)
|
||||||
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
|
(FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||||
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
|
(concreteStr typeEnv env structTy (memberXObjsToPairs membersXObjs) strOrPrn)
|
||||||
("converts a `" ++ typeName ++ "` to a string.")
|
("converts a `" ++ show structTy ++ "` to a string.")
|
||||||
)
|
)
|
||||||
binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
|
binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
|
||||||
|
|
||||||
-- | The template for the 'str' function for a concrete deftype.
|
-- | The template for the 'str' function for a concrete deftype.
|
||||||
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
|
concreteStr :: TypeEnv -> Env -> Ty -> [(String, Ty)] -> String -> Template
|
||||||
concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy typeName) _) memberPairs _ =
|
concreteStr typeEnv env concreteStructTy@(StructTy (ConcreteNameTy name) _) memberPairs _ =
|
||||||
Template
|
Template
|
||||||
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||||
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
||||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||||
tokensForStr typeEnv env typeName memberPairs concreteStructTy
|
tokensForStr typeEnv env (show name) memberPairs concreteStructTy
|
||||||
)
|
)
|
||||||
( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
|
( \(FuncTy [RefTy (StructTy _ _) (VarTy "q")] StringTy _) ->
|
||||||
concatMap
|
concatMap
|
||||||
@ -455,12 +477,12 @@ concreteStr _ _ _ _ _ = error "concretestr"
|
|||||||
|
|
||||||
-- | The template for the 'str' function for a generic deftype.
|
-- | The template for the 'str' function for a generic deftype.
|
||||||
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
|
genericStr :: [String] -> Ty -> [XObj] -> String -> (String, Binder)
|
||||||
genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs strOrPrn =
|
genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy name) _) membersXObjs strOrPrn =
|
||||||
defineTypeParameterizedTemplate templateCreator path t docs
|
defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings strOrPrn
|
path = SymPath pathStrings strOrPrn
|
||||||
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
||||||
docs = "converts a `" ++ typeName ++ "` to a string."
|
docs = "converts a `" ++ show originalStructTy ++ "` to a string."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
@ -472,7 +494,7 @@ genericStr pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) m
|
|||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
|
||||||
memberPairs = memberXObjsToPairs correctedMembers
|
memberPairs = memberXObjsToPairs correctedMembers
|
||||||
in tokensForStr typeEnv env typeName memberPairs concreteStructTy
|
in tokensForStr typeEnv env (show name) memberPairs concreteStructTy
|
||||||
)
|
)
|
||||||
( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
@ -509,8 +531,8 @@ tokensForStr typeEnv env typeName memberPairs concreteStructTy =
|
|||||||
|
|
||||||
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
-- | Figure out how big the string needed for the string representation of the struct has to be.
|
||||||
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
|
||||||
calculateStructStrSize typeEnv env members (StructTy (ConcreteNameTy name) _) =
|
calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) =
|
||||||
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ name ++ "\");\n"
|
" int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
|
||||||
++ unlines (map (memberPrnSize typeEnv env) members)
|
++ unlines (map (memberPrnSize typeEnv env) members)
|
||||||
calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
|
calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
|
||||||
|
|
||||||
@ -525,7 +547,7 @@ memberAssignment allocationMode memberName = " instance" ++ sep ++ memberName
|
|||||||
|
|
||||||
-- | Helper function to create the binder for the 'delete' template.
|
-- | Helper function to create the binder for the 'delete' template.
|
||||||
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
|
binderForDelete :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
|
||||||
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
|
binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
|
||||||
if isTypeGeneric structTy
|
if isTypeGeneric structTy
|
||||||
then Right (genericDelete insidePath structTy membersXObjs, [])
|
then Right (genericDelete insidePath structTy membersXObjs, [])
|
||||||
else
|
else
|
||||||
@ -534,18 +556,18 @@ binderForDelete typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeNa
|
|||||||
(SymPath insidePath "delete")
|
(SymPath insidePath "delete")
|
||||||
(FuncTy [structTy] UnitTy StaticLifetimeTy)
|
(FuncTy [structTy] UnitTy StaticLifetimeTy)
|
||||||
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
|
(concreteDelete typeEnv env (memberXObjsToPairs membersXObjs))
|
||||||
("deletes a `" ++ typeName ++ "`.")
|
("deletes a `" ++ show structTy ++ "`.")
|
||||||
)
|
)
|
||||||
binderForDelete _ _ _ _ _ = error "binderfordelete"
|
binderForDelete _ _ _ _ _ = error "binderfordelete"
|
||||||
|
|
||||||
-- | The template for the 'delete' function of a generic deftype.
|
-- | The template for the 'delete' function of a generic deftype.
|
||||||
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
|
genericDelete :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||||
genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
|
genericDelete pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
|
||||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
|
defineTypeParameterizedTemplate templateCreator path (FuncTy [originalStructTy] UnitTy StaticLifetimeTy) docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings "delete"
|
path = SymPath pathStrings "delete"
|
||||||
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
|
t = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy
|
||||||
docs = "deletes a `" ++ typeName ++ "`. Should usually not be called manually."
|
docs = "deletes a `" ++ show originalStructTy ++ "`. Should usually not be called manually."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
@ -578,7 +600,7 @@ genericDelete _ _ _ = error "genericdelete"
|
|||||||
|
|
||||||
-- | Helper function to create the binder for the 'copy' template.
|
-- | Helper function to create the binder for the 'copy' template.
|
||||||
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
|
binderForCopy :: TypeEnv -> Env -> [String] -> Ty -> [XObj] -> Either TypeError ((String, Binder), [XObj])
|
||||||
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName) _) [XObj (Arr membersXObjs) _ _] =
|
binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
|
||||||
if isTypeGeneric structTy
|
if isTypeGeneric structTy
|
||||||
then Right (genericCopy insidePath structTy membersXObjs, [])
|
then Right (genericCopy insidePath structTy membersXObjs, [])
|
||||||
else
|
else
|
||||||
@ -587,18 +609,18 @@ binderForCopy typeEnv env insidePath structTy@(StructTy (ConcreteNameTy typeName
|
|||||||
(SymPath insidePath "copy")
|
(SymPath insidePath "copy")
|
||||||
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
|
(FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy)
|
||||||
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
|
(concreteCopy typeEnv env (memberXObjsToPairs membersXObjs))
|
||||||
("copies a `" ++ typeName ++ "`.")
|
("copies a `" ++ show structTy ++ "`.")
|
||||||
)
|
)
|
||||||
binderForCopy _ _ _ _ _ = error "binderforcopy"
|
binderForCopy _ _ _ _ _ = error "binderforcopy"
|
||||||
|
|
||||||
-- | The template for the 'copy' function of a generic deftype.
|
-- | The template for the 'copy' function of a generic deftype.
|
||||||
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
|
genericCopy :: [String] -> Ty -> [XObj] -> (String, Binder)
|
||||||
genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy typeName) _) membersXObjs =
|
genericCopy pathStrings originalStructTy@(StructTy (ConcreteNameTy _) _) membersXObjs =
|
||||||
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
|
defineTypeParameterizedTemplate templateCreator path (FuncTy [RefTy originalStructTy (VarTy "q")] originalStructTy StaticLifetimeTy) docs
|
||||||
where
|
where
|
||||||
path = SymPath pathStrings "copy"
|
path = SymPath pathStrings "copy"
|
||||||
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
|
t = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy
|
||||||
docs = "copies the `" ++ typeName ++ "`."
|
docs = "copies the `" ++ show originalStructTy ++ "`."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
|
61
src/Emit.hs
61
src/Emit.hs
@ -8,6 +8,7 @@ module Emit
|
|||||||
checkForUnresolvedSymbols,
|
checkForUnresolvedSymbols,
|
||||||
ToCMode (..),
|
ToCMode (..),
|
||||||
wrapInInitFunction,
|
wrapInInitFunction,
|
||||||
|
typeEnvToDeclarations,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -139,7 +140,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\'']
|
x -> show (ord x) ++ "/*" ++ show x ++ "*/" -- ['U', '\'', x, '\'']
|
||||||
Closure elt _ -> visit indent elt
|
Closure elt _ -> visit indent elt
|
||||||
Sym _ _ -> visitSymbol indent xobj
|
Sym _ _ -> visitSymbol indent xobj
|
||||||
Mod _ -> error (show (CannotEmitModKeyword xobj))
|
Mod _ _ -> error (show (CannotEmitModKeyword xobj))
|
||||||
External _ -> error (show (CannotEmitExternal xobj))
|
External _ -> error (show (CannotEmitExternal xobj))
|
||||||
(Defn _) -> dontVisit
|
(Defn _) -> dontVisit
|
||||||
Def -> dontVisit
|
Def -> dontVisit
|
||||||
@ -258,7 +259,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
Just callback = name
|
Just callback = name
|
||||||
callbackMangled = pathToC callback
|
callbackMangled = pathToC callback
|
||||||
needEnv = not (null capturedVars)
|
needEnv = not (null capturedVars)
|
||||||
lambdaEnvTypeName = callbackMangled ++ "_env" -- The name of the struct is the callback name with suffix '_env'.
|
lambdaEnvTypeName = (SymPath [] (callbackMangled ++ "_ty")) -- The name of the struct is the callback name with suffix '_ty'.
|
||||||
lambdaEnvType = StructTy (ConcreteNameTy lambdaEnvTypeName) []
|
lambdaEnvType = StructTy (ConcreteNameTy lambdaEnvTypeName) []
|
||||||
lambdaEnvName = freshVar info ++ "_env"
|
lambdaEnvName = freshVar info ++ "_env"
|
||||||
appendToSrc
|
appendToSrc
|
||||||
@ -293,8 +294,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
|
appendToSrc (addIndent indent ++ "Lambda " ++ retVar ++ " = {\n")
|
||||||
appendToSrc (addIndent indent ++ " .callback = (void*)" ++ callbackMangled ++ ",\n")
|
appendToSrc (addIndent indent ++ " .callback = (void*)" ++ callbackMangled ++ ",\n")
|
||||||
appendToSrc (addIndent indent ++ " .env = " ++ (if needEnv then lambdaEnvName else "NULL") ++ ",\n")
|
appendToSrc (addIndent indent ++ " .env = " ++ (if needEnv then lambdaEnvName else "NULL") ++ ",\n")
|
||||||
appendToSrc (addIndent indent ++ " .delete = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n")
|
appendToSrc (addIndent indent ++ " .delete = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_delete" else "NULL") ++ ",\n")
|
||||||
appendToSrc (addIndent indent ++ " .copy = (void*)" ++ (if needEnv then "" ++ lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n")
|
appendToSrc (addIndent indent ++ " .copy = (void*)" ++ (if needEnv then "" ++ show lambdaEnvTypeName ++ "_copy" else "NULL") ++ "\n")
|
||||||
appendToSrc (addIndent indent ++ "};\n")
|
appendToSrc (addIndent indent ++ "};\n")
|
||||||
pure retVar
|
pure retVar
|
||||||
-- Def
|
-- Def
|
||||||
@ -661,8 +662,8 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix voidless) ++ ")"
|
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix voidless) ++ ")"
|
||||||
castToFnWithEnv =
|
castToFnWithEnv =
|
||||||
if unwrapLambdas
|
if unwrapLambdas
|
||||||
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
|
then tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCRawFunctionPtrFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")"
|
||||||
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy "LambdaEnv") [] : voidless)) ++ ")"
|
else tyToCLambdaFix retTy ++ "(*)(" ++ joinWithComma (map tyToCLambdaFix (StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) [] : voidless)) ++ ")"
|
||||||
callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null argListAsC then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ ");\n"
|
callLambda = funcToCall ++ ".env ? ((" ++ castToFnWithEnv ++ ")" ++ funcToCall ++ ".callback)" ++ "(" ++ funcToCall ++ ".env" ++ (if null argListAsC then "" else ", ") ++ argListAsC ++ ") : ((" ++ castToFn ++ ")" ++ funcToCall ++ ".callback)(" ++ argListAsC ++ ");\n"
|
||||||
if isUnit retTy
|
if isUnit retTy
|
||||||
then do
|
then do
|
||||||
@ -703,7 +704,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
do
|
do
|
||||||
let arrayVar = freshVar i
|
let arrayVar = freshVar i
|
||||||
len = length xobjs
|
len = length xobjs
|
||||||
Just (StructTy (ConcreteNameTy "Array") [innerTy]) = t
|
Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [innerTy]) = t
|
||||||
appendToSrc
|
appendToSrc
|
||||||
( addIndent indent ++ "Array " ++ arrayVar
|
( addIndent indent ++ "Array " ++ arrayVar
|
||||||
++ " = { .len = "
|
++ " = { .len = "
|
||||||
@ -744,7 +745,7 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo
|
|||||||
retVar = arrayVar ++ "_retref"
|
retVar = arrayVar ++ "_retref"
|
||||||
arrayDataVar = arrayVar ++ "_data"
|
arrayDataVar = arrayVar ++ "_data"
|
||||||
len = length xobjs
|
len = length xobjs
|
||||||
Just tt@(RefTy (StructTy (ConcreteNameTy "StaticArray") [innerTy]) _) = t
|
Just tt@(RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [innerTy]) _) = t
|
||||||
appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n")
|
appendToSrc (addIndent indent ++ tyToCLambdaFix innerTy ++ " " ++ arrayDataVar ++ "[" ++ show len ++ "];\n")
|
||||||
appendToSrc
|
appendToSrc
|
||||||
( addIndent indent ++ "Array " ++ arrayVar
|
( addIndent indent ++ "Array " ++ arrayVar
|
||||||
@ -960,7 +961,7 @@ binderToC toCMode binder =
|
|||||||
XObj (External _) _ _ -> Right ""
|
XObj (External _) _ _ -> Right ""
|
||||||
XObj (ExternalType _) _ _ -> Right ""
|
XObj (ExternalType _) _ _ -> Right ""
|
||||||
XObj (Command _) _ _ -> Right ""
|
XObj (Command _) _ _ -> Right ""
|
||||||
XObj (Mod env) _ _ -> envToC env toCMode
|
XObj (Mod env _) _ _ -> envToC env toCMode
|
||||||
_ -> case xobjTy xobj of
|
_ -> case xobjTy xobj of
|
||||||
Just t ->
|
Just t ->
|
||||||
if isTypeGeneric t
|
if isTypeGeneric t
|
||||||
@ -974,16 +975,16 @@ binderToDeclaration :: TypeEnv -> Binder -> Either ToCError String
|
|||||||
binderToDeclaration typeEnv binder =
|
binderToDeclaration typeEnv binder =
|
||||||
let xobj = binderXObj binder
|
let xobj = binderXObj binder
|
||||||
in case xobj of
|
in case xobj of
|
||||||
XObj (Mod env) _ _ -> envToDeclarations typeEnv env
|
XObj (Mod env _) _ _ -> envToDeclarations typeEnv env
|
||||||
_ -> case xobjTy xobj of
|
_ -> case xobjTy xobj of
|
||||||
Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "")
|
Just t -> if isTypeGeneric t then Right "" else Right (toDeclaration binder ++ "")
|
||||||
Nothing -> Left (BinderIsMissingType binder)
|
Nothing -> Left (BinderIsMissingType binder)
|
||||||
|
|
||||||
envToC :: Env -> ToCMode -> Either ToCError String
|
envToC :: Env -> ToCMode -> Either ToCError String
|
||||||
envToC env toCMode =
|
envToC env toCMode =
|
||||||
let binders = Map.toList (envBindings env)
|
let binders' = Map.toList (envBindings env)
|
||||||
in do
|
in do
|
||||||
okCodes <- mapM (binderToC toCMode . snd) binders
|
okCodes <- mapM (binderToC toCMode . snd) binders'
|
||||||
pure (concat okCodes)
|
pure (concat okCodes)
|
||||||
|
|
||||||
globalsToC :: Env -> Either ToCError String
|
globalsToC :: Env -> Either ToCError String
|
||||||
@ -1000,6 +1001,34 @@ globalsToC globalEnv =
|
|||||||
(sortGlobalVariableBinders globalEnv allGlobalBinders)
|
(sortGlobalVariableBinders globalEnv allGlobalBinders)
|
||||||
pure (concat okCodes)
|
pure (concat okCodes)
|
||||||
|
|
||||||
|
-- | Similar to envToDeclarations, however, to get types, we need to traverse
|
||||||
|
-- the global environment, pull out local type envs from modules, then emit
|
||||||
|
-- binders for these types.
|
||||||
|
--
|
||||||
|
-- TODO: It should be possible to define a general function that works for both
|
||||||
|
-- value/type envs, then we can merge this and envToDeclarations
|
||||||
|
typeEnvToDeclarations :: TypeEnv -> Env -> Either ToCError String
|
||||||
|
typeEnvToDeclarations typeEnv global =
|
||||||
|
let -- We need to carry the type environment to pass the correct environment on the binderToDeclaration call.
|
||||||
|
addEnvToScore tyE = (sortDeclarationBinders tyE (map snd (Map.toList (binders tyE))))
|
||||||
|
bindersWithScore = (addEnvToScore typeEnv)
|
||||||
|
mods = (findModules global)
|
||||||
|
folder =
|
||||||
|
( \sorted (XObj (Mod e t) _ _) ->
|
||||||
|
sorted ++ (foldl folder (addEnvToScore t) (findModules e))
|
||||||
|
)
|
||||||
|
allScoredBinders = sortOn fst (foldl folder bindersWithScore mods)
|
||||||
|
in do
|
||||||
|
okDecls <-
|
||||||
|
mapM
|
||||||
|
( \(score, binder) ->
|
||||||
|
fmap
|
||||||
|
(\s -> if s == "" then "" else ("\n// Depth " ++ show score ++ "\n") ++ s)
|
||||||
|
(binderToDeclaration typeEnv binder)
|
||||||
|
)
|
||||||
|
allScoredBinders
|
||||||
|
pure (concat okDecls)
|
||||||
|
|
||||||
envToDeclarations :: TypeEnv -> Env -> Either ToCError String
|
envToDeclarations :: TypeEnv -> Env -> Either ToCError String
|
||||||
envToDeclarations typeEnv env =
|
envToDeclarations typeEnv env =
|
||||||
let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env)))
|
let bindersWithScore = sortDeclarationBinders typeEnv (map snd (Map.toList (envBindings env)))
|
||||||
@ -1018,13 +1047,13 @@ envToDeclarations typeEnv env =
|
|||||||
-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
|
-- debugScorePair (s,b) = trace ("Scored binder: " ++ show b ++ ", score: " ++ show s) (s,b)
|
||||||
|
|
||||||
sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
|
sortDeclarationBinders :: TypeEnv -> [Binder] -> [(Int, Binder)]
|
||||||
sortDeclarationBinders typeEnv binders =
|
sortDeclarationBinders typeEnv binders' =
|
||||||
--trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders))))
|
--trace ("\nSORTED: " ++ (show (sortOn fst (map (scoreBinder typeEnv) binders))))
|
||||||
sortOn fst (map (scoreTypeBinder typeEnv) binders)
|
sortOn fst (map (scoreTypeBinder typeEnv) binders')
|
||||||
|
|
||||||
sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)]
|
sortGlobalVariableBinders :: Env -> [Binder] -> [(Int, Binder)]
|
||||||
sortGlobalVariableBinders globalEnv binders =
|
sortGlobalVariableBinders globalEnv binders' =
|
||||||
sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders)
|
sortOn fst (map (scoreValueBinder globalEnv Set.empty) binders')
|
||||||
|
|
||||||
checkForUnresolvedSymbols :: XObj -> Either ToCError ()
|
checkForUnresolvedSymbols :: XObj -> Either ToCError ()
|
||||||
checkForUnresolvedSymbols = visit
|
checkForUnresolvedSymbols = visit
|
||||||
|
720
src/Env.hs
720
src/Env.hs
@ -1,109 +1,659 @@
|
|||||||
module Env where
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
import Data.List (foldl')
|
module Env
|
||||||
|
( EnvironmentError,
|
||||||
|
Environment (..),
|
||||||
|
Mode (..),
|
||||||
|
-- utils
|
||||||
|
empty,
|
||||||
|
new,
|
||||||
|
parent,
|
||||||
|
setParent,
|
||||||
|
nested,
|
||||||
|
recursive,
|
||||||
|
binders,
|
||||||
|
------------------------
|
||||||
|
-- lookups
|
||||||
|
getType,
|
||||||
|
getTypeBinder,
|
||||||
|
findType,
|
||||||
|
findTypeBinder,
|
||||||
|
searchType,
|
||||||
|
searchTypeBinder,
|
||||||
|
getValue,
|
||||||
|
getValueBinder,
|
||||||
|
findValue,
|
||||||
|
findValueBinder,
|
||||||
|
searchValue,
|
||||||
|
searchValueBinder,
|
||||||
|
-------------------------
|
||||||
|
-- Environment getters
|
||||||
|
getInnerEnv,
|
||||||
|
contextEnv,
|
||||||
|
envIsExternal,
|
||||||
|
envPublicBindingNames,
|
||||||
|
-------------------------
|
||||||
|
-- mutation
|
||||||
|
insert,
|
||||||
|
insertX,
|
||||||
|
replace,
|
||||||
|
addBinding,
|
||||||
|
deleteBinding,
|
||||||
|
addListOfBindings,
|
||||||
|
addUsePath,
|
||||||
|
-------------------------
|
||||||
|
-- finds
|
||||||
|
findPoly,
|
||||||
|
findAllByMeta,
|
||||||
|
findChildren,
|
||||||
|
findImplementations,
|
||||||
|
findAllGlobalVariables,
|
||||||
|
findModules,
|
||||||
|
allImportedEnvs,
|
||||||
|
-------------------------
|
||||||
|
-- lookups
|
||||||
|
lookupContextually,
|
||||||
|
lookupMeta,
|
||||||
|
lookupChildren,
|
||||||
|
lookupInUsed,
|
||||||
|
lookupEverywhere,
|
||||||
|
lookupBinderEverywhere,
|
||||||
|
progenitor,
|
||||||
|
replaceInPlace,
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Data.Either (fromRight, rights)
|
||||||
|
import Data.List (foldl', unfoldr)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Map
|
import qualified Map
|
||||||
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
|
import qualified Set
|
||||||
import Types
|
import Types
|
||||||
|
|
||||||
-- | Add an XObj to a specific environment. TODO: rename to envInsert
|
--------------------------------------------------------------------------------
|
||||||
extendEnv :: Env -> String -> XObj -> Env
|
-- Data
|
||||||
extendEnv env name xobj = envAddBinding env name (Binder emptyMeta xobj)
|
|
||||||
|
|
||||||
-- | Add a Binder to an environment at a specific path location.
|
data EnvironmentError
|
||||||
envInsertAt :: Env -> SymPath -> Binder -> Env
|
= NoEnvInNonModule
|
||||||
envInsertAt env (SymPath [] name) binder =
|
| NoReplaceInNonModule
|
||||||
envAddBinding env name binder
|
| BindingNotFound String Env
|
||||||
envInsertAt env (SymPath (p : ps) name) xobj =
|
| NoMatchingBindingFound String
|
||||||
case Map.lookup p (envBindings env) of
|
| NestedTypeError String
|
||||||
Just (Binder meta (XObj (Mod innerEnv) i t)) ->
|
|
||||||
let newInnerEnv = Binder meta (XObj (Mod (envInsertAt innerEnv (SymPath ps name) xobj)) i t)
|
|
||||||
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
|
|
||||||
Just _ -> error ("Can't insert into non-module: " ++ p)
|
|
||||||
Nothing -> error ("Can't insert into non-existing module: " ++ p)
|
|
||||||
|
|
||||||
envReplaceEnvAt :: Env -> [String] -> Env -> Env
|
instance Show EnvironmentError where
|
||||||
envReplaceEnvAt _ [] replacement = replacement
|
show NoEnvInNonModule = "Can't get an environment from a non-module."
|
||||||
envReplaceEnvAt env (p : ps) replacement =
|
show NoReplaceInNonModule = "Can't replace an environment in a non-module."
|
||||||
case Map.lookup p (envBindings env) of
|
show (BindingNotFound name e) = "Failed to find " ++ name ++ "in the given environment: " ++ show e
|
||||||
Just (Binder _ (XObj (Mod innerEnv) i t)) ->
|
show (NoMatchingBindingFound predicate) = "Couldn't find any bindings with " ++ predicate ++ "in the given environment."
|
||||||
let newInnerEnv = Binder emptyMeta (XObj (Mod (envReplaceEnvAt innerEnv ps replacement)) i t)
|
show (NestedTypeError name) =
|
||||||
in env {envBindings = Map.insert p newInnerEnv (envBindings env)}
|
"Couldn't insert the top-level type " ++ name
|
||||||
Just _ -> error ("Can't replace non-module: " ++ p)
|
++ " in a module environment."
|
||||||
Nothing -> error ("Can't replace non-existing module: " ++ p)
|
|
||||||
|
|
||||||
-- | Add a Binder to a specific environment.
|
data Mode = Types | Values
|
||||||
envAddBinding :: Env -> String -> Binder -> Env
|
|
||||||
envAddBinding env name binder = env {envBindings = Map.insert name binder (envBindings env)}
|
|
||||||
|
|
||||||
{-# ANN addListOfBindings "HLint: ignore Eta reduce" #-}
|
--------------------------------------------------------------------------------
|
||||||
|
-- The Environment class and implementations
|
||||||
|
|
||||||
-- | Add a list of bindings to an environment
|
-- | Class for generically handling type and value environments.
|
||||||
addListOfBindings :: Env -> [(String, Binder)] -> Env
|
class Environment e where
|
||||||
addListOfBindings env bindingsToAdd = foldl' (\e (n, b) -> envAddBinding e n b) env bindingsToAdd
|
inj :: Env -> e
|
||||||
|
prj :: e -> Env
|
||||||
|
update :: e -> Binder -> Either EnvironmentError Binder
|
||||||
|
modality :: e -> Mode
|
||||||
|
|
||||||
-- | Get an inner environment.
|
-- | The value environment
|
||||||
getEnv :: Env -> [String] -> Env
|
instance Environment Env where
|
||||||
getEnv env [] = env
|
inj = id
|
||||||
getEnv env (p : ps) = case Map.lookup p (envBindings env) of
|
prj = id
|
||||||
Just (Binder _ (XObj (Mod innerEnv) _ _)) -> getEnv innerEnv ps
|
update e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t))
|
||||||
Just _ -> error "Can't get non-env."
|
update _ _ = Left NoReplaceInNonModule
|
||||||
Nothing -> error "Can't get env."
|
modality _ = Values
|
||||||
|
|
||||||
contextEnv :: Context -> Env
|
-- | The type environment
|
||||||
contextEnv Context {contextInternalEnv = Just e} = e
|
instance Environment TypeEnv where
|
||||||
contextEnv Context {contextGlobalEnv = e, contextPath = p} = getEnv e p
|
inj = TypeEnv
|
||||||
|
prj = getTypeEnv
|
||||||
|
update e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev e) i t))
|
||||||
|
update _ _ = Left NoReplaceInNonModule
|
||||||
|
modality _ = Types
|
||||||
|
|
||||||
-- | Checks if an environment is "external", meaning it's either the global scope or a module scope.
|
--------------------------------------------------------------------------------
|
||||||
envIsExternal :: Env -> Bool
|
-- Misc. Environment utilities
|
||||||
envIsExternal env =
|
|
||||||
case envMode env of
|
-- | Returns an unnamed empty environment with no parent.
|
||||||
|
empty :: Environment e => e
|
||||||
|
empty = inj $ Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0
|
||||||
|
|
||||||
|
-- | Returns a new environment with a given parent and name.
|
||||||
|
new :: Environment e => Maybe e -> Maybe String -> e
|
||||||
|
new p name =
|
||||||
|
let e' = Env (Map.fromList []) (fmap prj p) name Set.empty ExternalEnv 0
|
||||||
|
in inj e'
|
||||||
|
|
||||||
|
-- | Returns a new environment with a designated nesting level.
|
||||||
|
nested :: Environment e => Maybe e -> Maybe String -> Int -> e
|
||||||
|
nested p name lvl = inj ((prj (new p name)) {envMode = InternalEnv, envFunctionNestingLevel = lvl})
|
||||||
|
|
||||||
|
-- | Returns a new recursive environment with a designated nesting level.
|
||||||
|
recursive :: Environment e => Maybe e -> Maybe String -> Int -> e
|
||||||
|
recursive p name lvl = inj ((prj (new p name)) {envMode = RecursionEnv, envFunctionNestingLevel = lvl})
|
||||||
|
|
||||||
|
-- | Returns the binders stored in an environment.
|
||||||
|
binders :: Environment e => e -> Map.Map String Binder
|
||||||
|
binders = envBindings . prj
|
||||||
|
|
||||||
|
-- | Get the parent of an environment.
|
||||||
|
parent :: Environment e => e -> Maybe e
|
||||||
|
parent = fmap inj . envParent . prj
|
||||||
|
|
||||||
|
-- | Set the parent of an environment.
|
||||||
|
setParent :: Environment e => e -> e -> e
|
||||||
|
setParent e p = inj ((prj e) {envParent = Just (prj p)})
|
||||||
|
|
||||||
|
-- | Get an environment stored in a module binder.
|
||||||
|
nextEnv :: Mode -> Binder -> Either EnvironmentError Env
|
||||||
|
nextEnv Types (Binder _ (XObj (Mod _ et) _ _)) = Right $ prj et
|
||||||
|
nextEnv Values (Binder _ (XObj (Mod ev _) _ _)) = Right $ prj ev
|
||||||
|
nextEnv _ _ = Left NoEnvInNonModule
|
||||||
|
|
||||||
|
-- | Replace an environment stored in a module binder.
|
||||||
|
updateEnv :: Mode -> Env -> Binder -> Either EnvironmentError Binder
|
||||||
|
updateEnv Values e (Binder meta (XObj (Mod _ et) i t)) = Right (Binder meta (XObj (Mod e et) i t))
|
||||||
|
updateEnv Types e (Binder meta (XObj (Mod ev _) i t)) = Right (Binder meta (XObj (Mod ev (TypeEnv e)) i t))
|
||||||
|
updateEnv _ _ _ = Left NoEnvInNonModule
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Environment traversal
|
||||||
|
--
|
||||||
|
-- Naming conventions:
|
||||||
|
--
|
||||||
|
-- get: Direct lookup. Try to get the designated binder directly from an
|
||||||
|
-- environment, without traversing into parents or children. If not found,
|
||||||
|
-- fail.
|
||||||
|
--
|
||||||
|
-- find: Preorder lookup. Try to get the designated binder by proceeding from
|
||||||
|
-- the root environment down to its children. If not found in a child, fail.
|
||||||
|
--
|
||||||
|
-- search: pre and post order lookup: Try to get the designated binder by
|
||||||
|
-- proceeding from the root to children. If not found, try to find the binder
|
||||||
|
-- by proceeding from the root's parent, if it exists, to its children. If
|
||||||
|
-- not found, fail.
|
||||||
|
|
||||||
|
-- | Walk down an environment chain.
|
||||||
|
walk' :: Mode -> Env -> SymPath -> Either EnvironmentError Env
|
||||||
|
walk' _ e (SymPath [] _) = pure e
|
||||||
|
walk' mode' e (SymPath (p : ps) name) =
|
||||||
|
do
|
||||||
|
(_, binder) <- get e p
|
||||||
|
go (SymPath ps name) binder
|
||||||
|
where
|
||||||
|
go :: SymPath -> Binder -> Either EnvironmentError Env
|
||||||
|
go (SymPath [] _) binder = nextEnv mode' binder
|
||||||
|
go path binder =
|
||||||
|
do
|
||||||
|
env <- nextEnv Values binder
|
||||||
|
walk' mode' env path
|
||||||
|
|
||||||
|
-- | Generic *unidirectional* retrieval of binders (does not check parents).
|
||||||
|
walkAndGet :: Environment e => e -> SymPath -> (Either EnvironmentError e, Either EnvironmentError Binder)
|
||||||
|
walkAndGet e path@(SymPath _ name) =
|
||||||
|
let target = walk' (modality e) (prj e) path
|
||||||
|
binder = target >>= \t -> get t name
|
||||||
|
in (fmap inj target, fmap snd binder)
|
||||||
|
|
||||||
|
-- | Direct lookup for a binder in environment `e`.
|
||||||
|
-- The environment returned in the output will be the same as that given as input.
|
||||||
|
--
|
||||||
|
-- Returns an error if not found.
|
||||||
|
get :: Environment e => e -> String -> Either EnvironmentError (e, Binder)
|
||||||
|
get e name =
|
||||||
|
case Map.lookup name (binders e) of
|
||||||
|
Nothing -> Left $ BindingNotFound name (prj e)
|
||||||
|
Just b -> Right (e, b)
|
||||||
|
|
||||||
|
-- | Same as `get` but only returns a binder.
|
||||||
|
getBinder :: Environment e => e -> String -> Either EnvironmentError Binder
|
||||||
|
getBinder e name = fmap snd (get e name)
|
||||||
|
|
||||||
|
-- | Generic unidirectional retrieval of binders.
|
||||||
|
-- Searches the children of `e` using a given path, stopping at the terminus.
|
||||||
|
--
|
||||||
|
-- Returns an error if not found.
|
||||||
|
find' :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder)
|
||||||
|
find' e path =
|
||||||
|
case walkAndGet e path of
|
||||||
|
(Right e', Right b) -> Right (e', b)
|
||||||
|
(Left err, _) -> Left err
|
||||||
|
(_, Left err) -> Left err
|
||||||
|
|
||||||
|
-- | Same as `find` but only returns a binder.
|
||||||
|
findBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
|
||||||
|
findBinder e path = fmap snd (find' e path)
|
||||||
|
|
||||||
|
-- | Generic *multidirectional* retrieval of binders.
|
||||||
|
-- Searches the children and parents of `e` (or the parent of a sub-environment
|
||||||
|
-- found in `e` and given by `path`).
|
||||||
|
--
|
||||||
|
-- Returns an error if not found.
|
||||||
|
search :: Environment e => e -> SymPath -> Either EnvironmentError (e, Binder)
|
||||||
|
search e path =
|
||||||
|
case walkAndGet e path of
|
||||||
|
(Right e', Right b) -> Right (e', b)
|
||||||
|
(Right e', Left err) -> (checkParent e' err)
|
||||||
|
(Left err, Left _) -> (checkParent e err) <> Left err
|
||||||
|
-- impossible case. Included to keep `walk` honest.
|
||||||
|
(Left _, Right _) -> error "impossible"
|
||||||
|
where
|
||||||
|
checkParent env err = maybe (Left err) (`search` path) (parent env)
|
||||||
|
|
||||||
|
-- | Same as `search` but only returns a binder.
|
||||||
|
searchBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
|
||||||
|
searchBinder e path = fmap snd (search e path)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Specialized retrievals
|
||||||
|
--
|
||||||
|
-- These functions are all equivalent to the generic retrieval functions
|
||||||
|
-- defined above but they enforce further restrictions at type level. Thus,
|
||||||
|
-- they can be used to help enforce constraints at call sites.
|
||||||
|
--
|
||||||
|
-- For example, suppose we want to search for a binder that may name a type
|
||||||
|
|
||||||
|
-- * or* module, preferring types. One could cast to enforce a type search
|
||||||
|
|
||||||
|
-- starting from the global env:
|
||||||
|
--
|
||||||
|
-- search typeEnv path
|
||||||
|
-- <> search (TypeEnv global) path
|
||||||
|
-- <> search global path
|
||||||
|
--
|
||||||
|
-- But:
|
||||||
|
--
|
||||||
|
-- searchType typeEnv path
|
||||||
|
-- searchType global path
|
||||||
|
-- <> searchValue global path
|
||||||
|
--
|
||||||
|
-- Is arguably much clearer.
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Type retrievals
|
||||||
|
|
||||||
|
-- | Get a type from a type environment.
|
||||||
|
getType :: TypeEnv -> String -> Either EnvironmentError (TypeEnv, Binder)
|
||||||
|
getType = get
|
||||||
|
|
||||||
|
-- | Get a type binder from a type environment.
|
||||||
|
getTypeBinder :: TypeEnv -> String -> Either EnvironmentError Binder
|
||||||
|
getTypeBinder = getBinder
|
||||||
|
|
||||||
|
-- | Unidirectional binder retrieval specialized to types.
|
||||||
|
--
|
||||||
|
-- Restricts the final step of a search to binders in a module's *type* environment.
|
||||||
|
findType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
|
||||||
|
findType e path = find' (inj (prj e)) path
|
||||||
|
|
||||||
|
findTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
|
||||||
|
findTypeBinder e path = fmap snd (findType e path)
|
||||||
|
|
||||||
|
-- | Multidirectional binder retrieval specialized to types.
|
||||||
|
--
|
||||||
|
-- Restricts the final step of a search to binders in a module's *type* environment.
|
||||||
|
searchType :: Environment e => e -> SymPath -> Either EnvironmentError (TypeEnv, Binder)
|
||||||
|
searchType e path = search (inj (prj e)) path
|
||||||
|
|
||||||
|
searchTypeBinder :: Environment e => e -> SymPath -> Either EnvironmentError Binder
|
||||||
|
searchTypeBinder e path = fmap snd (searchType e path)
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Value retrievals
|
||||||
|
|
||||||
|
-- | Get a value from a value environment.
|
||||||
|
getValue :: Env -> String -> Either EnvironmentError (Env, Binder)
|
||||||
|
getValue = get
|
||||||
|
|
||||||
|
getValueBinder :: Env -> String -> Either EnvironmentError Binder
|
||||||
|
getValueBinder = getBinder
|
||||||
|
|
||||||
|
-- | Unidirectional binder retrieval specialized to values.
|
||||||
|
findValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder)
|
||||||
|
findValue = find'
|
||||||
|
|
||||||
|
findValueBinder :: Env -> SymPath -> Either EnvironmentError Binder
|
||||||
|
findValueBinder = findBinder
|
||||||
|
|
||||||
|
-- | Multidirectional binder retrieval specialized to values.
|
||||||
|
searchValue :: Env -> SymPath -> Either EnvironmentError (Env, Binder)
|
||||||
|
searchValue = search
|
||||||
|
|
||||||
|
searchValueBinder :: Env -> SymPath -> Either EnvironmentError Binder
|
||||||
|
searchValueBinder = searchBinder
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Environment mutation
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Mutation primitives
|
||||||
|
|
||||||
|
-- N.B. The following functions returns an Either for compatibility with other
|
||||||
|
-- functions in this module. It is a constant function in the co-domain of
|
||||||
|
-- Either, as they always returns Right.
|
||||||
|
|
||||||
|
-- | Add a new binding to an environment.
|
||||||
|
addBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e
|
||||||
|
addBinding e name b = pure (inj ((prj e) {envBindings = Map.insert name b (binders e)}))
|
||||||
|
|
||||||
|
-- | Replace the value of a binding in an environment, but only if it already
|
||||||
|
-- exists.
|
||||||
|
replaceBinding :: Environment e => e -> String -> Binder -> Either EnvironmentError e
|
||||||
|
replaceBinding e name b =
|
||||||
|
pure (inj ((prj e) {envBindings = Map.adjust (const b) name (binders e)}))
|
||||||
|
|
||||||
|
-- | Delete a binding in an environment.
|
||||||
|
deleteBinding :: Environment e => e -> String -> Either EnvironmentError e
|
||||||
|
deleteBinding e name = pure (inj ((prj e) {envBindings = Map.delete name (binders e)}))
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Generic environment mutation
|
||||||
|
|
||||||
|
type EnvironmentProducer e = (e -> String -> Binder -> Either EnvironmentError e)
|
||||||
|
|
||||||
|
-- | Given an environment and a complete identifier path, traverse a chain of
|
||||||
|
-- environments until the path is exhausted, if requested, mutating the
|
||||||
|
-- environments along the way:
|
||||||
|
mutate :: Environment e => (EnvironmentProducer e) -> e -> SymPath -> Binder -> Either EnvironmentError e
|
||||||
|
mutate f e path binder = go path
|
||||||
|
where
|
||||||
|
go (SymPath [] name) = f e name binder
|
||||||
|
go (SymPath (p : ps) name) =
|
||||||
|
getBinder e p
|
||||||
|
>>= \modu ->
|
||||||
|
nextEnv (modality e) modu
|
||||||
|
>>= \oldEnv ->
|
||||||
|
mutate f (inj oldEnv) (SymPath ps name) binder
|
||||||
|
>>= \result ->
|
||||||
|
updateEnv (modality e) (prj result) modu
|
||||||
|
>>= addBinding e p
|
||||||
|
|
||||||
|
-- | Insert a binding into an environment at the given path.
|
||||||
|
insert :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e
|
||||||
|
insert = mutate addBinding
|
||||||
|
|
||||||
|
-- | Insert an XObj into an environment at the specified path.
|
||||||
|
-- This function does not perform insertions into parents.
|
||||||
|
insertX :: Environment e => e -> SymPath -> XObj -> Either EnvironmentError e
|
||||||
|
insertX e path x = insert e path (toBinder x)
|
||||||
|
|
||||||
|
-- | Replace a binding at the given path in an environment.
|
||||||
|
replace :: Environment e => e -> SymPath -> Binder -> Either EnvironmentError e
|
||||||
|
replace = mutate replaceBinding
|
||||||
|
|
||||||
|
-- | Replaces a binding "in-place" in an environment chain.
|
||||||
|
--
|
||||||
|
-- This function *only* considers members of an environment chain, that is,
|
||||||
|
-- it's limited to the given input environment and all of its ancestors (it's
|
||||||
|
-- parent and the parent of its parent all the way up).
|
||||||
|
--
|
||||||
|
-- It does not look in any "external" environments (used environments or
|
||||||
|
-- "children" (environments stored in module bindings)).
|
||||||
|
replaceInPlace :: Environment e => e -> String -> Binder -> Either EnvironmentError e
|
||||||
|
replaceInPlace e name b =
|
||||||
|
(get e name >>= \_ -> addBinding e name b)
|
||||||
|
<> case parent e of
|
||||||
|
Just p -> replaceInPlace p name b >>= \p' -> pure (inj ((prj e) {envParent = Just (prj p')}))
|
||||||
|
Nothing -> Left (BindingNotFound name (prj e))
|
||||||
|
|
||||||
|
-- | Add a list of bindings to an environment.
|
||||||
|
addListOfBindings :: Environment e => e -> [(String, Binder)] -> e
|
||||||
|
addListOfBindings e bindings =
|
||||||
|
foldl' (\e' (n, b) -> fromRight e (addBinding e' n b)) e bindings
|
||||||
|
|
||||||
|
-- | Add a module path to an environment's list of used modules.
|
||||||
|
addUsePath :: Environment e => e -> SymPath -> e
|
||||||
|
addUsePath e path = inj ((prj e) {envUseModules = Set.insert path (envUseModules (prj e))})
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Additional binding lookup functions
|
||||||
|
--
|
||||||
|
-- find* functions perform lookup in a single environment, without recursion.
|
||||||
|
-- lookup* functions perform lookups in an environment chain, with recursion.
|
||||||
|
|
||||||
|
-- | Get the metadata associated with the binder at the specified path in an environment.
|
||||||
|
lookupMeta :: Environment e => e -> SymPath -> Either EnvironmentError MetaData
|
||||||
|
lookupMeta e path = searchBinder e path >>= pure . Meta.fromBinder
|
||||||
|
|
||||||
|
-- | Find all binders in an environment that have a specified meta key.
|
||||||
|
findAllByMeta :: Environment e => e -> String -> Either EnvironmentError [Binder]
|
||||||
|
findAllByMeta e metaKey =
|
||||||
|
let candidates = Map.elems (Map.filter (Meta.binderMember metaKey) (binders e))
|
||||||
|
in case candidates of
|
||||||
|
[] -> Left (NoMatchingBindingFound ("metadata " ++ metaKey))
|
||||||
|
_ -> Right $ candidates
|
||||||
|
|
||||||
|
-- | Find all modules directly stored in environment `e`.
|
||||||
|
findModules :: Environment e => e -> [XObj]
|
||||||
|
findModules e =
|
||||||
|
map binderXObj (filter modsOnly (Map.elems (binders e)))
|
||||||
|
where
|
||||||
|
modsOnly :: Binder -> Bool
|
||||||
|
modsOnly binder =
|
||||||
|
case binderXObj binder of
|
||||||
|
XObj (Mod _ _) _ _ -> True
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
-- | It's more efficient to specialize this function as it can take advantage
|
||||||
|
-- of laziness; once we found the candidate function for a polymorphic
|
||||||
|
-- function, there's no need to consume the rest of the environment.
|
||||||
|
findPoly :: Environment e => e -> String -> Ty -> Either EnvironmentError (e, Binder)
|
||||||
|
findPoly env name ty =
|
||||||
|
case getBinder env name of
|
||||||
|
Right b ->
|
||||||
|
if unify b
|
||||||
|
then Right (env, b)
|
||||||
|
else (foldl' go (Left (BindingNotFound name (prj env))) (findChildren env))
|
||||||
|
Left _ -> foldl' go (Left (BindingNotFound name (prj env))) (findChildren env)
|
||||||
|
where
|
||||||
|
go x e = x <> (findPoly e name ty)
|
||||||
|
unify = areUnifiable ty . fromMaybe Universe . xobjTy . binderXObj
|
||||||
|
|
||||||
|
-- | Find all environments that are *direct* children of an environment (one
|
||||||
|
-- level down).
|
||||||
|
--
|
||||||
|
-- The modality of the children is determined by the modality of the root.
|
||||||
|
--
|
||||||
|
-- N.B. Don't use find here. We access binders directly, so there's no need to
|
||||||
|
-- perform additional O(n) lookup calls.
|
||||||
|
findChildren :: Environment e => e -> [e]
|
||||||
|
findChildren e =
|
||||||
|
foldl' getEnv [] (binders e)
|
||||||
|
where
|
||||||
|
getEnv acc binder =
|
||||||
|
case (nextEnv (modality e) binder) of
|
||||||
|
Left _ -> acc
|
||||||
|
Right e' -> ((inj e') : acc)
|
||||||
|
|
||||||
|
-- | Find all the environments contained in the modules initial environment,
|
||||||
|
-- plus any module environments contained in *those* modules.
|
||||||
|
lookupChildren :: Environment e => e -> [e]
|
||||||
|
lookupChildren e =
|
||||||
|
foldl' go [] (findChildren e)
|
||||||
|
where
|
||||||
|
go acc e' = case findChildren e' of
|
||||||
|
[] -> (e' : acc)
|
||||||
|
xs -> (foldl' go [] xs ++ acc)
|
||||||
|
|
||||||
|
-- | Find all the environments designated by the use paths in an environment.
|
||||||
|
findImportedEnvs :: Environment e => e -> [e]
|
||||||
|
findImportedEnvs e =
|
||||||
|
let eMode = modality e
|
||||||
|
usePaths = Set.toList (envUseModules (prj e))
|
||||||
|
getter path =
|
||||||
|
walk' eMode (prj e) path
|
||||||
|
>>= \e' ->
|
||||||
|
get e' (getName' path)
|
||||||
|
>>= nextEnv eMode . snd
|
||||||
|
>>= pure . inj
|
||||||
|
used = fmap getter usePaths
|
||||||
|
in (rights used)
|
||||||
|
where
|
||||||
|
getName' (SymPath _ name) = name
|
||||||
|
|
||||||
|
-- | Given an environment, get its topmost parent up the environment chain.
|
||||||
|
--
|
||||||
|
-- For nearly all environments, this should be the global environment.
|
||||||
|
progenitor :: Environment e => e -> e
|
||||||
|
progenitor e = fromMaybe e (parent e >>= \p -> pure (progenitor p))
|
||||||
|
|
||||||
|
-- | Find all possible environments imported at some point *upwards* from e in a chain of environments.
|
||||||
|
allImportedEnvs :: Environment e => e -> Env -> [e]
|
||||||
|
allImportedEnvs e global =
|
||||||
|
let env = prj e
|
||||||
|
paths = (Set.toList (foldl' og (envUseModules env) (unfoldr go env)))
|
||||||
|
in (rights (map get' paths))
|
||||||
|
where
|
||||||
|
go e' = parent e' >>= \p -> pure (p, p)
|
||||||
|
og acc e' = (envUseModules e') <> acc
|
||||||
|
get' path =
|
||||||
|
findBinder global path
|
||||||
|
>>= nextEnv (modality e)
|
||||||
|
>>= pure . inj
|
||||||
|
|
||||||
|
-- | Find all binders the implement a given interface, designated by its path.
|
||||||
|
findImplementations :: Environment e => e -> SymPath -> Either EnvironmentError [Binder]
|
||||||
|
findImplementations e interface =
|
||||||
|
( (findAllByMeta e "implements")
|
||||||
|
>>= \is -> (pure (filter (isImpl . Meta.fromBinder) is))
|
||||||
|
)
|
||||||
|
<> Left (NoMatchingBindingFound ("implementation meta for " ++ show interface))
|
||||||
|
where
|
||||||
|
isImpl :: MetaData -> Bool
|
||||||
|
isImpl meta =
|
||||||
|
case Meta.get "implements" meta of
|
||||||
|
Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces
|
||||||
|
_ -> False
|
||||||
|
|
||||||
|
-- | Searches for binders exhaustively in the given environment, a list of
|
||||||
|
-- child environments it contains derived using a function and its parent, if
|
||||||
|
-- it has one.
|
||||||
|
--
|
||||||
|
-- The parent environment, when it exists, is also searched exhaustively
|
||||||
|
-- (derived children of the parent are searched, as well as the parent of the
|
||||||
|
-- parent, should it exist).
|
||||||
|
lookupExhuastive :: Environment e => (e -> [e]) -> e -> String -> [(e, Binder)]
|
||||||
|
lookupExhuastive f e name =
|
||||||
|
let envs = [e] ++ (f e)
|
||||||
|
in (go (parent e) envs)
|
||||||
|
where
|
||||||
|
go _ [] = []
|
||||||
|
go Nothing xs = foldl' accum [] xs
|
||||||
|
go (Just p) xs = go (parent p) (xs ++ [p] ++ (f p))
|
||||||
|
accum acc e' = case getBinder e' name of
|
||||||
|
Right b -> ((e', b) : acc)
|
||||||
|
_ -> acc
|
||||||
|
|
||||||
|
lookupBinderExhuastive :: Environment e => (e -> [e]) -> e -> String -> [Binder]
|
||||||
|
lookupBinderExhuastive f e name = fmap snd (lookupExhuastive f e name)
|
||||||
|
|
||||||
|
lookupEverywhere :: Environment e => e -> String -> [(e, Binder)]
|
||||||
|
lookupEverywhere = lookupExhuastive lookupChildren
|
||||||
|
|
||||||
|
lookupInImports :: Environment e => e -> String -> [(e, Binder)]
|
||||||
|
lookupInImports = lookupExhuastive findImportedEnvs
|
||||||
|
|
||||||
|
lookupInUsed :: Environment e => e -> Env -> SymPath -> [(e, Binder)]
|
||||||
|
lookupInUsed e global spath =
|
||||||
|
foldl' go [] (allImportedEnvs e global)
|
||||||
|
where
|
||||||
|
go :: Environment e => [(e, Binder)] -> e -> [(e, Binder)]
|
||||||
|
go acc e' = case (search e' spath) of
|
||||||
|
Right (e'', b) -> ((e'', b) : acc)
|
||||||
|
_ -> acc
|
||||||
|
|
||||||
|
-- | Lookup a binder in *all* possible environments in the chain of an initial
|
||||||
|
-- environment (parents and children, including Use modules).
|
||||||
|
lookupBinderEverywhere :: Environment e => e -> String -> [Binder]
|
||||||
|
lookupBinderEverywhere = lookupBinderExhuastive lookupChildren
|
||||||
|
|
||||||
|
lookupContextually :: Environment e => e -> SymPath -> Either EnvironmentError [(e, Binder)]
|
||||||
|
lookupContextually e (SymPath [] name) =
|
||||||
|
case lookupInImports e name of
|
||||||
|
[] -> Left (BindingNotFound name (prj e))
|
||||||
|
xs -> Right xs
|
||||||
|
lookupContextually e path@(SymPath (p : ps) name) =
|
||||||
|
lookupDirectly <> lookupInUsedAndParent
|
||||||
|
where
|
||||||
|
lookupDirectly =
|
||||||
|
(getBinder e p)
|
||||||
|
>>= nextEnv (modality e)
|
||||||
|
>>= \e' ->
|
||||||
|
search (inj e') (SymPath ps name)
|
||||||
|
>>= pure . (: [])
|
||||||
|
lookupInUsedAndParent = case rights (fmap ((flip search) path) (findImportedEnvs e)) of
|
||||||
|
[] -> Left (BindingNotFound name (prj e))
|
||||||
|
xs ->
|
||||||
|
case parent e of
|
||||||
|
Nothing -> Right xs
|
||||||
|
Just e' -> (Env.search e' path >>= \found -> Right $ xs ++ [found]) <> Right xs
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Environment retrieval functions
|
||||||
|
|
||||||
|
-- | Get the environment at a given path that corresponds to the type of an
|
||||||
|
-- initial environment.
|
||||||
|
--
|
||||||
|
-- Returns the initial environment when given an empty path.
|
||||||
|
getInnerEnv :: Environment e => e -> [String] -> Either EnvironmentError e
|
||||||
|
getInnerEnv e [] = Right e
|
||||||
|
getInnerEnv e (p : ps) =
|
||||||
|
(getBinder e p)
|
||||||
|
>>= nextEnv (modality e)
|
||||||
|
>>= \moduleEnv -> getInnerEnv (inj moduleEnv) ps
|
||||||
|
|
||||||
|
-- | Get a context's internal environment if it exists, otherwise get the
|
||||||
|
-- innermost module's value environment based on the context path.
|
||||||
|
contextEnv :: Environment e => Context -> e
|
||||||
|
contextEnv Context {contextInternalEnv = Just e} = inj e
|
||||||
|
contextEnv Context {contextGlobalEnv = e, contextPath = p} = inj (fromRight e (getInnerEnv e p))
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Utility functions
|
||||||
|
|
||||||
|
-- | Checks if an environment is "external", meaning it's either the global
|
||||||
|
-- scope or a module scope.
|
||||||
|
envIsExternal :: Environment e => e -> Bool
|
||||||
|
envIsExternal e =
|
||||||
|
case envMode (prj e) of
|
||||||
ExternalEnv -> True
|
ExternalEnv -> True
|
||||||
InternalEnv -> False
|
InternalEnv -> False
|
||||||
RecursionEnv -> True
|
RecursionEnv -> True
|
||||||
|
|
||||||
envReplaceBinding :: SymPath -> Binder -> Env -> Env
|
--------------------------------------------------------------------------------
|
||||||
envReplaceBinding s@(SymPath [] name) binder env =
|
-- Binding Utilities
|
||||||
case Map.lookup name (envBindings env) of
|
|
||||||
Just _ ->
|
|
||||||
envAddBinding env name binder
|
|
||||||
Nothing ->
|
|
||||||
case envParent env of
|
|
||||||
Just parent -> env {envParent = Just (envReplaceBinding s binder parent)}
|
|
||||||
Nothing -> env
|
|
||||||
envReplaceBinding s@(SymPath (p : ps) name) binder env =
|
|
||||||
case Map.lookup p (envBindings env) of
|
|
||||||
Just b@(Binder _ (XObj (Mod innerEnv) i t)) ->
|
|
||||||
envReplaceBinding (SymPath [] p) b {binderXObj = (XObj (Mod (envReplaceBinding (SymPath ps name) binder innerEnv)) i t)} env
|
|
||||||
_ ->
|
|
||||||
fromMaybe env (envParent env >>= \parent -> Just (env {envParent = Just (envReplaceBinding s binder parent)}))
|
|
||||||
|
|
||||||
envBindingNames :: Env -> [String]
|
-- | Get a list of all the names of bindings in an environment that aren't
|
||||||
envBindingNames = concatMap select . envBindings
|
-- hidden or private.
|
||||||
|
envPublicBindingNames :: Environment e => e -> [String]
|
||||||
|
envPublicBindingNames e = concatMap select (Map.toList (binders e))
|
||||||
where
|
where
|
||||||
select :: Binder -> [String]
|
select :: (String, Binder) -> [String]
|
||||||
select (Binder _ (XObj (Mod m) _ _)) = envBindingNames m
|
select (name, binder) =
|
||||||
select (Binder _ obj) = [getName obj]
|
case (nextEnv (modality e) binder) of
|
||||||
|
Left _ ->
|
||||||
envPublicBindingNames :: Env -> [String]
|
if metaIsTrue (binderMeta binder) "private" || metaIsTrue (binderMeta binder) "hidden"
|
||||||
envPublicBindingNames = concatMap select . envBindings
|
then []
|
||||||
where
|
else [name]
|
||||||
select :: Binder -> [String]
|
Right e' -> envPublicBindingNames e'
|
||||||
select (Binder _ (XObj (Mod m) _ _)) = envPublicBindingNames m
|
|
||||||
select (Binder meta obj) =
|
|
||||||
if metaIsTrue meta "private" || metaIsTrue meta "hidden"
|
|
||||||
then []
|
|
||||||
else [getName obj]
|
|
||||||
|
|
||||||
-- | Recursively look through all environments for (def ...) forms.
|
-- | Recursively look through all environments for (def ...) forms.
|
||||||
|
--
|
||||||
|
-- N.B. Don't use find here. We access binders directly, so there's no need to
|
||||||
|
-- perform additional O(n) lookup calls.
|
||||||
findAllGlobalVariables :: Env -> [Binder]
|
findAllGlobalVariables :: Env -> [Binder]
|
||||||
findAllGlobalVariables env =
|
findAllGlobalVariables e =
|
||||||
concatMap finder (envBindings env)
|
foldl' finder [] (Map.elems (binders e))
|
||||||
where
|
where
|
||||||
finder :: Binder -> [Binder]
|
finder :: [Binder] -> Binder -> [Binder]
|
||||||
finder def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) =
|
finder acc (Binder _ (XObj (Mod ev _) _ _)) = acc ++ (findAllGlobalVariables (inj ev))
|
||||||
[def]
|
finder acc def@(Binder _ (XObj (Lst (XObj Def _ _ : _)) _ _)) = (def : acc)
|
||||||
finder (Binder _ (XObj (Mod innerEnv) _ _)) =
|
finder acc _ = acc
|
||||||
findAllGlobalVariables innerEnv
|
|
||||||
finder _ =
|
|
||||||
[]
|
|
||||||
|
126
src/Eval.hs
126
src/Eval.hs
@ -8,17 +8,17 @@ import Context
|
|||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
|
import Data.Either (fromRight)
|
||||||
import Data.Foldable (foldlM, foldrM)
|
import Data.Foldable (foldlM, foldrM)
|
||||||
import Data.List (foldl', intercalate, isSuffixOf)
|
import Data.List (foldl', intercalate, isSuffixOf)
|
||||||
import Data.List.Split (splitOn, splitWhen)
|
import Data.List.Split (splitOn, splitWhen)
|
||||||
import Data.Maybe (fromJust, fromMaybe, isJust)
|
import Data.Maybe (fromJust, fromMaybe, isJust)
|
||||||
import Emit
|
import Emit
|
||||||
import Env
|
import qualified Env as E
|
||||||
import EvalError
|
import EvalError
|
||||||
import Expand
|
import Expand
|
||||||
import Infer
|
import Infer
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import qualified Meta
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
@ -81,9 +81,10 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
|||||||
then pure (ctx, Left (HasStaticCall xobj info))
|
then pure (ctx, Left (HasStaticCall xobj info))
|
||||||
else pure v
|
else pure v
|
||||||
checkStatic v = pure v
|
checkStatic v = pure v
|
||||||
|
-- all else failed, error.
|
||||||
unwrapLookup =
|
unwrapLookup =
|
||||||
fromMaybe
|
fromMaybe
|
||||||
(throwErr (SymbolNotFound spath) ctx info) -- all else failed, error.
|
(throwErr (SymbolNotFound spath) ctx info)
|
||||||
tryAllLookups =
|
tryAllLookups =
|
||||||
( case preference of
|
( case preference of
|
||||||
PreferDynamic -> tryDynamicLookup
|
PreferDynamic -> tryDynamicLookup
|
||||||
@ -91,19 +92,25 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
|||||||
)
|
)
|
||||||
<|> (if null p then tryInternalLookup spath else tryLookup spath)
|
<|> (if null p then tryInternalLookup spath else tryLookup spath)
|
||||||
tryDynamicLookup =
|
tryDynamicLookup =
|
||||||
lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
|
( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ("Dynamic" : p) n))
|
||||||
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
|
||||||
tryInternalLookup path =
|
|
||||||
( contextInternalEnv ctx
|
|
||||||
>>= lookupBinder path
|
|
||||||
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
||||||
)
|
)
|
||||||
|
tryInternalLookup path =
|
||||||
|
--trace ("Looking for internally " ++ show path) -- ++ show (fmap (fmap E.binders . E.parent) (contextInternalEnv ctx)))
|
||||||
|
( contextInternalEnv ctx
|
||||||
|
>>= \e ->
|
||||||
|
maybeId (E.searchValueBinder e path)
|
||||||
|
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
||||||
|
)
|
||||||
<|> tryLookup path -- fallback
|
<|> tryLookup path -- fallback
|
||||||
tryLookup path =
|
tryLookup path =
|
||||||
( lookupBinder path (contextGlobalEnv ctx)
|
( maybeId (E.searchValueBinder (contextGlobalEnv ctx) path)
|
||||||
>>= \(Binder meta found) -> checkPrivate meta found
|
>>= \(Binder meta found) -> checkPrivate meta found
|
||||||
)
|
)
|
||||||
<|> ( lookupBinder path (getTypeEnv (contextTypeEnv ctx))
|
<|> ( maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath ((contextPath ctx) ++ p) n))
|
||||||
|
>>= \(Binder meta found) -> checkPrivate meta found
|
||||||
|
)
|
||||||
|
<|> ( maybeId (lookupBinderInTypeEnv ctx path)
|
||||||
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
|
||||||
)
|
)
|
||||||
<|> ( foldl
|
<|> ( foldl
|
||||||
@ -111,7 +118,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
|||||||
Nothing
|
Nothing
|
||||||
( map
|
( map
|
||||||
( \(SymPath p' n') ->
|
( \(SymPath p' n') ->
|
||||||
lookupBinder (SymPath (p' ++ (n' : p)) n) (contextGlobalEnv ctx)
|
maybeId (E.searchValueBinder (contextGlobalEnv ctx) (SymPath (p' ++ (n' : p)) n))
|
||||||
>>= \(Binder meta found) -> checkPrivate meta found
|
>>= \(Binder meta found) -> checkPrivate meta found
|
||||||
)
|
)
|
||||||
(Set.toList (envUseModules (contextGlobalEnv ctx)))
|
(Set.toList (envUseModules (contextGlobalEnv ctx)))
|
||||||
@ -220,7 +227,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
|
|||||||
(newCtx, res) <- eval ctx' x preference resolver
|
(newCtx, res) <- eval ctx' x preference resolver
|
||||||
case res of
|
case res of
|
||||||
Right okX ->
|
Right okX ->
|
||||||
pure $ Right (bindLetDeclaration newCtx n okX)
|
pure $ Right (fromRight (error "Failed to eval let binding!!") (bindLetDeclaration newCtx n okX))
|
||||||
Left err -> pure $ Left err
|
Left err -> pure $ Left err
|
||||||
[f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do
|
[f@(XObj Fn {} _ _), args@(XObj (Arr a) _ _), body] -> do
|
||||||
(newCtx, expanded) <- macroExpand ctx body
|
(newCtx, expanded) <- macroExpand ctx body
|
||||||
@ -446,7 +453,7 @@ macroExpand ctx xobj =
|
|||||||
|
|
||||||
apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
|
apply :: Context -> XObj -> [XObj] -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||||
apply ctx@Context {contextInternalEnv = internal} body params args =
|
apply ctx@Context {contextInternalEnv = internal} body params args =
|
||||||
let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx)
|
let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx)
|
||||||
allParams = map getName params
|
allParams = map getName params
|
||||||
in case splitWhen (":rest" ==) allParams of
|
in case splitWhen (":rest" ==) allParams of
|
||||||
[a, b] -> callWith env a b
|
[a, b] -> callWith env a b
|
||||||
@ -459,18 +466,21 @@ apply ctx@Context {contextInternalEnv = internal} body params args =
|
|||||||
insideEnv = Env Map.empty internal Nothing Set.empty InternalEnv 0
|
insideEnv = Env Map.empty internal Nothing Set.empty InternalEnv 0
|
||||||
insideEnv' =
|
insideEnv' =
|
||||||
foldl'
|
foldl'
|
||||||
(\e (p, x) -> extendEnv e p (toLocalDef p x))
|
(\e (p, x) -> fromRight (error "Couldn't add local def ") (E.insertX e (SymPath [] p) (toLocalDef p x)))
|
||||||
insideEnv
|
insideEnv
|
||||||
(zip proper (take n args))
|
(zip proper (take n args))
|
||||||
insideEnv'' =
|
insideEnv'' =
|
||||||
if null rest
|
if null rest
|
||||||
then insideEnv'
|
then insideEnv'
|
||||||
else
|
else
|
||||||
extendEnv
|
fromRight
|
||||||
insideEnv'
|
(error "couldn't insert into inside env")
|
||||||
(head rest)
|
( E.insertX
|
||||||
(XObj (Lst (drop n args)) Nothing Nothing)
|
insideEnv'
|
||||||
(c, r) <- evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body
|
(SymPath [] (head rest))
|
||||||
|
(XObj (Lst (drop n args)) Nothing Nothing)
|
||||||
|
)
|
||||||
|
(c, r) <- (evalDynamic ResolveLocal (replaceInternalEnv ctx insideEnv'') body)
|
||||||
pure (c {contextInternalEnv = internal}, r)
|
pure (c {contextInternalEnv = internal}, r)
|
||||||
|
|
||||||
-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
|
-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
|
||||||
@ -597,12 +607,12 @@ catcher ctx exception =
|
|||||||
|
|
||||||
specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
|
specialCommandWith :: Context -> XObj -> SymPath -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||||
specialCommandWith ctx _ path forms = do
|
specialCommandWith ctx _ path forms = do
|
||||||
let Just env = contextInternalEnv ctx <|> innermostModuleEnv ctx <|> Just (contextGlobalEnv ctx)
|
let Just env = contextInternalEnv ctx <|> maybeId (innermostModuleEnv ctx) <|> Just (contextGlobalEnv ctx)
|
||||||
useThese = envUseModules env
|
useThese = envUseModules env
|
||||||
env' = env {envUseModules = Set.insert path useThese}
|
env' = env {envUseModules = Set.insert path useThese}
|
||||||
ctx' = replaceGlobalEnv ctx env'
|
ctx' = replaceGlobalEnv ctx env'
|
||||||
ctxAfter <- liftIO $ foldM folder ctx' forms
|
ctxAfter <- liftIO $ foldM folder ctx' forms
|
||||||
let Just envAfter = contextInternalEnv ctxAfter <|> innermostModuleEnv ctxAfter <|> Just (contextGlobalEnv ctxAfter)
|
let Just envAfter = contextInternalEnv ctxAfter <|> maybeId (innermostModuleEnv ctxAfter) <|> Just (contextGlobalEnv ctxAfter)
|
||||||
-- undo ALL use:s made inside the 'with'.
|
-- undo ALL use:s made inside the 'with'.
|
||||||
ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese})
|
ctxAfter' = replaceGlobalEnv ctx (envAfter {envUseModules = useThese})
|
||||||
pure (ctxAfter', dynamicNil)
|
pure (ctxAfter', dynamicNil)
|
||||||
@ -645,7 +655,7 @@ getSigFromDefnOrDef ctx xobj =
|
|||||||
fullPath = case path of
|
fullPath = case path of
|
||||||
(SymPath [] _) -> consPath pathStrings path
|
(SymPath [] _) -> consPath pathStrings path
|
||||||
(SymPath _ _) -> path
|
(SymPath _ _) -> path
|
||||||
metaData = lookupMeta fullPath globalEnv
|
metaData = either (const emptyMeta) id (E.lookupMeta globalEnv fullPath)
|
||||||
in case Meta.get "sig" metaData of
|
in case Meta.get "sig" metaData of
|
||||||
Just foundSignature ->
|
Just foundSignature ->
|
||||||
case xobjToTy foundSignature of
|
case xobjToTy foundSignature of
|
||||||
@ -683,39 +693,45 @@ annotateWithinContext ctx xobj = do
|
|||||||
Right ok -> pure (ctx, Right ok)
|
Right ok -> pure (ctx, Right ok)
|
||||||
|
|
||||||
primitiveDefmodule :: VariadicPrimitiveCallback
|
primitiveDefmodule :: VariadicPrimitiveCallback
|
||||||
primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) =
|
primitiveDefmodule xobj ctx@(Context env i tenv pathStrings _ _ _ _) (XObj (Sym (SymPath [] moduleName) _) _ _ : innerExpressions) =
|
||||||
-- N.B. The `envParent` rewrite at the end of this line is important!
|
-- N.B. The `envParent` rewrite at the end of this line is important!
|
||||||
-- lookups delve into parent envs by default, which is normally what we want, but in this case it leads to problems
|
-- lookups delve into parent envs by default, which is normally what we want, but in this case it leads to problems
|
||||||
-- when submodules happen to share a name with an existing module or type at the global level.
|
-- when submodules happen to share a name with an existing module or type at the global level.
|
||||||
maybe (defineNewModule emptyMeta) updateExistingModule (lookupBinder (SymPath [] moduleName) ((getEnv env pathStrings) {envParent = Nothing}))
|
either (const (defineNewModule emptyMeta)) updateExistingModule (E.searchValueBinder ((fromRight env (E.getInnerEnv env pathStrings)) {envParent = Nothing}) (SymPath [] moduleName))
|
||||||
>>= defineModuleBindings
|
>>= defineModuleBindings
|
||||||
>>= \(newCtx, result) ->
|
>>= \(newCtx, result) ->
|
||||||
case result of
|
let updater c = (c {contextInternalEnv = (E.parent =<< contextInternalEnv c)})
|
||||||
Left err -> pure (newCtx, Left err)
|
in case result of
|
||||||
Right _ -> pure (popModulePath (newCtx {contextInternalEnv = envParent =<< contextInternalEnv newCtx}), dynamicNil)
|
Left err -> pure (newCtx, Left err)
|
||||||
|
Right _ -> pure (updater (popModulePath newCtx), dynamicNil)
|
||||||
where
|
where
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Update an existing module by modifying its environment parents and updating the current context path.
|
||||||
updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
|
updateExistingModule :: Binder -> IO (Context, Either EvalError XObj)
|
||||||
updateExistingModule (Binder _ (XObj (Mod innerEnv) _ _)) =
|
updateExistingModule (Binder _ (XObj (Mod innerEnv _) _ _)) =
|
||||||
let ctx' =
|
let updateContext =
|
||||||
ctx
|
replacePath' (contextPath ctx ++ [moduleName])
|
||||||
{ contextInternalEnv = Just innerEnv {envParent = i},
|
. replaceInternalEnv' (innerEnv {envParent = i})
|
||||||
contextPath = contextPath ctx ++ [moduleName]
|
in pure (updateContext ctx, dynamicNil)
|
||||||
}
|
|
||||||
in pure (ctx', dynamicNil)
|
|
||||||
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
|
updateExistingModule (Binder meta (XObj (Lst [XObj MetaStub _ _, _]) _ _)) =
|
||||||
defineNewModule meta
|
defineNewModule meta
|
||||||
updateExistingModule _ =
|
updateExistingModule _ =
|
||||||
pure (throwErr (ModuleRedefinition moduleName) ctx (xobjInfo xobj))
|
pure (throwErr (ModuleRedefinition moduleName) ctx (xobjInfo xobj))
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Define a brand new module with a context's current environments as its parents.
|
||||||
defineNewModule :: MetaData -> IO (Context, Either EvalError XObj)
|
defineNewModule :: MetaData -> IO (Context, Either EvalError XObj)
|
||||||
defineNewModule meta =
|
defineNewModule meta =
|
||||||
pure (ctx', dynamicNil)
|
pure (fromRight ctx (updater ctx), dynamicNil)
|
||||||
where
|
where
|
||||||
moduleEnv = Env (Map.fromList []) (Just (getEnv env pathStrings)) (Just moduleName) Set.empty ExternalEnv 0
|
moduleDefs = E.new (Just (fromRight env (E.getInnerEnv env pathStrings))) (Just moduleName)
|
||||||
newModule = XObj (Mod moduleEnv) (xobjInfo xobj) (Just ModuleTy)
|
moduleTypes = E.new (Just tenv) (Just moduleName)
|
||||||
updatedGlobalEnv = envInsertAt env (SymPath pathStrings moduleName) (Binder meta newModule)
|
newModule = XObj (Mod moduleDefs moduleTypes) (xobjInfo xobj) (Just ModuleTy)
|
||||||
-- The parent of the internal env needs to be set to i here for contextual `use` calls to work.
|
updater = \c ->
|
||||||
-- In theory this shouldn't be necessary; but for now it is.
|
insertInGlobalEnv' (markQualified (SymPath pathStrings moduleName)) (Binder meta newModule) c
|
||||||
ctx' = ctx {contextGlobalEnv = updatedGlobalEnv, contextInternalEnv = Just moduleEnv {envParent = i}, contextPath = contextPath ctx ++ [moduleName]}
|
>>= pure . replaceInternalEnv' (moduleDefs {envParent = i})
|
||||||
|
>>= pure . replacePath' (contextPath ctx ++ [moduleName])
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
-- Define bindings for the module.
|
||||||
defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
|
defineModuleBindings :: (Context, Either EvalError XObj) -> IO (Context, Either EvalError XObj)
|
||||||
defineModuleBindings (context, Left e) = pure (context, Left e)
|
defineModuleBindings (context, Left e) = pure (context, Left e)
|
||||||
defineModuleBindings (context, _) =
|
defineModuleBindings (context, _) =
|
||||||
@ -725,7 +741,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
|
|||||||
step (ctx', Right _) expressions =
|
step (ctx', Right _) expressions =
|
||||||
macroExpand ctx' expressions
|
macroExpand ctx' expressions
|
||||||
>>= \(ctx'', res) -> case res of
|
>>= \(ctx'', res) -> case res of
|
||||||
Left _ -> pure (ctx'', res)
|
Left err -> pure (ctx'', Left err)
|
||||||
Right r -> evalDynamic ResolveLocal ctx'' r
|
Right r -> evalDynamic ResolveLocal ctx'' r
|
||||||
primitiveDefmodule _ ctx (x : _) =
|
primitiveDefmodule _ ctx (x : _) =
|
||||||
pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x))
|
pure (throwErr (DefmoduleContainsNonSymbol x) ctx (xobjInfo x))
|
||||||
@ -1013,21 +1029,21 @@ primitiveDefdynamic _ ctx notName _ =
|
|||||||
pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName))
|
pure (throwErr (DefnDynamicInvalidName notName) ctx (xobjInfo notName))
|
||||||
|
|
||||||
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
|
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
|
||||||
specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] =
|
specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ _) _) _ _), val] =
|
||||||
let lookupInternal =
|
let lookupInternal =
|
||||||
contextInternalEnv ctx
|
maybe (Left "") Right (contextInternalEnv ctx)
|
||||||
>>= \e ->
|
>>= \e ->
|
||||||
lookupBinder path e
|
unwrapErr (E.searchValueBinder e path)
|
||||||
>>= \binder -> pure (binder, setInternal, e)
|
>>= \binder -> pure (binder, setInternal, e)
|
||||||
lookupGlobal =
|
lookupGlobal =
|
||||||
Just (contextGlobalEnv ctx)
|
Right (contextGlobalEnv ctx)
|
||||||
>>= \e ->
|
>>= \e ->
|
||||||
lookupBinder path e
|
unwrapErr (E.searchValueBinder e path)
|
||||||
>>= \binder -> pure (binder, setGlobal, e)
|
>>= \binder -> pure (binder, setGlobal, e)
|
||||||
in maybe
|
in either
|
||||||
(pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))
|
((const (pure $ (throwErr (SetVarNotFound orig) ctx (xobjInfo orig)))))
|
||||||
(\(binder', setter', env') -> evalAndSet binder' setter' env')
|
(\(binder', setter', env') -> evalAndSet binder' setter' env')
|
||||||
(lookupInternal <|> lookupGlobal)
|
(lookupInternal <> lookupGlobal)
|
||||||
where
|
where
|
||||||
evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj)
|
evalAndSet :: Binder -> (Context -> Env -> Either EvalError XObj -> Binder -> IO (Context, Either EvalError XObj)) -> Env -> IO (Context, Either EvalError XObj)
|
||||||
evalAndSet binder setter env =
|
evalAndSet binder setter env =
|
||||||
@ -1051,7 +1067,7 @@ specialCommandSet ctx [orig@(XObj (Sym path@(SymPath _ n) _) _ _), val] =
|
|||||||
setInternal ctx' env value binder =
|
setInternal ctx' env value binder =
|
||||||
pure $ either (failure ctx' orig) (success ctx') value
|
pure $ either (failure ctx' orig) (success ctx') value
|
||||||
where
|
where
|
||||||
success c xo = (replaceInternalEnv c (setStaticOrDynamicVar (SymPath [] n) env binder xo), dynamicNil)
|
success c xo = (replaceInternalEnv c (setStaticOrDynamicVar path env binder xo), dynamicNil)
|
||||||
specialCommandSet ctx [notName, _] =
|
specialCommandSet ctx [notName, _] =
|
||||||
pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName))
|
pure (throwErr (SetInvalidVarName notName) ctx (xobjInfo notName))
|
||||||
specialCommandSet ctx args =
|
specialCommandSet ctx args =
|
||||||
@ -1080,14 +1096,14 @@ typeCheckValueAgainstBinder ctx val binder = do
|
|||||||
-- assigns an appropriate type to the variable.
|
-- assigns an appropriate type to the variable.
|
||||||
-- Returns a new environment containing the assignment.
|
-- Returns a new environment containing the assignment.
|
||||||
setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
|
setStaticOrDynamicVar :: SymPath -> Env -> Binder -> XObj -> Env
|
||||||
setStaticOrDynamicVar path env binder value =
|
setStaticOrDynamicVar path@(SymPath _ name) env binder value =
|
||||||
case binder of
|
case binder of
|
||||||
(Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
|
(Binder meta (XObj (Lst (def@(XObj Def _ _) : sym : _)) _ t)) ->
|
||||||
envReplaceBinding path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)) env
|
fromRight env (E.insert env path (Binder meta (XObj (Lst [def, sym, value]) (xobjInfo value) t)))
|
||||||
(Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
|
(Binder meta (XObj (Lst (defdy@(XObj DefDynamic _ _) : sym : _)) _ _)) ->
|
||||||
envReplaceBinding path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))) env
|
fromRight env (E.insert env path (Binder meta (XObj (Lst [defdy, sym, value]) (xobjInfo value) (Just DynamicTy))))
|
||||||
(Binder meta (XObj (Lst (lett@(XObj LocalDef _ _) : sym : _)) _ t)) ->
|
(Binder meta (XObj (Lst (lett@(XObj LocalDef _ _) : sym : _)) _ t)) ->
|
||||||
envReplaceBinding path (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)) env
|
fromRight (error "FAILED!") (E.replaceInPlace env name (Binder meta (XObj (Lst [lett, sym, value]) (xobjInfo value) t)))
|
||||||
-- shouldn't happen, errors are thrown at call sites.
|
-- shouldn't happen, errors are thrown at call sites.
|
||||||
-- TODO: Return an either here to propagate error.
|
-- TODO: Return an either here to propagate error.
|
||||||
_ -> env
|
_ -> env
|
||||||
|
@ -4,7 +4,6 @@ import Control.Monad.State (State, evalState, get, put)
|
|||||||
import Data.Foldable (foldlM)
|
import Data.Foldable (foldlM)
|
||||||
import Env
|
import Env
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import Obj
|
import Obj
|
||||||
import TypeError
|
import TypeError
|
||||||
import Types
|
import Types
|
||||||
@ -219,7 +218,7 @@ expand eval ctx xobj =
|
|||||||
("`ref` takes a single argument, but I got `" ++ pretty xobj ++ "`.")
|
("`ref` takes a single argument, but I got `" ++ pretty xobj ++ "`.")
|
||||||
(xobjInfo xobj)
|
(xobjInfo xobj)
|
||||||
)
|
)
|
||||||
XObj (Mod modEnv) _ _ : args ->
|
XObj (Mod modEnv _) _ _ : args ->
|
||||||
let pathToModule = pathToEnv modEnv
|
let pathToModule = pathToEnv modEnv
|
||||||
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
|
implicitInit = XObj (Sym (SymPath pathToModule "init") Symbol) i t
|
||||||
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
|
in expand eval ctx (XObj (Lst (implicitInit : args)) (xobjInfo xobj) (xobjTy xobj))
|
||||||
@ -280,15 +279,15 @@ expand eval ctx xobj =
|
|||||||
expandArray _ = error "Can't expand non-array in expandArray."
|
expandArray _ = error "Can't expand non-array in expandArray."
|
||||||
expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
|
expandSymbol :: XObj -> IO (Context, Either EvalError XObj)
|
||||||
expandSymbol sym@(XObj (Sym path _) _ _) =
|
expandSymbol sym@(XObj (Sym path _) _ _) =
|
||||||
case lookupBinder path (contextEnv ctx) of
|
case searchValueBinder (contextEnv ctx) path of
|
||||||
Just (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj (External _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj (Deftemplate _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj (Defn _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj Def _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
Right (Binder meta (XObj (Lst (XObj (Defalias _) _ _ : _)) _ _)) -> isPrivate meta xobj
|
||||||
Just (Binder meta found) -> isPrivate meta found -- use the found value
|
Right (Binder meta found) -> isPrivate meta found -- use the found value
|
||||||
Nothing -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
|
Left _ -> pure (ctx, Right xobj) -- symbols that are not found are left as-is
|
||||||
where
|
where
|
||||||
isPrivate m x =
|
isPrivate m x =
|
||||||
pure $
|
pure $
|
||||||
|
@ -272,7 +272,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
|||||||
(Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
|
(Sym (SymPath [] ("I inferred the type of the array from its first element " ++ show (getPath x))) Symbol)
|
||||||
(xobjInfo x)
|
(xobjInfo x)
|
||||||
(Just headTy)
|
(Just headTy)
|
||||||
Just (StructTy (ConcreteNameTy "Array") [t]) = xobjTy xobj
|
Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [t]) = xobjTy xobj
|
||||||
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
|
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
|
||||||
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
||||||
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
|
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
|
||||||
@ -293,7 +293,7 @@ genConstraints _ root rootSig = fmap sort (gen root)
|
|||||||
(Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
|
(Sym (SymPath [] ("I inferred the type of the static array from its first element " ++ show (getPath x))) Symbol)
|
||||||
(xobjInfo x)
|
(xobjInfo x)
|
||||||
(Just headTy)
|
(Just headTy)
|
||||||
Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [t]) _) = xobjTy xobj
|
Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [t]) _) = xobjTy xobj
|
||||||
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
|
betweenExprConstraints = zipWith (\o n -> Constraint headTy (forceTy o) headObj (genObj o n) xobj OrdArrBetween) xs [1 ..]
|
||||||
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
headConstraint = Constraint headTy t headObj (genObj x 1) xobj OrdArrHead
|
||||||
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
|
pure (headConstraint : insideExprConstraints ++ betweenExprConstraints)
|
||||||
|
@ -1,9 +1,8 @@
|
|||||||
module InitialTypes where
|
module InitialTypes where
|
||||||
|
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Env
|
import Env as E
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
import qualified Set
|
||||||
@ -99,7 +98,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
If -> pure (Left (InvalidObj If xobj))
|
If -> pure (Left (InvalidObj If xobj))
|
||||||
While -> pure (Left (InvalidObj While xobj))
|
While -> pure (Left (InvalidObj While xobj))
|
||||||
Do -> pure (Left (InvalidObj Do xobj))
|
Do -> pure (Left (InvalidObj Do xobj))
|
||||||
(Mod _) -> pure (Left (InvalidObj If xobj))
|
(Mod _ _) -> pure (Left (InvalidObj If xobj))
|
||||||
e@(Deftype _) -> pure (Left (InvalidObj e xobj))
|
e@(Deftype _) -> pure (Left (InvalidObj e xobj))
|
||||||
e@(External _) -> pure (Left (InvalidObj e xobj))
|
e@(External _) -> pure (Left (InvalidObj e xobj))
|
||||||
e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
|
e@(ExternalType _) -> pure (Left (InvalidObj e xobj))
|
||||||
@ -128,8 +127,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
SymPath _ name@('?' : _) -> pure (Right (xobj {xobjTy = Just (VarTy name)}))
|
SymPath _ name@('?' : _) -> pure (Right (xobj {xobjTy = Just (VarTy name)}))
|
||||||
SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
|
SymPath _ (':' : _) -> pure (Left (LeadingColon xobj))
|
||||||
_ ->
|
_ ->
|
||||||
case lookupInEnv symPath env of
|
case E.searchValue env symPath of
|
||||||
Just (foundEnv, binder) ->
|
Right (foundEnv, binder) ->
|
||||||
case xobjTy (binderXObj binder) of
|
case xobjTy (binderXObj binder) of
|
||||||
-- Don't rename internal symbols like parameters etc!
|
-- Don't rename internal symbols like parameters etc!
|
||||||
Just theType
|
Just theType
|
||||||
@ -138,7 +137,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
pure (Right (xobj {xobjTy = Just renamed}))
|
pure (Right (xobj {xobjTy = Just renamed}))
|
||||||
| otherwise -> pure (Right (xobj {xobjTy = Just theType}))
|
| otherwise -> pure (Right (xobj {xobjTy = Just theType}))
|
||||||
Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
|
Nothing -> pure (Left (SymbolMissingType xobj foundEnv))
|
||||||
Nothing -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
|
Left _ -> pure (Left (SymbolNotDefined symPath xobj env)) -- Gives the error message "Trying to refer to an undefined symbol ..."
|
||||||
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
|
visitMultiSym :: Env -> XObj -> [SymPath] -> State Integer (Either TypeError XObj)
|
||||||
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
|
visitMultiSym _ xobj@(XObj (MultiSym _ _) _ _) _ =
|
||||||
do
|
do
|
||||||
@ -148,10 +147,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
|
visitInterfaceSym :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||||
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
|
visitInterfaceSym _ xobj@(XObj (InterfaceSym name) _ _) =
|
||||||
do
|
do
|
||||||
freshTy <- case lookupBinder (SymPath [] name) (getTypeEnv typeEnv) of
|
freshTy <- case getTypeBinder typeEnv name of
|
||||||
Just (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
|
Right (Binder _ (XObj (Lst [XObj (Interface interfaceSignature _) _ _, _]) _ _)) -> renameVarTys interfaceSignature
|
||||||
Just (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
|
Right (Binder _ x) -> error ("A non-interface named '" ++ name ++ "' was found in the type environment: " ++ pretty x)
|
||||||
Nothing -> genVarTy
|
Left _ -> genVarTy
|
||||||
pure (Right xobj {xobjTy = Just freshTy})
|
pure (Right xobj {xobjTy = Just freshTy})
|
||||||
visitInterfaceSym _ _ = error "visitinterfacesym"
|
visitInterfaceSym _ _ = error "visitinterfacesym"
|
||||||
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
visitArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||||
@ -161,7 +160,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
arrayVarTy <- genVarTy
|
arrayVarTy <- genVarTy
|
||||||
pure $ do
|
pure $ do
|
||||||
okVisited <- sequence visited
|
okVisited <- sequence visited
|
||||||
Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy "Array") [arrayVarTy])))
|
Right (XObj (Arr okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Array")) [arrayVarTy])))
|
||||||
visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them."
|
visitArray _ _ = error "The function 'visitArray' only accepts XObj:s with arrays in them."
|
||||||
visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
visitStaticArray :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||||
visitStaticArray env (XObj (StaticArr xobjs) i _) =
|
visitStaticArray env (XObj (StaticArr xobjs) i _) =
|
||||||
@ -171,7 +170,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
lt <- genVarTy
|
lt <- genVarTy
|
||||||
pure $ do
|
pure $ do
|
||||||
okVisited <- sequence visited
|
okVisited <- sequence visited
|
||||||
Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy "StaticArray") [arrayVarTy]) lt)))
|
Right (XObj (StaticArr okVisited) i (Just (RefTy (StructTy (ConcreteNameTy (SymPath [] "StaticArray")) [arrayVarTy]) lt)))
|
||||||
visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them."
|
visitStaticArray _ _ = error "The function 'visitStaticArray' only accepts XObj:s with arrays in them."
|
||||||
visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
|
visitDictionary :: Env -> XObj -> State Integer (Either TypeError XObj)
|
||||||
visitDictionary env (XObj (Dict xobjs) i _) =
|
visitDictionary env (XObj (Dict xobjs) i _) =
|
||||||
@ -180,7 +179,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
arrayVarTy <- genVarTy
|
arrayVarTy <- genVarTy
|
||||||
pure $ do
|
pure $ do
|
||||||
okVisited <- sequence visited
|
okVisited <- sequence visited
|
||||||
Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy "Dictionary") [arrayVarTy])))
|
Right (XObj (Dict okVisited) i (Just (StructTy (ConcreteNameTy (SymPath [] "Dictionary")) [arrayVarTy])))
|
||||||
visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them."
|
visitDictionary _ _ = error "The function 'visitArray' only accepts XObj:s with dictionaries in them."
|
||||||
getTys env argList =
|
getTys env argList =
|
||||||
do
|
do
|
||||||
@ -198,7 +197,7 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
|
let funcTy = Just (FuncTy argTypes returnType StaticLifetimeTy)
|
||||||
typedNameSymbol = nameSymbol {xobjTy = funcTy}
|
typedNameSymbol = nameSymbol {xobjTy = funcTy}
|
||||||
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
|
-- TODO! After the introduction of 'LookupRecursive' this env shouldn't be needed anymore? (but it is for some reason...)
|
||||||
envWithSelf = extendEnv funcScopeEnv name typedNameSymbol
|
Right envWithSelf = E.insertX funcScopeEnv (SymPath [] name) typedNameSymbol
|
||||||
visitedBody <- visit envWithSelf body
|
visitedBody <- visit envWithSelf body
|
||||||
visitedArgs <- mapM (visit envWithSelf) argList
|
visitedArgs <- mapM (visit envWithSelf) argList
|
||||||
pure $ do
|
pure $ do
|
||||||
@ -440,15 +439,18 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
(Sym (SymPath _ name) _) ->
|
(Sym (SymPath _ name) _) ->
|
||||||
do
|
do
|
||||||
visited <- visit env' expr
|
visited <- visit env' expr
|
||||||
pure (envAddBinding env' name . Binder emptyMeta <$> visited)
|
pure
|
||||||
|
( join
|
||||||
|
(replaceLeft (InvalidLetBinding xobjs (sym, expr)) . E.insert env' (SymPath [] name) . Binder emptyMeta <$> visited)
|
||||||
|
)
|
||||||
_ -> pure (Left (InvalidLetBinding xobjs (sym, expr)))
|
_ -> pure (Left (InvalidLetBinding xobjs (sym, expr)))
|
||||||
extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
|
extendEnvWithParamList :: Env -> [XObj] -> State Integer Env
|
||||||
extendEnvWithParamList env xobjs =
|
extendEnvWithParamList env xobjs =
|
||||||
do
|
do
|
||||||
binders <- mapM createBinderForParam xobjs
|
binders' <- mapM createBinderForParam xobjs
|
||||||
pure
|
pure
|
||||||
Env
|
Env
|
||||||
{ envBindings = Map.fromList binders,
|
{ envBindings = Map.fromList binders',
|
||||||
envParent = Just env,
|
envParent = Just env,
|
||||||
envModuleName = Nothing,
|
envModuleName = Nothing,
|
||||||
envUseModules = Set.empty,
|
envUseModules = Set.empty,
|
||||||
@ -468,10 +470,10 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
|
extendEnvWithCaseMatch :: Env -> XObj -> State Integer Env
|
||||||
extendEnvWithCaseMatch env caseRoot =
|
extendEnvWithCaseMatch env caseRoot =
|
||||||
do
|
do
|
||||||
binders <- createBindersForCaseVariable caseRoot
|
binders' <- createBindersForCaseVariable caseRoot
|
||||||
pure
|
pure
|
||||||
Env
|
Env
|
||||||
{ envBindings = Map.fromList binders,
|
{ envBindings = Map.fromList binders',
|
||||||
envParent = Just env,
|
envParent = Just env,
|
||||||
envModuleName = Nothing,
|
envModuleName = Nothing,
|
||||||
envUseModules = Set.empty,
|
envUseModules = Set.empty,
|
||||||
@ -484,8 +486,8 @@ initialTypes typeEnv rootEnv root = evalState (visit rootEnv root) 0
|
|||||||
createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name
|
createBindersForCaseVariable xobj@(XObj (MultiSym name _) _ _) = createBinderInternal xobj name
|
||||||
createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name
|
createBindersForCaseVariable xobj@(XObj (InterfaceSym name) _ _) = createBinderInternal xobj name
|
||||||
createBindersForCaseVariable (XObj (Lst lst) _ _) = do
|
createBindersForCaseVariable (XObj (Lst lst) _ _) = do
|
||||||
binders <- mapM createBindersForCaseVariable lst
|
binders' <- mapM createBindersForCaseVariable lst
|
||||||
pure (concat binders)
|
pure (concat binders')
|
||||||
createBindersForCaseVariable (XObj Ref _ _) = pure []
|
createBindersForCaseVariable (XObj Ref _ _) = pure []
|
||||||
createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism
|
createBindersForCaseVariable x = error ("Can't create binder for non-symbol in 'case' variable match:" ++ show x) -- TODO: Should use proper error mechanism
|
||||||
createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]
|
createBinderInternal :: XObj -> String -> State Integer [(String, Binder)]
|
||||||
|
@ -14,12 +14,13 @@ where
|
|||||||
|
|
||||||
import ColorText
|
import ColorText
|
||||||
import Constraints
|
import Constraints
|
||||||
|
import Context
|
||||||
|
import Data.Either (fromRight, rights)
|
||||||
import Data.List (delete, deleteBy, foldl')
|
import Data.List (delete, deleteBy, foldl')
|
||||||
import Data.Maybe (fromMaybe, mapMaybe)
|
import qualified Env
|
||||||
import Env
|
|
||||||
import Lookup
|
|
||||||
import qualified Meta
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
|
import qualified Qualify
|
||||||
import Types
|
import Types
|
||||||
import Util
|
import Util
|
||||||
|
|
||||||
@ -67,7 +68,7 @@ instance Show InterfaceError where
|
|||||||
-- | Get the first path of an interface implementation that matches a given type signature
|
-- | Get the first path of an interface implementation that matches a given type signature
|
||||||
getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath
|
getFirstMatchingImplementation :: Context -> [SymPath] -> Ty -> Maybe SymPath
|
||||||
getFirstMatchingImplementation ctx paths ty =
|
getFirstMatchingImplementation ctx paths ty =
|
||||||
case filter predicate (mapMaybe (`lookupBinder` global) paths) of
|
case filter predicate (rights (map (global `Env.searchValueBinder`) paths)) of
|
||||||
[] -> Nothing
|
[] -> Nothing
|
||||||
(x : _) -> Just ((getPath . binderXObj) x)
|
(x : _) -> Just ((getPath . binderXObj) x)
|
||||||
where
|
where
|
||||||
@ -77,53 +78,51 @@ getFirstMatchingImplementation ctx paths ty =
|
|||||||
-- | Remove an interface from a binder's list of implemented interfaces
|
-- | Remove an interface from a binder's list of implemented interfaces
|
||||||
removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context
|
removeInterfaceFromImplements :: SymPath -> XObj -> Context -> Context
|
||||||
removeInterfaceFromImplements oldImplPath interface ctx =
|
removeInterfaceFromImplements oldImplPath interface ctx =
|
||||||
fromMaybe
|
fromRight
|
||||||
ctx
|
ctx
|
||||||
( lookupBinder oldImplPath (contextGlobalEnv ctx)
|
( lookupBinderInGlobalEnv ctx (Qualify.markQualified oldImplPath)
|
||||||
>>= \binder ->
|
>>= \binder ->
|
||||||
Meta.getBinderMetaValue "implements" binder
|
pure
|
||||||
>>= ( \x ->
|
( case Meta.getBinderMetaValue "implements" binder of
|
||||||
case x of
|
Just (XObj (Lst impls) i t) -> Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
|
||||||
(XObj (Lst impls) i t) ->
|
_ -> binder
|
||||||
pure $ Meta.updateBinderMeta binder "implements" (XObj (Lst (deleteBy matchPath interface impls)) i t)
|
)
|
||||||
_ -> Nothing
|
>>= insertInGlobalEnv ctx (Qualify.markQualified oldImplPath)
|
||||||
)
|
|
||||||
>>= (\b -> pure $ ctx {contextGlobalEnv = envInsertAt (contextGlobalEnv ctx) oldImplPath b})
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
matchPath xobj xobj' = getPath xobj == getPath xobj'
|
matchPath xobj xobj' = getPath xobj == getPath xobj'
|
||||||
|
|
||||||
-- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
|
-- TODO: This is currently called once outside of this module--try to remove that call and make this internal.
|
||||||
-- Checks whether a given form's type matches an interface, and if so, registers the form with the interface.
|
-- Checks whether a given form's type matches an interface, and if so, registers the form with the interface.
|
||||||
registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Context, Maybe InterfaceError)
|
registerInInterfaceIfNeeded :: Context -> Binder -> Binder -> Ty -> (Either ContextError Context, Maybe InterfaceError)
|
||||||
registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
registerInInterfaceIfNeeded ctx implementation interface definitionSignature =
|
||||||
case interface of
|
case interface of
|
||||||
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
Binder _ (XObj (Lst [inter@(XObj (Interface interfaceSignature paths) ii it), isym]) i t) ->
|
||||||
if checkKinds interfaceSignature definitionSignature
|
if checkKinds interfaceSignature definitionSignature
|
||||||
then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
|
then case solve [Constraint interfaceSignature definitionSignature inter inter inter OrdInterfaceImpl] of
|
||||||
Left _ -> (ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
|
Left _ -> (Right ctx, Just (TypeMismatch implPath definitionSignature interfaceSignature))
|
||||||
Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
|
Right _ -> case getFirstMatchingImplementation ctx paths definitionSignature of
|
||||||
Nothing -> (updatedCtx, Nothing)
|
Nothing -> (updatedCtx, Nothing)
|
||||||
Just x ->
|
Just x ->
|
||||||
if x == implPath
|
if x == implPath
|
||||||
then (updatedCtx, Nothing)
|
then (updatedCtx, Nothing)
|
||||||
else (implReplacedCtx x, Just (AlreadyImplemented ipath x implPath definitionSignature))
|
else (implReplacedCtx x, Just (AlreadyImplemented ipath x implPath definitionSignature))
|
||||||
else (ctx, Just (KindMismatch implPath definitionSignature interfaceSignature))
|
else (Right ctx, Just (KindMismatch implPath definitionSignature interfaceSignature))
|
||||||
where
|
where
|
||||||
|
qpath = (Qualify.markQualified (SymPath [] name))
|
||||||
updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
|
updatedInterface = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath paths)) ii it, isym]) i t
|
||||||
updatedCtx = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name updatedInterface)}
|
updatedCtx = replaceTypeBinder ctx qpath (toBinder updatedInterface)
|
||||||
implReplacedInterface x = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath (delete x paths))) ii it, isym]) i t
|
implReplacedInterface x = XObj (Lst [XObj (Interface interfaceSignature (addIfNotPresent implPath (delete x paths))) ii it, isym]) i t
|
||||||
implReplacedCtx x = ctx {contextTypeEnv = TypeEnv (extendEnv typeEnv name (implReplacedInterface x))}
|
implReplacedCtx x = replaceTypeBinder ctx qpath (toBinder (implReplacedInterface x))
|
||||||
_ ->
|
_ ->
|
||||||
(ctx, Just (NonInterface (getBinderPath interface)))
|
(Right ctx, Just (NonInterface (getBinderPath interface)))
|
||||||
where
|
where
|
||||||
implPath = getBinderPath implementation
|
implPath = getBinderPath implementation
|
||||||
typeEnv = getTypeEnv (contextTypeEnv ctx)
|
|
||||||
ipath@(SymPath _ name) = getBinderPath interface
|
ipath@(SymPath _ name) = getBinderPath interface
|
||||||
|
|
||||||
-- | Given a binder and an interface path, ensure that the form is
|
-- | Given a binder and an interface path, ensure that the form is
|
||||||
-- registered with the interface.
|
-- registered with the interface.
|
||||||
registerInInterface :: Context -> Binder -> Binder -> (Context, Maybe InterfaceError)
|
registerInInterface :: Context -> Binder -> Binder -> (Either ContextError Context, Maybe InterfaceError)
|
||||||
registerInInterface ctx implementation interface =
|
registerInInterface ctx implementation interface =
|
||||||
case binderXObj implementation of
|
case binderXObj implementation of
|
||||||
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
XObj (Lst [XObj (Defn _) _ _, _, _, _]) _ (Just t) ->
|
||||||
@ -141,26 +140,26 @@ registerInInterface ctx implementation interface =
|
|||||||
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
-- And instantiated/auto-derived type functions! (e.g. Pair.a)
|
||||||
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
XObj (Lst [XObj (Instantiate _) _ _, _]) _ (Just t) ->
|
||||||
registerInInterfaceIfNeeded ctx implementation interface t
|
registerInInterfaceIfNeeded ctx implementation interface t
|
||||||
_ -> (ctx, Nothing)
|
_ -> (Right ctx, Nothing)
|
||||||
|
|
||||||
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
-- | For forms that were declared as implementations of interfaces that didn't exist,
|
||||||
-- retroactively register those forms with the interface once its defined.
|
-- retroactively register those forms with the interface once its defined.
|
||||||
retroactivelyRegisterInInterface :: Context -> Binder -> Context
|
retroactivelyRegisterInInterface :: Context -> Binder -> Either ContextError Context
|
||||||
retroactivelyRegisterInInterface ctx interface =
|
retroactivelyRegisterInInterface ctx interface =
|
||||||
-- TODO: Propagate error
|
-- TODO: Propagate error
|
||||||
maybe resultCtx (error . show) err
|
maybe resultCtx (error . show) err
|
||||||
where
|
where
|
||||||
env = contextGlobalEnv ctx
|
env = contextGlobalEnv ctx
|
||||||
impls = lookupMany Everywhere lookupImplementations (getPath (binderXObj interface)) env
|
impls = concat (rights (fmap ((flip Env.findImplementations) (getPath (binderXObj interface))) (env : (Env.lookupChildren env))))
|
||||||
(resultCtx, err) = foldl' (\(context, _) binder -> registerInInterface context binder interface) (ctx, Nothing) impls
|
(resultCtx, err) = foldl' (\(Right context, _) binder -> registerInInterface context binder interface) (Right ctx, Nothing) impls
|
||||||
|
|
||||||
-- | Checks whether an interface is implemented for a certain type signature,
|
-- | Checks whether an interface is implemented for a certain type signature,
|
||||||
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
-- | e.g. Is "delete" implemented for `(Fn [String] ())` ?
|
||||||
interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool
|
interfaceImplementedForTy :: TypeEnv -> Env -> String -> Ty -> Bool
|
||||||
interfaceImplementedForTy (TypeEnv typeEnv) globalEnv interfaceName matchingTy =
|
interfaceImplementedForTy typeEnv globalEnv interfaceName matchingTy =
|
||||||
case lookupBinder (SymPath [] interfaceName) typeEnv of
|
case Env.getTypeBinder typeEnv interfaceName of
|
||||||
Just (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (Interface _ paths) _ _ : _)) _ _)) ->
|
||||||
let lookupType path = forceTy . binderXObj <$> lookupBinder path globalEnv
|
let lookupType' path = forceTy . binderXObj <$> (Env.searchValueBinder globalEnv path)
|
||||||
matches = filter (areUnifiable matchingTy) (mapMaybe lookupType paths)
|
matches = filter (areUnifiable matchingTy) (rights (map lookupType' paths))
|
||||||
in not . null $ matches
|
in not . null $ matches
|
||||||
_ -> False
|
_ -> False
|
||||||
|
143
src/Lookup.hs
143
src/Lookup.hs
@ -1,143 +0,0 @@
|
|||||||
module Lookup where
|
|
||||||
|
|
||||||
import Data.Maybe (catMaybes, mapMaybe)
|
|
||||||
import Env
|
|
||||||
import qualified Map
|
|
||||||
import qualified Meta
|
|
||||||
import Obj
|
|
||||||
import qualified Set
|
|
||||||
import Types
|
|
||||||
|
|
||||||
-- | The type of generic lookup functions.
|
|
||||||
type LookupFunc a b = a -> Env -> [b]
|
|
||||||
|
|
||||||
-- | Find the Binder at a specified path.
|
|
||||||
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
|
|
||||||
lookupInEnv (SymPath [] name) env =
|
|
||||||
case Map.lookup name (envBindings env) of
|
|
||||||
Just found -> Just (env, found)
|
|
||||||
Nothing -> case envParent env of
|
|
||||||
Just parent -> lookupInEnv (SymPath [] name) parent
|
|
||||||
Nothing -> Nothing
|
|
||||||
lookupInEnv path@(SymPath (p : ps) name) env =
|
|
||||||
case Map.lookup p (envBindings env) of
|
|
||||||
Just (Binder _ xobj) ->
|
|
||||||
case xobj of
|
|
||||||
(XObj (Mod modEnv) _ _) -> lookupInEnv (SymPath ps name) modEnv
|
|
||||||
_ -> Nothing
|
|
||||||
Nothing ->
|
|
||||||
case envParent env of
|
|
||||||
Just parent -> lookupInEnv path parent
|
|
||||||
Nothing -> Nothing
|
|
||||||
|
|
||||||
-- | Performs a multiLookupEverywhere but drops envs from the result and wraps
|
|
||||||
-- the results in a Maybe.
|
|
||||||
multiLookupBinderEverywhere :: Context -> SymPath -> Maybe [Binder]
|
|
||||||
multiLookupBinderEverywhere ctx (SymPath _ name) =
|
|
||||||
case map snd (multiLookupEverywhere name (contextEnv ctx)) of
|
|
||||||
[] -> Nothing
|
|
||||||
xs -> Just xs
|
|
||||||
|
|
||||||
-- | Like 'lookupInEnv' but only returns the Binder (no Env)
|
|
||||||
lookupBinder :: SymPath -> Env -> Maybe Binder
|
|
||||||
lookupBinder path env = snd <$> lookupInEnv path env
|
|
||||||
|
|
||||||
-- | Like 'lookupBinder' but return the Meta for the binder, or a default empty meta.
|
|
||||||
lookupMeta :: SymPath -> Env -> MetaData
|
|
||||||
lookupMeta path globalEnv =
|
|
||||||
maybe emptyMeta Meta.fromBinder (lookupBinder path globalEnv)
|
|
||||||
|
|
||||||
-- | Get the Env stored in a binder, if any.
|
|
||||||
envFromBinder :: Binder -> Maybe Env
|
|
||||||
envFromBinder (Binder _ (XObj (Mod e) _ _)) = Just e
|
|
||||||
envFromBinder _ = Nothing
|
|
||||||
|
|
||||||
-- | Given an environment, returns the list of all environments of binders from
|
|
||||||
-- imported modules.
|
|
||||||
importedEnvs :: Env -> [Env]
|
|
||||||
importedEnvs env =
|
|
||||||
catMaybes $ mapMaybe (\path -> fmap envFromBinder (lookupBinder path env)) (Set.toList (envUseModules env))
|
|
||||||
|
|
||||||
-- | Given an environment, returns the list of all environments of its binders.
|
|
||||||
allEnvs :: Env -> [Env]
|
|
||||||
allEnvs env =
|
|
||||||
let envs = mapMaybe (envFromBinder . snd) (Map.toList (envBindings env))
|
|
||||||
in envs ++ concatMap allEnvs envs
|
|
||||||
|
|
||||||
data LookWhere = Everywhere | OnlyImports
|
|
||||||
|
|
||||||
getEnvs :: LookWhere -> Env -> [Env]
|
|
||||||
getEnvs Everywhere = allEnvs
|
|
||||||
getEnvs OnlyImports = importedEnvs
|
|
||||||
|
|
||||||
-- | Given an environment, use a lookup function to recursively find all binders
|
|
||||||
-- in the environment that satisfy the lookup.
|
|
||||||
lookupMany :: LookWhere -> LookupFunc a b -> a -> Env -> [b]
|
|
||||||
lookupMany lookWhere lookf input env =
|
|
||||||
let spine = lookf input env
|
|
||||||
leaves = concatMap (lookf input) (getEnvs lookWhere env)
|
|
||||||
above = case envParent env of
|
|
||||||
Just parent -> lookupMany lookWhere lookf input parent
|
|
||||||
Nothing -> []
|
|
||||||
in spine ++ leaves ++ above
|
|
||||||
|
|
||||||
-- | Lookup binders by name in a single Env (no recursion),
|
|
||||||
lookupByName :: String -> Env -> [(Env, Binder)]
|
|
||||||
lookupByName name env =
|
|
||||||
let filtered = Map.filterWithKey (\k _ -> k == name) (envBindings env)
|
|
||||||
in map ((,) env . snd) (Map.toList filtered)
|
|
||||||
|
|
||||||
-- | Lookup binders that have specified metadata.
|
|
||||||
lookupByMeta :: String -> Env -> [Binder]
|
|
||||||
lookupByMeta key env =
|
|
||||||
let filtered = Map.filter hasMeta (envBindings env)
|
|
||||||
in map snd $ Map.toList filtered
|
|
||||||
where
|
|
||||||
hasMeta b = Meta.binderMember key b
|
|
||||||
|
|
||||||
-- | Given an interface, lookup all binders that implement the interface.
|
|
||||||
lookupImplementations :: SymPath -> Env -> [Binder]
|
|
||||||
lookupImplementations interface env =
|
|
||||||
let binders = lookupByMeta "implements" env
|
|
||||||
in filter isImpl binders
|
|
||||||
where
|
|
||||||
isImpl (Binder meta _) =
|
|
||||||
case Meta.get "implements" meta of
|
|
||||||
Just (XObj (Lst interfaces) _ _) -> interface `elem` map getPath interfaces
|
|
||||||
_ -> False
|
|
||||||
|
|
||||||
-- | Find the possible (imported) symbols that could be referred to by a name.
|
|
||||||
multiLookupImports :: String -> Env -> [(Env, Binder)]
|
|
||||||
multiLookupImports = lookupMany OnlyImports lookupByName
|
|
||||||
|
|
||||||
-- | Find all symbols with a certain name, in *all* environments.
|
|
||||||
multiLookupEverywhere :: String -> Env -> [(Env, Binder)]
|
|
||||||
multiLookupEverywhere = lookupMany Everywhere lookupByName
|
|
||||||
|
|
||||||
-- | Enables look up "semi qualified" (and fully qualified) symbols.
|
|
||||||
-- | i.e. if there are nested environments with a function A.B.f
|
|
||||||
-- | you can find it by doing "(use A)" and then "(B.f)".
|
|
||||||
multiLookupQualified :: SymPath -> Env -> [(Env, Binder)]
|
|
||||||
multiLookupQualified (SymPath [] name) rootEnv =
|
|
||||||
-- This case is just like normal multiLookup, we have a name but no qualifyers:
|
|
||||||
multiLookupImports name rootEnv
|
|
||||||
multiLookupQualified path@(SymPath (p : _) _) rootEnv =
|
|
||||||
case lookupInEnv (SymPath [] p) rootEnv of
|
|
||||||
Just (_, Binder _ (XObj (Mod _) _ _)) ->
|
|
||||||
-- Found a module with the correct name, that means we should not look at anything else:
|
|
||||||
case lookupInEnv path rootEnv of
|
|
||||||
Just found -> [found]
|
|
||||||
Nothing -> []
|
|
||||||
Just _ -> inexactMatch
|
|
||||||
Nothing -> inexactMatch
|
|
||||||
where
|
|
||||||
inexactMatch =
|
|
||||||
-- No exact match on the first qualifier, will look in various places for a match:
|
|
||||||
let fromParent = case envParent rootEnv of
|
|
||||||
Just parent -> multiLookupQualified path parent
|
|
||||||
Nothing -> []
|
|
||||||
fromUsedModules =
|
|
||||||
let usedModules = envUseModules rootEnv
|
|
||||||
envs = catMaybes $ mapMaybe (\path' -> fmap envFromBinder (lookupBinder path' rootEnv)) (Set.toList usedModules)
|
|
||||||
in concatMap (multiLookupQualified path) envs
|
|
||||||
in fromParent ++ fromUsedModules
|
|
12
src/Map.hs
12
src/Map.hs
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE DeriveTraversable #-}
|
{-# LANGUAGE DeriveTraversable #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
@ -18,7 +19,7 @@ fromList :: Ord k => [(k, v)] -> Map k v
|
|||||||
fromList = Map . M.fromList
|
fromList = Map . M.fromList
|
||||||
|
|
||||||
lookup :: Ord k => k -> Map k v -> Maybe v
|
lookup :: Ord k => k -> Map k v -> Maybe v
|
||||||
lookup k (Map m) = M.lookup k m
|
lookup !k (Map !m) = M.lookup k m
|
||||||
|
|
||||||
member :: Ord k => k -> Map k v -> Bool
|
member :: Ord k => k -> Map k v -> Bool
|
||||||
member k (Map m) = M.member k m
|
member k (Map m) = M.member k m
|
||||||
@ -46,3 +47,12 @@ union (Map m) (Map m') = (Map (M.union m m'))
|
|||||||
|
|
||||||
assocs :: Map k a -> [(k, a)]
|
assocs :: Map k a -> [(k, a)]
|
||||||
assocs (Map m) = M.assocs m
|
assocs (Map m) = M.assocs m
|
||||||
|
|
||||||
|
elems :: Map k a -> [a]
|
||||||
|
elems (Map m) = M.elems m
|
||||||
|
|
||||||
|
adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a
|
||||||
|
adjust f k (Map m) = (Map (M.adjust f k m))
|
||||||
|
|
||||||
|
delete :: Ord k => k -> Map k a -> Map k a
|
||||||
|
delete k (Map m) = (Map (M.delete k m))
|
||||||
|
24
src/Obj.hs
24
src/Obj.hs
@ -149,7 +149,7 @@ data Obj
|
|||||||
| Break
|
| Break
|
||||||
| If
|
| If
|
||||||
| Match MatchMode
|
| Match MatchMode
|
||||||
| Mod Env
|
| Mod Env TypeEnv
|
||||||
| Deftype Ty
|
| Deftype Ty
|
||||||
| DefSumtype Ty
|
| DefSumtype Ty
|
||||||
| With
|
| With
|
||||||
@ -342,7 +342,7 @@ getBinderDescription (XObj (Lst (XObj MetaStub _ _ : XObj (Sym _ _) _ _ : _)) _
|
|||||||
getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
getBinderDescription (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
||||||
getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
getBinderDescription (XObj (Lst (XObj (DefSumtype _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "deftype"
|
||||||
getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface"
|
getBinderDescription (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym _ _) _ _ : _)) _ _) = "interface"
|
||||||
getBinderDescription (XObj (Mod _) _ _) = "module"
|
getBinderDescription (XObj (Mod _ _) _ _) = "module"
|
||||||
getBinderDescription b = error ("Unhandled binder: " ++ show b)
|
getBinderDescription b = error ("Unhandled binder: " ++ show b)
|
||||||
|
|
||||||
getName :: XObj -> String
|
getName :: XObj -> String
|
||||||
@ -384,7 +384,7 @@ getPath (XObj (Lst (XObj (External _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = p
|
|||||||
getPath (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (ExternalType _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj MetaStub _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj MetaStub _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (Deftype _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj (Mod _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (Mod _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (Interface _ _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (Command _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
getPath (XObj (Lst (XObj (Primitive _) _ _ : XObj (Sym path _) _ _ : _)) _ _) = path
|
||||||
@ -449,7 +449,7 @@ pretty = visit 0
|
|||||||
Do -> "do"
|
Do -> "do"
|
||||||
Let -> "let"
|
Let -> "let"
|
||||||
LocalDef -> "local-binding"
|
LocalDef -> "local-binding"
|
||||||
Mod env -> fromMaybe "module" (envModuleName env)
|
Mod env _ -> fromMaybe "module" (envModuleName env)
|
||||||
Deftype _ -> "deftype"
|
Deftype _ -> "deftype"
|
||||||
DefSumtype _ -> "deftype"
|
DefSumtype _ -> "deftype"
|
||||||
Deftemplate _ -> "deftemplate"
|
Deftemplate _ -> "deftemplate"
|
||||||
@ -515,7 +515,7 @@ prettyUpTo lim xobj =
|
|||||||
Do -> ""
|
Do -> ""
|
||||||
Let -> ""
|
Let -> ""
|
||||||
LocalDef -> ""
|
LocalDef -> ""
|
||||||
Mod _ -> ""
|
Mod _ _ -> ""
|
||||||
Deftype _ -> ""
|
Deftype _ -> ""
|
||||||
DefSumtype _ -> ""
|
DefSumtype _ -> ""
|
||||||
Deftemplate _ -> ""
|
Deftemplate _ -> ""
|
||||||
@ -643,10 +643,12 @@ forceShowBinder :: Binder -> String
|
|||||||
forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder)
|
forceShowBinder binder = showBinderIndented 0 True (getName (binderXObj binder), binder)
|
||||||
|
|
||||||
showBinderIndented :: Int -> Bool -> (String, Binder) -> String
|
showBinderIndented :: Int -> Bool -> (String, Binder) -> String
|
||||||
showBinderIndented indent _ (name, Binder _ (XObj (Mod env) _ _)) =
|
showBinderIndented indent _ (name, Binder _ (XObj (Mod env tenv) _ _)) =
|
||||||
replicate indent ' ' ++ name ++ " : Module = {\n"
|
replicate indent ' ' ++ name ++ " : Module = {\n"
|
||||||
++ prettyEnvironmentIndented (indent + 4) env
|
++ prettyEnvironmentIndented (indent + 4) env
|
||||||
++ "\n"
|
++ "\n"
|
||||||
|
++ prettyEnvironmentIndented (indent + 4) (getTypeEnv tenv)
|
||||||
|
++ "\n"
|
||||||
++ replicate indent ' '
|
++ replicate indent ' '
|
||||||
++ "}"
|
++ "}"
|
||||||
showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) =
|
showBinderIndented indent _ (name, Binder _ (XObj (Lst [XObj (Interface t paths) _ _, _]) _ _)) =
|
||||||
@ -717,7 +719,7 @@ instance Hashable ClosureContext
|
|||||||
instance Eq ClosureContext where
|
instance Eq ClosureContext where
|
||||||
_ == _ = True
|
_ == _ = True
|
||||||
|
|
||||||
newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic)
|
newtype TypeEnv = TypeEnv {getTypeEnv :: Env} deriving (Generic, Eq)
|
||||||
|
|
||||||
instance Hashable TypeEnv
|
instance Hashable TypeEnv
|
||||||
|
|
||||||
@ -798,9 +800,9 @@ xobjToTy (XObj (Sym (SymPath _ "Pattern") _) _ _) = Just PatternTy
|
|||||||
xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
|
xobjToTy (XObj (Sym (SymPath _ "Char") _) _ _) = Just CharTy
|
||||||
xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
|
xobjToTy (XObj (Sym (SymPath _ "Bool") _) _ _) = Just BoolTy
|
||||||
xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
|
xobjToTy (XObj (Sym (SymPath _ "Static") _) _ _) = Just StaticLifetimeTy
|
||||||
xobjToTy (XObj (Sym (SymPath prefixes s@(firstLetter : _)) _) _ _)
|
xobjToTy (XObj (Sym spath@(SymPath _ s@(firstLetter : _)) _) _ _)
|
||||||
| isLower firstLetter = Just (VarTy s)
|
| isLower firstLetter = Just (VarTy s)
|
||||||
| otherwise = Just (StructTy (ConcreteNameTy (createStructName prefixes s)) [])
|
| otherwise = Just (StructTy (ConcreteNameTy spath) [])
|
||||||
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
|
xobjToTy (XObj (Lst [XObj (Sym (SymPath _ "Ptr") _) _ _, innerTy]) _ _) =
|
||||||
do
|
do
|
||||||
okInnerTy <- xobjToTy innerTy
|
okInnerTy <- xobjToTy innerTy
|
||||||
@ -945,10 +947,10 @@ defineFunctionTypeAlias :: Ty -> XObj
|
|||||||
defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
|
defineFunctionTypeAlias aliasTy = defineTypeAlias (tyToC aliasTy) aliasTy
|
||||||
|
|
||||||
defineArrayTypeAlias :: Ty -> XObj
|
defineArrayTypeAlias :: Ty -> XObj
|
||||||
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") [])
|
defineArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])
|
||||||
|
|
||||||
defineStaticArrayTypeAlias :: Ty -> XObj
|
defineStaticArrayTypeAlias :: Ty -> XObj
|
||||||
defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy "Array") [])
|
defineStaticArrayTypeAlias t = defineTypeAlias (tyToC t) (StructTy (ConcreteNameTy (SymPath [] "Array")) [])
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
defineInterface :: String -> Ty -> [SymPath] -> Maybe Info -> XObj
|
defineInterface :: String -> Ty -> [SymPath] -> Maybe Info -> XObj
|
||||||
|
@ -1,24 +1,30 @@
|
|||||||
module Polymorphism where
|
module Polymorphism
|
||||||
|
( nameOfPolymorphicFunction,
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Lookup
|
import Env as E
|
||||||
import Obj
|
import Obj
|
||||||
import Types
|
import Types
|
||||||
|
|
||||||
-- | Calculate the full, mangled name of a concretized polymorphic function.
|
-- | Calculate the full, mangled name of a concretized polymorphic function.
|
||||||
-- | For example, The 'id' in "(id 3)" will become 'id__int'.
|
-- For example, The 'id' in "(id 3)" will become 'id__int'.
|
||||||
-- | This function uses the 'multiLookupALL' function which gives it acces to
|
--
|
||||||
-- | modules that are not imported. This allows it to access 'delete' functions
|
-- This function uses findPoly, which gives it access to *all* possible
|
||||||
-- | and similar for internal use.
|
-- environments in the given input environment (children, (modules) parents,
|
||||||
|
-- and use modules). This allows it to derive the correct name for functions
|
||||||
-- | TODO: Environments are passed in different order here!!!
|
-- that may be defined in a different environment.
|
||||||
|
--
|
||||||
|
-- TODO: Environments are passed in different order here!!!
|
||||||
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
|
nameOfPolymorphicFunction :: TypeEnv -> Env -> Ty -> String -> Maybe SymPath
|
||||||
nameOfPolymorphicFunction _ env functionType functionName =
|
nameOfPolymorphicFunction _ env functionType functionName =
|
||||||
let foundBinders = multiLookupEverywhere functionName env
|
let foundBinder =
|
||||||
in case filter ((\(Just t') -> areUnifiable functionType t') . xobjTy . binderXObj . snd) foundBinders of
|
(E.findPoly env functionName functionType)
|
||||||
[] -> Nothing
|
<> (E.findPoly (progenitor env) functionName functionType)
|
||||||
[(_, Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))] ->
|
in case foundBinder of
|
||||||
|
Right (_, (Binder _ (XObj (Lst (XObj (External (Just name)) _ _ : _)) _ _))) ->
|
||||||
Just (SymPath [] name)
|
Just (SymPath [] name)
|
||||||
[(_, Binder _ single)] ->
|
Right (_, (Binder _ single)) ->
|
||||||
let Just t' = xobjTy single
|
let Just t' = xobjTy single
|
||||||
(SymPath pathStrings name) = getPath single
|
(SymPath pathStrings name) = getPath single
|
||||||
suffix = polymorphicSuffix t' functionType
|
suffix = polymorphicSuffix t' functionType
|
||||||
|
@ -11,6 +11,14 @@ data PrimitiveError
|
|||||||
| ForewardImplementsMeta
|
| ForewardImplementsMeta
|
||||||
| RegisterTypeError
|
| RegisterTypeError
|
||||||
| SymbolNotFoundError SymPath
|
| SymbolNotFoundError SymPath
|
||||||
|
| BadDeftypeMembers
|
||||||
|
| QualifiedTypeMember [XObj]
|
||||||
|
| InvalidTypeName XObj
|
||||||
|
| InvalidTypeVariables XObj
|
||||||
|
| MetaSetFailed XObj String
|
||||||
|
| StructNotFound XObj
|
||||||
|
| NonTypeInTypeEnv SymPath XObj
|
||||||
|
| InvalidSumtypeCase XObj
|
||||||
|
|
||||||
data PrimitiveWarning
|
data PrimitiveWarning
|
||||||
= NonExistentInterfaceWarning XObj
|
= NonExistentInterfaceWarning XObj
|
||||||
@ -40,6 +48,32 @@ instance Show PrimitiveError where
|
|||||||
++ " (register-type Name c-name [field0 Type, ...]"
|
++ " (register-type Name c-name [field0 Type, ...]"
|
||||||
show (SymbolNotFoundError path) =
|
show (SymbolNotFoundError path) =
|
||||||
"I can’t find the symbol `" ++ show path ++ "`"
|
"I can’t find the symbol `" ++ show path ++ "`"
|
||||||
|
show (BadDeftypeMembers) =
|
||||||
|
"All fields must have a name and a type."
|
||||||
|
++ "Example:\n"
|
||||||
|
++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n"
|
||||||
|
show (QualifiedTypeMember xobjs) =
|
||||||
|
"Type members must be unqualified symbols, but got `"
|
||||||
|
++ concatMap pretty xobjs
|
||||||
|
++ "`"
|
||||||
|
show (InvalidTypeName xobj) =
|
||||||
|
("Invalid name for type definition: " ++ pretty xobj)
|
||||||
|
show (InvalidTypeVariables xobj) =
|
||||||
|
("Invalid type variables for type definition: " ++ pretty xobj)
|
||||||
|
show (MetaSetFailed xobj e) =
|
||||||
|
"`meta-set!` failed on `" ++ pretty xobj
|
||||||
|
++ "` "
|
||||||
|
++ show e
|
||||||
|
show (StructNotFound xobj) =
|
||||||
|
"Couldn't find a type named '" ++ (show (getPath xobj))
|
||||||
|
++ "' in the type environment."
|
||||||
|
show (NonTypeInTypeEnv path xobj) =
|
||||||
|
"Can't get members for: " ++ show path
|
||||||
|
++ " found a non-type in the type environment: "
|
||||||
|
++ (pretty xobj)
|
||||||
|
show (PrimitiveError.InvalidSumtypeCase xobj) =
|
||||||
|
"Can't get members for an invalid sumtype case: "
|
||||||
|
++ pretty xobj
|
||||||
|
|
||||||
instance Show PrimitiveWarning where
|
instance Show PrimitiveWarning where
|
||||||
show (NonExistentInterfaceWarning x) =
|
show (NonExistentInterfaceWarning x) =
|
||||||
|
@ -8,27 +8,26 @@ import Context
|
|||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad (foldM, unless, when)
|
import Control.Monad (foldM, unless, when)
|
||||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||||
import Data.Either (rights)
|
import Data.Bifunctor
|
||||||
|
import Data.Either (fromRight, rights)
|
||||||
import Data.Functor ((<&>))
|
import Data.Functor ((<&>))
|
||||||
import Data.List (foldl')
|
import Data.List (foldl')
|
||||||
import Data.Maybe (fromJust, fromMaybe, mapMaybe)
|
import Data.Maybe (fromJust, fromMaybe)
|
||||||
import Deftype
|
import Deftype
|
||||||
import Emit
|
import Emit
|
||||||
import Env
|
import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
|
||||||
import Infer
|
import Infer
|
||||||
import Info
|
import Info
|
||||||
import Interfaces
|
import Interfaces
|
||||||
import Lookup
|
|
||||||
import Managed
|
import Managed
|
||||||
import qualified Map
|
|
||||||
import qualified Meta
|
import qualified Meta
|
||||||
import Obj
|
import Obj
|
||||||
import PrimitiveError
|
import PrimitiveError
|
||||||
import Project
|
import Project
|
||||||
import Qualify (Qualified (..), getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
|
import Qualify (Qualified (..), QualifiedPath, getQualifiedPath, markQualified, qualify, qualifyNull, qualifyPath, unqualify)
|
||||||
import Reify
|
import Reify
|
||||||
import qualified Set
|
|
||||||
import Sumtypes
|
import Sumtypes
|
||||||
|
import SymPath
|
||||||
import Template
|
import Template
|
||||||
import ToTemplate
|
import ToTemplate
|
||||||
import TypeError
|
import TypeError
|
||||||
@ -122,10 +121,10 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
|
|||||||
do
|
do
|
||||||
(maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath)
|
(maybeInterface, maybeImpl) <- pure (lookupInterface ctx interface, lookupBinderInGlobalEnv ctx qpath)
|
||||||
case (maybeInterface, maybeImpl) of
|
case (maybeInterface, maybeImpl) of
|
||||||
(_, Nothing) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
|
(_, Left _) -> updateMeta (Meta.stub (contextualize path ctx)) ctx
|
||||||
(Nothing, Just implBinder) ->
|
(Left _, Right implBinder) ->
|
||||||
warn >> updateMeta implBinder ctx
|
warn >> updateMeta implBinder ctx
|
||||||
(Just interfaceBinder, Just implBinder) ->
|
(Right interfaceBinder, Right implBinder) ->
|
||||||
-- N.B. The found binding will be fully qualified!
|
-- N.B. The found binding will be fully qualified!
|
||||||
addToInterface interfaceBinder implBinder
|
addToInterface interfaceBinder implBinder
|
||||||
where
|
where
|
||||||
@ -134,7 +133,7 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
|
|||||||
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
warn = emitWarning (show (NonExistentInterfaceWarning x))
|
||||||
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
addToInterface :: Binder -> Binder -> IO (Context, Either EvalError XObj)
|
||||||
addToInterface inter impl =
|
addToInterface inter impl =
|
||||||
let (newCtx, maybeErr) = registerInInterface ctx impl inter
|
let (Right newCtx, maybeErr) = registerInInterface ctx impl inter
|
||||||
in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
|
in maybe (updateMeta impl newCtx) (handleError newCtx impl) maybeErr
|
||||||
handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
|
handleError :: Context -> Binder -> InterfaceError -> IO (Context, Either EvalError XObj)
|
||||||
handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
|
handleError context impl e@(AlreadyImplemented _ oldImplPath _ _) =
|
||||||
@ -143,9 +142,9 @@ primitiveImplements _ ctx x@(XObj (Sym interface@(SymPath _ _) _) _ _) (XObj (Sy
|
|||||||
emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
|
emitError (show e) >> pure (evalError context (show e) (xobjInfo x))
|
||||||
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
updateMeta :: Binder -> Context -> IO (Context, Either EvalError XObj)
|
||||||
updateMeta binder context =
|
updateMeta binder context =
|
||||||
pure (fromJust update, dynamicNil)
|
pure (fromRight (error "Couldn't insert updated meta!!") (fromJust updater), dynamicNil)
|
||||||
where
|
where
|
||||||
update =
|
updater =
|
||||||
( ( Meta.getBinderMetaValue "implements" binder
|
( ( Meta.getBinderMetaValue "implements" binder
|
||||||
<&> updateImplementations binder
|
<&> updateImplementations binder
|
||||||
)
|
)
|
||||||
@ -178,20 +177,22 @@ define hidden ctx qualifiedXObj =
|
|||||||
freshBinder = toBinder annXObj
|
freshBinder = toBinder annXObj
|
||||||
qpath = getQualifiedPath qualifiedXObj
|
qpath = getQualifiedPath qualifiedXObj
|
||||||
defineInTypeEnv :: Binder -> IO Context
|
defineInTypeEnv :: Binder -> IO Context
|
||||||
defineInTypeEnv = pure . (insertInTypeEnv ctx qpath)
|
defineInTypeEnv = pure . fromRight ctx . (insertTypeBinder ctx qpath)
|
||||||
defineInGlobalEnv :: Binder -> IO Context
|
defineInGlobalEnv :: Binder -> IO Context
|
||||||
defineInGlobalEnv newBinder =
|
defineInGlobalEnv newBinder =
|
||||||
when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj)))
|
when (projectEchoC (contextProj ctx)) (putStrLn (toC All (Binder emptyMeta annXObj)))
|
||||||
>> case (lookupBinderInGlobalEnv ctx qpath) of
|
>> case (lookupBinderInGlobalEnv ctx qpath) of
|
||||||
Nothing -> pure (insertInGlobalEnv ctx qpath newBinder)
|
Left _ -> pure (fromRight ctx (insertInGlobalEnv ctx qpath newBinder))
|
||||||
Just oldBinder -> redefineExistingBinder oldBinder newBinder
|
Right oldBinder -> redefineExistingBinder oldBinder newBinder
|
||||||
redefineExistingBinder :: Binder -> Binder -> IO Context
|
redefineExistingBinder :: Binder -> Binder -> IO Context
|
||||||
redefineExistingBinder old@(Binder meta _) (Binder _ x) =
|
redefineExistingBinder old@(Binder meta _) (Binder _ x) =
|
||||||
do
|
do
|
||||||
warnTypeChange old
|
unless (isInstantiation (binderXObj old)) (warnTypeChange old)
|
||||||
-- TODO: Merge meta more elegantly.
|
-- TODO: Merge meta more elegantly.
|
||||||
updatedContext <- (implementInterfaces (Binder meta x))
|
updatedContext <- (implementInterfaces (Binder meta x))
|
||||||
pure (insertInGlobalEnv updatedContext qpath (Binder meta x))
|
pure (fromRight (error ("Failed to insert " ++ show qpath)) (insertInGlobalEnv updatedContext qpath (Binder meta x)))
|
||||||
|
isInstantiation (XObj (Lst (XObj (Instantiate _) _ _ : _)) _ _) = True
|
||||||
|
isInstantiation _ = False
|
||||||
warnTypeChange :: Binder -> IO ()
|
warnTypeChange :: Binder -> IO ()
|
||||||
warnTypeChange binder =
|
warnTypeChange binder =
|
||||||
unless (areUnifiable (forceTy annXObj) previousType) warn
|
unless (areUnifiable (forceTy annXObj) previousType) warn
|
||||||
@ -208,9 +209,9 @@ define hidden ctx qualifiedXObj =
|
|||||||
>>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces)
|
>>= \(XObj (Lst interfaces) _ _) -> pure (map Qualified interfaces)
|
||||||
)
|
)
|
||||||
>>= \maybeinterfaces ->
|
>>= \maybeinterfaces ->
|
||||||
pure (mapMaybe (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces))
|
pure (rights (fmap (lookupBinderInTypeEnv ctx . getQualifiedPath) (fromMaybe [] maybeinterfaces)))
|
||||||
>>= \interfaceBinders ->
|
>>= \interfaceBinders ->
|
||||||
pure (foldl' (\(ctx', _) interface -> registerInInterface ctx' binder interface) (ctx, Nothing) interfaceBinders)
|
pure (foldl' (\(ctx', _) interface -> first (fromRight ctx') (registerInInterface ctx' binder interface)) (ctx, Nothing) interfaceBinders)
|
||||||
>>= \(newCtx, err) -> case err of
|
>>= \(newCtx, err) -> case err of
|
||||||
Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
|
Just e -> printError (contextExecMode ctx) (show e) >> pure ctx
|
||||||
Nothing -> pure newCtx
|
Nothing -> pure newCtx
|
||||||
@ -233,13 +234,17 @@ primitiveRegisterType _ ctx [x@(XObj (Sym (SymPath [] t) _) _ _), members] =
|
|||||||
primitiveRegisterTypeWithFields ctx x t Nothing members
|
primitiveRegisterTypeWithFields ctx x t Nothing members
|
||||||
primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
|
primitiveRegisterType x ctx _ = pure (toEvalError ctx x RegisterTypeError)
|
||||||
|
|
||||||
|
-- | Register an external type that has no fields.
|
||||||
primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
|
primitiveRegisterTypeWithoutFields :: Context -> String -> Maybe String -> IO (Context, Either EvalError XObj)
|
||||||
primitiveRegisterTypeWithoutFields ctx t override = do
|
primitiveRegisterTypeWithoutFields ctx t override = do
|
||||||
let path = SymPath [] t
|
let path = SymPath [] t
|
||||||
typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
||||||
-- TODO: Support registering types in modules
|
-- TODO: Support registering types in modules
|
||||||
pure (insertInTypeEnv ctx (markQualified path) (toBinder typeDefinition), dynamicNil)
|
case insertTypeBinder ctx (markQualified path) (toBinder typeDefinition) of
|
||||||
|
Left e -> pure (evalError ctx (show e) Nothing)
|
||||||
|
Right c -> pure (c, dynamicNil)
|
||||||
|
|
||||||
|
-- | Register an external type that has fields.
|
||||||
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
|
primitiveRegisterTypeWithFields :: Context -> XObj -> String -> Maybe String -> XObj -> IO (Context, Either EvalError XObj)
|
||||||
primitiveRegisterTypeWithFields ctx x t override members =
|
primitiveRegisterTypeWithFields ctx x t override members =
|
||||||
either
|
either
|
||||||
@ -252,46 +257,47 @@ primitiveRegisterTypeWithFields ctx x t override members =
|
|||||||
do
|
do
|
||||||
let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
let typeDefinition = XObj (Lst [XObj (ExternalType override) Nothing Nothing, XObj (Sym path Symbol) Nothing Nothing]) Nothing (Just TypeTy)
|
||||||
path' = (qualifyPath ctx (SymPath [] typeModuleName))
|
path' = (qualifyPath ctx (SymPath [] typeModuleName))
|
||||||
update = insertInTypeEnv' path' (toBinder typeDefinition) . insertInGlobalEnv' path' (toBinder typeModuleXObj)
|
update = \c -> insertInGlobalEnv' path' (toBinder typeModuleXObj) c >>= insertTypeBinder' path' (toBinder typeDefinition)
|
||||||
ctx' = update ctx
|
Right ctx' = update ctx
|
||||||
-- TODO: Another case where define does not get formally qualified deps!
|
-- TODO: Another case where define does not get formally qualified deps!
|
||||||
contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
|
contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
|
||||||
pure (contextWithDefs, dynamicNil)
|
pure (contextWithDefs, dynamicNil)
|
||||||
path = SymPath [] t
|
path = SymPath [] t
|
||||||
preExistingModule = case lookupBinderInGlobalEnv ctx path of
|
preExistingModule = case lookupBinderInGlobalEnv ctx path of
|
||||||
Just (Binder _ (XObj (Mod found) _ _)) -> Just found
|
Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
|
notFound :: Context -> XObj -> SymPath -> IO (Context, Either EvalError XObj)
|
||||||
notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
|
notFound ctx x path = pure (toEvalError ctx x (SymbolNotFoundError path))
|
||||||
|
|
||||||
|
-- | Get information about a binding.
|
||||||
primitiveInfo :: UnaryPrimitiveCallback
|
primitiveInfo :: UnaryPrimitiveCallback
|
||||||
primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ name) _) _ _) =
|
||||||
case path of
|
case path of
|
||||||
SymPath [] _ ->
|
SymPath [] _ ->
|
||||||
do
|
do
|
||||||
let found = lookupBinderInTypeEnv ctx path
|
let found = lookupBinderInTypeEnv ctx path
|
||||||
_ <- printIfFound found
|
_ <- printIfFound found
|
||||||
_ <- printInterfaceImplementationsOrAll found otherBindings
|
_ <- printInterfaceImplementationsOrAll found otherBindings
|
||||||
maybe (notFound ctx target path) (const ok) (found <|> fmap head otherBindings)
|
either (const (notFound ctx target path)) (const ok) (found <> fmap head otherBindings)
|
||||||
where
|
where
|
||||||
otherBindings =
|
otherBindings =
|
||||||
fmap (: []) (lookupBinderInContextEnv ctx path)
|
fmap (: []) (lookupBinderInContextEnv ctx path)
|
||||||
<|> multiLookupBinderEverywhere ctx path
|
<> (Right (lookupBinderEverywhere (contextGlobalEnv ctx) name))
|
||||||
_ ->
|
_ ->
|
||||||
do
|
do
|
||||||
let found = lookupBinderInTypeEnv ctx path
|
let found = lookupBinderInTypeEnv ctx path
|
||||||
let others = lookupBinderInContextEnv ctx path
|
let others = lookupBinderInContextEnv ctx path
|
||||||
_ <- printIfFound found
|
_ <- printIfFound found
|
||||||
_ <- maybe (pure ()) printer others
|
_ <- either (const (pure ())) printer others
|
||||||
maybe (notFound ctx target path) (const ok) (found <|> others)
|
either (const (notFound ctx target path)) (const ok) (found <> others)
|
||||||
where
|
where
|
||||||
ok :: IO (Context, Either EvalError XObj)
|
ok :: IO (Context, Either EvalError XObj)
|
||||||
ok = pure (ctx, dynamicNil)
|
ok = pure (ctx, dynamicNil)
|
||||||
printInterfaceImplementationsOrAll :: Maybe Binder -> Maybe [Binder] -> IO ()
|
printInterfaceImplementationsOrAll :: Either ContextError Binder -> Either ContextError [Binder] -> IO ()
|
||||||
printInterfaceImplementationsOrAll interface impls =
|
printInterfaceImplementationsOrAll interface impls =
|
||||||
maybe
|
either
|
||||||
(pure ())
|
(const (pure ()))
|
||||||
(foldM (\_ binder -> printer binder) ())
|
(foldM (\_ binder -> printer binder) ())
|
||||||
( ( interface
|
( ( interface
|
||||||
>>= \binder ->
|
>>= \binder ->
|
||||||
@ -302,7 +308,7 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
|||||||
fmap (filter (implementsInterface binder)) impls
|
fmap (filter (implementsInterface binder)) impls
|
||||||
_ -> impls
|
_ -> impls
|
||||||
)
|
)
|
||||||
<|> impls
|
<> impls
|
||||||
)
|
)
|
||||||
implementsInterface :: Binder -> Binder -> Bool
|
implementsInterface :: Binder -> Binder -> Bool
|
||||||
implementsInterface binder binder' =
|
implementsInterface binder binder' =
|
||||||
@ -310,8 +316,8 @@ primitiveInfo _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) =
|
|||||||
False
|
False
|
||||||
(\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls)
|
(\(XObj (Lst impls) _ _) -> getBinderPath binder `elem` map getPath impls)
|
||||||
(Meta.getBinderMetaValue "implements" binder')
|
(Meta.getBinderMetaValue "implements" binder')
|
||||||
printIfFound :: Maybe Binder -> IO ()
|
printIfFound :: Either ContextError Binder -> IO ()
|
||||||
printIfFound = maybe (pure ()) printer
|
printIfFound = either (const (pure ())) printer
|
||||||
printer :: Binder -> IO ()
|
printer :: Binder -> IO ()
|
||||||
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
|
printer binder@(Binder metaData x@(XObj _ (Just i) _)) =
|
||||||
putStrLnWithColor Blue (forceShowBinder binder)
|
putStrLnWithColor Blue (forceShowBinder binder)
|
||||||
@ -345,101 +351,63 @@ dynamicOrMacroWith :: Context -> (SymPath -> [XObj]) -> Ty -> String -> XObj ->
|
|||||||
dynamicOrMacroWith ctx producer ty name body = do
|
dynamicOrMacroWith ctx producer ty name body = do
|
||||||
let qpath = qualifyPath ctx (SymPath [] name)
|
let qpath = qualifyPath ctx (SymPath [] name)
|
||||||
elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty)
|
elt = XObj (Lst (producer (unqualify qpath))) (xobjInfo body) (Just ty)
|
||||||
meta = lookupMeta (getPath elt) (contextGlobalEnv ctx)
|
meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath elt))
|
||||||
pure (insertInGlobalEnv ctx qpath (Binder meta elt), dynamicNil)
|
pure
|
||||||
|
( case (insertInGlobalEnv ctx qpath (Binder meta elt)) of
|
||||||
|
Left e -> evalError ctx (show e) (xobjInfo body)
|
||||||
|
Right c -> (c, dynamicNil)
|
||||||
|
)
|
||||||
|
|
||||||
|
-- | Get the members of a type declaration.
|
||||||
primitiveMembers :: UnaryPrimitiveCallback
|
primitiveMembers :: UnaryPrimitiveCallback
|
||||||
primitiveMembers _ ctx target = do
|
primitiveMembers _ ctx xobj@(XObj (Sym path _) _ _) =
|
||||||
case bottomedTarget target of
|
case (lookupBinderInTypeEnv ctx path) of
|
||||||
XObj (Sym path@(SymPath _ name) _) _ _ ->
|
Left _ -> pure $ toEvalError ctx xobj (StructNotFound xobj)
|
||||||
case lookupBinderInTypeEnv ctx path of
|
Right b -> go (binderXObj b)
|
||||||
Just
|
|
||||||
( Binder
|
|
||||||
_
|
|
||||||
( XObj
|
|
||||||
( Lst
|
|
||||||
[ XObj (Deftype _) Nothing Nothing,
|
|
||||||
XObj (Sym (SymPath _ _) Symbol) Nothing Nothing,
|
|
||||||
XObj (Arr members) _ _
|
|
||||||
]
|
|
||||||
)
|
|
||||||
_
|
|
||||||
_
|
|
||||||
)
|
|
||||||
) ->
|
|
||||||
pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
|
|
||||||
Just
|
|
||||||
( Binder
|
|
||||||
_
|
|
||||||
( XObj
|
|
||||||
( Lst
|
|
||||||
( XObj (DefSumtype _) Nothing Nothing
|
|
||||||
: XObj (Sym (SymPath _ _) Symbol) Nothing Nothing
|
|
||||||
: sumtypeCases
|
|
||||||
)
|
|
||||||
)
|
|
||||||
_
|
|
||||||
_
|
|
||||||
)
|
|
||||||
) ->
|
|
||||||
pure (ctx, Right (XObj (Arr (concatMap getMembersFromCase sumtypeCases)) Nothing Nothing))
|
|
||||||
where
|
|
||||||
getMembersFromCase :: XObj -> [XObj]
|
|
||||||
getMembersFromCase (XObj (Lst members) _ _) =
|
|
||||||
map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members)
|
|
||||||
getMembersFromCase x@(XObj (Sym _ _) _ _) =
|
|
||||||
[XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
|
|
||||||
getMembersFromCase (XObj x _ _) =
|
|
||||||
error ("Can't handle case " ++ show x)
|
|
||||||
_ ->
|
|
||||||
pure (evalError ctx ("Can't find a struct type named '" ++ name ++ "' in type environment") (xobjInfo target))
|
|
||||||
_ -> pure (evalError ctx ("Can't get the members of non-symbol: " ++ pretty target) (xobjInfo target))
|
|
||||||
where
|
where
|
||||||
bottomedTarget t =
|
go :: XObj -> IO (Context, Either EvalError XObj)
|
||||||
case t of
|
go (XObj (Lst [(XObj (Deftype _) _ _), _, (XObj (Arr members) _ _)]) _ _) =
|
||||||
XObj (Sym targetPath _) _ _ ->
|
pure (ctx, Right (XObj (Arr (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))) Nothing Nothing))
|
||||||
case lookupBinderInContextEnv ctx targetPath of
|
go (XObj (Lst ((XObj (DefSumtype _) _ _) : _ : cases)) _ _) =
|
||||||
-- this is a trick: every type generates a module in the env;
|
pure $ (ctx, (either Left (\a -> Right (XObj (Arr (concat a)) Nothing Nothing)) (mapM getMembersFromCase cases)))
|
||||||
-- we’re special-casing here because we need the parent of the
|
go x = pure (toEvalError ctx x (NonTypeInTypeEnv path x))
|
||||||
-- module
|
|
||||||
Just (Binder _ (XObj (Mod _) _ _)) -> t
|
getMembersFromCase :: XObj -> Either EvalError [XObj]
|
||||||
-- if we’re recursing into a non-sym, we’ll stop one level down
|
getMembersFromCase (XObj (Lst members) _ _) =
|
||||||
Just (Binder _ x) -> bottomedTarget x
|
Right (map (\(a, b) -> XObj (Lst [a, b]) Nothing Nothing) (pairwise members))
|
||||||
_ -> target
|
getMembersFromCase x@(XObj (Sym _ _) _ _) =
|
||||||
_ -> target
|
Right [XObj (Lst [x, XObj (Arr []) Nothing Nothing]) Nothing Nothing]
|
||||||
|
getMembersFromCase x =
|
||||||
|
second (: []) (snd (toEvalError ctx x (PrimitiveError.InvalidSumtypeCase x)))
|
||||||
|
primitiveMembers _ ctx x = argumentErr ctx "members" "a symbol" "first" x
|
||||||
|
|
||||||
-- | Set meta data for a Binder
|
-- | Set meta data for a Binder
|
||||||
|
--
|
||||||
|
-- Permits "forward-declaration": if the binder doesn't exist, it creates a
|
||||||
|
-- "meta stub" for the binder with the meta information.
|
||||||
primitiveMetaSet :: TernaryPrimitiveCallback
|
primitiveMetaSet :: TernaryPrimitiveCallback
|
||||||
primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath prefixes _) _) _ _) (XObj (Str key) _ _) value =
|
primitiveMetaSet _ ctx target@(XObj (Sym path@(SymPath _ _) _) _ _) (XObj (Str key) _ _) value =
|
||||||
pure $ maybe create (,dynamicNil) lookupAndUpdate
|
pure $ either (const create) (,dynamicNil) (lookupGlobal <> lookupType)
|
||||||
where
|
where
|
||||||
qpath = qualifyPath ctx path
|
qpath = qualifyPath ctx path
|
||||||
fullPath@(SymPath modules _) = unqualify qpath
|
lookupGlobal :: Either ContextError Context
|
||||||
lookupAndUpdate :: Maybe Context
|
lookupGlobal =
|
||||||
lookupAndUpdate =
|
lookupBinderInGlobalEnv ctx path
|
||||||
( lookupBinderInGlobalEnv ctx path
|
>>= \binder ->
|
||||||
>>= \binder ->
|
pure (Meta.updateBinderMeta binder key value)
|
||||||
pure (Meta.updateBinderMeta binder key value)
|
>>= insertInGlobalEnv ctx qpath
|
||||||
>>= pure . (insertInGlobalEnv ctx qpath)
|
lookupType :: Either ContextError Context
|
||||||
)
|
lookupType =
|
||||||
-- This is a global name but it doesn't exist in the global env
|
lookupBinderInTypeEnv ctx qpath
|
||||||
-- Before creating a new binder, check that it doesn't denote an existing type or interface.
|
>>= \binder ->
|
||||||
<|> if null modules
|
pure (Meta.updateBinderMeta binder key value)
|
||||||
then
|
>>= insertTypeBinder ctx qpath
|
||||||
lookupBinderInTypeEnv ctx qpath
|
|
||||||
>>= \binder ->
|
|
||||||
pure (Meta.updateBinderMeta binder key value)
|
|
||||||
>>= pure . (insertInTypeEnv ctx qpath)
|
|
||||||
else Nothing
|
|
||||||
create :: (Context, Either EvalError XObj)
|
create :: (Context, Either EvalError XObj)
|
||||||
create =
|
create =
|
||||||
-- TODO: Remove the special casing here (null check) and throw a general
|
let updated = Meta.updateBinderMeta (Meta.stub (unqualify qpath)) key value
|
||||||
-- error when modules don't exist
|
in case (insertInGlobalEnv ctx qpath updated) of
|
||||||
if null prefixes
|
Left e -> toEvalError ctx target (MetaSetFailed target (show e))
|
||||||
then
|
Right c -> (c, dynamicNil)
|
||||||
let updated = Meta.updateBinderMeta (Meta.stub fullPath) key value
|
|
||||||
in (insertInGlobalEnv ctx qpath updated, dynamicNil)
|
|
||||||
else evalError ctx ("`meta-set!` failed, I can't find the symbol `" ++ pretty target ++ "`") (xobjInfo target)
|
|
||||||
primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ =
|
primitiveMetaSet _ ctx (XObj (Sym (SymPath _ _) _) _ _) key _ =
|
||||||
argumentErr ctx "meta-set!" "a string" "second" key
|
argumentErr ctx "meta-set!" "a string" "second" key
|
||||||
primitiveMetaSet _ ctx target _ _ =
|
primitiveMetaSet _ ctx target _ _ =
|
||||||
@ -450,13 +418,13 @@ primitiveDefinterface xobj ctx nameXObj@(XObj (Sym path@(SymPath [] name) _) _ _
|
|||||||
pure $ maybe invalidType validType (xobjToTy ty)
|
pure $ maybe invalidType validType (xobjToTy ty)
|
||||||
where
|
where
|
||||||
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
|
invalidType = evalError ctx ("Invalid type for interface `" ++ name ++ "`: " ++ pretty ty) (xobjInfo ty)
|
||||||
validType t = maybe defInterface updateInterface (lookupBinderInTypeEnv ctx path)
|
validType t = either (const defInterface) updateInterface (lookupBinderInTypeEnv ctx path)
|
||||||
where
|
where
|
||||||
defInterface =
|
defInterface =
|
||||||
let interface = defineInterface name t [] (xobjInfo nameXObj)
|
let interface = defineInterface name t [] (xobjInfo nameXObj)
|
||||||
binder = toBinder interface
|
binder = toBinder interface
|
||||||
ctx' = insertInTypeEnv ctx (markQualified (SymPath [] name)) binder
|
Right ctx' = insertTypeBinder ctx (markQualified (SymPath [] name)) binder
|
||||||
newCtx = retroactivelyRegisterInInterface ctx' binder
|
Right newCtx = retroactivelyRegisterInInterface ctx' binder
|
||||||
in (newCtx, dynamicNil)
|
in (newCtx, dynamicNil)
|
||||||
updateInterface binder = case binder of
|
updateInterface binder = case binder of
|
||||||
Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
|
Binder _ (XObj (Lst (XObj (Interface foundType _) _ _ : _)) _ _) ->
|
||||||
@ -502,8 +470,10 @@ registerInternal ctx name ty override =
|
|||||||
)
|
)
|
||||||
(xobjInfo ty)
|
(xobjInfo ty)
|
||||||
(Just t)
|
(Just t)
|
||||||
meta = lookupMeta (getPath registration) (contextGlobalEnv ctx)
|
meta = fromRight emptyMeta (lookupMeta (contextGlobalEnv ctx) (getPath registration))
|
||||||
in (insertInGlobalEnv ctx qpath (Binder meta registration), dynamicNil)
|
in case (insertInGlobalEnv ctx qpath (Binder meta registration)) of
|
||||||
|
Left err -> evalError ctx (show err) (xobjInfo ty)
|
||||||
|
Right c -> (c, dynamicNil)
|
||||||
|
|
||||||
primitiveRegister :: VariadicPrimitiveCallback
|
primitiveRegister :: VariadicPrimitiveCallback
|
||||||
primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] =
|
primitiveRegister _ ctx [XObj (Sym (SymPath [] name) _) _ _, ty] =
|
||||||
@ -549,147 +519,158 @@ primitiveRegister x ctx _ =
|
|||||||
)
|
)
|
||||||
|
|
||||||
primitiveDeftype :: VariadicPrimitiveCallback
|
primitiveDeftype :: VariadicPrimitiveCallback
|
||||||
primitiveDeftype xobj ctx (name : rest) =
|
primitiveDeftype xobj ctx (name : rest@(XObj (Arr a) _ _ : _)) =
|
||||||
case rest of
|
case members a of
|
||||||
(XObj (Arr a) _ _ : _) ->
|
Nothing -> pure (toEvalError ctx xobj BadDeftypeMembers)
|
||||||
case members a of
|
Just ms -> ensureUnqualified (map fst ms)
|
||||||
Nothing ->
|
|
||||||
pure $
|
|
||||||
makeEvalError
|
|
||||||
ctx
|
|
||||||
Nothing
|
|
||||||
( "All fields must have a name and a type."
|
|
||||||
++ "Example:\n"
|
|
||||||
++ "```(deftype Name [field1 Type1, field2 Type2, field3 Type3])```\n"
|
|
||||||
)
|
|
||||||
(xobjInfo xobj)
|
|
||||||
Just ms ->
|
|
||||||
ensureUnqualified $ map fst ms
|
|
||||||
where
|
|
||||||
members :: [XObj] -> Maybe [(XObj, XObj)]
|
|
||||||
members (binding : val : xs) = do
|
|
||||||
xs' <- members xs
|
|
||||||
Just $ (binding, val) : xs'
|
|
||||||
members [_] = Nothing
|
|
||||||
members [] = Just []
|
|
||||||
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
|
|
||||||
ensureUnqualified objs =
|
|
||||||
if all isUnqualifiedSym objs
|
|
||||||
then deftype name
|
|
||||||
else
|
|
||||||
pure $
|
|
||||||
makeEvalError
|
|
||||||
ctx
|
|
||||||
Nothing
|
|
||||||
( "Type members must be unqualified symbols, but got `"
|
|
||||||
++ concatMap pretty rest
|
|
||||||
++ "`"
|
|
||||||
)
|
|
||||||
(xobjInfo xobj)
|
|
||||||
_ -> deftype name
|
|
||||||
where
|
where
|
||||||
deftype nm@(XObj (Sym (SymPath _ ty) _) _ _) = deftype' nm ty []
|
members :: [XObj] -> Maybe [(XObj, XObj)]
|
||||||
deftype (XObj (Lst (nm@(XObj (Sym (SymPath _ ty) _) _ _) : tyvars)) _ _) =
|
members [] = Just []
|
||||||
deftype' nm ty tyvars
|
members [_] = Nothing
|
||||||
deftype nm =
|
members (binding : val : xs) = members xs >>= \xs' -> pure $ (binding, val) : xs'
|
||||||
pure
|
ensureUnqualified :: [XObj] -> IO (Context, Either EvalError XObj)
|
||||||
( evalError
|
ensureUnqualified objs =
|
||||||
ctx
|
if all isUnqualifiedSym objs
|
||||||
("Invalid name for type definition: " ++ pretty nm)
|
then deftype ctx name (selectConstructor rest)
|
||||||
(xobjInfo nm)
|
else pure (toEvalError ctx xobj (QualifiedTypeMember rest))
|
||||||
)
|
primitiveDeftype _ ctx (name : rest) =
|
||||||
deftype' :: XObj -> String -> [XObj] -> IO (Context, Either EvalError XObj)
|
deftype ctx name (selectConstructor rest)
|
||||||
deftype' nameXObj typeName typeVariableXObjs = do
|
|
||||||
let pathStrings = contextPath ctx
|
|
||||||
env = contextGlobalEnv ctx
|
|
||||||
innerEnv = contextInternalEnv ctx
|
|
||||||
typeEnv = contextTypeEnv ctx
|
|
||||||
typeVariables = mapM xobjToTy typeVariableXObjs
|
|
||||||
(preExistingModule, preExistingMeta) =
|
|
||||||
case lookupBinder (SymPath pathStrings typeName) (fromMaybe env innerEnv) {envParent = Nothing} of
|
|
||||||
Just (Binder meta (XObj (Mod found) _ _)) -> (Just found, meta)
|
|
||||||
Just (Binder meta _) -> (Nothing, meta)
|
|
||||||
_ -> (Nothing, emptyMeta)
|
|
||||||
(creatorFunction, typeConstructor) =
|
|
||||||
if length rest == 1 && isArray (head rest)
|
|
||||||
then (moduleForDeftype, Deftype)
|
|
||||||
else (moduleForSumtype, DefSumtype)
|
|
||||||
case (nameXObj, typeVariables) of
|
|
||||||
(XObj (Sym (SymPath _ tyName) _) i _, Just okTypeVariables) ->
|
|
||||||
case creatorFunction (Just (getEnv env pathStrings)) typeEnv env pathStrings tyName okTypeVariables rest i preExistingModule of
|
|
||||||
Right (typeModuleName, typeModuleXObj, deps) ->
|
|
||||||
let structTy = StructTy (ConcreteNameTy (createStructName pathStrings tyName)) okTypeVariables
|
|
||||||
updatedGlobal = insertInGlobalEnv ctx (qualifyPath ctx (SymPath [] typeModuleName)) (Binder preExistingMeta typeModuleXObj)
|
|
||||||
typeDefinition =
|
|
||||||
-- NOTE: The type binding is needed to emit the type definition and all the member functions of the type.
|
|
||||||
XObj
|
|
||||||
( Lst
|
|
||||||
( XObj (typeConstructor structTy) Nothing Nothing :
|
|
||||||
XObj (Sym (SymPath pathStrings tyName) Symbol) Nothing Nothing :
|
|
||||||
rest
|
|
||||||
)
|
|
||||||
)
|
|
||||||
i
|
|
||||||
(Just TypeTy)
|
|
||||||
holderEnv name' prev = Env (Map.fromList []) (Just prev) (Just name') Set.empty ExternalEnv 0
|
|
||||||
holderModule name'' prevEnv priorPaths tyenv =
|
|
||||||
case lookupBinder (SymPath priorPaths name'') tyenv of
|
|
||||||
Just existing@(Binder _ (XObj (Mod _) _ _)) -> existing
|
|
||||||
_ -> Binder emptyMeta (XObj (Mod (holderEnv name'' prevEnv)) (Just dummyInfo) (Just ModuleTy))
|
|
||||||
folder (contx, prev, priorPaths) pathstring =
|
|
||||||
(insertInTypeEnv contx (markQualified (SymPath priorPaths pathstring)) (holderModule pathstring prev priorPaths (getTypeEnv (contextTypeEnv contx))), holderEnv pathstring prev, priorPaths ++ [pathstring])
|
|
||||||
(wHolders, _, _) = (foldl' folder (ctx, getTypeEnv typeEnv, []) pathStrings)
|
|
||||||
update = insertInTypeEnv' (markQualified (SymPath pathStrings tyName)) (toBinder typeDefinition) . replaceGlobalEnv' (contextGlobalEnv updatedGlobal)
|
|
||||||
ctx' = update wHolders
|
|
||||||
in do
|
|
||||||
-- TODO: !This is a case where `define` doesn't actually receive fully qualified xobjs.
|
|
||||||
ctxWithDeps <- liftIO (foldM (define True) ctx' (map Qualified deps))
|
|
||||||
let fakeImplBinder sympath t = Binder emptyMeta (XObj (Sym sympath Symbol) (Just dummyInfo) (Just t))
|
|
||||||
deleteSig = FuncTy [structTy] UnitTy StaticLifetimeTy
|
|
||||||
strSig = FuncTy [RefTy structTy (VarTy "q")] StringTy StaticLifetimeTy
|
|
||||||
copySig = FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy
|
|
||||||
Just deleteInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "delete"))
|
|
||||||
Just strInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "str"))
|
|
||||||
Just copyInterface = lookupBinderInTypeEnv ctx (markQualified (SymPath [] "copy"))
|
|
||||||
modulePath = SymPath (pathStrings ++ [typeModuleName])
|
|
||||||
(ctxWithInterfaceRegistrations, err) =
|
|
||||||
-- Since these functions are autogenerated, we treat them as a special case
|
|
||||||
-- and automatically implement the interfaces.
|
|
||||||
foldl'
|
|
||||||
(\(context, _) (path, sig, interface) -> registerInInterfaceIfNeeded context path interface sig)
|
|
||||||
(ctxWithDeps, Nothing)
|
|
||||||
[ (fakeImplBinder (modulePath "delete") deleteSig, deleteSig, deleteInterface),
|
|
||||||
(fakeImplBinder (modulePath "str") strSig, strSig, strInterface),
|
|
||||||
(fakeImplBinder (modulePath "copy") copySig, copySig, copyInterface)
|
|
||||||
]
|
|
||||||
case err of
|
|
||||||
Just e@AlreadyImplemented {} ->
|
|
||||||
emitWarning (show e)
|
|
||||||
>> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
|
||||||
Just e ->
|
|
||||||
putStrLnWithColor Red (show e)
|
|
||||||
>> pure (ctx, dynamicNil)
|
|
||||||
Nothing -> pure (ctxWithInterfaceRegistrations, dynamicNil)
|
|
||||||
Left err ->
|
|
||||||
pure (makeEvalError ctx (Just err) ("Invalid type definition for '" ++ pretty nameXObj ++ "':\n\n" ++ show err) Nothing)
|
|
||||||
(_, Nothing) ->
|
|
||||||
pure (makeEvalError ctx Nothing ("Invalid type variables for type definition: " ++ pretty nameXObj) (xobjInfo nameXObj))
|
|
||||||
_ -> error "primitiveDeftype1"
|
|
||||||
primitiveDeftype _ _ _ = error "primitivedeftype"
|
primitiveDeftype _ _ _ = error "primitivedeftype"
|
||||||
|
|
||||||
|
type ModuleCreator = Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
|
||||||
|
|
||||||
|
-- | Build an XObj representing the constructor of a type in Carp.
|
||||||
|
selectConstructor :: [XObj] -> (Ty -> (XObj, [XObj], ModuleCreator))
|
||||||
|
selectConstructor xs =
|
||||||
|
let (constructor, creator, mems) =
|
||||||
|
if length xs == 1 && isArray (head xs)
|
||||||
|
then (Deftype, moduleForDeftypeInContext, xs)
|
||||||
|
else (DefSumtype, moduleForSumtypeInContext, xs)
|
||||||
|
in \t ->
|
||||||
|
( XObj
|
||||||
|
( Lst
|
||||||
|
( XObj (constructor t) Nothing Nothing :
|
||||||
|
XObj (Sym (getStructPath t) Symbol) Nothing Nothing :
|
||||||
|
mems
|
||||||
|
)
|
||||||
|
)
|
||||||
|
Nothing
|
||||||
|
(Just TypeTy),
|
||||||
|
mems,
|
||||||
|
creator
|
||||||
|
)
|
||||||
|
|
||||||
|
deftype :: Context -> XObj -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError XObj)
|
||||||
|
deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
|
||||||
|
do
|
||||||
|
(ctxWithType, e) <- (makeType ctx name [] constructor)
|
||||||
|
case e of
|
||||||
|
Left err -> pure (evalError ctx (show err) (xobjInfo x))
|
||||||
|
Right t -> autoDerive ctxWithType t
|
||||||
|
deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
|
||||||
|
do
|
||||||
|
(ctxWithType, e) <-
|
||||||
|
( either
|
||||||
|
(\s -> pure (evalError ctx s Nothing))
|
||||||
|
(\vars -> makeType ctx name vars constructor)
|
||||||
|
(maybe (Left (show (InvalidTypeVariables x))) Right (checkVariables tyvars))
|
||||||
|
)
|
||||||
|
case e of
|
||||||
|
Left err -> pure (evalError ctx (show err) (xobjInfo x))
|
||||||
|
Right t -> autoDerive ctxWithType t
|
||||||
|
deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)
|
||||||
|
|
||||||
|
checkVariables :: [XObj] -> Maybe [Ty]
|
||||||
|
checkVariables vars = mapM xobjToTy vars
|
||||||
|
|
||||||
|
makeType :: Context -> String -> [Ty] -> (Ty -> (XObj, [XObj], ModuleCreator)) -> IO (Context, Either EvalError Ty)
|
||||||
|
makeType ctx name vars constructor =
|
||||||
|
let qpath = (qualifyPath ctx (SymPath [] name))
|
||||||
|
ty = StructTy (ConcreteNameTy (unqualify qpath)) vars
|
||||||
|
(typeX, members, creator) = constructor ty
|
||||||
|
in case ( unwrapErr (creator ctx name vars members Nothing)
|
||||||
|
>>= \(_, modx, deps) ->
|
||||||
|
pure (existingOr ctx qpath modx)
|
||||||
|
>>= \mod' ->
|
||||||
|
unwrapErr (insertType ctx qpath (toBinder typeX) mod')
|
||||||
|
>>= \c -> pure (foldM (define True) c (map Qualified deps))
|
||||||
|
) of
|
||||||
|
Left e -> pure (evalError ctx e (xobjInfo typeX))
|
||||||
|
Right result -> (result >>= \ctx' -> pure (ctx', pure ty))
|
||||||
|
where
|
||||||
|
existingOr :: Context -> QualifiedPath -> XObj -> Binder
|
||||||
|
existingOr c q x@(XObj (Mod e _) _ _) =
|
||||||
|
case ((lookupBinderInInternalEnv c q) <> (lookupBinderInGlobalEnv c q)) of
|
||||||
|
Right (Binder meta (XObj (Mod ve te) ii tt)) ->
|
||||||
|
(Binder meta (XObj (Mod (e <> ve) te) ii tt))
|
||||||
|
_ -> (toBinder x)
|
||||||
|
existingOr _ _ x = (toBinder x)
|
||||||
|
|
||||||
|
-- | Automatically derive implementations of interfaces.
|
||||||
|
autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj)
|
||||||
|
autoDerive c ty =
|
||||||
|
let (SymPath mods tyname) = (getStructPath ty)
|
||||||
|
implBinder :: String -> Ty -> Binder
|
||||||
|
implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t))
|
||||||
|
getSig :: String -> Ty
|
||||||
|
getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy
|
||||||
|
getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
|
||||||
|
getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy
|
||||||
|
getSig _ = VarTy "z"
|
||||||
|
interfaces =
|
||||||
|
[ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")),
|
||||||
|
lookupBinderInTypeEnv c (markQualified (SymPath [] "str")),
|
||||||
|
lookupBinderInTypeEnv c (markQualified (SymPath [] "copy"))
|
||||||
|
]
|
||||||
|
registration interface =
|
||||||
|
let name = getSimpleName (binderXObj interface)
|
||||||
|
sig = getSig name
|
||||||
|
in (implBinder name sig, sig, interface)
|
||||||
|
derives =
|
||||||
|
(sequence interfaces)
|
||||||
|
>>= \binders -> pure (fmap registration binders)
|
||||||
|
in case derives of
|
||||||
|
Left _ -> pure (evalError c "Couldn't derive interfaces." Nothing)
|
||||||
|
Right regs ->
|
||||||
|
case foldl' (\(context, _) (path, sig, interface) -> first (fromRight (error "COULDNT DERIVE!")) (registerInInterfaceIfNeeded context path interface sig)) (c, Nothing) regs of
|
||||||
|
(ci, Just err@AlreadyImplemented {}) -> emitWarning (show err) >> pure (ci, dynamicNil :: Either EvalError XObj)
|
||||||
|
(_, Just err) -> pure $ evalError c (show err) Nothing
|
||||||
|
(ci, Nothing) -> pure (ci, dynamicNil :: Either EvalError XObj)
|
||||||
|
|
||||||
|
-- | Add a module to the list of implicitly imported modules.
|
||||||
primitiveUse :: UnaryPrimitiveCallback
|
primitiveUse :: UnaryPrimitiveCallback
|
||||||
primitiveUse xobj ctx (XObj (Sym path _) _ _) =
|
primitiveUse xobj ctx (XObj (Sym path _) _ _) =
|
||||||
pure $ maybe lookupInGlobal useModule (lookupInEnv path e)
|
let modulePath = fromStrings (contextPath ctx)
|
||||||
|
contextualized = (consPath (contextPath ctx) path)
|
||||||
|
global = (contextGlobalEnv ctx)
|
||||||
|
-- Look up the module to see if we can actually use it.
|
||||||
|
-- The reference might be contextual, if so, append the current context path strings.
|
||||||
|
path' = case (searchValueBinder global path) of
|
||||||
|
Right _ -> path
|
||||||
|
_ -> contextualized
|
||||||
|
in pure
|
||||||
|
( case modulePath of
|
||||||
|
(SymPath [] "") -> updateGlobalUsePaths global path'
|
||||||
|
_ -> case searchValueBinder global modulePath of
|
||||||
|
Left err -> (evalError ctx (show err) (xobjInfo xobj))
|
||||||
|
Right binder ->
|
||||||
|
updateModuleUsePaths global modulePath binder path'
|
||||||
|
)
|
||||||
where
|
where
|
||||||
pathStrings = contextPath ctx
|
updateGlobalUsePaths :: Env -> SymPath -> (Context, Either EvalError XObj)
|
||||||
env = contextGlobalEnv ctx
|
updateGlobalUsePaths e spath =
|
||||||
e = getEnv env pathStrings
|
((replaceGlobalEnv ctx (addUsePath e spath)), dynamicNil)
|
||||||
useThese = envUseModules e
|
|
||||||
e' = e {envUseModules = Set.insert path useThese}
|
updateModuleUsePaths :: Env -> SymPath -> Binder -> SymPath -> (Context, Either EvalError XObj)
|
||||||
lookupInGlobal = maybe missing useModule (lookupInEnv path env)
|
updateModuleUsePaths e p (Binder meta (XObj (Mod ev et) i t)) spath =
|
||||||
where
|
either
|
||||||
missing = evalError ctx ("Can't find a module named '" ++ show path ++ "'") (xobjInfo xobj)
|
(\err -> (evalError ctx err (xobjInfo xobj)))
|
||||||
useModule _ = (replaceGlobalEnv ctx (envReplaceEnvAt env pathStrings e'), dynamicNil)
|
(\newCtx -> (newCtx, dynamicNil))
|
||||||
|
( (unwrapErr (insert e p (Binder meta (XObj (Mod (addUsePath ev spath) et) i t))))
|
||||||
|
>>= pure . replaceGlobalEnv ctx
|
||||||
|
)
|
||||||
|
updateModuleUsePaths _ _ _ _ =
|
||||||
|
(evalError ctx "Context path pointed to non-module!" (xobjInfo xobj))
|
||||||
primitiveUse _ ctx x =
|
primitiveUse _ ctx x =
|
||||||
argumentErr ctx "use" "a symbol" "first" x
|
argumentErr ctx "use" "a symbol" "first" x
|
||||||
|
|
||||||
@ -699,7 +680,7 @@ primitiveMeta (XObj _ i _) ctx (XObj (Sym path _) _ _) (XObj (Str key) _ _) =
|
|||||||
pure $ maybe errNotFound foundBinder lookup'
|
pure $ maybe errNotFound foundBinder lookup'
|
||||||
where
|
where
|
||||||
lookup' :: Maybe Binder
|
lookup' :: Maybe Binder
|
||||||
lookup' = (lookupBinderInGlobalEnv ctx path <|> lookupBinderInTypeEnv ctx path) >>= pure
|
lookup' = either (const Nothing) Just (lookupBinderInGlobalEnv ctx path <> lookupBinderInTypeEnv ctx path)
|
||||||
foundBinder :: Binder -> (Context, Either EvalError XObj)
|
foundBinder :: Binder -> (Context, Either EvalError XObj)
|
||||||
foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
|
foundBinder binder = (ctx, maybe dynamicNil Right (Meta.getBinderMetaValue key binder))
|
||||||
errNotFound :: (Context, Either EvalError XObj)
|
errNotFound :: (Context, Either EvalError XObj)
|
||||||
@ -711,14 +692,14 @@ primitiveMeta _ ctx path _ =
|
|||||||
|
|
||||||
primitiveDefined :: UnaryPrimitiveCallback
|
primitiveDefined :: UnaryPrimitiveCallback
|
||||||
primitiveDefined _ ctx (XObj (Sym path _) _ _) =
|
primitiveDefined _ ctx (XObj (Sym path _) _ _) =
|
||||||
pure $ maybe (ctx, Right falseXObj) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path)
|
pure $ either (const (ctx, Right falseXObj)) (const (ctx, Right trueXObj)) (lookupBinderInContextEnv ctx path)
|
||||||
primitiveDefined _ ctx arg =
|
primitiveDefined _ ctx arg =
|
||||||
argumentErr ctx "defined" "a symbol" "first" arg
|
argumentErr ctx "defined" "a symbol" "first" arg
|
||||||
|
|
||||||
primitiveDeftemplate :: QuaternaryPrimitiveCallback
|
primitiveDeftemplate :: QuaternaryPrimitiveCallback
|
||||||
-- deftemplate can't receive a dependency function, as Ty aren't exposed in Carp
|
-- deftemplate can't receive a dependency function, as Ty aren't exposed in Carp
|
||||||
primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) =
|
primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str declTempl) _ _) (XObj (Str defTempl) _ _) =
|
||||||
pure $ maybe invalidType validType (xobjToTy ty)
|
pure $ maybe invalidType (fromRight invalidType . fmap (\x -> (x, dynamicNil)) . validType) (xobjToTy ty)
|
||||||
where
|
where
|
||||||
typeEnv = contextTypeEnv ctx
|
typeEnv = contextTypeEnv ctx
|
||||||
globalEnv = contextGlobalEnv ctx
|
globalEnv = contextGlobalEnv ctx
|
||||||
@ -728,13 +709,13 @@ primitiveDeftemplate _ ctx (XObj (Sym p@(SymPath [] _) _) _ _) ty (XObj (Str dec
|
|||||||
if isTypeGeneric t
|
if isTypeGeneric t
|
||||||
then
|
then
|
||||||
let (Binder _ registration) = b
|
let (Binder _ registration) = b
|
||||||
meta = lookupMeta (getPath registration) globalEnv
|
meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
|
||||||
in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
|
in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
|
||||||
else
|
else
|
||||||
let templateCreator = getTemplateCreator template
|
let templateCreator = getTemplateCreator template
|
||||||
(registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv)
|
(registration, _) = instantiateTemplate (contextualize p ctx) t (templateCreator typeEnv globalEnv)
|
||||||
meta = lookupMeta (getPath registration) globalEnv
|
meta = fromRight emptyMeta (lookupMeta globalEnv (getPath registration))
|
||||||
in (insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration), dynamicNil)
|
in insertInGlobalEnv ctx (qualifyPath ctx p) (Binder meta registration)
|
||||||
_ -> error "primitivedeftemplate1"
|
_ -> error "primitivedeftemplate1"
|
||||||
primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x =
|
primitiveDeftemplate _ ctx (XObj (Sym (SymPath [] _) _) _ _) _ (XObj (Str _) _ _) x =
|
||||||
argumentErr ctx "deftemplate" "a string" "fourth" x
|
argumentErr ctx "deftemplate" "a string" "fourth" x
|
||||||
@ -754,10 +735,10 @@ primitiveType _ ctx (XObj _ _ (Just Universe)) =
|
|||||||
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
|
pure (ctx, Right (XObj (Lst []) Nothing Nothing))
|
||||||
primitiveType _ ctx (XObj _ _ (Just TypeTy)) = liftIO $ pure (ctx, Right $ reify TypeTy)
|
primitiveType _ ctx (XObj _ _ (Just TypeTy)) = liftIO $ pure (ctx, Right $ reify TypeTy)
|
||||||
primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
|
primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
|
||||||
maybe otherDefs go (lookupBinderInGlobalEnv ctx path)
|
fromRight otherDefs (second go (lookupBinderInGlobalEnv ctx path))
|
||||||
where
|
where
|
||||||
env = contextGlobalEnv ctx
|
env = contextGlobalEnv ctx
|
||||||
otherDefs = case multiLookupEverywhere name env of
|
otherDefs = case lookupEverywhere env name of
|
||||||
[] ->
|
[] ->
|
||||||
notFound ctx x path
|
notFound ctx x path
|
||||||
binders ->
|
binders ->
|
||||||
@ -771,7 +752,7 @@ primitiveType _ ctx x@(XObj (Sym path@(SymPath [] name) _) _ _) =
|
|||||||
Nothing -> noTypeError ctx x
|
Nothing -> noTypeError ctx x
|
||||||
Just t -> pure (ctx, Right (reify t))
|
Just t -> pure (ctx, Right (reify t))
|
||||||
primitiveType _ ctx x@(XObj (Sym qualifiedPath _) _ _) =
|
primitiveType _ ctx x@(XObj (Sym qualifiedPath _) _ _) =
|
||||||
maybe (notFound ctx x qualifiedPath) go (lookupBinderInGlobalEnv ctx qualifiedPath)
|
fromRight (notFound ctx x qualifiedPath) (second go (lookupBinderInGlobalEnv ctx qualifiedPath))
|
||||||
where
|
where
|
||||||
go binder =
|
go binder =
|
||||||
case xobjTy (binderXObj binder) of
|
case xobjTy (binderXObj binder) of
|
||||||
|
277
src/Qualify.hs
277
src/Qualify.hs
@ -1,3 +1,5 @@
|
|||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Defines data, errors, and functions for qualifying symbols in a given
|
-- | Defines data, errors, and functions for qualifying symbols in a given
|
||||||
@ -16,15 +18,14 @@ module Qualify
|
|||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad (foldM, liftM)
|
import Control.Monad (foldM, liftM)
|
||||||
import Data.List (foldl')
|
import Data.Bifunctor
|
||||||
import Debug.Trace
|
import Data.Either (fromRight)
|
||||||
import Env
|
import qualified Env as E
|
||||||
import Info
|
import Info
|
||||||
import Lookup
|
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
import qualified Set
|
||||||
import Types
|
import SymPath
|
||||||
import Util
|
import Util
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
@ -35,6 +36,11 @@ data QualificationError
|
|||||||
= FailedToQualifyDeclarationName XObj
|
= FailedToQualifyDeclarationName XObj
|
||||||
| FailedToQualifySymbols XObj
|
| FailedToQualifySymbols XObj
|
||||||
| FailedToQualifyPath SymPath
|
| FailedToQualifyPath SymPath
|
||||||
|
| NonVariableInMatch XObj
|
||||||
|
| NakedInitForUnnamedModule [String]
|
||||||
|
| QualifiedMulti SymPath
|
||||||
|
| LocalMulti SymPath [(Env, Binder)]
|
||||||
|
| FailedToFindSymbol XObj
|
||||||
|
|
||||||
instance Show QualificationError where
|
instance Show QualificationError where
|
||||||
show (FailedToQualifyDeclarationName xobj) =
|
show (FailedToQualifyDeclarationName xobj) =
|
||||||
@ -44,6 +50,18 @@ instance Show QualificationError where
|
|||||||
show (FailedToQualifyPath spath) =
|
show (FailedToQualifyPath spath) =
|
||||||
"Couldn't fully qualify the symbol: " ++ show spath
|
"Couldn't fully qualify the symbol: " ++ show spath
|
||||||
++ "in the given context."
|
++ "in the given context."
|
||||||
|
show (NonVariableInMatch xobj) =
|
||||||
|
"Couldn't qualify the xobj: " ++ pretty xobj
|
||||||
|
++ "in a match expression."
|
||||||
|
show (NakedInitForUnnamedModule s) =
|
||||||
|
"Tried to emit a naked init for an unnamed module: " ++ (show s)
|
||||||
|
show (QualifiedMulti spath) =
|
||||||
|
"Tried to use a qualified symbol as a multi sym: " ++ (show spath)
|
||||||
|
show (LocalMulti spath binders) =
|
||||||
|
"Tried to use a symbol that has local bindings as a multi sym: " ++ show spath
|
||||||
|
++ show binders
|
||||||
|
show (FailedToFindSymbol xobj) =
|
||||||
|
"Couldn't find the xobj: " ++ pretty xobj
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Data
|
-- Data
|
||||||
@ -52,7 +70,7 @@ instance Show QualificationError where
|
|||||||
--
|
--
|
||||||
-- A fully qualified xobj **must not** be qualified further (e.g. using context
|
-- A fully qualified xobj **must not** be qualified further (e.g. using context
|
||||||
-- paths).
|
-- paths).
|
||||||
newtype Qualified = Qualified {unQualified :: XObj}
|
newtype Qualified = Qualified {unQualified :: XObj} deriving (Show)
|
||||||
|
|
||||||
-- | Denotes a symbol that has been fully qualified.
|
-- | Denotes a symbol that has been fully qualified.
|
||||||
newtype QualifiedPath = QualifiedPath SymPath
|
newtype QualifiedPath = QualifiedPath SymPath
|
||||||
@ -115,10 +133,10 @@ qualify ctx xobj@(XObj obj info ty) =
|
|||||||
-- TODO: Merge this with setFullyQualifiedSymbols
|
-- TODO: Merge this with setFullyQualifiedSymbols
|
||||||
case obj of
|
case obj of
|
||||||
Lst [defn, (XObj (Sym (SymPath _ name) mode) symi symt), args, body] ->
|
Lst [defn, (XObj (Sym (SymPath _ name) mode) symi symt), args, body] ->
|
||||||
setFullyQualifiedSymbols t g i (XObj (Lst [defn, (XObj (Sym (SymPath pathStrings name) mode) symi symt), args, body]) info ty)
|
inner >>= \i -> setFullyQualifiedSymbols t g i (XObj (Lst [defn, (XObj (Sym (SymPath pathStrings name) mode) symi symt), args, body]) info ty)
|
||||||
Lst [def, XObj (Sym (SymPath _ name) mode) symi symt, expr] ->
|
Lst [def, XObj (Sym (SymPath _ name) mode) symi symt, expr] ->
|
||||||
setFullyQualifiedSymbols t g i (XObj (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty)
|
inner >>= \i -> setFullyQualifiedSymbols t g i (XObj (Lst [def, (XObj (Sym (SymPath pathStrings name) mode) symi symt), expr]) info ty)
|
||||||
_ -> setFullyQualifiedSymbols t g i xobj
|
_ -> inner >>= \i -> setFullyQualifiedSymbols t g i xobj
|
||||||
where
|
where
|
||||||
pathStrings :: [String]
|
pathStrings :: [String]
|
||||||
pathStrings = contextPath ctx
|
pathStrings = contextPath ctx
|
||||||
@ -126,8 +144,8 @@ qualify ctx xobj@(XObj obj info ty) =
|
|||||||
t = contextTypeEnv ctx
|
t = contextTypeEnv ctx
|
||||||
g :: Env
|
g :: Env
|
||||||
g = contextGlobalEnv ctx
|
g = contextGlobalEnv ctx
|
||||||
i :: Env
|
inner :: Either QualificationError Env
|
||||||
i = getEnv g pathStrings
|
inner = replaceLeft (FailedToQualifySymbols xobj) (E.getInnerEnv g pathStrings)
|
||||||
|
|
||||||
-- | Changes all symbols EXCEPT bound vars (defn names, variable names, etc) to their fully qualified paths.
|
-- | Changes all symbols EXCEPT bound vars (defn names, variable names, etc) to their fully qualified paths.
|
||||||
-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment.
|
-- | This must run after the 'setFullyQualifiedDefn' function has fixed the paths of all bindings in the environment.
|
||||||
@ -176,29 +194,32 @@ type Qualifier = TypeEnv -> Env -> Env -> XObj -> Either QualificationError Qual
|
|||||||
|
|
||||||
-- | Qualify the symbols in a Defn form's body.
|
-- | Qualify the symbols in a Defn form's body.
|
||||||
qualifyFunctionDefinition :: Qualifier
|
qualifyFunctionDefinition :: Qualifier
|
||||||
qualifyFunctionDefinition typeEnv globalEnv env (XObj (Lst [defn@(XObj (Defn _) _ _), sym@(XObj (Sym (SymPath _ functionName) _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
qualifyFunctionDefinition typeEnv globalEnv env x@(XObj (Lst [defn@(XObj (Defn _) _ _), sym@(XObj (Sym (SymPath _ functionName) _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
||||||
-- For self-recursion, there must be a binding to the function in the inner env.
|
-- For self-recursion, there must be a binding to the function in the inner env.
|
||||||
-- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup.
|
-- It is marked as RecursionEnv basically is the same thing as external to not mess up lookup.
|
||||||
-- Inside the recursion env is the function env that contains bindings for the arguments of the function.
|
-- Inside the recursion env is the function env that contains bindings for the arguments of the function.
|
||||||
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
|
-- Note: These inner envs is ephemeral since they are not stored in a module or global scope.
|
||||||
do
|
do
|
||||||
let recursionEnv = Env Map.empty (Just env) (Just (functionName ++ "-recurse-env")) Set.empty RecursionEnv 0
|
recursionEnv <- fixLeft (pure (E.recursive (Just env) (Just (functionName ++ "-recurse-env")) 0))
|
||||||
envWithSelf = extendEnv recursionEnv functionName sym
|
envWithSelf <- fixLeft (E.insertX recursionEnv (SymPath [] functionName) sym)
|
||||||
functionEnv = Env Map.empty (Just envWithSelf) Nothing Set.empty InternalEnv 0
|
-- Copy the use modules from the local env to ensure they are available from the function env.
|
||||||
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
|
functionEnv <- fixLeft (pure ((E.nested (Just envWithSelf) (Just (functionName ++ "-function-env")) 0) {envUseModules = (envUseModules env)}))
|
||||||
|
envWithArgs <- fixLeft (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr)
|
||||||
qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
||||||
pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t))
|
pure (Qualified (XObj (Lst [defn, sym, args, qualifiedBody]) i t))
|
||||||
|
where
|
||||||
|
fixLeft = replaceLeft (FailedToQualifyDeclarationName x)
|
||||||
qualifyFunctionDefinition _ _ _ xobj = Left $ FailedToQualifyDeclarationName xobj
|
qualifyFunctionDefinition _ _ _ xobj = Left $ FailedToQualifyDeclarationName xobj
|
||||||
|
|
||||||
-- | Qualify the symbols in a lambda body.
|
-- | Qualify the symbols in a lambda body.
|
||||||
qualifyLambda :: Qualifier
|
qualifyLambda :: Qualifier
|
||||||
qualifyLambda typeEnv globalEnv env (XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
qualifyLambda typeEnv globalEnv env x@(XObj (Lst [fn@(XObj (Fn _ _) _ _), args@(XObj (Arr argsArr) _ _), body]) i t) =
|
||||||
do
|
let lvl = envFunctionNestingLevel env
|
||||||
let lvl = envFunctionNestingLevel env
|
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1)
|
||||||
functionEnv = Env Map.empty (Just env) Nothing Set.empty InternalEnv (lvl + 1)
|
in (replaceLeft (FailedToQualifySymbols x) (foldM (\e arg@(XObj (Sym path _) _ _) -> E.insertX e path arg) functionEnv argsArr))
|
||||||
envWithArgs = foldl' (\e arg@(XObj (Sym (SymPath _ argSymName) _) _ _) -> extendEnv e argSymName arg) functionEnv argsArr
|
>>= \envWithArgs ->
|
||||||
qualifiedBody <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv envWithArgs body)
|
||||||
pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
|
>>= \qualifiedBody -> pure (Qualified (XObj (Lst [fn, args, qualifiedBody]) i t))
|
||||||
qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
qualifyLambda _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||||
|
|
||||||
-- | Qualify the symbols in a The form's body.
|
-- | Qualify the symbols in a The form's body.
|
||||||
@ -219,7 +240,7 @@ qualifyDef _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
|||||||
|
|
||||||
-- | Qualify the symbols in a Let form's bindings and body.
|
-- | Qualify the symbols in a Let form's bindings and body.
|
||||||
qualifyLet :: Qualifier
|
qualifyLet :: Qualifier
|
||||||
qualifyLet typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t)
|
qualifyLet typeEnv globalEnv env x@(XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj (Arr bindings) bindi bindt), body]) i t)
|
||||||
| odd (length bindings) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
|
| odd (length bindings) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
|
||||||
| not (all isSym (evenIndices bindings)) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
|
| not (all isSym (evenIndices bindings)) = Right $ Qualified $ XObj (Lst [letExpr, bind, body]) i t -- Leave it untouched for the compiler to find the error.
|
||||||
| otherwise =
|
| otherwise =
|
||||||
@ -232,17 +253,19 @@ qualifyLet typeEnv globalEnv env (XObj (Lst [letExpr@(XObj Let _ _), bind@(XObj
|
|||||||
pure (Qualified (XObj (Lst [letExpr, XObj (Arr qualifiedBindings) bindi bindt, qualifiedBody]) i t))
|
pure (Qualified (XObj (Lst [letExpr, XObj (Arr qualifiedBindings) bindi bindt, qualifiedBody]) i t))
|
||||||
where
|
where
|
||||||
qualifyBinding :: (Env, [XObj]) -> (XObj, XObj) -> Either QualificationError (Env, [XObj])
|
qualifyBinding :: (Env, [XObj]) -> (XObj, XObj) -> Either QualificationError (Env, [XObj])
|
||||||
qualifyBinding (e, bs) (s@(XObj (Sym (SymPath _ binderName) _) _ _), o) =
|
qualifyBinding (e, bs) (s@(XObj (Sym path _) _ _), o) =
|
||||||
do
|
do
|
||||||
qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o)
|
qualified <- liftM unQualified (setFullyQualifiedSymbols typeEnv globalEnv e o)
|
||||||
(pure (extendEnv e binderName s, bs ++ [s, qualified]))
|
updated <- (replaceLeft (FailedToQualifySymbols x) (E.insertX e path s))
|
||||||
|
(pure (updated, bs ++ [s, qualified]))
|
||||||
qualifyBinding _ _ = error "bad let binding"
|
qualifyBinding _ _ = error "bad let binding"
|
||||||
qualifyLet _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
qualifyLet _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||||
|
|
||||||
-- | Qualify symbols in a Match form.
|
-- | Qualify symbols in a Match form.
|
||||||
qualifyMatch :: Qualifier
|
qualifyMatch :: Qualifier
|
||||||
qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : casesXObjs)) i t)
|
qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) : expr : casesXObjs)) i t)
|
||||||
| odd (length casesXObjs) = pure $ Qualified $ XObj (Lst (matchExpr : expr : casesXObjs)) i t -- Leave it untouched for the compiler to find the error.
|
-- Leave it untouched for the compiler to find the error.
|
||||||
|
| odd (length casesXObjs) = pure $ Qualified $ XObj (Lst (matchExpr : expr : casesXObjs)) i t
|
||||||
| otherwise =
|
| otherwise =
|
||||||
do
|
do
|
||||||
qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr
|
qualifiedExpr <- pure . unQualified =<< setFullyQualifiedSymbols typeEnv globalEnv env expr
|
||||||
@ -251,26 +274,33 @@ qualifyMatch typeEnv globalEnv env (XObj (Lst (matchExpr@(XObj (Match _) _ _) :
|
|||||||
where
|
where
|
||||||
Just ii = i
|
Just ii = i
|
||||||
lvl = envFunctionNestingLevel env
|
lvl = envFunctionNestingLevel env
|
||||||
|
-- Create an inner environment for each case.
|
||||||
innerEnv :: Env
|
innerEnv :: Env
|
||||||
innerEnv = Env Map.empty (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) Set.empty InternalEnv lvl
|
innerEnv = E.nested (Just env) (Just ("case-env-" ++ show (infoIdentifier ii))) lvl
|
||||||
|
-- Qualify each case in the match form.
|
||||||
qualifyCases :: (XObj, XObj) -> Either QualificationError [Qualified]
|
qualifyCases :: (XObj, XObj) -> Either QualificationError [Qualified]
|
||||||
qualifyCases (l@(XObj (Lst (_ : xs)) _ _), r) =
|
qualifyCases (l@(XObj (Lst (_ : xs)) _ _), r) =
|
||||||
do
|
do
|
||||||
let innerEnv' = foldl' foldVars innerEnv xs
|
innerEnv' <- foldM foldVars innerEnv xs
|
||||||
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
|
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' l
|
||||||
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
|
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv innerEnv' r
|
||||||
Right [qualifiedLHS, qualifiedRHS]
|
Right [qualifiedLHS, qualifiedRHS]
|
||||||
|
qualifyCases (wild@(XObj (Sym (SymPath _ "_") _) _ _), r) =
|
||||||
|
do
|
||||||
|
qualifiedLHS <- foldVars env wild >>= \e -> setFullyQualifiedSymbols typeEnv globalEnv e wild
|
||||||
|
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r
|
||||||
|
Right [qualifiedLHS, qualifiedRHS]
|
||||||
qualifyCases (l, r) =
|
qualifyCases (l, r) =
|
||||||
do
|
do
|
||||||
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
|
qualifiedLHS <- setFullyQualifiedSymbols typeEnv globalEnv env l
|
||||||
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r
|
qualifiedRHS <- setFullyQualifiedSymbols typeEnv globalEnv env r
|
||||||
Right [qualifiedLHS, qualifiedRHS]
|
Right [qualifiedLHS, qualifiedRHS]
|
||||||
foldVars :: Env -> XObj -> Env
|
-- Add variables in a case to its environment
|
||||||
foldVars env' v@(XObj (Sym (SymPath _ binderName) _) _ _) = extendEnv env' binderName v
|
foldVars :: Env -> XObj -> Either QualificationError Env
|
||||||
-- Nested sumtypes
|
foldVars env' v@(XObj (Sym path _) _ _) = (replaceLeft (FailedToQualifySymbols v) (E.insertX env' path v))
|
||||||
-- fold recursively -- is there a more efficient way?
|
-- Nested sumtypes; fold recursively -- is there a more efficient way?
|
||||||
foldVars _ (XObj (Lst (_ : ys)) _ _) = foldl' foldVars innerEnv ys
|
foldVars _ (XObj (Lst (_ : ys)) _ _) = foldM foldVars innerEnv ys
|
||||||
foldVars _ v = error ("Can't match variable with " ++ show v)
|
foldVars _ v = Left $ NonVariableInMatch v
|
||||||
qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
qualifyMatch _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||||
|
|
||||||
-- | Qualify symbols in a With form.
|
-- | Qualify symbols in a With form.
|
||||||
@ -291,104 +321,93 @@ qualifyLst typeEnv globalEnv env (XObj (Lst xobjs) i t) =
|
|||||||
qualifyLst _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
qualifyLst _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||||
|
|
||||||
-- | Qualify a single symbol.
|
-- | Qualify a single symbol.
|
||||||
-- TODO: Clean this up
|
|
||||||
qualifySym :: Qualifier
|
qualifySym :: Qualifier
|
||||||
qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path _) i t) =
|
-- Unqualified path.
|
||||||
Right $
|
qualifySym typeEnv globalEnv localEnv xobj@(XObj (Sym path@(SymPath _ name) _) i t) =
|
||||||
Qualified $
|
( ( ( replaceLeft
|
||||||
case path of
|
(FailedToFindSymbol xobj)
|
||||||
-- Unqualified:
|
-- TODO: Why do we need getValue here? We should be able to restrict this
|
||||||
SymPath [] name ->
|
-- search only to direct children of the type environment, but this causes
|
||||||
case lookupBinder path (getTypeEnv typeEnv) of
|
-- errors.
|
||||||
Just (Binder _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _)) ->
|
( fmap (\(e, b) -> ((E.prj typeEnv), (E.prj e, b))) (E.searchType typeEnv path)
|
||||||
-- Found an interface with the same path!
|
<> fmap (localEnv,) (E.searchValue localEnv path)
|
||||||
-- Have to ensure it's not a local variable with the same name as the interface
|
<> fmap (globalEnv,) (E.searchValue globalEnv path)
|
||||||
case lookupInEnv path localEnv of
|
)
|
||||||
Just (foundEnv, _) ->
|
)
|
||||||
if envIsExternal foundEnv
|
>>= \(origin, (e, binder)) ->
|
||||||
then createInterfaceSym name
|
resolve (E.prj origin) (E.prj e) (binderXObj binder)
|
||||||
else doesNotBelongToAnInterface False localEnv
|
>>= pure . Qualified
|
||||||
Nothing ->
|
)
|
||||||
--trace ("Will turn '" ++ show path ++ "' " ++ prettyInfoFromXObj xobj ++ " into an interface symbol.")
|
<> ((resolveMulti path (E.lookupInUsed localEnv globalEnv path)) >>= pure . Qualified)
|
||||||
createInterfaceSym name
|
<> ((replaceLeft (FailedToFindSymbol xobj) (E.lookupContextually globalEnv path)) >>= (resolveMulti path) >>= pure . Qualified)
|
||||||
_ ->
|
<> ((resolveMulti path (E.lookupEverywhere globalEnv name)) >>= pure . Qualified)
|
||||||
doesNotBelongToAnInterface False localEnv
|
<> pure (Qualified xobj)
|
||||||
-- Qualified:
|
)
|
||||||
_ ->
|
|
||||||
doesNotBelongToAnInterface False localEnv
|
|
||||||
where
|
where
|
||||||
createInterfaceSym name =
|
resolve :: Env -> Env -> XObj -> Either QualificationError XObj
|
||||||
XObj (InterfaceSym name) i t
|
resolve _ _ (XObj (Lst (XObj (Interface _ _) _ _ : _)) _ _) =
|
||||||
captureOrNot foundEnv =
|
-- Before we return an interface, double check that it isn't shadowed by a local let-binding.
|
||||||
if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
|
case (E.searchValue localEnv path) of
|
||||||
then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
|
Right (e, Binder _ _) ->
|
||||||
else NoCapture
|
case envMode e of
|
||||||
doesNotBelongToAnInterface :: Bool -> Env -> XObj
|
InternalEnv -> pure (XObj (Sym (getPath xobj) (LookupLocal (captureOrNot e localEnv))) i t)
|
||||||
doesNotBelongToAnInterface finalRecurse theEnv =
|
_ -> pure (XObj (InterfaceSym name) i t)
|
||||||
let results = multiLookupQualified path theEnv
|
_ -> pure (XObj (InterfaceSym name) i t)
|
||||||
results' = removeThoseShadowedByRecursiveSymbol results
|
resolve _ _ x@(XObj (Lst (XObj (External (Just overrideName)) _ _ : _)) _ _) =
|
||||||
in case results' of
|
pure (XObj (Sym (getPath x) (LookupGlobalOverride overrideName)) i t)
|
||||||
[] -> case envParent theEnv of
|
resolve _ _ (XObj (Mod modenv _) _ _) =
|
||||||
Just p ->
|
nakedInit modenv
|
||||||
doesNotBelongToAnInterface False p
|
resolve origin found xobj' =
|
||||||
Nothing ->
|
if (isTypeDef xobj')
|
||||||
-- OBS! The environment with no parent is the global env but it's an old one without the latest bindings!
|
then
|
||||||
if finalRecurse
|
( (replaceLeft (FailedToFindSymbol xobj') (fmap (globalEnv,) (E.searchValue globalEnv path)))
|
||||||
then xobj -- This was the TRUE global env, stop here and leave 'xobj' as is.
|
>>= \(origin', (e', binder)) -> resolve (E.prj origin') (E.prj e') (binderXObj binder)
|
||||||
else doesNotBelongToAnInterface True globalEnv
|
)
|
||||||
[(_, Binder _ foundOne@(XObj (Lst (XObj (External (Just overrideWithName)) _ _ : _)) _ _))] ->
|
else case envMode (E.prj found) of
|
||||||
XObj (Sym (getPath foundOne) (LookupGlobalOverride overrideWithName)) i t
|
RecursionEnv -> pure (XObj (Sym (getPath xobj') LookupRecursive) i t)
|
||||||
[(e, Binder _ (XObj (Mod modEnv) _ _))] ->
|
InternalEnv -> pure (XObj (Sym (getPath xobj') (LookupLocal (captureOrNot found origin))) i t)
|
||||||
-- Lookup of a "naked" module name means that the Carp code is trying to
|
ExternalEnv -> pure (XObj (Sym (getPath xobj') (LookupGlobal (if isExternalFunction xobj' then ExternalCode else CarpLand) (definitionMode xobj'))) i t)
|
||||||
-- instantiate a (nested) module with an implicit .init, e.g. (Pair 1 2)
|
resolveMulti :: (Show e, E.Environment e) => SymPath -> [(e, Binder)] -> Either QualificationError XObj
|
||||||
case envModuleName modEnv of
|
resolveMulti _ [] =
|
||||||
Nothing -> error ("Can't get name from unqualified module path: " ++ show path)
|
Left (FailedToFindSymbol xobj)
|
||||||
Just name ->
|
resolveMulti _ [(e, b)] =
|
||||||
let pathHere = pathToEnv e
|
resolve (E.prj e) (E.prj e) (binderXObj b)
|
||||||
in XObj (Sym (SymPath (pathHere ++ [name]) "init") (LookupGlobal CarpLand AFunction)) i t
|
resolveMulti spath xs =
|
||||||
[(e, Binder _ foundOne)] ->
|
let localOnly = remove (E.envIsExternal . fst) xs
|
||||||
case envMode e of
|
paths = map (getModuleSym . (second binderXObj)) xs
|
||||||
ExternalEnv ->
|
in case localOnly of
|
||||||
XObj
|
[] -> case spath of
|
||||||
( Sym
|
(SymPath [] _) ->
|
||||||
(getPath foundOne)
|
Right $ XObj (MultiSym name paths) i t
|
||||||
(LookupGlobal (if isExternalFunction foundOne then ExternalCode else CarpLand) (definitionMode foundOne))
|
_ -> Left (QualifiedMulti spath)
|
||||||
)
|
ys -> Left (LocalMulti spath (map (first E.prj) ys))
|
||||||
i
|
nakedInit :: Env -> Either QualificationError XObj
|
||||||
t
|
nakedInit e =
|
||||||
RecursionEnv -> XObj (Sym (getPath foundOne) LookupRecursive) i t
|
maybe
|
||||||
_ ->
|
(Left (NakedInitForUnnamedModule (pathToEnv e)))
|
||||||
--trace ("\nLOCAL variable " ++ show (getPath foundOne) ++ ":\n" ++ prettyEnvironmentChain e) $
|
(Right . id)
|
||||||
XObj (Sym (getPath foundOne) (LookupLocal (captureOrNot e))) i t
|
( envModuleName e
|
||||||
multiple ->
|
>>= \name' ->
|
||||||
case filter (not . envIsExternal . fst) multiple of
|
pure (XObj (Sym (SymPath ((init (pathToEnv e)) ++ [name']) "init") (LookupGlobal CarpLand AFunction)) i t)
|
||||||
-- There is at least one local binding, use the path of that one:
|
)
|
||||||
(e, Binder _ local) : _ -> XObj (Sym (getPath local) (LookupLocal (captureOrNot e))) i t
|
getModuleSym (_, x) =
|
||||||
-- There are no local bindings, this is allowed to become a multi lookup symbol:
|
case x of
|
||||||
[] ->
|
XObj (Mod ev _) _ _ ->
|
||||||
-- (trace $ "Turned " ++ show path ++ " into multisym: " ++ joinWithComma (map (show . (\(e, b) -> (getPath (binderXObj b), safeEnvModuleName e, envMode e))) multiple)) $
|
fromRight
|
||||||
case path of
|
(SymPath (init (pathToEnv ev)) name)
|
||||||
(SymPath [] name) ->
|
( (replaceLeft (FailedToFindSymbol x) (E.searchType globalEnv (SymPath (init (pathToEnv ev)) name)))
|
||||||
-- Create a MultiSym!
|
>> (fmap getPath (nakedInit ev))
|
||||||
XObj (MultiSym name (map (getPath . binderXObj . snd) multiple)) i t
|
|
||||||
pathWithQualifiers ->
|
|
||||||
-- The symbol IS qualified but can't be found, should produce an error later during compilation.
|
|
||||||
trace ("PROBLEMATIC: " ++ show path) (XObj (Sym pathWithQualifiers (LookupGlobal CarpLand AFunction)) i t)
|
|
||||||
removeThoseShadowedByRecursiveSymbol :: [(Env, Binder)] -> [(Env, Binder)]
|
|
||||||
removeThoseShadowedByRecursiveSymbol allBinders = visit allBinders allBinders
|
|
||||||
where
|
|
||||||
visit bs res =
|
|
||||||
foldl'
|
|
||||||
( \result b ->
|
|
||||||
case b of
|
|
||||||
(Env {envMode = RecursionEnv}, Binder _ xobj') ->
|
|
||||||
remove (\(_, Binder _ x) -> xobj' /= x && getName xobj' == getName x) result
|
|
||||||
_ -> result
|
|
||||||
)
|
)
|
||||||
res
|
_ -> (getPath x)
|
||||||
bs
|
|
||||||
qualifySym _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
qualifySym _ _ _ xobj = Left $ FailedToQualifySymbols xobj
|
||||||
|
|
||||||
|
-- | Determine whether or not this symbol is captured in a local environment (closures).
|
||||||
|
captureOrNot :: Env -> Env -> CaptureMode
|
||||||
|
captureOrNot foundEnv localEnv =
|
||||||
|
if envFunctionNestingLevel foundEnv < envFunctionNestingLevel localEnv
|
||||||
|
then Capture (envFunctionNestingLevel localEnv - envFunctionNestingLevel foundEnv)
|
||||||
|
else NoCapture
|
||||||
|
|
||||||
-- | Qualify an Arr form.
|
-- | Qualify an Arr form.
|
||||||
qualifyArr :: Qualifier
|
qualifyArr :: Qualifier
|
||||||
qualifyArr typeEnv globalEnv env (XObj (Arr array) i t) =
|
qualifyArr typeEnv globalEnv env (XObj (Arr array) i t) =
|
||||||
|
@ -40,6 +40,7 @@ instance Reifiable Ty where
|
|||||||
reify (FuncTy ats rt lt) = XObj (Lst [literal "Fn", array ats, reify rt, lifetime lt]) Nothing (Just TypeTy)
|
reify (FuncTy ats rt lt) = XObj (Lst [literal "Fn", array ats, reify rt, lifetime lt]) Nothing (Just TypeTy)
|
||||||
reify TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe)
|
reify TypeTy = XObj (Sym (SymPath [] (show TypeTy)) Symbol) Nothing (Just Universe)
|
||||||
reify UnitTy = XObj (Sym (SymPath [] "Unit") Symbol) Nothing (Just TypeTy)
|
reify UnitTy = XObj (Sym (SymPath [] "Unit") Symbol) Nothing (Just TypeTy)
|
||||||
|
reify (ConcreteNameTy path) = XObj (Sym path Symbol) Nothing (Just TypeTy)
|
||||||
reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
|
reify t = XObj (Sym (SymPath [] (show t)) Symbol) Nothing (Just TypeTy)
|
||||||
|
|
||||||
instance Reifiable String where
|
instance Reifiable String where
|
||||||
|
@ -52,7 +52,7 @@ saveDocsForEnvs ctx pathsAndEnvBinders =
|
|||||||
getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
|
getEnvAndMetaFromBinder :: Binder -> (Env, MetaData)
|
||||||
getEnvAndMetaFromBinder envBinder =
|
getEnvAndMetaFromBinder envBinder =
|
||||||
case envBinder of
|
case envBinder of
|
||||||
Binder meta (XObj (Mod env) _ _) -> (env, meta)
|
Binder meta (XObj (Mod env _) _ _) -> (env, meta)
|
||||||
_ -> error "Binder's not a module. This should be detected in 'commandSaveDocsInternal'."
|
_ -> error "Binder's not a module. This should be detected in 'commandSaveDocsInternal'."
|
||||||
|
|
||||||
projectIndexPage :: Project -> [String] -> String
|
projectIndexPage :: Project -> [String] -> String
|
||||||
|
@ -1,7 +1,7 @@
|
|||||||
module Scoring (scoreTypeBinder, scoreValueBinder) where
|
module Scoring (scoreTypeBinder, scoreValueBinder) where
|
||||||
|
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Lookup
|
import Env as E
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
import qualified Set
|
||||||
import Types
|
import Types
|
||||||
@ -24,15 +24,12 @@ scoreTypeBinder typeEnv b@(Binder _ (XObj (Lst (XObj x _ _ : XObj (Sym _ _) _ _
|
|||||||
ExternalType _ -> (0, b)
|
ExternalType _ -> (0, b)
|
||||||
_ -> (500, b)
|
_ -> (500, b)
|
||||||
where
|
where
|
||||||
depthOfStruct (StructTy (ConcreteNameTy structName) varTys) =
|
depthOfStruct (StructTy (ConcreteNameTy (SymPath _ name)) varTys) =
|
||||||
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
|
case E.getTypeBinder typeEnv name of
|
||||||
Just (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
Right (Binder _ typedef) -> (depthOfDeftype typeEnv Set.empty typedef varTys + 1, b)
|
||||||
Nothing -> error ("Can't find user defined type '" ++ structName ++ "' in type env.")
|
Left e -> error (show e)
|
||||||
where
|
|
||||||
lookupPath = getPathFromStructName structName
|
|
||||||
name = getNameFromStructName structName
|
|
||||||
depthOfStruct _ = error "depthofstruct"
|
depthOfStruct _ = error "depthofstruct"
|
||||||
scoreTypeBinder _ b@(Binder _ (XObj (Mod _) _ _)) =
|
scoreTypeBinder _ b@(Binder _ (XObj (Mod _ _) _ _)) =
|
||||||
(1000, b)
|
(1000, b)
|
||||||
scoreTypeBinder _ x = error ("Can't score: " ++ show x)
|
scoreTypeBinder _ x = error ("Can't score: " ++ show x)
|
||||||
|
|
||||||
@ -79,17 +76,19 @@ depthOfType typeEnv visited selfName theType =
|
|||||||
_
|
_
|
||||||
| tyToC struct == selfName -> 1
|
| tyToC struct == selfName -> 1
|
||||||
| otherwise ->
|
| otherwise ->
|
||||||
case lookupBinder (SymPath lookupPath s) (getTypeEnv typeEnv) of
|
case E.getTypeBinder typeEnv s of
|
||||||
Just (Binder _ typedef) -> moduleDepth + depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
Right (Binder _ typedef) -> depthOfDeftype typeEnv (Set.insert theType visited) typedef varTys
|
||||||
where
|
Left _ ->
|
||||||
moduleDepth = length lookupPath * 1000 -- modules have score 1000
|
|
||||||
Nothing ->
|
|
||||||
--trace ("Unknown type: " ++ name) $
|
--trace ("Unknown type: " ++ name) $
|
||||||
depthOfVarTys -- The problem here is that generic types don't generate
|
-- Two problems here:
|
||||||
-- their definition in time so we get nothing for those.
|
--
|
||||||
-- Instead, let's try the type vars.
|
-- 1. generic types don't generate their definition in time
|
||||||
|
-- so we get nothing for those. Instead, let's try the type
|
||||||
|
-- vars.
|
||||||
|
-- 2. If a type wasn't found type may also refer to a type defined in another
|
||||||
|
-- module that's not yet been scored. To be safe, add 500
|
||||||
|
500 + depthOfVarTys
|
||||||
where
|
where
|
||||||
lookupPath = getPathFromStructName (getStructName struct)
|
|
||||||
s = getNameFromStructName (getStructName struct)
|
s = getNameFromStructName (getStructName struct)
|
||||||
depthOfVarTys =
|
depthOfVarTys =
|
||||||
case fmap (depthOfType typeEnv visited (getStructName struct)) varTys of
|
case fmap (depthOfType typeEnv visited (getStructName struct)) varTys of
|
||||||
@ -121,12 +120,12 @@ scoreBody globalEnv visited = visit
|
|||||||
(Sym path (LookupGlobal _ _)) ->
|
(Sym path (LookupGlobal _ _)) ->
|
||||||
if Set.member path visited
|
if Set.member path visited
|
||||||
then 0
|
then 0
|
||||||
else case lookupBinder path globalEnv of
|
else case E.searchValueBinder globalEnv path of
|
||||||
Just foundBinder ->
|
Right foundBinder ->
|
||||||
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
|
let (score, _) = scoreValueBinder globalEnv (Set.insert path visited) foundBinder
|
||||||
in score + 1
|
in score + 1
|
||||||
Nothing ->
|
Left e ->
|
||||||
error ("Failed to lookup '" ++ show path ++ "'.")
|
error (show e)
|
||||||
_ -> 0
|
_ -> 0
|
||||||
visitList (XObj (Lst []) _ _) =
|
visitList (XObj (Lst []) _ _) =
|
||||||
0
|
0
|
||||||
|
@ -2,6 +2,7 @@ module StartingEnv where
|
|||||||
|
|
||||||
import qualified ArrayTemplates
|
import qualified ArrayTemplates
|
||||||
import Commands
|
import Commands
|
||||||
|
import qualified Env as E
|
||||||
import Eval
|
import Eval
|
||||||
import Info
|
import Info
|
||||||
import qualified Map
|
import qualified Map
|
||||||
@ -123,7 +124,7 @@ functionModule =
|
|||||||
where
|
where
|
||||||
bindEnv env =
|
bindEnv env =
|
||||||
let Just name = envModuleName env
|
let Just name = envModuleName env
|
||||||
in (name, Binder emptyMeta (XObj (Mod env) Nothing Nothing))
|
in (name, Binder emptyMeta (XObj (Mod env E.empty) Nothing Nothing))
|
||||||
bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity])
|
bindings = Map.fromList (map (bindEnv . generateInnerFunctionModule) [0 .. maxArity])
|
||||||
|
|
||||||
-- | Each arity of functions need their own module to enable copying and string representation
|
-- | Each arity of functions need their own module to enable copying and string representation
|
||||||
@ -329,10 +330,10 @@ dynamicModule =
|
|||||||
f "help" primitiveHelp "prints help." "(help)"
|
f "help" primitiveHelp "prints help." "(help)"
|
||||||
]
|
]
|
||||||
mods =
|
mods =
|
||||||
[ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule) Nothing Nothing)),
|
[ ("String", Binder emptyMeta (XObj (Mod dynamicStringModule E.empty) Nothing Nothing)),
|
||||||
("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule) Nothing Nothing)),
|
("Symbol", Binder emptyMeta (XObj (Mod dynamicSymModule E.empty) Nothing Nothing)),
|
||||||
("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule) Nothing Nothing)),
|
("Project", Binder emptyMeta (XObj (Mod dynamicProjectModule E.empty) Nothing Nothing)),
|
||||||
("Path", Binder emptyMeta (XObj (Mod dynamicPathModule) Nothing Nothing))
|
("Path", Binder emptyMeta (XObj (Mod dynamicPathModule E.empty) Nothing Nothing))
|
||||||
]
|
]
|
||||||
|
|
||||||
-- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
|
-- | A submodule of the Dynamic module. Contains functions for working with strings in the repl or during compilation.
|
||||||
@ -494,12 +495,12 @@ startingGlobalEnv noArray =
|
|||||||
makeSymbol "deref" "" "" Deref,
|
makeSymbol "deref" "" "" Deref,
|
||||||
makeSymbol "with" "" "" With
|
makeSymbol "with" "" "" With
|
||||||
]
|
]
|
||||||
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule) Nothing Nothing)) | not noArray]
|
++ [("Array", Binder emptyMeta (XObj (Mod arrayModule E.empty) Nothing Nothing)) | not noArray]
|
||||||
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule) Nothing Nothing))]
|
++ [("StaticArray", Binder emptyMeta (XObj (Mod staticArrayModule E.empty) Nothing Nothing))]
|
||||||
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule) Nothing Nothing))]
|
++ [("Pointer", Binder emptyMeta (XObj (Mod pointerModule E.empty) Nothing Nothing))]
|
||||||
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule) Nothing Nothing))]
|
++ [("Dynamic", Binder emptyMeta (XObj (Mod dynamicModule E.empty) Nothing Nothing))]
|
||||||
++ [("Function", Binder emptyMeta (XObj (Mod functionModule) Nothing Nothing))]
|
++ [("Function", Binder emptyMeta (XObj (Mod functionModule E.empty) Nothing Nothing))]
|
||||||
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule) Nothing Nothing))]
|
++ [("Unsafe", Binder emptyMeta (XObj (Mod unsafeModule E.empty) Nothing Nothing))]
|
||||||
|
|
||||||
-- | The type environment (containing deftypes and interfaces) before any code is run.
|
-- | The type environment (containing deftypes and interfaces) before any code is run.
|
||||||
startingTypeEnv :: Env
|
startingTypeEnv :: Env
|
||||||
|
@ -11,7 +11,7 @@ import Types
|
|||||||
-- since there are some small differences here and there I'v decided to not
|
-- since there are some small differences here and there I'v decided to not
|
||||||
-- try to abstract over them and just duplicate the templates instead.
|
-- try to abstract over them and just duplicate the templates instead.
|
||||||
concreteArray :: Ty
|
concreteArray :: Ty
|
||||||
concreteArray = ConcreteNameTy "StaticArray"
|
concreteArray = ConcreteNameTy (SymPath [] "StaticArray")
|
||||||
|
|
||||||
templateUnsafeNth :: (String, Binder)
|
templateUnsafeNth :: (String, Binder)
|
||||||
templateUnsafeNth =
|
templateUnsafeNth =
|
||||||
|
@ -1,14 +1,13 @@
|
|||||||
module Sumtypes where
|
module Sumtypes where
|
||||||
|
|
||||||
import Concretize
|
import Concretize
|
||||||
|
import Context
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Deftype
|
import Deftype
|
||||||
import Env
|
import Env (addListOfBindings, new)
|
||||||
import Info
|
import Info
|
||||||
import Managed
|
import Managed
|
||||||
import qualified Map
|
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
|
||||||
import StructUtils
|
import StructUtils
|
||||||
import SumtypeCase
|
import SumtypeCase
|
||||||
import Template
|
import Template
|
||||||
@ -25,13 +24,35 @@ getCase cases caseNameToFind =
|
|||||||
found : _ -> Just found
|
found : _ -> Just found
|
||||||
[] -> Nothing
|
[] -> Nothing
|
||||||
|
|
||||||
moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe Env -> Either TypeError (String, XObj, [XObj])
|
moduleForSumtypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
|
||||||
|
moduleForSumtypeInContext ctx name vars members info =
|
||||||
|
let global = contextGlobalEnv ctx
|
||||||
|
types = contextTypeEnv ctx
|
||||||
|
path = contextPath ctx
|
||||||
|
inner = either (const Nothing) Just (innermostModuleEnv ctx)
|
||||||
|
previous =
|
||||||
|
either
|
||||||
|
(const Nothing)
|
||||||
|
Just
|
||||||
|
( (lookupBinderInInternalEnv ctx (SymPath path name))
|
||||||
|
<> (lookupBinderInGlobalEnv ctx (SymPath path name))
|
||||||
|
>>= \b ->
|
||||||
|
replaceLeft
|
||||||
|
(NotFoundGlobal (SymPath path name))
|
||||||
|
( case binderXObj b of
|
||||||
|
XObj (Mod ev et) _ _ -> Right (ev, et)
|
||||||
|
_ -> Left "Non module"
|
||||||
|
)
|
||||||
|
)
|
||||||
|
in moduleForSumtype inner types global path name vars members info previous
|
||||||
|
|
||||||
|
moduleForSumtype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
|
||||||
moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
|
||||||
let typeModuleName = typeName
|
let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
|
||||||
typeModuleEnv = fromMaybe (Env (Map.fromList []) innerEnv (Just typeModuleName) Set.empty ExternalEnv 0) existingEnv
|
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
|
||||||
insidePath = pathStrings ++ [typeModuleName]
|
insidePath = pathStrings ++ [typeName]
|
||||||
in do
|
in do
|
||||||
let structTy = StructTy (ConcreteNameTy (createStructName pathStrings typeName)) typeVariables
|
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
|
||||||
cases <- toCases typeEnv typeVariables rest
|
cases <- toCases typeEnv typeVariables rest
|
||||||
okIniters <- initers insidePath structTy cases
|
okIniters <- initers insidePath structTy cases
|
||||||
okTag <- binderForTag insidePath structTy
|
okTag <- binderForTag insidePath structTy
|
||||||
@ -40,9 +61,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
|
|||||||
okDelete <- binderForDelete typeEnv env insidePath structTy cases
|
okDelete <- binderForDelete typeEnv env insidePath structTy cases
|
||||||
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
|
(okCopy, okCopyDeps) <- binderForCopy typeEnv env insidePath structTy cases
|
||||||
okMemberDeps <- memberDeps typeEnv cases
|
okMemberDeps <- memberDeps typeEnv cases
|
||||||
let moduleEnvWithBindings = addListOfBindings typeModuleEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okIniters ++ [okStr, okPrn, okDelete, okCopy, okTag])
|
||||||
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
|
||||||
pure (typeModuleName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
|
pure (typeName, typeModuleXObj, okMemberDeps ++ okCopyDeps ++ okStrDeps)
|
||||||
|
|
||||||
memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
|
memberDeps :: TypeEnv -> [SumtypeCase] -> Either TypeError [XObj]
|
||||||
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
|
memberDeps typeEnv cases = fmap concat (mapM (concretizeType typeEnv) (concatMap caseTys cases))
|
||||||
@ -108,13 +129,13 @@ genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
|
|||||||
)
|
)
|
||||||
|
|
||||||
tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
|
tokensForCaseInit :: AllocationMode -> Ty -> SumtypeCase -> [Token]
|
||||||
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy typeName) _) sumtypeCase =
|
tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCase =
|
||||||
toTemplate $
|
toTemplate $
|
||||||
unlines
|
unlines
|
||||||
[ "$DECL {",
|
[ "$DECL {",
|
||||||
case allocationMode of
|
case allocationMode of
|
||||||
StackAlloc -> " $p instance;"
|
StackAlloc -> " $p instance;"
|
||||||
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
|
HeapAlloc -> " $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));",
|
||||||
joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
|
joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
|
||||||
" instance._tag = " ++ tagName sumTy correctedName ++ ";",
|
" instance._tag = " ++ tagName sumTy correctedName ++ ";",
|
||||||
" return instance;",
|
" return instance;",
|
||||||
@ -134,7 +155,7 @@ caseMemberAssignment allocationMode caseNm memberName =
|
|||||||
HeapAlloc -> "->u."
|
HeapAlloc -> "->u."
|
||||||
|
|
||||||
binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
|
binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
|
||||||
binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) =
|
binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) =
|
||||||
Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
|
Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc
|
||||||
where
|
where
|
||||||
path = SymPath insidePath "get-tag"
|
path = SymPath insidePath "get-tag"
|
||||||
@ -145,7 +166,7 @@ binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _)
|
|||||||
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
|
(\(FuncTy [RefTy structTy _] IntTy _) -> toTemplate $ proto structTy ++ " { return p->_tag; }")
|
||||||
(const [])
|
(const [])
|
||||||
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
|
proto structTy = "int $NAME(" ++ tyToCLambdaFix structTy ++ " *p)"
|
||||||
doc = "Gets the tag from a `" ++ typeName ++ "`."
|
doc = "Gets the tag from a `" ++ show originalStructTy ++ "`."
|
||||||
binderForTag _ _ = error "binderfortag"
|
binderForTag _ _ = error "binderfortag"
|
||||||
|
|
||||||
-- | Helper function to create the binder for the 'str' template.
|
-- | Helper function to create the binder for the 'str' template.
|
||||||
@ -159,16 +180,16 @@ binderForStrOrPrn _ _ _ _ _ _ = error "binderforstrorprn"
|
|||||||
|
|
||||||
-- | The template for the 'str' function for a concrete deftype.
|
-- | The template for the 'str' function for a concrete deftype.
|
||||||
concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj])
|
concreteStr :: TypeEnv -> Env -> [String] -> Ty -> [SumtypeCase] -> String -> ((String, Binder), [XObj])
|
||||||
concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
|
concreteStr typeEnv env insidePath concreteStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
|
||||||
instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
|
instanceBinderWithDeps (SymPath insidePath strOrPrn) (FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy) template doc
|
||||||
where
|
where
|
||||||
doc = "converts a `" ++ typeName ++ "` to a string."
|
doc = "converts a `" ++ (show concreteStructTy) ++ "` to a string."
|
||||||
template =
|
template =
|
||||||
Template
|
Template
|
||||||
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
(FuncTy [RefTy concreteStructTy (VarTy "q")] StringTy StaticLifetimeTy)
|
||||||
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
(\(FuncTy [RefTy structTy _] StringTy _) -> toTemplate $ "String $NAME(" ++ tyToCLambdaFix structTy ++ " *p)")
|
||||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||||
tokensForStr typeEnv env typeName cases concreteStructTy
|
tokensForStr typeEnv env (show name) cases concreteStructTy
|
||||||
)
|
)
|
||||||
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
( \(FuncTy [RefTy (StructTy _ _) _] StringTy _) ->
|
||||||
concatMap
|
concatMap
|
||||||
@ -179,12 +200,12 @@ concreteStr _ _ _ _ _ _ = error "concretestr"
|
|||||||
|
|
||||||
-- | The template for the 'str' function for a generic deftype.
|
-- | The template for the 'str' function for a generic deftype.
|
||||||
genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
|
genericStr :: [String] -> Ty -> [SumtypeCase] -> String -> (String, Binder)
|
||||||
genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) cases strOrPrn =
|
genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy name) _) cases strOrPrn =
|
||||||
defineTypeParameterizedTemplate templateCreator path t docs
|
defineTypeParameterizedTemplate templateCreator path t docs
|
||||||
where
|
where
|
||||||
path = SymPath insidePath strOrPrn
|
path = SymPath insidePath strOrPrn
|
||||||
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
t = FuncTy [RefTy originalStructTy (VarTy "q")] StringTy StaticLifetimeTy
|
||||||
docs = "stringifies a `" ++ show typeName ++ "`."
|
docs = "stringifies a `" ++ show originalStructTy ++ "`."
|
||||||
templateCreator = TemplateCreator $
|
templateCreator = TemplateCreator $
|
||||||
\typeEnv env ->
|
\typeEnv env ->
|
||||||
Template
|
Template
|
||||||
@ -195,7 +216,7 @@ genericStr insidePath originalStructTy@(StructTy (ConcreteNameTy typeName) _) ca
|
|||||||
( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
( \(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
correctedCases = replaceGenericTypesOnCases mappings cases
|
correctedCases = replaceGenericTypesOnCases mappings cases
|
||||||
in tokensForStr typeEnv env typeName correctedCases concreteStructTy
|
in tokensForStr typeEnv env (show name) correctedCases concreteStructTy
|
||||||
)
|
)
|
||||||
( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
( \ft@(FuncTy [RefTy concreteStructTy@(StructTy _ _) _] StringTy _) ->
|
||||||
let mappings = unifySignatures originalStructTy concreteStructTy
|
let mappings = unifySignatures originalStructTy concreteStructTy
|
||||||
@ -307,10 +328,10 @@ genericSumtypeDelete pathStrings originalStructTy cases =
|
|||||||
|
|
||||||
-- | The template for the 'delete' function of a concrete sumtype
|
-- | The template for the 'delete' function of a concrete sumtype
|
||||||
concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
|
concreteSumtypeDelete :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> (String, Binder)
|
||||||
concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
|
concreteSumtypeDelete insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases =
|
||||||
instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc
|
instanceBinder (SymPath insidePath "delete") (FuncTy [structTy] UnitTy StaticLifetimeTy) template doc
|
||||||
where
|
where
|
||||||
doc = "deletes a `" ++ typeName ++ "`. This should usually not be called manually."
|
doc = "deletes a `" ++ (show structTy) ++ "`. This should usually not be called manually."
|
||||||
template =
|
template =
|
||||||
Template
|
Template
|
||||||
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
|
(FuncTy [VarTy "p"] UnitTy StaticLifetimeTy)
|
||||||
@ -381,10 +402,10 @@ genericSumtypeCopy pathStrings originalStructTy cases =
|
|||||||
|
|
||||||
-- | The template for the 'copy' function of a concrete sumtype
|
-- | The template for the 'copy' function of a concrete sumtype
|
||||||
concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj])
|
concreteSumtypeCopy :: [String] -> TypeEnv -> Env -> Ty -> [SumtypeCase] -> ((String, Binder), [XObj])
|
||||||
concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy typeName) _) cases =
|
concreteSumtypeCopy insidePath typeEnv env structTy@(StructTy (ConcreteNameTy _) _) cases =
|
||||||
instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc
|
instanceBinderWithDeps (SymPath insidePath "copy") (FuncTy [RefTy structTy (VarTy "q")] structTy StaticLifetimeTy) template doc
|
||||||
where
|
where
|
||||||
doc = "copies a `" ++ typeName ++ "`."
|
doc = "copies a `" ++ (show structTy) ++ "`."
|
||||||
template =
|
template =
|
||||||
Template
|
Template
|
||||||
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
(FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy)
|
||||||
|
@ -5,6 +5,7 @@ module SymPath
|
|||||||
mangle,
|
mangle,
|
||||||
pathToC,
|
pathToC,
|
||||||
consPath,
|
consPath,
|
||||||
|
fromStrings,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -89,3 +90,9 @@ pathToC (SymPath modulePath name) =
|
|||||||
consPath :: [String] -> SymPath -> SymPath
|
consPath :: [String] -> SymPath -> SymPath
|
||||||
consPath qualifyers (SymPath stringPaths name) =
|
consPath qualifyers (SymPath stringPaths name) =
|
||||||
SymPath (qualifyers ++ stringPaths) name
|
SymPath (qualifyers ++ stringPaths) name
|
||||||
|
|
||||||
|
-- | Convert a list of strings into a path.
|
||||||
|
fromStrings :: [String] -> SymPath
|
||||||
|
fromStrings [] = SymPath [] ""
|
||||||
|
fromStrings (s : []) = SymPath [] s
|
||||||
|
fromStrings ss = SymPath (init ss) (last ss)
|
||||||
|
@ -60,6 +60,7 @@ data TypeError
|
|||||||
| UsingDeadReference XObj String
|
| UsingDeadReference XObj String
|
||||||
| UninhabitedConstructor Ty XObj Int Int
|
| UninhabitedConstructor Ty XObj Int Int
|
||||||
| InconsistentKinds String [XObj]
|
| InconsistentKinds String [XObj]
|
||||||
|
| FailedToAddLambdaStructToTyEnv SymPath XObj
|
||||||
|
|
||||||
instance Show TypeError where
|
instance Show TypeError where
|
||||||
show (SymbolMissingType xobj env) =
|
show (SymbolMissingType xobj env) =
|
||||||
@ -305,6 +306,10 @@ instance Show TypeError where
|
|||||||
"Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got
|
"Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got
|
||||||
show (InconsistentKinds varName xobjs) =
|
show (InconsistentKinds varName xobjs) =
|
||||||
" The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."
|
" The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."
|
||||||
|
show (FailedToAddLambdaStructToTyEnv path xobj) =
|
||||||
|
"Failed to add the lambda: " ++ show path ++ " represented by struct: "
|
||||||
|
++ pretty xobj
|
||||||
|
++ " to the type environment."
|
||||||
|
|
||||||
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
|
machineReadableErrorStrings :: FilePathPrintLength -> TypeError -> [String]
|
||||||
machineReadableErrorStrings fppl err =
|
machineReadableErrorStrings fppl err =
|
||||||
@ -421,6 +426,11 @@ machineReadableErrorStrings fppl err =
|
|||||||
[machineReadableInfoFromXObj fppl xobj ++ "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got]
|
[machineReadableInfoFromXObj fppl xobj ++ "Can't use a struct or sumtype constructor without arguments as a member type at " ++ prettyInfoFromXObj xobj ++ ". The type constructor " ++ show ty ++ " expects " ++ show wanted ++ " arguments but got " ++ show got]
|
||||||
(InconsistentKinds varName xobjs) ->
|
(InconsistentKinds varName xobjs) ->
|
||||||
[machineReadableInfoFromXObj fppl (head xobjs) ++ " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."]
|
[machineReadableInfoFromXObj fppl (head xobjs) ++ " The type variable `" ++ varName ++ "` is used inconsistently: " ++ joinWithComma (map pretty (filter (doesTypeContainTyVarWithName varName . fromMaybe Universe . xobjToTy) xobjs)) ++ " Type variables must be applied to the same number of arguments."]
|
||||||
|
(FailedToAddLambdaStructToTyEnv path xobj) ->
|
||||||
|
[ machineReadableInfoFromXObj fppl xobj ++ "Failed to add the lambda: " ++ show path ++ " represented by struct: "
|
||||||
|
++ pretty xobj
|
||||||
|
++ " to the type environment."
|
||||||
|
]
|
||||||
_ ->
|
_ ->
|
||||||
[show err]
|
[show err]
|
||||||
|
|
||||||
@ -473,7 +483,7 @@ keysInEnvEditDistance path@(SymPath (p : ps) name) env distance =
|
|||||||
case Map.lookup p (envBindings env) of
|
case Map.lookup p (envBindings env) of
|
||||||
Just (Binder _ xobj) ->
|
Just (Binder _ xobj) ->
|
||||||
case xobj of
|
case xobj of
|
||||||
(XObj (Mod modEnv) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
|
(XObj (Mod modEnv _) _ _) -> keysInEnvEditDistance (SymPath ps name) modEnv distance
|
||||||
_ -> []
|
_ -> []
|
||||||
Nothing ->
|
Nothing ->
|
||||||
case envParent env of
|
case envParent env of
|
||||||
|
14
src/Types.hs
14
src/Types.hs
@ -26,6 +26,7 @@ module Types
|
|||||||
getStructName,
|
getStructName,
|
||||||
getPathFromStructName,
|
getPathFromStructName,
|
||||||
getNameFromStructName,
|
getNameFromStructName,
|
||||||
|
getStructPath,
|
||||||
promoteNumber,
|
promoteNumber,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
@ -60,7 +61,7 @@ data Ty
|
|||||||
| RefTy Ty Ty -- second Ty is the lifetime
|
| RefTy Ty Ty -- second Ty is the lifetime
|
||||||
| StaticLifetimeTy
|
| StaticLifetimeTy
|
||||||
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
|
| StructTy Ty [Ty] -- the name (possibly a var) of the struct, and it's type parameters
|
||||||
| ConcreteNameTy String -- the name of a struct
|
| ConcreteNameTy SymPath -- the name of a struct
|
||||||
| TypeTy -- the type of types
|
| TypeTy -- the type of types
|
||||||
| MacroTy
|
| MacroTy
|
||||||
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
|
| DynamicTy -- the type of dynamic functions (used in REPL and macros)
|
||||||
@ -179,7 +180,7 @@ instance Show Ty where
|
|||||||
show InterfaceTy = "Interface"
|
show InterfaceTy = "Interface"
|
||||||
show (StructTy s []) = show s
|
show (StructTy s []) = show s
|
||||||
show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
|
show (StructTy s typeArgs) = "(" ++ show s ++ " " ++ joinWithSpace (map show typeArgs) ++ ")"
|
||||||
show (ConcreteNameTy name) = name
|
show (ConcreteNameTy spath) = show spath
|
||||||
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
|
show (PointerTy p) = "(Ptr " ++ show p ++ ")"
|
||||||
show (RefTy r lt) =
|
show (RefTy r lt) =
|
||||||
-- case r of
|
-- case r of
|
||||||
@ -336,13 +337,13 @@ typesDeleterFunctionType memberType = FuncTy [memberType] UnitTy StaticLifetimeT
|
|||||||
|
|
||||||
-- | The type of environments sent to Lambdas (used in emitted C code)
|
-- | The type of environments sent to Lambdas (used in emitted C code)
|
||||||
lambdaEnvTy :: Ty
|
lambdaEnvTy :: Ty
|
||||||
lambdaEnvTy = StructTy (ConcreteNameTy "LambdaEnv") []
|
lambdaEnvTy = StructTy (ConcreteNameTy (SymPath [] "LambdaEnv")) []
|
||||||
|
|
||||||
createStructName :: [String] -> String -> String
|
createStructName :: [String] -> String -> String
|
||||||
createStructName path name = intercalate "." (path ++ [name])
|
createStructName path name = intercalate "." (path ++ [name])
|
||||||
|
|
||||||
getStructName :: Ty -> String
|
getStructName :: Ty -> String
|
||||||
getStructName (StructTy (ConcreteNameTy name) _) = name
|
getStructName (StructTy (ConcreteNameTy spath) _) = show spath
|
||||||
getStructName (StructTy (VarTy name) _) = name
|
getStructName (StructTy (VarTy name) _) = name
|
||||||
getStructName _ = ""
|
getStructName _ = ""
|
||||||
|
|
||||||
@ -354,6 +355,11 @@ getPathFromStructName structName =
|
|||||||
getNameFromStructName :: String -> String
|
getNameFromStructName :: String -> String
|
||||||
getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
|
getNameFromStructName structName = last (map unpack (splitOn (pack ".") (pack structName)))
|
||||||
|
|
||||||
|
getStructPath :: Ty -> SymPath
|
||||||
|
getStructPath (StructTy (ConcreteNameTy spath) _) = spath
|
||||||
|
getStructPath (StructTy (VarTy name) _) = (SymPath [] name)
|
||||||
|
getStructPath _ = (SymPath [] "")
|
||||||
|
|
||||||
-- N.B.: promoteNumber is only safe for numeric types!
|
-- N.B.: promoteNumber is only safe for numeric types!
|
||||||
promoteNumber :: Ty -> Ty -> Ty
|
promoteNumber :: Ty -> Ty -> Ty
|
||||||
promoteNumber a b | a == b = a
|
promoteNumber a b | a == b = a
|
||||||
|
@ -44,7 +44,7 @@ tyToCManglePtr _ ty = f ty
|
|||||||
f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
|
f (FuncTy argTys retTy _) = "Fn__" ++ joinWithUnderscore (map (tyToCManglePtr True) argTys) ++ "_" ++ tyToCManglePtr True retTy
|
||||||
f (StructTy s []) = tyToCManglePtr False s
|
f (StructTy s []) = tyToCManglePtr False s
|
||||||
f (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
|
f (StructTy s typeArgs) = tyToCManglePtr False s ++ "__" ++ joinWithUnderscore (map (tyToCManglePtr True) typeArgs)
|
||||||
f (ConcreteNameTy name) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack name))))
|
f (ConcreteNameTy spath) = mangle (intercalate "" (map unpack (splitOn (pack ".") (pack (show spath)))))
|
||||||
f ModuleTy = err "modules"
|
f ModuleTy = err "modules"
|
||||||
f TypeTy = err "types"
|
f TypeTy = err "types"
|
||||||
f MacroTy = err "macros"
|
f MacroTy = err "macros"
|
||||||
|
13
src/Util.hs
13
src/Util.hs
@ -1,5 +1,6 @@
|
|||||||
module Util where
|
module Util where
|
||||||
|
|
||||||
|
import Data.Bifunctor
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import qualified Map
|
import qualified Map
|
||||||
@ -116,3 +117,15 @@ intToArgName 7 = "t"
|
|||||||
intToArgName 8 = "s"
|
intToArgName 8 = "s"
|
||||||
intToArgName 9 = "r"
|
intToArgName 9 = "r"
|
||||||
intToArgName n = intToArgName 1 ++ intToArgName (n `div` 10)
|
intToArgName n = intToArgName 1 ++ intToArgName (n `div` 10)
|
||||||
|
|
||||||
|
replaceLeft :: b -> Either a c -> Either b c
|
||||||
|
replaceLeft x e = first (const x) e
|
||||||
|
|
||||||
|
unwrapErr :: Show e => Either e a -> Either String a
|
||||||
|
unwrapErr = first show
|
||||||
|
|
||||||
|
toMaybe :: (b -> c) -> Either a b -> Maybe c
|
||||||
|
toMaybe f e = either (const Nothing) (Just . f) e
|
||||||
|
|
||||||
|
maybeId :: Either a b -> Maybe b
|
||||||
|
maybeId = toMaybe id
|
||||||
|
@ -4,7 +4,7 @@ import Control.Monad (foldM)
|
|||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
import Data.List (nubBy, (\\))
|
import Data.List (nubBy, (\\))
|
||||||
import Data.Maybe (fromJust)
|
import Data.Maybe (fromJust)
|
||||||
import Lookup
|
import qualified Env as E
|
||||||
import Obj
|
import Obj
|
||||||
import TypeError
|
import TypeError
|
||||||
import TypePredicates
|
import TypePredicates
|
||||||
@ -104,21 +104,19 @@ canBeUsedAsMemberType typeEnv typeVariables ty xobj =
|
|||||||
_ -> Left (InvalidMemberType ty xobj)
|
_ -> Left (InvalidMemberType ty xobj)
|
||||||
where
|
where
|
||||||
checkStruct :: Ty -> [Ty] -> Either TypeError ()
|
checkStruct :: Ty -> [Ty] -> Either TypeError ()
|
||||||
checkStruct (ConcreteNameTy "Array") [innerType] =
|
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
|
||||||
canBeUsedAsMemberType typeEnv typeVariables innerType xobj
|
canBeUsedAsMemberType typeEnv typeVariables innerType xobj
|
||||||
>> pure ()
|
>> pure ()
|
||||||
checkStruct (ConcreteNameTy n) vars =
|
checkStruct (ConcreteNameTy (SymPath _ name)) vars =
|
||||||
case lookupBinder (SymPath lookupPath name) (getTypeEnv typeEnv) of
|
case E.getTypeBinder typeEnv name of
|
||||||
Just (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
|
||||||
pure ()
|
pure ()
|
||||||
Just (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
|
||||||
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
|
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
|
||||||
Just (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
|
Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
|
||||||
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
|
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeEnv typeVariables typ xobj) () vars
|
||||||
_ -> Left (NotAmongRegisteredTypes ty xobj)
|
_ -> Left (NotAmongRegisteredTypes ty xobj)
|
||||||
where
|
where
|
||||||
lookupPath = getPathFromStructName n
|
|
||||||
name = getNameFromStructName n
|
|
||||||
checkInhabitants :: Ty -> Either TypeError ()
|
checkInhabitants :: Ty -> Either TypeError ()
|
||||||
checkInhabitants (StructTy _ vs) =
|
checkInhabitants (StructTy _ vs) =
|
||||||
if length vs == length vars
|
if length vs == length vars
|
||||||
|
@ -116,16 +116,16 @@ testConstr10 =
|
|||||||
|
|
||||||
testConstr11 =
|
testConstr11 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy "Monkey") [])) x x x OrdNo]
|
[Constraint (PointerTy (VarTy "a")) (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Monkey")) [])) x x x OrdNo]
|
||||||
[("a", (StructTy (ConcreteNameTy "Monkey") []))]
|
[("a", (StructTy (ConcreteNameTy (SymPath [] "Monkey")) []))]
|
||||||
|
|
||||||
testConstr12 =
|
testConstr12 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint t1 (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy])) x x x OrdNo,
|
[ Constraint t1 (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy])) x x x OrdNo,
|
||||||
Constraint t1 (PointerTy t2) x x x OrdNo
|
Constraint t1 (PointerTy t2) x x x OrdNo
|
||||||
]
|
]
|
||||||
[ ("t1", (PointerTy (StructTy (ConcreteNameTy "Array") [IntTy]))),
|
[ ("t1", (PointerTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))),
|
||||||
("t2", (StructTy (ConcreteNameTy "Array") [IntTy]))
|
("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [IntTy]))
|
||||||
]
|
]
|
||||||
|
|
||||||
testConstr13 =
|
testConstr13 =
|
||||||
@ -144,36 +144,36 @@ testConstr13 =
|
|||||||
-- Struct types
|
-- Struct types
|
||||||
testConstr20 =
|
testConstr20 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint t0 (StructTy (ConcreteNameTy "Vector") [t1]) x x x OrdNo,
|
[ Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [t1]) x x x OrdNo,
|
||||||
Constraint t0 (StructTy (ConcreteNameTy "Vector") [IntTy]) x x x OrdNo
|
Constraint t0 (StructTy (ConcreteNameTy (SymPath [] "Vector")) [IntTy]) x x x OrdNo
|
||||||
]
|
]
|
||||||
[("t0", (StructTy (ConcreteNameTy "Vector") [IntTy])), ("t1", IntTy)]
|
[("t0", (StructTy (ConcreteNameTy (SymPath [] "Vector")) [IntTy])), ("t1", IntTy)]
|
||||||
|
|
||||||
testConstr21 =
|
testConstr21 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
|
[ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
|
||||||
Constraint t1 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
|
Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
|
||||||
Constraint t3 BoolTy x x x OrdNo
|
Constraint t3 BoolTy x x x OrdNo
|
||||||
]
|
]
|
||||||
[ ("t1", (StructTy (ConcreteNameTy "Array") [BoolTy])),
|
[ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [BoolTy])),
|
||||||
("t2", BoolTy),
|
("t2", BoolTy),
|
||||||
("t3", BoolTy)
|
("t3", BoolTy)
|
||||||
]
|
]
|
||||||
|
|
||||||
testConstr22 =
|
testConstr22 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint t1 (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
|
[ Constraint t1 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
|
||||||
Constraint t2 (StructTy (ConcreteNameTy "Array") [t3]) x x x OrdNo,
|
Constraint t2 (StructTy (ConcreteNameTy (SymPath [] "Array")) [t3]) x x x OrdNo,
|
||||||
Constraint t3 FloatTy x x x OrdNo
|
Constraint t3 FloatTy x x x OrdNo
|
||||||
]
|
]
|
||||||
[ ("t1", (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Array") [FloatTy])])),
|
[ ("t1", (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])])),
|
||||||
("t2", (StructTy (ConcreteNameTy "Array") [FloatTy])),
|
("t2", (StructTy (ConcreteNameTy (SymPath [] "Array")) [FloatTy])),
|
||||||
("t3", FloatTy)
|
("t3", FloatTy)
|
||||||
]
|
]
|
||||||
|
|
||||||
testConstr23 =
|
testConstr23 =
|
||||||
assertUnificationFailure
|
assertUnificationFailure
|
||||||
[ Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo,
|
[ Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo,
|
||||||
Constraint t1 IntTy x x x OrdNo,
|
Constraint t1 IntTy x x x OrdNo,
|
||||||
Constraint t2 FloatTy x x x OrdNo
|
Constraint t2 FloatTy x x x OrdNo
|
||||||
]
|
]
|
||||||
@ -182,7 +182,7 @@ testConstr24 =
|
|||||||
assertUnificationFailure
|
assertUnificationFailure
|
||||||
[ Constraint t2 FloatTy x x x OrdNo,
|
[ Constraint t2 FloatTy x x x OrdNo,
|
||||||
Constraint t1 IntTy x x x OrdNo,
|
Constraint t1 IntTy x x x OrdNo,
|
||||||
Constraint (StructTy (ConcreteNameTy "Array") [t1]) (StructTy (ConcreteNameTy "Array") [t2]) x x x OrdNo
|
Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [t1]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [t2]) x x x OrdNo
|
||||||
]
|
]
|
||||||
|
|
||||||
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
|
-- m9 = solve [Constraint (StructTy "Vector" [IntTy]) (StructTy "Vector" [t1]) x x x OrdNo]
|
||||||
@ -219,10 +219,10 @@ testConstr33 =
|
|||||||
|
|
||||||
testConstr34 =
|
testConstr34 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
|
[ Constraint (VarTy "a") (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) x x x OrdNo,
|
||||||
Constraint (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
|
Constraint (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) x x x OrdNo
|
||||||
]
|
]
|
||||||
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
|
[ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])),
|
||||||
("x0", (VarTy "x0")),
|
("x0", (VarTy "x0")),
|
||||||
("y0", (VarTy "y0")),
|
("y0", (VarTy "y0")),
|
||||||
("x1", (VarTy "x0")),
|
("x1", (VarTy "x0")),
|
||||||
@ -232,10 +232,10 @@ testConstr34 =
|
|||||||
-- Same as testConstr34, except everything is wrapped in refs
|
-- Same as testConstr34, except everything is wrapped in refs
|
||||||
testConstr35 =
|
testConstr35 =
|
||||||
assertSolution
|
assertSolution
|
||||||
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
|
[ Constraint (RefTy (VarTy "a") (VarTy "lt0")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")]) (VarTy "lt1")) x x x OrdNo,
|
||||||
Constraint (RefTy (StructTy (ConcreteNameTy "Array") [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy "Array") [(StructTy (ConcreteNameTy "Pair") [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
|
Constraint (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(VarTy "a")]) (VarTy "lt2")) (RefTy (StructTy (ConcreteNameTy (SymPath [] "Array")) [(StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x1"), (VarTy "y1")])]) (VarTy "lt3")) x x x OrdNo
|
||||||
]
|
]
|
||||||
[ ("a", (StructTy (ConcreteNameTy "Pair") [(VarTy "x0"), (VarTy "y0")])),
|
[ ("a", (StructTy (ConcreteNameTy (SymPath [] "Pair")) [(VarTy "x0"), (VarTy "y0")])),
|
||||||
("x0", (VarTy "x0")),
|
("x0", (VarTy "x0")),
|
||||||
("y0", (VarTy "y0")),
|
("y0", (VarTy "y0")),
|
||||||
("x1", (VarTy "x0")),
|
("x1", (VarTy "x0")),
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
module TestLookup where
|
module TestLookup where
|
||||||
|
|
||||||
import qualified Lookup as Lookup
|
import Env as E
|
||||||
import qualified Map
|
import qualified Map
|
||||||
import Obj
|
import Obj
|
||||||
import qualified Set
|
import qualified Set
|
||||||
@ -16,9 +16,9 @@ b1 = Binder emptyMeta (XObj (Str "b1") Nothing (Just StringTy))
|
|||||||
|
|
||||||
emptyRootEnv = Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0
|
emptyRootEnv = Env (Map.fromList []) Nothing Nothing Set.empty ExternalEnv 0
|
||||||
|
|
||||||
assertNotFound :: Maybe Binder -> Test
|
assertNotFound :: Either EnvironmentError Binder -> Test
|
||||||
assertNotFound Nothing = TestCase (assertBool "assertNotFound" True) -- Better way?
|
assertNotFound (Left _) = TestCase (assertBool "assertNotFound" True) -- Better way?
|
||||||
assertNotFound _ = TestCase (assertBool "assertNotFound" False)
|
assertNotFound _ = TestCase (assertBool "assertNotFound" False)
|
||||||
|
|
||||||
basicLookup :: Test
|
basicLookup :: Test
|
||||||
basicLookup = assertNotFound (fmap snd (Lookup.lookupInEnv (SymPath [] "nonexisting") emptyRootEnv))
|
basicLookup = assertNotFound (fmap snd (E.searchValue emptyRootEnv (SymPath [] "nonexisting")))
|
||||||
|
@ -9,6 +9,9 @@
|
|||||||
(defmodule Wrap2
|
(defmodule Wrap2
|
||||||
(deftype C []))
|
(deftype C []))
|
||||||
(use Wrap2)
|
(use Wrap2)
|
||||||
|
(use Wrap)
|
||||||
|
|
||||||
|
(deftype B [])
|
||||||
|
|
||||||
(deftest test
|
(deftest test
|
||||||
(assert-equal test
|
(assert-equal test
|
||||||
@ -23,4 +26,8 @@
|
|||||||
"(Wrap2.C)"
|
"(Wrap2.C)"
|
||||||
(ref (str (ref (C))))
|
(ref (str (ref (C))))
|
||||||
"implicit .init for 'use':d type defined inside module works")
|
"implicit .init for 'use':d type defined inside module works")
|
||||||
|
(assert-equal test
|
||||||
|
"(B)"
|
||||||
|
(ref (str (ref (B))))
|
||||||
|
"when module and global types compete, global types are preffered.")
|
||||||
)
|
)
|
||||||
|
Loading…
Reference in New Issue
Block a user